1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code *head, *current;
48 struct code_stack *prev;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels;
57 static code_stack *cs_base = NULL;
60 /* Nonzero if we're inside a FORALL block. */
62 static int forall_flag;
64 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
66 static int omp_workshare_flag;
68 /* Nonzero if we are processing a formal arglist. The corresponding function
69 resets the flag each time that it is read. */
70 static int formal_arg_flag = 0;
72 /* True if we are resolving a specification expression. */
73 static int specification_expr = 0;
75 /* The id of the last entry seen. */
76 static int current_entry_id;
78 /* We use bitmaps to determine if a branch target is valid. */
79 static bitmap_obstack labels_obstack;
81 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
82 static bool inquiry_argument = false;
85 gfc_is_formal_arg (void)
87 return formal_arg_flag;
90 /* Is the symbol host associated? */
92 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
94 for (ns = ns->parent; ns; ns = ns->parent)
103 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
104 an ABSTRACT derived-type. If where is not NULL, an error message with that
105 locus is printed, optionally using name. */
108 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
110 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
115 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
116 name, where, ts->u.derived->name);
118 gfc_error ("ABSTRACT type '%s' used at %L",
119 ts->u.derived->name, where);
129 static void resolve_symbol (gfc_symbol *sym);
130 static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
133 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
136 resolve_procedure_interface (gfc_symbol *sym)
138 if (sym->ts.interface == sym)
140 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
141 sym->name, &sym->declared_at);
144 if (sym->ts.interface->attr.procedure)
146 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
147 "in a later PROCEDURE statement", sym->ts.interface->name,
148 sym->name, &sym->declared_at);
152 /* Get the attributes from the interface (now resolved). */
153 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
155 gfc_symbol *ifc = sym->ts.interface;
156 resolve_symbol (ifc);
158 if (ifc->attr.intrinsic)
159 resolve_intrinsic (ifc, &ifc->declared_at);
162 sym->ts = ifc->result->ts;
165 sym->ts.interface = ifc;
166 sym->attr.function = ifc->attr.function;
167 sym->attr.subroutine = ifc->attr.subroutine;
168 gfc_copy_formal_args (sym, ifc);
170 sym->attr.allocatable = ifc->attr.allocatable;
171 sym->attr.pointer = ifc->attr.pointer;
172 sym->attr.pure = ifc->attr.pure;
173 sym->attr.elemental = ifc->attr.elemental;
174 sym->attr.dimension = ifc->attr.dimension;
175 sym->attr.contiguous = ifc->attr.contiguous;
176 sym->attr.recursive = ifc->attr.recursive;
177 sym->attr.always_explicit = ifc->attr.always_explicit;
178 sym->attr.ext_attr |= ifc->attr.ext_attr;
179 /* Copy array spec. */
180 sym->as = gfc_copy_array_spec (ifc->as);
184 for (i = 0; i < sym->as->rank; i++)
186 gfc_expr_replace_symbols (sym->as->lower[i], sym);
187 gfc_expr_replace_symbols (sym->as->upper[i], sym);
190 /* Copy char length. */
191 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
193 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
194 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
195 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
196 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
200 else if (sym->ts.interface->name[0] != '\0')
202 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
203 sym->ts.interface->name, sym->name, &sym->declared_at);
211 /* Resolve types of formal argument lists. These have to be done early so that
212 the formal argument lists of module procedures can be copied to the
213 containing module before the individual procedures are resolved
214 individually. We also resolve argument lists of procedures in interface
215 blocks because they are self-contained scoping units.
217 Since a dummy argument cannot be a non-dummy procedure, the only
218 resort left for untyped names are the IMPLICIT types. */
221 resolve_formal_arglist (gfc_symbol *proc)
223 gfc_formal_arglist *f;
227 if (proc->result != NULL)
232 if (gfc_elemental (proc)
233 || sym->attr.pointer || sym->attr.allocatable
234 || (sym->as && sym->as->rank > 0))
236 proc->attr.always_explicit = 1;
237 sym->attr.always_explicit = 1;
242 for (f = proc->formal; f; f = f->next)
248 /* Alternate return placeholder. */
249 if (gfc_elemental (proc))
250 gfc_error ("Alternate return specifier in elemental subroutine "
251 "'%s' at %L is not allowed", proc->name,
253 if (proc->attr.function)
254 gfc_error ("Alternate return specifier in function "
255 "'%s' at %L is not allowed", proc->name,
259 else if (sym->attr.procedure && sym->ts.interface
260 && sym->attr.if_source != IFSRC_DECL)
261 resolve_procedure_interface (sym);
263 if (sym->attr.if_source != IFSRC_UNKNOWN)
264 resolve_formal_arglist (sym);
266 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
268 if (gfc_pure (proc) && !gfc_pure (sym))
270 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
271 "also be PURE", sym->name, &sym->declared_at);
275 if (gfc_elemental (proc))
277 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
278 "procedure", &sym->declared_at);
282 if (sym->attr.function
283 && sym->ts.type == BT_UNKNOWN
284 && sym->attr.intrinsic)
286 gfc_intrinsic_sym *isym;
287 isym = gfc_find_function (sym->name);
288 if (isym == NULL || !isym->specific)
290 gfc_error ("Unable to find a specific INTRINSIC procedure "
291 "for the reference '%s' at %L", sym->name,
300 if (sym->ts.type == BT_UNKNOWN)
302 if (!sym->attr.function || sym->result == sym)
303 gfc_set_default_type (sym, 1, sym->ns);
306 gfc_resolve_array_spec (sym->as, 0);
308 /* We can't tell if an array with dimension (:) is assumed or deferred
309 shape until we know if it has the pointer or allocatable attributes.
311 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
312 && !(sym->attr.pointer || sym->attr.allocatable))
314 sym->as->type = AS_ASSUMED_SHAPE;
315 for (i = 0; i < sym->as->rank; i++)
316 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
320 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
321 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
322 || sym->attr.optional)
324 proc->attr.always_explicit = 1;
326 proc->result->attr.always_explicit = 1;
329 /* If the flavor is unknown at this point, it has to be a variable.
330 A procedure specification would have already set the type. */
332 if (sym->attr.flavor == FL_UNKNOWN)
333 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
335 if (gfc_pure (proc) && !sym->attr.pointer
336 && sym->attr.flavor != FL_PROCEDURE)
338 if (proc->attr.function && sym->attr.intent != INTENT_IN)
339 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
340 "INTENT(IN)", sym->name, proc->name,
343 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
344 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
345 "have its INTENT specified", sym->name, proc->name,
349 if (gfc_elemental (proc))
352 if (sym->attr.codimension)
354 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
355 "procedure", sym->name, &sym->declared_at);
361 gfc_error ("Argument '%s' of elemental procedure at %L must "
362 "be scalar", sym->name, &sym->declared_at);
366 if (sym->attr.allocatable)
368 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
369 "have the ALLOCATABLE attribute", sym->name,
374 if (sym->attr.pointer)
376 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
377 "have the POINTER attribute", sym->name,
382 if (sym->attr.flavor == FL_PROCEDURE)
384 gfc_error ("Dummy procedure '%s' not allowed in elemental "
385 "procedure '%s' at %L", sym->name, proc->name,
390 if (sym->attr.intent == INTENT_UNKNOWN)
392 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
393 "have its INTENT specified", sym->name, proc->name,
399 /* Each dummy shall be specified to be scalar. */
400 if (proc->attr.proc == PROC_ST_FUNCTION)
404 gfc_error ("Argument '%s' of statement function at %L must "
405 "be scalar", sym->name, &sym->declared_at);
409 if (sym->ts.type == BT_CHARACTER)
411 gfc_charlen *cl = sym->ts.u.cl;
412 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
414 gfc_error ("Character-valued argument '%s' of statement "
415 "function at %L must have constant length",
416 sym->name, &sym->declared_at);
426 /* Work function called when searching for symbols that have argument lists
427 associated with them. */
430 find_arglists (gfc_symbol *sym)
432 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
435 resolve_formal_arglist (sym);
439 /* Given a namespace, resolve all formal argument lists within the namespace.
443 resolve_formal_arglists (gfc_namespace *ns)
448 gfc_traverse_ns (ns, find_arglists);
453 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
457 /* If this namespace is not a function or an entry master function,
459 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
460 || sym->attr.entry_master)
463 /* Try to find out of what the return type is. */
464 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
466 t = gfc_set_default_type (sym->result, 0, ns);
468 if (t == FAILURE && !sym->result->attr.untyped)
470 if (sym->result == sym)
471 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
472 sym->name, &sym->declared_at);
473 else if (!sym->result->attr.proc_pointer)
474 gfc_error ("Result '%s' of contained function '%s' at %L has "
475 "no IMPLICIT type", sym->result->name, sym->name,
476 &sym->result->declared_at);
477 sym->result->attr.untyped = 1;
481 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
482 type, lists the only ways a character length value of * can be used:
483 dummy arguments of procedures, named constants, and function results
484 in external functions. Internal function results and results of module
485 procedures are not on this list, ergo, not permitted. */
487 if (sym->result->ts.type == BT_CHARACTER)
489 gfc_charlen *cl = sym->result->ts.u.cl;
490 if (!cl || !cl->length)
492 /* See if this is a module-procedure and adapt error message
495 gcc_assert (ns->parent && ns->parent->proc_name);
496 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
498 gfc_error ("Character-valued %s '%s' at %L must not be"
500 module_proc ? _("module procedure")
501 : _("internal function"),
502 sym->name, &sym->declared_at);
508 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
509 introduce duplicates. */
512 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
514 gfc_formal_arglist *f, *new_arglist;
517 for (; new_args != NULL; new_args = new_args->next)
519 new_sym = new_args->sym;
520 /* See if this arg is already in the formal argument list. */
521 for (f = proc->formal; f; f = f->next)
523 if (new_sym == f->sym)
530 /* Add a new argument. Argument order is not important. */
531 new_arglist = gfc_get_formal_arglist ();
532 new_arglist->sym = new_sym;
533 new_arglist->next = proc->formal;
534 proc->formal = new_arglist;
539 /* Flag the arguments that are not present in all entries. */
542 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
544 gfc_formal_arglist *f, *head;
547 for (f = proc->formal; f; f = f->next)
552 for (new_args = head; new_args; new_args = new_args->next)
554 if (new_args->sym == f->sym)
561 f->sym->attr.not_always_present = 1;
566 /* Resolve alternate entry points. If a symbol has multiple entry points we
567 create a new master symbol for the main routine, and turn the existing
568 symbol into an entry point. */
571 resolve_entries (gfc_namespace *ns)
573 gfc_namespace *old_ns;
577 char name[GFC_MAX_SYMBOL_LEN + 1];
578 static int master_count = 0;
580 if (ns->proc_name == NULL)
583 /* No need to do anything if this procedure doesn't have alternate entry
588 /* We may already have resolved alternate entry points. */
589 if (ns->proc_name->attr.entry_master)
592 /* If this isn't a procedure something has gone horribly wrong. */
593 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
595 /* Remember the current namespace. */
596 old_ns = gfc_current_ns;
600 /* Add the main entry point to the list of entry points. */
601 el = gfc_get_entry_list ();
602 el->sym = ns->proc_name;
604 el->next = ns->entries;
606 ns->proc_name->attr.entry = 1;
608 /* If it is a module function, it needs to be in the right namespace
609 so that gfc_get_fake_result_decl can gather up the results. The
610 need for this arose in get_proc_name, where these beasts were
611 left in their own namespace, to keep prior references linked to
612 the entry declaration.*/
613 if (ns->proc_name->attr.function
614 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
617 /* Do the same for entries where the master is not a module
618 procedure. These are retained in the module namespace because
619 of the module procedure declaration. */
620 for (el = el->next; el; el = el->next)
621 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
622 && el->sym->attr.mod_proc)
626 /* Add an entry statement for it. */
633 /* Create a new symbol for the master function. */
634 /* Give the internal function a unique name (within this file).
635 Also include the function name so the user has some hope of figuring
636 out what is going on. */
637 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
638 master_count++, ns->proc_name->name);
639 gfc_get_ha_symbol (name, &proc);
640 gcc_assert (proc != NULL);
642 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
643 if (ns->proc_name->attr.subroutine)
644 gfc_add_subroutine (&proc->attr, proc->name, NULL);
648 gfc_typespec *ts, *fts;
649 gfc_array_spec *as, *fas;
650 gfc_add_function (&proc->attr, proc->name, NULL);
652 fas = ns->entries->sym->as;
653 fas = fas ? fas : ns->entries->sym->result->as;
654 fts = &ns->entries->sym->result->ts;
655 if (fts->type == BT_UNKNOWN)
656 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
657 for (el = ns->entries->next; el; el = el->next)
659 ts = &el->sym->result->ts;
661 as = as ? as : el->sym->result->as;
662 if (ts->type == BT_UNKNOWN)
663 ts = gfc_get_default_type (el->sym->result->name, NULL);
665 if (! gfc_compare_types (ts, fts)
666 || (el->sym->result->attr.dimension
667 != ns->entries->sym->result->attr.dimension)
668 || (el->sym->result->attr.pointer
669 != ns->entries->sym->result->attr.pointer))
671 else if (as && fas && ns->entries->sym->result != el->sym->result
672 && gfc_compare_array_spec (as, fas) == 0)
673 gfc_error ("Function %s at %L has entries with mismatched "
674 "array specifications", ns->entries->sym->name,
675 &ns->entries->sym->declared_at);
676 /* The characteristics need to match and thus both need to have
677 the same string length, i.e. both len=*, or both len=4.
678 Having both len=<variable> is also possible, but difficult to
679 check at compile time. */
680 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
681 && (((ts->u.cl->length && !fts->u.cl->length)
682 ||(!ts->u.cl->length && fts->u.cl->length))
684 && ts->u.cl->length->expr_type
685 != fts->u.cl->length->expr_type)
687 && ts->u.cl->length->expr_type == EXPR_CONSTANT
688 && mpz_cmp (ts->u.cl->length->value.integer,
689 fts->u.cl->length->value.integer) != 0)))
690 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
691 "entries returning variables of different "
692 "string lengths", ns->entries->sym->name,
693 &ns->entries->sym->declared_at);
698 sym = ns->entries->sym->result;
699 /* All result types the same. */
701 if (sym->attr.dimension)
702 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
703 if (sym->attr.pointer)
704 gfc_add_pointer (&proc->attr, NULL);
708 /* Otherwise the result will be passed through a union by
710 proc->attr.mixed_entry_master = 1;
711 for (el = ns->entries; el; el = el->next)
713 sym = el->sym->result;
714 if (sym->attr.dimension)
716 if (el == ns->entries)
717 gfc_error ("FUNCTION result %s can't be an array in "
718 "FUNCTION %s at %L", sym->name,
719 ns->entries->sym->name, &sym->declared_at);
721 gfc_error ("ENTRY result %s can't be an array in "
722 "FUNCTION %s at %L", sym->name,
723 ns->entries->sym->name, &sym->declared_at);
725 else if (sym->attr.pointer)
727 if (el == ns->entries)
728 gfc_error ("FUNCTION result %s can't be a POINTER in "
729 "FUNCTION %s at %L", sym->name,
730 ns->entries->sym->name, &sym->declared_at);
732 gfc_error ("ENTRY result %s can't be a POINTER in "
733 "FUNCTION %s at %L", sym->name,
734 ns->entries->sym->name, &sym->declared_at);
739 if (ts->type == BT_UNKNOWN)
740 ts = gfc_get_default_type (sym->name, NULL);
744 if (ts->kind == gfc_default_integer_kind)
748 if (ts->kind == gfc_default_real_kind
749 || ts->kind == gfc_default_double_kind)
753 if (ts->kind == gfc_default_complex_kind)
757 if (ts->kind == gfc_default_logical_kind)
761 /* We will issue error elsewhere. */
769 if (el == ns->entries)
770 gfc_error ("FUNCTION result %s can't be of type %s "
771 "in FUNCTION %s at %L", sym->name,
772 gfc_typename (ts), ns->entries->sym->name,
775 gfc_error ("ENTRY result %s can't be of type %s "
776 "in FUNCTION %s at %L", sym->name,
777 gfc_typename (ts), ns->entries->sym->name,
784 proc->attr.access = ACCESS_PRIVATE;
785 proc->attr.entry_master = 1;
787 /* Merge all the entry point arguments. */
788 for (el = ns->entries; el; el = el->next)
789 merge_argument_lists (proc, el->sym->formal);
791 /* Check the master formal arguments for any that are not
792 present in all entry points. */
793 for (el = ns->entries; el; el = el->next)
794 check_argument_lists (proc, el->sym->formal);
796 /* Use the master function for the function body. */
797 ns->proc_name = proc;
799 /* Finalize the new symbols. */
800 gfc_commit_symbols ();
802 /* Restore the original namespace. */
803 gfc_current_ns = old_ns;
807 /* Resolve common variables. */
809 resolve_common_vars (gfc_symbol *sym, bool named_common)
811 gfc_symbol *csym = sym;
813 for (; csym; csym = csym->common_next)
815 if (csym->value || csym->attr.data)
817 if (!csym->ns->is_block_data)
818 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
819 "but only in BLOCK DATA initialization is "
820 "allowed", csym->name, &csym->declared_at);
821 else if (!named_common)
822 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
823 "in a blank COMMON but initialization is only "
824 "allowed in named common blocks", csym->name,
828 if (csym->ts.type != BT_DERIVED)
831 if (!(csym->ts.u.derived->attr.sequence
832 || csym->ts.u.derived->attr.is_bind_c))
833 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
834 "has neither the SEQUENCE nor the BIND(C) "
835 "attribute", csym->name, &csym->declared_at);
836 if (csym->ts.u.derived->attr.alloc_comp)
837 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
838 "has an ultimate component that is "
839 "allocatable", csym->name, &csym->declared_at);
840 if (gfc_has_default_initializer (csym->ts.u.derived))
841 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
842 "may not have default initializer", csym->name,
845 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
846 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
850 /* Resolve common blocks. */
852 resolve_common_blocks (gfc_symtree *common_root)
856 if (common_root == NULL)
859 if (common_root->left)
860 resolve_common_blocks (common_root->left);
861 if (common_root->right)
862 resolve_common_blocks (common_root->right);
864 resolve_common_vars (common_root->n.common->head, true);
866 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
870 if (sym->attr.flavor == FL_PARAMETER)
871 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
872 sym->name, &common_root->n.common->where, &sym->declared_at);
874 if (sym->attr.intrinsic)
875 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
876 sym->name, &common_root->n.common->where);
877 else if (sym->attr.result
878 || gfc_is_function_return_value (sym, gfc_current_ns))
879 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
880 "that is also a function result", sym->name,
881 &common_root->n.common->where);
882 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
883 && sym->attr.proc != PROC_ST_FUNCTION)
884 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
885 "that is also a global procedure", sym->name,
886 &common_root->n.common->where);
890 /* Resolve contained function types. Because contained functions can call one
891 another, they have to be worked out before any of the contained procedures
894 The good news is that if a function doesn't already have a type, the only
895 way it can get one is through an IMPLICIT type or a RESULT variable, because
896 by definition contained functions are contained namespace they're contained
897 in, not in a sibling or parent namespace. */
900 resolve_contained_functions (gfc_namespace *ns)
902 gfc_namespace *child;
905 resolve_formal_arglists (ns);
907 for (child = ns->contained; child; child = child->sibling)
909 /* Resolve alternate entry points first. */
910 resolve_entries (child);
912 /* Then check function return types. */
913 resolve_contained_fntype (child->proc_name, child);
914 for (el = child->entries; el; el = el->next)
915 resolve_contained_fntype (el->sym, child);
920 /* Resolve all of the elements of a structure constructor and make sure that
921 the types are correct. The 'init' flag indicates that the given
922 constructor is an initializer. */
925 resolve_structure_cons (gfc_expr *expr, int init)
927 gfc_constructor *cons;
934 if (expr->ts.type == BT_DERIVED)
935 resolve_symbol (expr->ts.u.derived);
937 cons = gfc_constructor_first (expr->value.constructor);
938 /* A constructor may have references if it is the result of substituting a
939 parameter variable. In this case we just pull out the component we
942 comp = expr->ref->u.c.sym->components;
944 comp = expr->ts.u.derived->components;
946 /* See if the user is trying to invoke a structure constructor for one of
947 the iso_c_binding derived types. */
948 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
949 && expr->ts.u.derived->ts.is_iso_c && cons
950 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
952 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
953 expr->ts.u.derived->name, &(expr->where));
957 /* Return if structure constructor is c_null_(fun)prt. */
958 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
959 && expr->ts.u.derived->ts.is_iso_c && cons
960 && cons->expr && cons->expr->expr_type == EXPR_NULL)
963 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
970 if (gfc_resolve_expr (cons->expr) == FAILURE)
976 rank = comp->as ? comp->as->rank : 0;
977 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
978 && (comp->attr.allocatable || cons->expr->rank))
980 gfc_error ("The rank of the element in the derived type "
981 "constructor at %L does not match that of the "
982 "component (%d/%d)", &cons->expr->where,
983 cons->expr->rank, rank);
987 /* If we don't have the right type, try to convert it. */
989 if (!comp->attr.proc_pointer &&
990 !gfc_compare_types (&cons->expr->ts, &comp->ts))
993 if (strcmp (comp->name, "$extends") == 0)
995 /* Can afford to be brutal with the $extends initializer.
996 The derived type can get lost because it is PRIVATE
997 but it is not usage constrained by the standard. */
998 cons->expr->ts = comp->ts;
1001 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1002 gfc_error ("The element in the derived type constructor at %L, "
1003 "for pointer component '%s', is %s but should be %s",
1004 &cons->expr->where, comp->name,
1005 gfc_basic_typename (cons->expr->ts.type),
1006 gfc_basic_typename (comp->ts.type));
1008 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1011 /* For strings, the length of the constructor should be the same as
1012 the one of the structure, ensure this if the lengths are known at
1013 compile time and when we are dealing with PARAMETER or structure
1015 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1016 && comp->ts.u.cl->length
1017 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1018 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1019 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1020 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1021 comp->ts.u.cl->length->value.integer) != 0)
1023 if (cons->expr->expr_type == EXPR_VARIABLE
1024 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1026 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1027 to make use of the gfc_resolve_character_array_constructor
1028 machinery. The expression is later simplified away to
1029 an array of string literals. */
1030 gfc_expr *para = cons->expr;
1031 cons->expr = gfc_get_expr ();
1032 cons->expr->ts = para->ts;
1033 cons->expr->where = para->where;
1034 cons->expr->expr_type = EXPR_ARRAY;
1035 cons->expr->rank = para->rank;
1036 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1037 gfc_constructor_append_expr (&cons->expr->value.constructor,
1038 para, &cons->expr->where);
1040 if (cons->expr->expr_type == EXPR_ARRAY)
1043 p = gfc_constructor_first (cons->expr->value.constructor);
1044 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1046 gfc_charlen *cl, *cl2;
1049 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1051 if (cl == cons->expr->ts.u.cl)
1059 cl2->next = cl->next;
1061 gfc_free_expr (cl->length);
1065 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1066 cons->expr->ts.u.cl->length_from_typespec = true;
1067 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1068 gfc_resolve_character_array_constructor (cons->expr);
1072 if (cons->expr->expr_type == EXPR_NULL
1073 && !(comp->attr.pointer || comp->attr.allocatable
1074 || comp->attr.proc_pointer
1075 || (comp->ts.type == BT_CLASS
1076 && (CLASS_DATA (comp)->attr.class_pointer
1077 || CLASS_DATA (comp)->attr.allocatable))))
1080 gfc_error ("The NULL in the derived type constructor at %L is "
1081 "being applied to component '%s', which is neither "
1082 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1086 if (!comp->attr.pointer || comp->attr.proc_pointer
1087 || cons->expr->expr_type == EXPR_NULL)
1090 a = gfc_expr_attr (cons->expr);
1092 if (!a.pointer && !a.target)
1095 gfc_error ("The element in the derived type constructor at %L, "
1096 "for pointer component '%s' should be a POINTER or "
1097 "a TARGET", &cons->expr->where, comp->name);
1102 /* F08:C461. Additional checks for pointer initialization. */
1106 gfc_error ("Pointer initialization target at %L "
1107 "must not be ALLOCATABLE ", &cons->expr->where);
1112 gfc_error ("Pointer initialization target at %L "
1113 "must have the SAVE attribute", &cons->expr->where);
1117 /* F2003, C1272 (3). */
1118 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1119 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1120 || gfc_is_coindexed (cons->expr)))
1123 gfc_error ("Invalid expression in the derived type constructor for "
1124 "pointer component '%s' at %L in PURE procedure",
1125 comp->name, &cons->expr->where);
1134 /****************** Expression name resolution ******************/
1136 /* Returns 0 if a symbol was not declared with a type or
1137 attribute declaration statement, nonzero otherwise. */
1140 was_declared (gfc_symbol *sym)
1146 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1149 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1150 || a.optional || a.pointer || a.save || a.target || a.volatile_
1151 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1152 || a.asynchronous || a.codimension)
1159 /* Determine if a symbol is generic or not. */
1162 generic_sym (gfc_symbol *sym)
1166 if (sym->attr.generic ||
1167 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1170 if (was_declared (sym) || sym->ns->parent == NULL)
1173 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1180 return generic_sym (s);
1187 /* Determine if a symbol is specific or not. */
1190 specific_sym (gfc_symbol *sym)
1194 if (sym->attr.if_source == IFSRC_IFBODY
1195 || sym->attr.proc == PROC_MODULE
1196 || sym->attr.proc == PROC_INTERNAL
1197 || sym->attr.proc == PROC_ST_FUNCTION
1198 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1199 || sym->attr.external)
1202 if (was_declared (sym) || sym->ns->parent == NULL)
1205 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1207 return (s == NULL) ? 0 : specific_sym (s);
1211 /* Figure out if the procedure is specific, generic or unknown. */
1214 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1218 procedure_kind (gfc_symbol *sym)
1220 if (generic_sym (sym))
1221 return PTYPE_GENERIC;
1223 if (specific_sym (sym))
1224 return PTYPE_SPECIFIC;
1226 return PTYPE_UNKNOWN;
1229 /* Check references to assumed size arrays. The flag need_full_assumed_size
1230 is nonzero when matching actual arguments. */
1232 static int need_full_assumed_size = 0;
1235 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1237 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1240 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1241 What should it be? */
1242 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1243 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1244 && (e->ref->u.ar.type == AR_FULL))
1246 gfc_error ("The upper bound in the last dimension must "
1247 "appear in the reference to the assumed size "
1248 "array '%s' at %L", sym->name, &e->where);
1255 /* Look for bad assumed size array references in argument expressions
1256 of elemental and array valued intrinsic procedures. Since this is
1257 called from procedure resolution functions, it only recurses at
1261 resolve_assumed_size_actual (gfc_expr *e)
1266 switch (e->expr_type)
1269 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1274 if (resolve_assumed_size_actual (e->value.op.op1)
1275 || resolve_assumed_size_actual (e->value.op.op2))
1286 /* Check a generic procedure, passed as an actual argument, to see if
1287 there is a matching specific name. If none, it is an error, and if
1288 more than one, the reference is ambiguous. */
1290 count_specific_procs (gfc_expr *e)
1297 sym = e->symtree->n.sym;
1299 for (p = sym->generic; p; p = p->next)
1300 if (strcmp (sym->name, p->sym->name) == 0)
1302 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1308 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1312 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1313 "argument at %L", sym->name, &e->where);
1319 /* See if a call to sym could possibly be a not allowed RECURSION because of
1320 a missing RECURIVE declaration. This means that either sym is the current
1321 context itself, or sym is the parent of a contained procedure calling its
1322 non-RECURSIVE containing procedure.
1323 This also works if sym is an ENTRY. */
1326 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1328 gfc_symbol* proc_sym;
1329 gfc_symbol* context_proc;
1330 gfc_namespace* real_context;
1332 if (sym->attr.flavor == FL_PROGRAM)
1335 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1337 /* If we've got an ENTRY, find real procedure. */
1338 if (sym->attr.entry && sym->ns->entries)
1339 proc_sym = sym->ns->entries->sym;
1343 /* If sym is RECURSIVE, all is well of course. */
1344 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1347 /* Find the context procedure's "real" symbol if it has entries.
1348 We look for a procedure symbol, so recurse on the parents if we don't
1349 find one (like in case of a BLOCK construct). */
1350 for (real_context = context; ; real_context = real_context->parent)
1352 /* We should find something, eventually! */
1353 gcc_assert (real_context);
1355 context_proc = (real_context->entries ? real_context->entries->sym
1356 : real_context->proc_name);
1358 /* In some special cases, there may not be a proc_name, like for this
1360 real(bad_kind()) function foo () ...
1361 when checking the call to bad_kind ().
1362 In these cases, we simply return here and assume that the
1367 if (context_proc->attr.flavor != FL_LABEL)
1371 /* A call from sym's body to itself is recursion, of course. */
1372 if (context_proc == proc_sym)
1375 /* The same is true if context is a contained procedure and sym the
1377 if (context_proc->attr.contained)
1379 gfc_symbol* parent_proc;
1381 gcc_assert (context->parent);
1382 parent_proc = (context->parent->entries ? context->parent->entries->sym
1383 : context->parent->proc_name);
1385 if (parent_proc == proc_sym)
1393 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1394 its typespec and formal argument list. */
1397 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1399 gfc_intrinsic_sym* isym;
1405 /* We already know this one is an intrinsic, so we don't call
1406 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1407 gfc_find_subroutine directly to check whether it is a function or
1410 if ((isym = gfc_find_function (sym->name)))
1412 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1413 && !sym->attr.implicit_type)
1414 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1415 " ignored", sym->name, &sym->declared_at);
1417 if (!sym->attr.function &&
1418 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1423 else if ((isym = gfc_find_subroutine (sym->name)))
1425 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1427 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1428 " specifier", sym->name, &sym->declared_at);
1432 if (!sym->attr.subroutine &&
1433 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1438 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1443 gfc_copy_formal_args_intr (sym, isym);
1445 /* Check it is actually available in the standard settings. */
1446 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1449 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1450 " available in the current standard settings but %s. Use"
1451 " an appropriate -std=* option or enable -fall-intrinsics"
1452 " in order to use it.",
1453 sym->name, &sym->declared_at, symstd);
1461 /* Resolve a procedure expression, like passing it to a called procedure or as
1462 RHS for a procedure pointer assignment. */
1465 resolve_procedure_expression (gfc_expr* expr)
1469 if (expr->expr_type != EXPR_VARIABLE)
1471 gcc_assert (expr->symtree);
1473 sym = expr->symtree->n.sym;
1475 if (sym->attr.intrinsic)
1476 resolve_intrinsic (sym, &expr->where);
1478 if (sym->attr.flavor != FL_PROCEDURE
1479 || (sym->attr.function && sym->result == sym))
1482 /* A non-RECURSIVE procedure that is used as procedure expression within its
1483 own body is in danger of being called recursively. */
1484 if (is_illegal_recursion (sym, gfc_current_ns))
1485 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1486 " itself recursively. Declare it RECURSIVE or use"
1487 " -frecursive", sym->name, &expr->where);
1493 /* Resolve an actual argument list. Most of the time, this is just
1494 resolving the expressions in the list.
1495 The exception is that we sometimes have to decide whether arguments
1496 that look like procedure arguments are really simple variable
1500 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1501 bool no_formal_args)
1504 gfc_symtree *parent_st;
1506 int save_need_full_assumed_size;
1507 gfc_component *comp;
1509 for (; arg; arg = arg->next)
1514 /* Check the label is a valid branching target. */
1517 if (arg->label->defined == ST_LABEL_UNKNOWN)
1519 gfc_error ("Label %d referenced at %L is never defined",
1520 arg->label->value, &arg->label->where);
1527 if (gfc_is_proc_ptr_comp (e, &comp))
1530 if (e->expr_type == EXPR_PPC)
1532 if (comp->as != NULL)
1533 e->rank = comp->as->rank;
1534 e->expr_type = EXPR_FUNCTION;
1536 if (gfc_resolve_expr (e) == FAILURE)
1541 if (e->expr_type == EXPR_VARIABLE
1542 && e->symtree->n.sym->attr.generic
1544 && count_specific_procs (e) != 1)
1547 if (e->ts.type != BT_PROCEDURE)
1549 save_need_full_assumed_size = need_full_assumed_size;
1550 if (e->expr_type != EXPR_VARIABLE)
1551 need_full_assumed_size = 0;
1552 if (gfc_resolve_expr (e) != SUCCESS)
1554 need_full_assumed_size = save_need_full_assumed_size;
1558 /* See if the expression node should really be a variable reference. */
1560 sym = e->symtree->n.sym;
1562 if (sym->attr.flavor == FL_PROCEDURE
1563 || sym->attr.intrinsic
1564 || sym->attr.external)
1568 /* If a procedure is not already determined to be something else
1569 check if it is intrinsic. */
1570 if (!sym->attr.intrinsic
1571 && !(sym->attr.external || sym->attr.use_assoc
1572 || sym->attr.if_source == IFSRC_IFBODY)
1573 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1574 sym->attr.intrinsic = 1;
1576 if (sym->attr.proc == PROC_ST_FUNCTION)
1578 gfc_error ("Statement function '%s' at %L is not allowed as an "
1579 "actual argument", sym->name, &e->where);
1582 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1583 sym->attr.subroutine);
1584 if (sym->attr.intrinsic && actual_ok == 0)
1586 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1587 "actual argument", sym->name, &e->where);
1590 if (sym->attr.contained && !sym->attr.use_assoc
1591 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1593 gfc_error ("Internal procedure '%s' is not allowed as an "
1594 "actual argument at %L", sym->name, &e->where);
1597 if (sym->attr.elemental && !sym->attr.intrinsic)
1599 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1600 "allowed as an actual argument at %L", sym->name,
1604 /* Check if a generic interface has a specific procedure
1605 with the same name before emitting an error. */
1606 if (sym->attr.generic && count_specific_procs (e) != 1)
1609 /* Just in case a specific was found for the expression. */
1610 sym = e->symtree->n.sym;
1612 /* If the symbol is the function that names the current (or
1613 parent) scope, then we really have a variable reference. */
1615 if (gfc_is_function_return_value (sym, sym->ns))
1618 /* If all else fails, see if we have a specific intrinsic. */
1619 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1621 gfc_intrinsic_sym *isym;
1623 isym = gfc_find_function (sym->name);
1624 if (isym == NULL || !isym->specific)
1626 gfc_error ("Unable to find a specific INTRINSIC procedure "
1627 "for the reference '%s' at %L", sym->name,
1632 sym->attr.intrinsic = 1;
1633 sym->attr.function = 1;
1636 if (gfc_resolve_expr (e) == FAILURE)
1641 /* See if the name is a module procedure in a parent unit. */
1643 if (was_declared (sym) || sym->ns->parent == NULL)
1646 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1648 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1652 if (parent_st == NULL)
1655 sym = parent_st->n.sym;
1656 e->symtree = parent_st; /* Point to the right thing. */
1658 if (sym->attr.flavor == FL_PROCEDURE
1659 || sym->attr.intrinsic
1660 || sym->attr.external)
1662 if (gfc_resolve_expr (e) == FAILURE)
1668 e->expr_type = EXPR_VARIABLE;
1670 if (sym->as != NULL)
1672 e->rank = sym->as->rank;
1673 e->ref = gfc_get_ref ();
1674 e->ref->type = REF_ARRAY;
1675 e->ref->u.ar.type = AR_FULL;
1676 e->ref->u.ar.as = sym->as;
1679 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1680 primary.c (match_actual_arg). If above code determines that it
1681 is a variable instead, it needs to be resolved as it was not
1682 done at the beginning of this function. */
1683 save_need_full_assumed_size = need_full_assumed_size;
1684 if (e->expr_type != EXPR_VARIABLE)
1685 need_full_assumed_size = 0;
1686 if (gfc_resolve_expr (e) != SUCCESS)
1688 need_full_assumed_size = save_need_full_assumed_size;
1691 /* Check argument list functions %VAL, %LOC and %REF. There is
1692 nothing to do for %REF. */
1693 if (arg->name && arg->name[0] == '%')
1695 if (strncmp ("%VAL", arg->name, 4) == 0)
1697 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1699 gfc_error ("By-value argument at %L is not of numeric "
1706 gfc_error ("By-value argument at %L cannot be an array or "
1707 "an array section", &e->where);
1711 /* Intrinsics are still PROC_UNKNOWN here. However,
1712 since same file external procedures are not resolvable
1713 in gfortran, it is a good deal easier to leave them to
1715 if (ptype != PROC_UNKNOWN
1716 && ptype != PROC_DUMMY
1717 && ptype != PROC_EXTERNAL
1718 && ptype != PROC_MODULE)
1720 gfc_error ("By-value argument at %L is not allowed "
1721 "in this context", &e->where);
1726 /* Statement functions have already been excluded above. */
1727 else if (strncmp ("%LOC", arg->name, 4) == 0
1728 && e->ts.type == BT_PROCEDURE)
1730 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1732 gfc_error ("Passing internal procedure at %L by location "
1733 "not allowed", &e->where);
1739 /* Fortran 2008, C1237. */
1740 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1741 && gfc_has_ultimate_pointer (e))
1743 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1744 "component", &e->where);
1753 /* Do the checks of the actual argument list that are specific to elemental
1754 procedures. If called with c == NULL, we have a function, otherwise if
1755 expr == NULL, we have a subroutine. */
1758 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1760 gfc_actual_arglist *arg0;
1761 gfc_actual_arglist *arg;
1762 gfc_symbol *esym = NULL;
1763 gfc_intrinsic_sym *isym = NULL;
1765 gfc_intrinsic_arg *iformal = NULL;
1766 gfc_formal_arglist *eformal = NULL;
1767 bool formal_optional = false;
1768 bool set_by_optional = false;
1772 /* Is this an elemental procedure? */
1773 if (expr && expr->value.function.actual != NULL)
1775 if (expr->value.function.esym != NULL
1776 && expr->value.function.esym->attr.elemental)
1778 arg0 = expr->value.function.actual;
1779 esym = expr->value.function.esym;
1781 else if (expr->value.function.isym != NULL
1782 && expr->value.function.isym->elemental)
1784 arg0 = expr->value.function.actual;
1785 isym = expr->value.function.isym;
1790 else if (c && c->ext.actual != NULL)
1792 arg0 = c->ext.actual;
1794 if (c->resolved_sym)
1795 esym = c->resolved_sym;
1797 esym = c->symtree->n.sym;
1800 if (!esym->attr.elemental)
1806 /* The rank of an elemental is the rank of its array argument(s). */
1807 for (arg = arg0; arg; arg = arg->next)
1809 if (arg->expr != NULL && arg->expr->rank > 0)
1811 rank = arg->expr->rank;
1812 if (arg->expr->expr_type == EXPR_VARIABLE
1813 && arg->expr->symtree->n.sym->attr.optional)
1814 set_by_optional = true;
1816 /* Function specific; set the result rank and shape. */
1820 if (!expr->shape && arg->expr->shape)
1822 expr->shape = gfc_get_shape (rank);
1823 for (i = 0; i < rank; i++)
1824 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1831 /* If it is an array, it shall not be supplied as an actual argument
1832 to an elemental procedure unless an array of the same rank is supplied
1833 as an actual argument corresponding to a nonoptional dummy argument of
1834 that elemental procedure(12.4.1.5). */
1835 formal_optional = false;
1837 iformal = isym->formal;
1839 eformal = esym->formal;
1841 for (arg = arg0; arg; arg = arg->next)
1845 if (eformal->sym && eformal->sym->attr.optional)
1846 formal_optional = true;
1847 eformal = eformal->next;
1849 else if (isym && iformal)
1851 if (iformal->optional)
1852 formal_optional = true;
1853 iformal = iformal->next;
1856 formal_optional = true;
1858 if (pedantic && arg->expr != NULL
1859 && arg->expr->expr_type == EXPR_VARIABLE
1860 && arg->expr->symtree->n.sym->attr.optional
1863 && (set_by_optional || arg->expr->rank != rank)
1864 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1866 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1867 "MISSING, it cannot be the actual argument of an "
1868 "ELEMENTAL procedure unless there is a non-optional "
1869 "argument with the same rank (12.4.1.5)",
1870 arg->expr->symtree->n.sym->name, &arg->expr->where);
1875 for (arg = arg0; arg; arg = arg->next)
1877 if (arg->expr == NULL || arg->expr->rank == 0)
1880 /* Being elemental, the last upper bound of an assumed size array
1881 argument must be present. */
1882 if (resolve_assumed_size_actual (arg->expr))
1885 /* Elemental procedure's array actual arguments must conform. */
1888 if (gfc_check_conformance (arg->expr, e,
1889 "elemental procedure") == FAILURE)
1896 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1897 is an array, the intent inout/out variable needs to be also an array. */
1898 if (rank > 0 && esym && expr == NULL)
1899 for (eformal = esym->formal, arg = arg0; arg && eformal;
1900 arg = arg->next, eformal = eformal->next)
1901 if ((eformal->sym->attr.intent == INTENT_OUT
1902 || eformal->sym->attr.intent == INTENT_INOUT)
1903 && arg->expr && arg->expr->rank == 0)
1905 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1906 "ELEMENTAL subroutine '%s' is a scalar, but another "
1907 "actual argument is an array", &arg->expr->where,
1908 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1909 : "INOUT", eformal->sym->name, esym->name);
1916 /* Go through each actual argument in ACTUAL and see if it can be
1917 implemented as an inlined, non-copying intrinsic. FNSYM is the
1918 function being called, or NULL if not known. */
1921 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1923 gfc_actual_arglist *ap;
1926 for (ap = actual; ap; ap = ap->next)
1928 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1929 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1931 ap->expr->inline_noncopying_intrinsic = 1;
1935 /* This function does the checking of references to global procedures
1936 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1937 77 and 95 standards. It checks for a gsymbol for the name, making
1938 one if it does not already exist. If it already exists, then the
1939 reference being resolved must correspond to the type of gsymbol.
1940 Otherwise, the new symbol is equipped with the attributes of the
1941 reference. The corresponding code that is called in creating
1942 global entities is parse.c.
1944 In addition, for all but -std=legacy, the gsymbols are used to
1945 check the interfaces of external procedures from the same file.
1946 The namespace of the gsymbol is resolved and then, once this is
1947 done the interface is checked. */
1951 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1953 if (!gsym_ns->proc_name->attr.recursive)
1956 if (sym->ns == gsym_ns)
1959 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1966 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1968 if (gsym_ns->entries)
1970 gfc_entry_list *entry = gsym_ns->entries;
1972 for (; entry; entry = entry->next)
1974 if (strcmp (sym->name, entry->sym->name) == 0)
1976 if (strcmp (gsym_ns->proc_name->name,
1977 sym->ns->proc_name->name) == 0)
1981 && strcmp (gsym_ns->proc_name->name,
1982 sym->ns->parent->proc_name->name) == 0)
1991 resolve_global_procedure (gfc_symbol *sym, locus *where,
1992 gfc_actual_arglist **actual, int sub)
1996 enum gfc_symbol_type type;
1998 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2000 gsym = gfc_get_gsymbol (sym->name);
2002 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2003 gfc_global_used (gsym, where);
2005 if (gfc_option.flag_whole_file
2006 && (sym->attr.if_source == IFSRC_UNKNOWN
2007 || sym->attr.if_source == IFSRC_IFBODY)
2008 && gsym->type != GSYM_UNKNOWN
2010 && gsym->ns->resolved != -1
2011 && gsym->ns->proc_name
2012 && not_in_recursive (sym, gsym->ns)
2013 && not_entry_self_reference (sym, gsym->ns))
2015 gfc_symbol *def_sym;
2017 /* Resolve the gsymbol namespace if needed. */
2018 if (!gsym->ns->resolved)
2020 gfc_dt_list *old_dt_list;
2022 /* Stash away derived types so that the backend_decls do not
2024 old_dt_list = gfc_derived_types;
2025 gfc_derived_types = NULL;
2027 gfc_resolve (gsym->ns);
2029 /* Store the new derived types with the global namespace. */
2030 if (gfc_derived_types)
2031 gsym->ns->derived_types = gfc_derived_types;
2033 /* Restore the derived types of this namespace. */
2034 gfc_derived_types = old_dt_list;
2037 /* Make sure that translation for the gsymbol occurs before
2038 the procedure currently being resolved. */
2039 ns = gfc_global_ns_list;
2040 for (; ns && ns != gsym->ns; ns = ns->sibling)
2042 if (ns->sibling == gsym->ns)
2044 ns->sibling = gsym->ns->sibling;
2045 gsym->ns->sibling = gfc_global_ns_list;
2046 gfc_global_ns_list = gsym->ns;
2051 def_sym = gsym->ns->proc_name;
2052 if (def_sym->attr.entry_master)
2054 gfc_entry_list *entry;
2055 for (entry = gsym->ns->entries; entry; entry = entry->next)
2056 if (strcmp (entry->sym->name, sym->name) == 0)
2058 def_sym = entry->sym;
2063 /* Differences in constant character lengths. */
2064 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2066 long int l1 = 0, l2 = 0;
2067 gfc_charlen *cl1 = sym->ts.u.cl;
2068 gfc_charlen *cl2 = def_sym->ts.u.cl;
2071 && cl1->length != NULL
2072 && cl1->length->expr_type == EXPR_CONSTANT)
2073 l1 = mpz_get_si (cl1->length->value.integer);
2076 && cl2->length != NULL
2077 && cl2->length->expr_type == EXPR_CONSTANT)
2078 l2 = mpz_get_si (cl2->length->value.integer);
2080 if (l1 && l2 && l1 != l2)
2081 gfc_error ("Character length mismatch in return type of "
2082 "function '%s' at %L (%ld/%ld)", sym->name,
2083 &sym->declared_at, l1, l2);
2086 /* Type mismatch of function return type and expected type. */
2087 if (sym->attr.function
2088 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2089 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2090 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2091 gfc_typename (&def_sym->ts));
2093 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2095 gfc_formal_arglist *arg = def_sym->formal;
2096 for ( ; arg; arg = arg->next)
2099 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2100 else if (arg->sym->attr.allocatable
2101 || arg->sym->attr.asynchronous
2102 || arg->sym->attr.optional
2103 || arg->sym->attr.pointer
2104 || arg->sym->attr.target
2105 || arg->sym->attr.value
2106 || arg->sym->attr.volatile_)
2108 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2109 "has an attribute that requires an explicit "
2110 "interface for this procedure", arg->sym->name,
2111 sym->name, &sym->declared_at);
2114 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2115 else if (arg->sym && arg->sym->as
2116 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2118 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2119 "argument '%s' must have an explicit interface",
2120 sym->name, &sym->declared_at, arg->sym->name);
2123 /* F2008, 12.4.2.2 (2c) */
2124 else if (arg->sym->attr.codimension)
2126 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2127 "'%s' must have an explicit interface",
2128 sym->name, &sym->declared_at, arg->sym->name);
2131 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2132 else if (false) /* TODO: is a parametrized derived type */
2134 gfc_error ("Procedure '%s' at %L with parametrized derived "
2135 "type argument '%s' must have an explicit "
2136 "interface", sym->name, &sym->declared_at,
2140 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2141 else if (arg->sym->ts.type == BT_CLASS)
2143 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2144 "argument '%s' must have an explicit interface",
2145 sym->name, &sym->declared_at, arg->sym->name);
2150 if (def_sym->attr.function)
2152 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2153 if (def_sym->as && def_sym->as->rank
2154 && (!sym->as || sym->as->rank != def_sym->as->rank))
2155 gfc_error ("The reference to function '%s' at %L either needs an "
2156 "explicit INTERFACE or the rank is incorrect", sym->name,
2159 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2160 if ((def_sym->result->attr.pointer
2161 || def_sym->result->attr.allocatable)
2162 && (sym->attr.if_source != IFSRC_IFBODY
2163 || def_sym->result->attr.pointer
2164 != sym->result->attr.pointer
2165 || def_sym->result->attr.allocatable
2166 != sym->result->attr.allocatable))
2167 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2168 "result must have an explicit interface", sym->name,
2171 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2172 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2173 && def_sym->ts.u.cl->length != NULL)
2175 gfc_charlen *cl = sym->ts.u.cl;
2177 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2178 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2180 gfc_error ("Nonconstant character-length function '%s' at %L "
2181 "must have an explicit interface", sym->name,
2187 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2188 if (def_sym->attr.elemental && !sym->attr.elemental)
2190 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2191 "interface", sym->name, &sym->declared_at);
2194 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2195 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2197 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2198 "an explicit interface", sym->name, &sym->declared_at);
2201 if (gfc_option.flag_whole_file == 1
2202 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2203 && !(gfc_option.warn_std & GFC_STD_GNU)))
2204 gfc_errors_to_warnings (1);
2206 if (sym->attr.if_source != IFSRC_IFBODY)
2207 gfc_procedure_use (def_sym, actual, where);
2209 gfc_errors_to_warnings (0);
2212 if (gsym->type == GSYM_UNKNOWN)
2215 gsym->where = *where;
2222 /************* Function resolution *************/
2224 /* Resolve a function call known to be generic.
2225 Section 14.1.2.4.1. */
2228 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2232 if (sym->attr.generic)
2234 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2237 expr->value.function.name = s->name;
2238 expr->value.function.esym = s;
2240 if (s->ts.type != BT_UNKNOWN)
2242 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2243 expr->ts = s->result->ts;
2246 expr->rank = s->as->rank;
2247 else if (s->result != NULL && s->result->as != NULL)
2248 expr->rank = s->result->as->rank;
2250 gfc_set_sym_referenced (expr->value.function.esym);
2255 /* TODO: Need to search for elemental references in generic
2259 if (sym->attr.intrinsic)
2260 return gfc_intrinsic_func_interface (expr, 0);
2267 resolve_generic_f (gfc_expr *expr)
2272 sym = expr->symtree->n.sym;
2276 m = resolve_generic_f0 (expr, sym);
2279 else if (m == MATCH_ERROR)
2283 if (sym->ns->parent == NULL)
2285 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2289 if (!generic_sym (sym))
2293 /* Last ditch attempt. See if the reference is to an intrinsic
2294 that possesses a matching interface. 14.1.2.4 */
2295 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2297 gfc_error ("There is no specific function for the generic '%s' at %L",
2298 expr->symtree->n.sym->name, &expr->where);
2302 m = gfc_intrinsic_func_interface (expr, 0);
2306 gfc_error ("Generic function '%s' at %L is not consistent with a "
2307 "specific intrinsic interface", expr->symtree->n.sym->name,
2314 /* Resolve a function call known to be specific. */
2317 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2321 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2323 if (sym->attr.dummy)
2325 sym->attr.proc = PROC_DUMMY;
2329 sym->attr.proc = PROC_EXTERNAL;
2333 if (sym->attr.proc == PROC_MODULE
2334 || sym->attr.proc == PROC_ST_FUNCTION
2335 || sym->attr.proc == PROC_INTERNAL)
2338 if (sym->attr.intrinsic)
2340 m = gfc_intrinsic_func_interface (expr, 1);
2344 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2345 "with an intrinsic", sym->name, &expr->where);
2353 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2356 expr->ts = sym->result->ts;
2359 expr->value.function.name = sym->name;
2360 expr->value.function.esym = sym;
2361 if (sym->as != NULL)
2362 expr->rank = sym->as->rank;
2369 resolve_specific_f (gfc_expr *expr)
2374 sym = expr->symtree->n.sym;
2378 m = resolve_specific_f0 (sym, expr);
2381 if (m == MATCH_ERROR)
2384 if (sym->ns->parent == NULL)
2387 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2393 gfc_error ("Unable to resolve the specific function '%s' at %L",
2394 expr->symtree->n.sym->name, &expr->where);
2400 /* Resolve a procedure call not known to be generic nor specific. */
2403 resolve_unknown_f (gfc_expr *expr)
2408 sym = expr->symtree->n.sym;
2410 if (sym->attr.dummy)
2412 sym->attr.proc = PROC_DUMMY;
2413 expr->value.function.name = sym->name;
2417 /* See if we have an intrinsic function reference. */
2419 if (gfc_is_intrinsic (sym, 0, expr->where))
2421 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2426 /* The reference is to an external name. */
2428 sym->attr.proc = PROC_EXTERNAL;
2429 expr->value.function.name = sym->name;
2430 expr->value.function.esym = expr->symtree->n.sym;
2432 if (sym->as != NULL)
2433 expr->rank = sym->as->rank;
2435 /* Type of the expression is either the type of the symbol or the
2436 default type of the symbol. */
2439 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2441 if (sym->ts.type != BT_UNKNOWN)
2445 ts = gfc_get_default_type (sym->name, sym->ns);
2447 if (ts->type == BT_UNKNOWN)
2449 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2450 sym->name, &expr->where);
2461 /* Return true, if the symbol is an external procedure. */
2463 is_external_proc (gfc_symbol *sym)
2465 if (!sym->attr.dummy && !sym->attr.contained
2466 && !(sym->attr.intrinsic
2467 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2468 && sym->attr.proc != PROC_ST_FUNCTION
2469 && !sym->attr.proc_pointer
2470 && !sym->attr.use_assoc
2478 /* Figure out if a function reference is pure or not. Also set the name
2479 of the function for a potential error message. Return nonzero if the
2480 function is PURE, zero if not. */
2482 pure_stmt_function (gfc_expr *, gfc_symbol *);
2485 pure_function (gfc_expr *e, const char **name)
2491 if (e->symtree != NULL
2492 && e->symtree->n.sym != NULL
2493 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2494 return pure_stmt_function (e, e->symtree->n.sym);
2496 if (e->value.function.esym)
2498 pure = gfc_pure (e->value.function.esym);
2499 *name = e->value.function.esym->name;
2501 else if (e->value.function.isym)
2503 pure = e->value.function.isym->pure
2504 || e->value.function.isym->elemental;
2505 *name = e->value.function.isym->name;
2509 /* Implicit functions are not pure. */
2511 *name = e->value.function.name;
2519 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2520 int *f ATTRIBUTE_UNUSED)
2524 /* Don't bother recursing into other statement functions
2525 since they will be checked individually for purity. */
2526 if (e->expr_type != EXPR_FUNCTION
2528 || e->symtree->n.sym == sym
2529 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2532 return pure_function (e, &name) ? false : true;
2537 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2539 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2544 is_scalar_expr_ptr (gfc_expr *expr)
2546 gfc_try retval = SUCCESS;
2551 /* See if we have a gfc_ref, which means we have a substring, array
2552 reference, or a component. */
2553 if (expr->ref != NULL)
2556 while (ref->next != NULL)
2562 if (ref->u.ss.length != NULL
2563 && ref->u.ss.length->length != NULL
2565 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2567 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2569 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2570 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2571 if (end - start + 1 != 1)
2578 if (ref->u.ar.type == AR_ELEMENT)
2580 else if (ref->u.ar.type == AR_FULL)
2582 /* The user can give a full array if the array is of size 1. */
2583 if (ref->u.ar.as != NULL
2584 && ref->u.ar.as->rank == 1
2585 && ref->u.ar.as->type == AS_EXPLICIT
2586 && ref->u.ar.as->lower[0] != NULL
2587 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2588 && ref->u.ar.as->upper[0] != NULL
2589 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2591 /* If we have a character string, we need to check if
2592 its length is one. */
2593 if (expr->ts.type == BT_CHARACTER)
2595 if (expr->ts.u.cl == NULL
2596 || expr->ts.u.cl->length == NULL
2597 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2603 /* We have constant lower and upper bounds. If the
2604 difference between is 1, it can be considered a
2606 start = (int) mpz_get_si
2607 (ref->u.ar.as->lower[0]->value.integer);
2608 end = (int) mpz_get_si
2609 (ref->u.ar.as->upper[0]->value.integer);
2610 if (end - start + 1 != 1)
2625 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2627 /* Character string. Make sure it's of length 1. */
2628 if (expr->ts.u.cl == NULL
2629 || expr->ts.u.cl->length == NULL
2630 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2633 else if (expr->rank != 0)
2640 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2641 and, in the case of c_associated, set the binding label based on
2645 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2646 gfc_symbol **new_sym)
2648 char name[GFC_MAX_SYMBOL_LEN + 1];
2649 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2650 int optional_arg = 0;
2651 gfc_try retval = SUCCESS;
2652 gfc_symbol *args_sym;
2653 gfc_typespec *arg_ts;
2654 symbol_attribute arg_attr;
2656 if (args->expr->expr_type == EXPR_CONSTANT
2657 || args->expr->expr_type == EXPR_OP
2658 || args->expr->expr_type == EXPR_NULL)
2660 gfc_error ("Argument to '%s' at %L is not a variable",
2661 sym->name, &(args->expr->where));
2665 args_sym = args->expr->symtree->n.sym;
2667 /* The typespec for the actual arg should be that stored in the expr
2668 and not necessarily that of the expr symbol (args_sym), because
2669 the actual expression could be a part-ref of the expr symbol. */
2670 arg_ts = &(args->expr->ts);
2671 arg_attr = gfc_expr_attr (args->expr);
2673 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2675 /* If the user gave two args then they are providing something for
2676 the optional arg (the second cptr). Therefore, set the name and
2677 binding label to the c_associated for two cptrs. Otherwise,
2678 set c_associated to expect one cptr. */
2682 sprintf (name, "%s_2", sym->name);
2683 sprintf (binding_label, "%s_2", sym->binding_label);
2689 sprintf (name, "%s_1", sym->name);
2690 sprintf (binding_label, "%s_1", sym->binding_label);
2694 /* Get a new symbol for the version of c_associated that
2696 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2698 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2699 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2701 sprintf (name, "%s", sym->name);
2702 sprintf (binding_label, "%s", sym->binding_label);
2704 /* Error check the call. */
2705 if (args->next != NULL)
2707 gfc_error_now ("More actual than formal arguments in '%s' "
2708 "call at %L", name, &(args->expr->where));
2711 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2713 /* Make sure we have either the target or pointer attribute. */
2714 if (!arg_attr.target && !arg_attr.pointer)
2716 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2717 "a TARGET or an associated pointer",
2719 sym->name, &(args->expr->where));
2723 /* See if we have interoperable type and type param. */
2724 if (verify_c_interop (arg_ts) == SUCCESS
2725 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2727 if (args_sym->attr.target == 1)
2729 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2730 has the target attribute and is interoperable. */
2731 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2732 allocatable variable that has the TARGET attribute and
2733 is not an array of zero size. */
2734 if (args_sym->attr.allocatable == 1)
2736 if (args_sym->attr.dimension != 0
2737 && (args_sym->as && args_sym->as->rank == 0))
2739 gfc_error_now ("Allocatable variable '%s' used as a "
2740 "parameter to '%s' at %L must not be "
2741 "an array of zero size",
2742 args_sym->name, sym->name,
2743 &(args->expr->where));
2749 /* A non-allocatable target variable with C
2750 interoperable type and type parameters must be
2752 if (args_sym && args_sym->attr.dimension)
2754 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2756 gfc_error ("Assumed-shape array '%s' at %L "
2757 "cannot be an argument to the "
2758 "procedure '%s' because "
2759 "it is not C interoperable",
2761 &(args->expr->where), sym->name);
2764 else if (args_sym->as->type == AS_DEFERRED)
2766 gfc_error ("Deferred-shape array '%s' at %L "
2767 "cannot be an argument to the "
2768 "procedure '%s' because "
2769 "it is not C interoperable",
2771 &(args->expr->where), sym->name);
2776 /* Make sure it's not a character string. Arrays of
2777 any type should be ok if the variable is of a C
2778 interoperable type. */
2779 if (arg_ts->type == BT_CHARACTER)
2780 if (arg_ts->u.cl != NULL
2781 && (arg_ts->u.cl->length == NULL
2782 || arg_ts->u.cl->length->expr_type
2785 (arg_ts->u.cl->length->value.integer, 1)
2787 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2789 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2790 "at %L must have a length of 1",
2791 args_sym->name, sym->name,
2792 &(args->expr->where));
2797 else if (arg_attr.pointer
2798 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2800 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2802 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2803 "associated scalar POINTER", args_sym->name,
2804 sym->name, &(args->expr->where));
2810 /* The parameter is not required to be C interoperable. If it
2811 is not C interoperable, it must be a nonpolymorphic scalar
2812 with no length type parameters. It still must have either
2813 the pointer or target attribute, and it can be
2814 allocatable (but must be allocated when c_loc is called). */
2815 if (args->expr->rank != 0
2816 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2818 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2819 "scalar", args_sym->name, sym->name,
2820 &(args->expr->where));
2823 else if (arg_ts->type == BT_CHARACTER
2824 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2826 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2827 "%L must have a length of 1",
2828 args_sym->name, sym->name,
2829 &(args->expr->where));
2832 else if (arg_ts->type == BT_CLASS)
2834 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2835 "polymorphic", args_sym->name, sym->name,
2836 &(args->expr->where));
2841 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2843 if (args_sym->attr.flavor != FL_PROCEDURE)
2845 /* TODO: Update this error message to allow for procedure
2846 pointers once they are implemented. */
2847 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2849 args_sym->name, sym->name,
2850 &(args->expr->where));
2853 else if (args_sym->attr.is_bind_c != 1)
2855 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2857 args_sym->name, sym->name,
2858 &(args->expr->where));
2863 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2868 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2869 "iso_c_binding function: '%s'!\n", sym->name);
2876 /* Resolve a function call, which means resolving the arguments, then figuring
2877 out which entity the name refers to. */
2878 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2879 to INTENT(OUT) or INTENT(INOUT). */
2882 resolve_function (gfc_expr *expr)
2884 gfc_actual_arglist *arg;
2889 procedure_type p = PROC_INTRINSIC;
2890 bool no_formal_args;
2894 sym = expr->symtree->n.sym;
2896 /* If this is a procedure pointer component, it has already been resolved. */
2897 if (gfc_is_proc_ptr_comp (expr, NULL))
2900 if (sym && sym->attr.intrinsic
2901 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2904 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2906 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2910 /* If this ia a deferred TBP with an abstract interface (which may
2911 of course be referenced), expr->value.function.esym will be set. */
2912 if (sym && sym->attr.abstract && !expr->value.function.esym)
2914 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2915 sym->name, &expr->where);
2919 /* Switch off assumed size checking and do this again for certain kinds
2920 of procedure, once the procedure itself is resolved. */
2921 need_full_assumed_size++;
2923 if (expr->symtree && expr->symtree->n.sym)
2924 p = expr->symtree->n.sym->attr.proc;
2926 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2927 inquiry_argument = true;
2928 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2930 if (resolve_actual_arglist (expr->value.function.actual,
2931 p, no_formal_args) == FAILURE)
2933 inquiry_argument = false;
2937 inquiry_argument = false;
2939 /* Need to setup the call to the correct c_associated, depending on
2940 the number of cptrs to user gives to compare. */
2941 if (sym && sym->attr.is_iso_c == 1)
2943 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2947 /* Get the symtree for the new symbol (resolved func).
2948 the old one will be freed later, when it's no longer used. */
2949 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2952 /* Resume assumed_size checking. */
2953 need_full_assumed_size--;
2955 /* If the procedure is external, check for usage. */
2956 if (sym && is_external_proc (sym))
2957 resolve_global_procedure (sym, &expr->where,
2958 &expr->value.function.actual, 0);
2960 if (sym && sym->ts.type == BT_CHARACTER
2962 && sym->ts.u.cl->length == NULL
2964 && expr->value.function.esym == NULL
2965 && !sym->attr.contained)
2967 /* Internal procedures are taken care of in resolve_contained_fntype. */
2968 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2969 "be used at %L since it is not a dummy argument",
2970 sym->name, &expr->where);
2974 /* See if function is already resolved. */
2976 if (expr->value.function.name != NULL)
2978 if (expr->ts.type == BT_UNKNOWN)
2984 /* Apply the rules of section 14.1.2. */
2986 switch (procedure_kind (sym))
2989 t = resolve_generic_f (expr);
2992 case PTYPE_SPECIFIC:
2993 t = resolve_specific_f (expr);
2997 t = resolve_unknown_f (expr);
3001 gfc_internal_error ("resolve_function(): bad function type");
3005 /* If the expression is still a function (it might have simplified),
3006 then we check to see if we are calling an elemental function. */
3008 if (expr->expr_type != EXPR_FUNCTION)
3011 temp = need_full_assumed_size;
3012 need_full_assumed_size = 0;
3014 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3017 if (omp_workshare_flag
3018 && expr->value.function.esym
3019 && ! gfc_elemental (expr->value.function.esym))
3021 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3022 "in WORKSHARE construct", expr->value.function.esym->name,
3027 #define GENERIC_ID expr->value.function.isym->id
3028 else if (expr->value.function.actual != NULL
3029 && expr->value.function.isym != NULL
3030 && GENERIC_ID != GFC_ISYM_LBOUND
3031 && GENERIC_ID != GFC_ISYM_LEN
3032 && GENERIC_ID != GFC_ISYM_LOC
3033 && GENERIC_ID != GFC_ISYM_PRESENT)
3035 /* Array intrinsics must also have the last upper bound of an
3036 assumed size array argument. UBOUND and SIZE have to be
3037 excluded from the check if the second argument is anything
3040 for (arg = expr->value.function.actual; arg; arg = arg->next)
3042 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3043 && arg->next != NULL && arg->next->expr)
3045 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3048 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3051 if ((int)mpz_get_si (arg->next->expr->value.integer)
3056 if (arg->expr != NULL
3057 && arg->expr->rank > 0
3058 && resolve_assumed_size_actual (arg->expr))
3064 need_full_assumed_size = temp;
3067 if (!pure_function (expr, &name) && name)
3071 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3072 "FORALL %s", name, &expr->where,
3073 forall_flag == 2 ? "mask" : "block");
3076 else if (gfc_pure (NULL))
3078 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3079 "procedure within a PURE procedure", name, &expr->where);
3084 /* Functions without the RECURSIVE attribution are not allowed to
3085 * call themselves. */
3086 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3089 esym = expr->value.function.esym;
3091 if (is_illegal_recursion (esym, gfc_current_ns))
3093 if (esym->attr.entry && esym->ns->entries)
3094 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3095 " function '%s' is not RECURSIVE",
3096 esym->name, &expr->where, esym->ns->entries->sym->name);
3098 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3099 " is not RECURSIVE", esym->name, &expr->where);
3105 /* Character lengths of use associated functions may contains references to
3106 symbols not referenced from the current program unit otherwise. Make sure
3107 those symbols are marked as referenced. */
3109 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3110 && expr->value.function.esym->attr.use_assoc)
3112 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3116 && !((expr->value.function.esym
3117 && expr->value.function.esym->attr.elemental)
3119 (expr->value.function.isym
3120 && expr->value.function.isym->elemental)))
3121 find_noncopying_intrinsics (expr->value.function.esym,
3122 expr->value.function.actual);
3124 /* Make sure that the expression has a typespec that works. */
3125 if (expr->ts.type == BT_UNKNOWN)
3127 if (expr->symtree->n.sym->result
3128 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3129 && !expr->symtree->n.sym->result->attr.proc_pointer)
3130 expr->ts = expr->symtree->n.sym->result->ts;
3137 /************* Subroutine resolution *************/
3140 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3146 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3147 sym->name, &c->loc);
3148 else if (gfc_pure (NULL))
3149 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3155 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3159 if (sym->attr.generic)
3161 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3164 c->resolved_sym = s;
3165 pure_subroutine (c, s);
3169 /* TODO: Need to search for elemental references in generic interface. */
3172 if (sym->attr.intrinsic)
3173 return gfc_intrinsic_sub_interface (c, 0);
3180 resolve_generic_s (gfc_code *c)
3185 sym = c->symtree->n.sym;
3189 m = resolve_generic_s0 (c, sym);
3192 else if (m == MATCH_ERROR)
3196 if (sym->ns->parent == NULL)
3198 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3202 if (!generic_sym (sym))
3206 /* Last ditch attempt. See if the reference is to an intrinsic
3207 that possesses a matching interface. 14.1.2.4 */
3208 sym = c->symtree->n.sym;
3210 if (!gfc_is_intrinsic (sym, 1, c->loc))
3212 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3213 sym->name, &c->loc);
3217 m = gfc_intrinsic_sub_interface (c, 0);
3221 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3222 "intrinsic subroutine interface", sym->name, &c->loc);
3228 /* Set the name and binding label of the subroutine symbol in the call
3229 expression represented by 'c' to include the type and kind of the
3230 second parameter. This function is for resolving the appropriate
3231 version of c_f_pointer() and c_f_procpointer(). For example, a
3232 call to c_f_pointer() for a default integer pointer could have a
3233 name of c_f_pointer_i4. If no second arg exists, which is an error
3234 for these two functions, it defaults to the generic symbol's name
3235 and binding label. */
3238 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3239 char *name, char *binding_label)
3241 gfc_expr *arg = NULL;
3245 /* The second arg of c_f_pointer and c_f_procpointer determines
3246 the type and kind for the procedure name. */
3247 arg = c->ext.actual->next->expr;
3251 /* Set up the name to have the given symbol's name,
3252 plus the type and kind. */
3253 /* a derived type is marked with the type letter 'u' */
3254 if (arg->ts.type == BT_DERIVED)
3257 kind = 0; /* set the kind as 0 for now */
3261 type = gfc_type_letter (arg->ts.type);
3262 kind = arg->ts.kind;
3265 if (arg->ts.type == BT_CHARACTER)
3266 /* Kind info for character strings not needed. */
3269 sprintf (name, "%s_%c%d", sym->name, type, kind);
3270 /* Set up the binding label as the given symbol's label plus
3271 the type and kind. */
3272 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3276 /* If the second arg is missing, set the name and label as
3277 was, cause it should at least be found, and the missing
3278 arg error will be caught by compare_parameters(). */
3279 sprintf (name, "%s", sym->name);
3280 sprintf (binding_label, "%s", sym->binding_label);
3287 /* Resolve a generic version of the iso_c_binding procedure given
3288 (sym) to the specific one based on the type and kind of the
3289 argument(s). Currently, this function resolves c_f_pointer() and
3290 c_f_procpointer based on the type and kind of the second argument
3291 (FPTR). Other iso_c_binding procedures aren't specially handled.
3292 Upon successfully exiting, c->resolved_sym will hold the resolved
3293 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3297 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3299 gfc_symbol *new_sym;
3300 /* this is fine, since we know the names won't use the max */
3301 char name[GFC_MAX_SYMBOL_LEN + 1];
3302 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3303 /* default to success; will override if find error */
3304 match m = MATCH_YES;
3306 /* Make sure the actual arguments are in the necessary order (based on the
3307 formal args) before resolving. */
3308 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3310 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3311 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3313 set_name_and_label (c, sym, name, binding_label);
3315 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3317 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3319 /* Make sure we got a third arg if the second arg has non-zero
3320 rank. We must also check that the type and rank are
3321 correct since we short-circuit this check in
3322 gfc_procedure_use() (called above to sort actual args). */
3323 if (c->ext.actual->next->expr->rank != 0)
3325 if(c->ext.actual->next->next == NULL
3326 || c->ext.actual->next->next->expr == NULL)
3329 gfc_error ("Missing SHAPE parameter for call to %s "
3330 "at %L", sym->name, &(c->loc));
3332 else if (c->ext.actual->next->next->expr->ts.type
3334 || c->ext.actual->next->next->expr->rank != 1)
3337 gfc_error ("SHAPE parameter for call to %s at %L must "
3338 "be a rank 1 INTEGER array", sym->name,
3345 if (m != MATCH_ERROR)
3347 /* the 1 means to add the optional arg to formal list */
3348 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3350 /* for error reporting, say it's declared where the original was */
3351 new_sym->declared_at = sym->declared_at;
3356 /* no differences for c_loc or c_funloc */
3360 /* set the resolved symbol */
3361 if (m != MATCH_ERROR)
3362 c->resolved_sym = new_sym;
3364 c->resolved_sym = sym;
3370 /* Resolve a subroutine call known to be specific. */
3373 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3377 if(sym->attr.is_iso_c)
3379 m = gfc_iso_c_sub_interface (c,sym);
3383 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3385 if (sym->attr.dummy)
3387 sym->attr.proc = PROC_DUMMY;
3391 sym->attr.proc = PROC_EXTERNAL;
3395 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3398 if (sym->attr.intrinsic)
3400 m = gfc_intrinsic_sub_interface (c, 1);
3404 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3405 "with an intrinsic", sym->name, &c->loc);
3413 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3415 c->resolved_sym = sym;
3416 pure_subroutine (c, sym);
3423 resolve_specific_s (gfc_code *c)
3428 sym = c->symtree->n.sym;
3432 m = resolve_specific_s0 (c, sym);
3435 if (m == MATCH_ERROR)
3438 if (sym->ns->parent == NULL)
3441 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3447 sym = c->symtree->n.sym;
3448 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3449 sym->name, &c->loc);
3455 /* Resolve a subroutine call not known to be generic nor specific. */
3458 resolve_unknown_s (gfc_code *c)
3462 sym = c->symtree->n.sym;
3464 if (sym->attr.dummy)
3466 sym->attr.proc = PROC_DUMMY;
3470 /* See if we have an intrinsic function reference. */
3472 if (gfc_is_intrinsic (sym, 1, c->loc))
3474 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3479 /* The reference is to an external name. */
3482 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3484 c->resolved_sym = sym;
3486 pure_subroutine (c, sym);
3492 /* Resolve a subroutine call. Although it was tempting to use the same code
3493 for functions, subroutines and functions are stored differently and this
3494 makes things awkward. */
3497 resolve_call (gfc_code *c)
3500 procedure_type ptype = PROC_INTRINSIC;
3501 gfc_symbol *csym, *sym;
3502 bool no_formal_args;
3504 csym = c->symtree ? c->symtree->n.sym : NULL;
3506 if (csym && csym->ts.type != BT_UNKNOWN)
3508 gfc_error ("'%s' at %L has a type, which is not consistent with "
3509 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3513 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3516 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3517 sym = st ? st->n.sym : NULL;
3518 if (sym && csym != sym
3519 && sym->ns == gfc_current_ns
3520 && sym->attr.flavor == FL_PROCEDURE
3521 && sym->attr.contained)
3524 if (csym->attr.generic)
3525 c->symtree->n.sym = sym;
3528 csym = c->symtree->n.sym;
3532 /* If this ia a deferred TBP with an abstract interface
3533 (which may of course be referenced), c->expr1 will be set. */
3534 if (csym && csym->attr.abstract && !c->expr1)
3536 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3537 csym->name, &c->loc);
3541 /* Subroutines without the RECURSIVE attribution are not allowed to
3542 * call themselves. */
3543 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3545 if (csym->attr.entry && csym->ns->entries)
3546 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3547 " subroutine '%s' is not RECURSIVE",
3548 csym->name, &c->loc, csym->ns->entries->sym->name);
3550 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3551 " is not RECURSIVE", csym->name, &c->loc);
3556 /* Switch off assumed size checking and do this again for certain kinds
3557 of procedure, once the procedure itself is resolved. */
3558 need_full_assumed_size++;
3561 ptype = csym->attr.proc;
3563 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3564 if (resolve_actual_arglist (c->ext.actual, ptype,
3565 no_formal_args) == FAILURE)
3568 /* Resume assumed_size checking. */
3569 need_full_assumed_size--;
3571 /* If external, check for usage. */
3572 if (csym && is_external_proc (csym))
3573 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3576 if (c->resolved_sym == NULL)
3578 c->resolved_isym = NULL;
3579 switch (procedure_kind (csym))
3582 t = resolve_generic_s (c);
3585 case PTYPE_SPECIFIC:
3586 t = resolve_specific_s (c);
3590 t = resolve_unknown_s (c);
3594 gfc_internal_error ("resolve_subroutine(): bad function type");
3598 /* Some checks of elemental subroutine actual arguments. */
3599 if (resolve_elemental_actual (NULL, c) == FAILURE)
3602 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
3603 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3608 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3609 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3610 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3611 if their shapes do not match. If either op1->shape or op2->shape is
3612 NULL, return SUCCESS. */
3615 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3622 if (op1->shape != NULL && op2->shape != NULL)
3624 for (i = 0; i < op1->rank; i++)
3626 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3628 gfc_error ("Shapes for operands at %L and %L are not conformable",
3629 &op1->where, &op2->where);
3640 /* Resolve an operator expression node. This can involve replacing the
3641 operation with a user defined function call. */
3644 resolve_operator (gfc_expr *e)
3646 gfc_expr *op1, *op2;
3648 bool dual_locus_error;
3651 /* Resolve all subnodes-- give them types. */
3653 switch (e->value.op.op)
3656 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3659 /* Fall through... */
3662 case INTRINSIC_UPLUS:
3663 case INTRINSIC_UMINUS:
3664 case INTRINSIC_PARENTHESES:
3665 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3670 /* Typecheck the new node. */
3672 op1 = e->value.op.op1;
3673 op2 = e->value.op.op2;
3674 dual_locus_error = false;
3676 if ((op1 && op1->expr_type == EXPR_NULL)
3677 || (op2 && op2->expr_type == EXPR_NULL))
3679 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3683 switch (e->value.op.op)
3685 case INTRINSIC_UPLUS:
3686 case INTRINSIC_UMINUS:
3687 if (op1->ts.type == BT_INTEGER
3688 || op1->ts.type == BT_REAL
3689 || op1->ts.type == BT_COMPLEX)
3695 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3696 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3699 case INTRINSIC_PLUS:
3700 case INTRINSIC_MINUS:
3701 case INTRINSIC_TIMES:
3702 case INTRINSIC_DIVIDE:
3703 case INTRINSIC_POWER:
3704 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3706 gfc_type_convert_binary (e, 1);
3711 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3712 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3713 gfc_typename (&op2->ts));
3716 case INTRINSIC_CONCAT:
3717 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3718 && op1->ts.kind == op2->ts.kind)
3720 e->ts.type = BT_CHARACTER;
3721 e->ts.kind = op1->ts.kind;
3726 _("Operands of string concatenation operator at %%L are %s/%s"),
3727 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3733 case INTRINSIC_NEQV:
3734 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3736 e->ts.type = BT_LOGICAL;
3737 e->ts.kind = gfc_kind_max (op1, op2);
3738 if (op1->ts.kind < e->ts.kind)
3739 gfc_convert_type (op1, &e->ts, 2);
3740 else if (op2->ts.kind < e->ts.kind)
3741 gfc_convert_type (op2, &e->ts, 2);
3745 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3746 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3747 gfc_typename (&op2->ts));
3752 if (op1->ts.type == BT_LOGICAL)
3754 e->ts.type = BT_LOGICAL;
3755 e->ts.kind = op1->ts.kind;
3759 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3760 gfc_typename (&op1->ts));
3764 case INTRINSIC_GT_OS:
3766 case INTRINSIC_GE_OS:
3768 case INTRINSIC_LT_OS:
3770 case INTRINSIC_LE_OS:
3771 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3773 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3777 /* Fall through... */
3780 case INTRINSIC_EQ_OS:
3782 case INTRINSIC_NE_OS:
3783 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3784 && op1->ts.kind == op2->ts.kind)
3786 e->ts.type = BT_LOGICAL;
3787 e->ts.kind = gfc_default_logical_kind;
3791 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3793 gfc_type_convert_binary (e, 1);
3795 e->ts.type = BT_LOGICAL;
3796 e->ts.kind = gfc_default_logical_kind;
3800 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3802 _("Logicals at %%L must be compared with %s instead of %s"),
3803 (e->value.op.op == INTRINSIC_EQ
3804 || e->value.op.op == INTRINSIC_EQ_OS)
3805 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3808 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3809 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3810 gfc_typename (&op2->ts));
3814 case INTRINSIC_USER:
3815 if (e->value.op.uop->op == NULL)
3816 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3817 else if (op2 == NULL)
3818 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3819 e->value.op.uop->name, gfc_typename (&op1->ts));
3821 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3822 e->value.op.uop->name, gfc_typename (&op1->ts),
3823 gfc_typename (&op2->ts));
3827 case INTRINSIC_PARENTHESES:
3829 if (e->ts.type == BT_CHARACTER)
3830 e->ts.u.cl = op1->ts.u.cl;
3834 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3837 /* Deal with arrayness of an operand through an operator. */
3841 switch (e->value.op.op)
3843 case INTRINSIC_PLUS:
3844 case INTRINSIC_MINUS:
3845 case INTRINSIC_TIMES:
3846 case INTRINSIC_DIVIDE:
3847 case INTRINSIC_POWER:
3848 case INTRINSIC_CONCAT:
3852 case INTRINSIC_NEQV:
3854 case INTRINSIC_EQ_OS:
3856 case INTRINSIC_NE_OS:
3858 case INTRINSIC_GT_OS:
3860 case INTRINSIC_GE_OS:
3862 case INTRINSIC_LT_OS:
3864 case INTRINSIC_LE_OS:
3866 if (op1->rank == 0 && op2->rank == 0)
3869 if (op1->rank == 0 && op2->rank != 0)
3871 e->rank = op2->rank;
3873 if (e->shape == NULL)
3874 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3877 if (op1->rank != 0 && op2->rank == 0)
3879 e->rank = op1->rank;
3881 if (e->shape == NULL)
3882 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3885 if (op1->rank != 0 && op2->rank != 0)
3887 if (op1->rank == op2->rank)
3889 e->rank = op1->rank;
3890 if (e->shape == NULL)
3892 t = compare_shapes (op1, op2);
3896 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3901 /* Allow higher level expressions to work. */
3904 /* Try user-defined operators, and otherwise throw an error. */
3905 dual_locus_error = true;
3907 _("Inconsistent ranks for operator at %%L and %%L"));
3914 case INTRINSIC_PARENTHESES:
3916 case INTRINSIC_UPLUS:
3917 case INTRINSIC_UMINUS:
3918 /* Simply copy arrayness attribute */
3919 e->rank = op1->rank;
3921 if (e->shape == NULL)
3922 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3930 /* Attempt to simplify the expression. */
3933 t = gfc_simplify_expr (e, 0);
3934 /* Some calls do not succeed in simplification and return FAILURE
3935 even though there is no error; e.g. variable references to
3936 PARAMETER arrays. */
3937 if (!gfc_is_constant_expr (e))
3946 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3953 if (dual_locus_error)
3954 gfc_error (msg, &op1->where, &op2->where);
3956 gfc_error (msg, &e->where);
3962 /************** Array resolution subroutines **************/
3965 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3968 /* Compare two integer expressions. */
3971 compare_bound (gfc_expr *a, gfc_expr *b)
3975 if (a == NULL || a->expr_type != EXPR_CONSTANT
3976 || b == NULL || b->expr_type != EXPR_CONSTANT)
3979 /* If either of the types isn't INTEGER, we must have
3980 raised an error earlier. */
3982 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3985 i = mpz_cmp (a->value.integer, b->value.integer);
3995 /* Compare an integer expression with an integer. */
3998 compare_bound_int (gfc_expr *a, int b)
4002 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4005 if (a->ts.type != BT_INTEGER)
4006 gfc_internal_error ("compare_bound_int(): Bad expression");
4008 i = mpz_cmp_si (a->value.integer, b);
4018 /* Compare an integer expression with a mpz_t. */
4021 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4025 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4028 if (a->ts.type != BT_INTEGER)
4029 gfc_internal_error ("compare_bound_int(): Bad expression");
4031 i = mpz_cmp (a->value.integer, b);
4041 /* Compute the last value of a sequence given by a triplet.
4042 Return 0 if it wasn't able to compute the last value, or if the
4043 sequence if empty, and 1 otherwise. */
4046 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4047 gfc_expr *stride, mpz_t last)
4051 if (start == NULL || start->expr_type != EXPR_CONSTANT
4052 || end == NULL || end->expr_type != EXPR_CONSTANT
4053 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4056 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4057 || (stride != NULL && stride->ts.type != BT_INTEGER))
4060 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4062 if (compare_bound (start, end) == CMP_GT)
4064 mpz_set (last, end->value.integer);
4068 if (compare_bound_int (stride, 0) == CMP_GT)
4070 /* Stride is positive */
4071 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4076 /* Stride is negative */
4077 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4082 mpz_sub (rem, end->value.integer, start->value.integer);
4083 mpz_tdiv_r (rem, rem, stride->value.integer);
4084 mpz_sub (last, end->value.integer, rem);
4091 /* Compare a single dimension of an array reference to the array
4095 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4099 if (ar->dimen_type[i] == DIMEN_STAR)
4101 gcc_assert (ar->stride[i] == NULL);
4102 /* This implies [*] as [*:] and [*:3] are not possible. */
4103 if (ar->start[i] == NULL)
4105 gcc_assert (ar->end[i] == NULL);
4110 /* Given start, end and stride values, calculate the minimum and
4111 maximum referenced indexes. */
4113 switch (ar->dimen_type[i])
4120 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4123 gfc_warning ("Array reference at %L is out of bounds "
4124 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4125 mpz_get_si (ar->start[i]->value.integer),
4126 mpz_get_si (as->lower[i]->value.integer), i+1);
4128 gfc_warning ("Array reference at %L is out of bounds "
4129 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4130 mpz_get_si (ar->start[i]->value.integer),
4131 mpz_get_si (as->lower[i]->value.integer),
4135 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4138 gfc_warning ("Array reference at %L is out of bounds "
4139 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4140 mpz_get_si (ar->start[i]->value.integer),
4141 mpz_get_si (as->upper[i]->value.integer), i+1);
4143 gfc_warning ("Array reference at %L is out of bounds "
4144 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4145 mpz_get_si (ar->start[i]->value.integer),
4146 mpz_get_si (as->upper[i]->value.integer),
4155 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4156 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4158 comparison comp_start_end = compare_bound (AR_START, AR_END);
4160 /* Check for zero stride, which is not allowed. */
4161 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4163 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4167 /* if start == len || (stride > 0 && start < len)
4168 || (stride < 0 && start > len),
4169 then the array section contains at least one element. In this
4170 case, there is an out-of-bounds access if
4171 (start < lower || start > upper). */
4172 if (compare_bound (AR_START, AR_END) == CMP_EQ
4173 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4174 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4175 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4176 && comp_start_end == CMP_GT))
4178 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4180 gfc_warning ("Lower array reference at %L is out of bounds "
4181 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4182 mpz_get_si (AR_START->value.integer),
4183 mpz_get_si (as->lower[i]->value.integer), i+1);
4186 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4188 gfc_warning ("Lower array reference at %L is out of bounds "
4189 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4190 mpz_get_si (AR_START->value.integer),
4191 mpz_get_si (as->upper[i]->value.integer), i+1);
4196 /* If we can compute the highest index of the array section,
4197 then it also has to be between lower and upper. */
4198 mpz_init (last_value);
4199 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4202 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4204 gfc_warning ("Upper array reference at %L is out of bounds "
4205 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4206 mpz_get_si (last_value),
4207 mpz_get_si (as->lower[i]->value.integer), i+1);
4208 mpz_clear (last_value);
4211 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4213 gfc_warning ("Upper array reference at %L is out of bounds "
4214 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4215 mpz_get_si (last_value),
4216 mpz_get_si (as->upper[i]->value.integer), i+1);
4217 mpz_clear (last_value);
4221 mpz_clear (last_value);
4229 gfc_internal_error ("check_dimension(): Bad array reference");
4236 /* Compare an array reference with an array specification. */
4239 compare_spec_to_ref (gfc_array_ref *ar)
4246 /* TODO: Full array sections are only allowed as actual parameters. */
4247 if (as->type == AS_ASSUMED_SIZE
4248 && (/*ar->type == AR_FULL
4249 ||*/ (ar->type == AR_SECTION
4250 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4252 gfc_error ("Rightmost upper bound of assumed size array section "
4253 "not specified at %L", &ar->where);
4257 if (ar->type == AR_FULL)
4260 if (as->rank != ar->dimen)
4262 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4263 &ar->where, ar->dimen, as->rank);
4267 /* ar->codimen == 0 is a local array. */
4268 if (as->corank != ar->codimen && ar->codimen != 0)
4270 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4271 &ar->where, ar->codimen, as->corank);
4275 for (i = 0; i < as->rank; i++)
4276 if (check_dimension (i, ar, as) == FAILURE)
4279 /* Local access has no coarray spec. */
4280 if (ar->codimen != 0)
4281 for (i = as->rank; i < as->rank + as->corank; i++)
4283 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4285 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4286 i + 1 - as->rank, &ar->where);
4289 if (check_dimension (i, ar, as) == FAILURE)
4297 /* Resolve one part of an array index. */
4300 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4301 int force_index_integer_kind)
4308 if (gfc_resolve_expr (index) == FAILURE)
4311 if (check_scalar && index->rank != 0)
4313 gfc_error ("Array index at %L must be scalar", &index->where);
4317 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4319 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4320 &index->where, gfc_basic_typename (index->ts.type));
4324 if (index->ts.type == BT_REAL)
4325 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4326 &index->where) == FAILURE)
4329 if ((index->ts.kind != gfc_index_integer_kind
4330 && force_index_integer_kind)
4331 || index->ts.type != BT_INTEGER)
4334 ts.type = BT_INTEGER;
4335 ts.kind = gfc_index_integer_kind;
4337 gfc_convert_type_warn (index, &ts, 2, 0);
4343 /* Resolve one part of an array index. */
4346 gfc_resolve_index (gfc_expr *index, int check_scalar)
4348 return gfc_resolve_index_1 (index, check_scalar, 1);
4351 /* Resolve a dim argument to an intrinsic function. */
4354 gfc_resolve_dim_arg (gfc_expr *dim)
4359 if (gfc_resolve_expr (dim) == FAILURE)
4364 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4369 if (dim->ts.type != BT_INTEGER)
4371 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4375 if (dim->ts.kind != gfc_index_integer_kind)
4380 ts.type = BT_INTEGER;
4381 ts.kind = gfc_index_integer_kind;
4383 gfc_convert_type_warn (dim, &ts, 2, 0);
4389 /* Given an expression that contains array references, update those array
4390 references to point to the right array specifications. While this is
4391 filled in during matching, this information is difficult to save and load
4392 in a module, so we take care of it here.
4394 The idea here is that the original array reference comes from the
4395 base symbol. We traverse the list of reference structures, setting
4396 the stored reference to references. Component references can
4397 provide an additional array specification. */
4400 find_array_spec (gfc_expr *e)
4404 gfc_symbol *derived;
4407 if (e->symtree->n.sym->ts.type == BT_CLASS)
4408 as = CLASS_DATA (e->symtree->n.sym)->as;
4410 as = e->symtree->n.sym->as;
4413 for (ref = e->ref; ref; ref = ref->next)
4418 gfc_internal_error ("find_array_spec(): Missing spec");
4425 if (derived == NULL)
4426 derived = e->symtree->n.sym->ts.u.derived;
4428 if (derived->attr.is_class)
4429 derived = derived->components->ts.u.derived;
4431 c = derived->components;
4433 for (; c; c = c->next)
4434 if (c == ref->u.c.component)
4436 /* Track the sequence of component references. */
4437 if (c->ts.type == BT_DERIVED)
4438 derived = c->ts.u.derived;
4443 gfc_internal_error ("find_array_spec(): Component not found");
4445 if (c->attr.dimension)
4448 gfc_internal_error ("find_array_spec(): unused as(1)");
4459 gfc_internal_error ("find_array_spec(): unused as(2)");
4463 /* Resolve an array reference. */
4466 resolve_array_ref (gfc_array_ref *ar)
4468 int i, check_scalar;
4471 for (i = 0; i < ar->dimen + ar->codimen; i++)
4473 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4475 /* Do not force gfc_index_integer_kind for the start. We can
4476 do fine with any integer kind. This avoids temporary arrays
4477 created for indexing with a vector. */
4478 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4480 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4482 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4487 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4491 ar->dimen_type[i] = DIMEN_ELEMENT;
4495 ar->dimen_type[i] = DIMEN_VECTOR;
4496 if (e->expr_type == EXPR_VARIABLE
4497 && e->symtree->n.sym->ts.type == BT_DERIVED)
4498 ar->start[i] = gfc_get_parentheses (e);
4502 gfc_error ("Array index at %L is an array of rank %d",
4503 &ar->c_where[i], e->rank);
4507 /* Fill in the upper bound, which may be lower than the
4508 specified one for something like a(2:10:5), which is
4509 identical to a(2:7:5). Only relevant for strides not equal
4511 if (ar->dimen_type[i] == DIMEN_RANGE
4512 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4513 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4517 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4519 if (ar->end[i] == NULL)
4522 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4524 mpz_set (ar->end[i]->value.integer, end);
4526 else if (ar->end[i]->ts.type == BT_INTEGER
4527 && ar->end[i]->expr_type == EXPR_CONSTANT)
4529 mpz_set (ar->end[i]->value.integer, end);
4540 if (ar->type == AR_FULL && ar->as->rank == 0)
4541 ar->type = AR_ELEMENT;
4543 /* If the reference type is unknown, figure out what kind it is. */
4545 if (ar->type == AR_UNKNOWN)
4547 ar->type = AR_ELEMENT;
4548 for (i = 0; i < ar->dimen; i++)
4549 if (ar->dimen_type[i] == DIMEN_RANGE
4550 || ar->dimen_type[i] == DIMEN_VECTOR)
4552 ar->type = AR_SECTION;
4557 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4565 resolve_substring (gfc_ref *ref)
4567 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4569 if (ref->u.ss.start != NULL)
4571 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4574 if (ref->u.ss.start->ts.type != BT_INTEGER)
4576 gfc_error ("Substring start index at %L must be of type INTEGER",
4577 &ref->u.ss.start->where);
4581 if (ref->u.ss.start->rank != 0)
4583 gfc_error ("Substring start index at %L must be scalar",
4584 &ref->u.ss.start->where);
4588 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4589 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4590 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4592 gfc_error ("Substring start index at %L is less than one",
4593 &ref->u.ss.start->where);
4598 if (ref->u.ss.end != NULL)
4600 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4603 if (ref->u.ss.end->ts.type != BT_INTEGER)
4605 gfc_error ("Substring end index at %L must be of type INTEGER",
4606 &ref->u.ss.end->where);
4610 if (ref->u.ss.end->rank != 0)
4612 gfc_error ("Substring end index at %L must be scalar",
4613 &ref->u.ss.end->where);
4617 if (ref->u.ss.length != NULL
4618 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4619 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4620 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4622 gfc_error ("Substring end index at %L exceeds the string length",
4623 &ref->u.ss.start->where);
4627 if (compare_bound_mpz_t (ref->u.ss.end,
4628 gfc_integer_kinds[k].huge) == CMP_GT
4629 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4630 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4632 gfc_error ("Substring end index at %L is too large",
4633 &ref->u.ss.end->where);
4642 /* This function supplies missing substring charlens. */
4645 gfc_resolve_substring_charlen (gfc_expr *e)
4648 gfc_expr *start, *end;
4650 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4651 if (char_ref->type == REF_SUBSTRING)
4657 gcc_assert (char_ref->next == NULL);
4661 if (e->ts.u.cl->length)
4662 gfc_free_expr (e->ts.u.cl->length);
4663 else if (e->expr_type == EXPR_VARIABLE
4664 && e->symtree->n.sym->attr.dummy)
4668 e->ts.type = BT_CHARACTER;
4669 e->ts.kind = gfc_default_character_kind;
4672 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4674 if (char_ref->u.ss.start)
4675 start = gfc_copy_expr (char_ref->u.ss.start);
4677 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4679 if (char_ref->u.ss.end)
4680 end = gfc_copy_expr (char_ref->u.ss.end);
4681 else if (e->expr_type == EXPR_VARIABLE)
4682 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4689 /* Length = (end - start +1). */
4690 e->ts.u.cl->length = gfc_subtract (end, start);
4691 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4692 gfc_get_int_expr (gfc_default_integer_kind,
4695 e->ts.u.cl->length->ts.type = BT_INTEGER;
4696 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4698 /* Make sure that the length is simplified. */
4699 gfc_simplify_expr (e->ts.u.cl->length, 1);
4700 gfc_resolve_expr (e->ts.u.cl->length);
4704 /* Resolve subtype references. */
4707 resolve_ref (gfc_expr *expr)
4709 int current_part_dimension, n_components, seen_part_dimension;
4712 for (ref = expr->ref; ref; ref = ref->next)
4713 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4715 find_array_spec (expr);
4719 for (ref = expr->ref; ref; ref = ref->next)
4723 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4731 resolve_substring (ref);
4735 /* Check constraints on part references. */
4737 current_part_dimension = 0;
4738 seen_part_dimension = 0;
4741 for (ref = expr->ref; ref; ref = ref->next)
4746 switch (ref->u.ar.type)
4749 /* Coarray scalar. */
4750 if (ref->u.ar.as->rank == 0)
4752 current_part_dimension = 0;
4757 current_part_dimension = 1;
4761 current_part_dimension = 0;
4765 gfc_internal_error ("resolve_ref(): Bad array reference");
4771 if (current_part_dimension || seen_part_dimension)
4774 if (ref->u.c.component->attr.pointer
4775 || ref->u.c.component->attr.proc_pointer)
4777 gfc_error ("Component to the right of a part reference "
4778 "with nonzero rank must not have the POINTER "
4779 "attribute at %L", &expr->where);
4782 else if (ref->u.c.component->attr.allocatable)
4784 gfc_error ("Component to the right of a part reference "
4785 "with nonzero rank must not have the ALLOCATABLE "
4786 "attribute at %L", &expr->where);
4798 if (((ref->type == REF_COMPONENT && n_components > 1)
4799 || ref->next == NULL)
4800 && current_part_dimension
4801 && seen_part_dimension)
4803 gfc_error ("Two or more part references with nonzero rank must "
4804 "not be specified at %L", &expr->where);
4808 if (ref->type == REF_COMPONENT)
4810 if (current_part_dimension)
4811 seen_part_dimension = 1;
4813 /* reset to make sure */
4814 current_part_dimension = 0;
4822 /* Given an expression, determine its shape. This is easier than it sounds.
4823 Leaves the shape array NULL if it is not possible to determine the shape. */
4826 expression_shape (gfc_expr *e)
4828 mpz_t array[GFC_MAX_DIMENSIONS];
4831 if (e->rank == 0 || e->shape != NULL)
4834 for (i = 0; i < e->rank; i++)
4835 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4838 e->shape = gfc_get_shape (e->rank);
4840 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4845 for (i--; i >= 0; i--)
4846 mpz_clear (array[i]);
4850 /* Given a variable expression node, compute the rank of the expression by
4851 examining the base symbol and any reference structures it may have. */
4854 expression_rank (gfc_expr *e)
4859 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4860 could lead to serious confusion... */
4861 gcc_assert (e->expr_type != EXPR_COMPCALL);
4865 if (e->expr_type == EXPR_ARRAY)
4867 /* Constructors can have a rank different from one via RESHAPE(). */
4869 if (e->symtree == NULL)
4875 e->rank = (e->symtree->n.sym->as == NULL)
4876 ? 0 : e->symtree->n.sym->as->rank;
4882 for (ref = e->ref; ref; ref = ref->next)
4884 if (ref->type != REF_ARRAY)
4887 if (ref->u.ar.type == AR_FULL)
4889 rank = ref->u.ar.as->rank;
4893 if (ref->u.ar.type == AR_SECTION)
4895 /* Figure out the rank of the section. */
4897 gfc_internal_error ("expression_rank(): Two array specs");
4899 for (i = 0; i < ref->u.ar.dimen; i++)
4900 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4901 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4911 expression_shape (e);
4915 /* Resolve a variable expression. */
4918 resolve_variable (gfc_expr *e)
4925 if (e->symtree == NULL)
4927 sym = e->symtree->n.sym;
4929 /* If this is an associate-name, it may be parsed with an array reference
4930 in error even though the target is scalar. Fail directly in this case. */
4931 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4934 /* On the other hand, the parser may not have known this is an array;
4935 in this case, we have to add a FULL reference. */
4936 if (sym->assoc && sym->attr.dimension && !e->ref)
4938 e->ref = gfc_get_ref ();
4939 e->ref->type = REF_ARRAY;
4940 e->ref->u.ar.type = AR_FULL;
4941 e->ref->u.ar.dimen = 0;
4944 if (e->ref && resolve_ref (e) == FAILURE)
4947 if (sym->attr.flavor == FL_PROCEDURE
4948 && (!sym->attr.function
4949 || (sym->attr.function && sym->result
4950 && sym->result->attr.proc_pointer
4951 && !sym->result->attr.function)))
4953 e->ts.type = BT_PROCEDURE;
4954 goto resolve_procedure;
4957 if (sym->ts.type != BT_UNKNOWN)
4958 gfc_variable_attr (e, &e->ts);
4961 /* Must be a simple variable reference. */
4962 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4967 if (check_assumed_size_reference (sym, e))
4970 /* Deal with forward references to entries during resolve_code, to
4971 satisfy, at least partially, 12.5.2.5. */
4972 if (gfc_current_ns->entries
4973 && current_entry_id == sym->entry_id
4976 && cs_base->current->op != EXEC_ENTRY)
4978 gfc_entry_list *entry;
4979 gfc_formal_arglist *formal;
4983 /* If the symbol is a dummy... */
4984 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4986 entry = gfc_current_ns->entries;
4989 /* ...test if the symbol is a parameter of previous entries. */
4990 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4991 for (formal = entry->sym->formal; formal; formal = formal->next)
4993 if (formal->sym && sym->name == formal->sym->name)
4997 /* If it has not been seen as a dummy, this is an error. */
5000 if (specification_expr)
5001 gfc_error ("Variable '%s', used in a specification expression"
5002 ", is referenced at %L before the ENTRY statement "
5003 "in which it is a parameter",
5004 sym->name, &cs_base->current->loc);
5006 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5007 "statement in which it is a parameter",
5008 sym->name, &cs_base->current->loc);
5013 /* Now do the same check on the specification expressions. */
5014 specification_expr = 1;
5015 if (sym->ts.type == BT_CHARACTER
5016 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5020 for (n = 0; n < sym->as->rank; n++)
5022 specification_expr = 1;
5023 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5025 specification_expr = 1;
5026 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5029 specification_expr = 0;
5032 /* Update the symbol's entry level. */
5033 sym->entry_id = current_entry_id + 1;
5036 /* If a symbol has been host_associated mark it. This is used latter,
5037 to identify if aliasing is possible via host association. */
5038 if (sym->attr.flavor == FL_VARIABLE
5039 && gfc_current_ns->parent
5040 && (gfc_current_ns->parent == sym->ns
5041 || (gfc_current_ns->parent->parent
5042 && gfc_current_ns->parent->parent == sym->ns)))
5043 sym->attr.host_assoc = 1;
5046 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5049 /* F2008, C617 and C1229. */
5050 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5051 && gfc_is_coindexed (e))
5053 gfc_ref *ref, *ref2 = NULL;
5055 if (e->ts.type == BT_CLASS)
5057 gfc_error ("Polymorphic subobject of coindexed object at %L",
5062 for (ref = e->ref; ref; ref = ref->next)
5064 if (ref->type == REF_COMPONENT)
5066 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5070 for ( ; ref; ref = ref->next)
5071 if (ref->type == REF_COMPONENT)
5074 /* Expression itself is coindexed object. */
5078 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5079 for ( ; c; c = c->next)
5080 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5082 gfc_error ("Coindexed object with polymorphic allocatable "
5083 "subcomponent at %L", &e->where);
5094 /* Checks to see that the correct symbol has been host associated.
5095 The only situation where this arises is that in which a twice
5096 contained function is parsed after the host association is made.
5097 Therefore, on detecting this, change the symbol in the expression
5098 and convert the array reference into an actual arglist if the old
5099 symbol is a variable. */
5101 check_host_association (gfc_expr *e)
5103 gfc_symbol *sym, *old_sym;
5107 gfc_actual_arglist *arg, *tail = NULL;
5108 bool retval = e->expr_type == EXPR_FUNCTION;
5110 /* If the expression is the result of substitution in
5111 interface.c(gfc_extend_expr) because there is no way in
5112 which the host association can be wrong. */
5113 if (e->symtree == NULL
5114 || e->symtree->n.sym == NULL
5115 || e->user_operator)
5118 old_sym = e->symtree->n.sym;
5120 if (gfc_current_ns->parent
5121 && old_sym->ns != gfc_current_ns)
5123 /* Use the 'USE' name so that renamed module symbols are
5124 correctly handled. */
5125 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5127 if (sym && old_sym != sym
5128 && sym->ts.type == old_sym->ts.type
5129 && sym->attr.flavor == FL_PROCEDURE
5130 && sym->attr.contained)
5132 /* Clear the shape, since it might not be valid. */
5133 if (e->shape != NULL)
5135 for (n = 0; n < e->rank; n++)
5136 mpz_clear (e->shape[n]);
5138 gfc_free (e->shape);
5141 /* Give the expression the right symtree! */
5142 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5143 gcc_assert (st != NULL);
5145 if (old_sym->attr.flavor == FL_PROCEDURE
5146 || e->expr_type == EXPR_FUNCTION)
5148 /* Original was function so point to the new symbol, since
5149 the actual argument list is already attached to the
5151 e->value.function.esym = NULL;
5156 /* Original was variable so convert array references into
5157 an actual arglist. This does not need any checking now
5158 since gfc_resolve_function will take care of it. */
5159 e->value.function.actual = NULL;
5160 e->expr_type = EXPR_FUNCTION;
5163 /* Ambiguity will not arise if the array reference is not
5164 the last reference. */
5165 for (ref = e->ref; ref; ref = ref->next)
5166 if (ref->type == REF_ARRAY && ref->next == NULL)
5169 gcc_assert (ref->type == REF_ARRAY);
5171 /* Grab the start expressions from the array ref and
5172 copy them into actual arguments. */
5173 for (n = 0; n < ref->u.ar.dimen; n++)
5175 arg = gfc_get_actual_arglist ();
5176 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5177 if (e->value.function.actual == NULL)
5178 tail = e->value.function.actual = arg;
5186 /* Dump the reference list and set the rank. */
5187 gfc_free_ref_list (e->ref);
5189 e->rank = sym->as ? sym->as->rank : 0;
5192 gfc_resolve_expr (e);
5196 /* This might have changed! */
5197 return e->expr_type == EXPR_FUNCTION;
5202 gfc_resolve_character_operator (gfc_expr *e)
5204 gfc_expr *op1 = e->value.op.op1;
5205 gfc_expr *op2 = e->value.op.op2;
5206 gfc_expr *e1 = NULL;
5207 gfc_expr *e2 = NULL;
5209 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5211 if (op1->ts.u.cl && op1->ts.u.cl->length)
5212 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5213 else if (op1->expr_type == EXPR_CONSTANT)
5214 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5215 op1->value.character.length);
5217 if (op2->ts.u.cl && op2->ts.u.cl->length)
5218 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5219 else if (op2->expr_type == EXPR_CONSTANT)
5220 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5221 op2->value.character.length);
5223 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5228 e->ts.u.cl->length = gfc_add (e1, e2);
5229 e->ts.u.cl->length->ts.type = BT_INTEGER;
5230 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5231 gfc_simplify_expr (e->ts.u.cl->length, 0);
5232 gfc_resolve_expr (e->ts.u.cl->length);
5238 /* Ensure that an character expression has a charlen and, if possible, a
5239 length expression. */
5242 fixup_charlen (gfc_expr *e)
5244 /* The cases fall through so that changes in expression type and the need
5245 for multiple fixes are picked up. In all circumstances, a charlen should
5246 be available for the middle end to hang a backend_decl on. */
5247 switch (e->expr_type)
5250 gfc_resolve_character_operator (e);
5253 if (e->expr_type == EXPR_ARRAY)
5254 gfc_resolve_character_array_constructor (e);
5256 case EXPR_SUBSTRING:
5257 if (!e->ts.u.cl && e->ref)
5258 gfc_resolve_substring_charlen (e);
5262 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5269 /* Update an actual argument to include the passed-object for type-bound
5270 procedures at the right position. */
5272 static gfc_actual_arglist*
5273 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5276 gcc_assert (argpos > 0);
5280 gfc_actual_arglist* result;
5282 result = gfc_get_actual_arglist ();
5286 result->name = name;
5292 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5294 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5299 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5302 extract_compcall_passed_object (gfc_expr* e)
5306 gcc_assert (e->expr_type == EXPR_COMPCALL);
5308 if (e->value.compcall.base_object)
5309 po = gfc_copy_expr (e->value.compcall.base_object);
5312 po = gfc_get_expr ();
5313 po->expr_type = EXPR_VARIABLE;
5314 po->symtree = e->symtree;
5315 po->ref = gfc_copy_ref (e->ref);
5316 po->where = e->where;
5319 if (gfc_resolve_expr (po) == FAILURE)
5326 /* Update the arglist of an EXPR_COMPCALL expression to include the
5330 update_compcall_arglist (gfc_expr* e)
5333 gfc_typebound_proc* tbp;
5335 tbp = e->value.compcall.tbp;
5340 po = extract_compcall_passed_object (e);
5344 if (tbp->nopass || e->value.compcall.ignore_pass)
5350 gcc_assert (tbp->pass_arg_num > 0);
5351 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5359 /* Extract the passed object from a PPC call (a copy of it). */
5362 extract_ppc_passed_object (gfc_expr *e)
5367 po = gfc_get_expr ();
5368 po->expr_type = EXPR_VARIABLE;
5369 po->symtree = e->symtree;
5370 po->ref = gfc_copy_ref (e->ref);
5371 po->where = e->where;
5373 /* Remove PPC reference. */
5375 while ((*ref)->next)
5376 ref = &(*ref)->next;
5377 gfc_free_ref_list (*ref);
5380 if (gfc_resolve_expr (po) == FAILURE)
5387 /* Update the actual arglist of a procedure pointer component to include the
5391 update_ppc_arglist (gfc_expr* e)
5395 gfc_typebound_proc* tb;
5397 if (!gfc_is_proc_ptr_comp (e, &ppc))
5404 else if (tb->nopass)
5407 po = extract_ppc_passed_object (e);
5413 gfc_error ("Passed-object at %L must be scalar", &e->where);
5417 gcc_assert (tb->pass_arg_num > 0);
5418 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5426 /* Check that the object a TBP is called on is valid, i.e. it must not be
5427 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5430 check_typebound_baseobject (gfc_expr* e)
5434 base = extract_compcall_passed_object (e);
5438 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5440 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5442 gfc_error ("Base object for type-bound procedure call at %L is of"
5443 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5447 /* If the procedure called is NOPASS, the base object must be scalar. */
5448 if (e->value.compcall.tbp->nopass && base->rank > 0)
5450 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5451 " be scalar", &e->where);
5455 /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
5458 gfc_error ("Non-scalar base object at %L currently not implemented",
5467 /* Resolve a call to a type-bound procedure, either function or subroutine,
5468 statically from the data in an EXPR_COMPCALL expression. The adapted
5469 arglist and the target-procedure symtree are returned. */
5472 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5473 gfc_actual_arglist** actual)
5475 gcc_assert (e->expr_type == EXPR_COMPCALL);
5476 gcc_assert (!e->value.compcall.tbp->is_generic);
5478 /* Update the actual arglist for PASS. */
5479 if (update_compcall_arglist (e) == FAILURE)
5482 *actual = e->value.compcall.actual;
5483 *target = e->value.compcall.tbp->u.specific;
5485 gfc_free_ref_list (e->ref);
5487 e->value.compcall.actual = NULL;
5493 /* Get the ultimate declared type from an expression. In addition,
5494 return the last class/derived type reference and the copy of the
5497 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5500 gfc_symbol *declared;
5507 *new_ref = gfc_copy_ref (e->ref);
5509 for (ref = e->ref; ref; ref = ref->next)
5511 if (ref->type != REF_COMPONENT)
5514 if (ref->u.c.component->ts.type == BT_CLASS
5515 || ref->u.c.component->ts.type == BT_DERIVED)
5517 declared = ref->u.c.component->ts.u.derived;
5523 if (declared == NULL)
5524 declared = e->symtree->n.sym->ts.u.derived;
5530 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5531 which of the specific bindings (if any) matches the arglist and transform
5532 the expression into a call of that binding. */
5535 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5537 gfc_typebound_proc* genproc;
5538 const char* genname;
5540 gfc_symbol *derived;
5542 gcc_assert (e->expr_type == EXPR_COMPCALL);
5543 genname = e->value.compcall.name;
5544 genproc = e->value.compcall.tbp;
5546 if (!genproc->is_generic)
5549 /* Try the bindings on this type and in the inheritance hierarchy. */
5550 for (; genproc; genproc = genproc->overridden)
5554 gcc_assert (genproc->is_generic);
5555 for (g = genproc->u.generic; g; g = g->next)
5558 gfc_actual_arglist* args;
5561 gcc_assert (g->specific);
5563 if (g->specific->error)
5566 target = g->specific->u.specific->n.sym;
5568 /* Get the right arglist by handling PASS/NOPASS. */
5569 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5570 if (!g->specific->nopass)
5573 po = extract_compcall_passed_object (e);
5577 gcc_assert (g->specific->pass_arg_num > 0);
5578 gcc_assert (!g->specific->error);
5579 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5580 g->specific->pass_arg);
5582 resolve_actual_arglist (args, target->attr.proc,
5583 is_external_proc (target) && !target->formal);
5585 /* Check if this arglist matches the formal. */
5586 matches = gfc_arglist_matches_symbol (&args, target);
5588 /* Clean up and break out of the loop if we've found it. */
5589 gfc_free_actual_arglist (args);
5592 e->value.compcall.tbp = g->specific;
5593 genname = g->specific_st->name;
5594 /* Pass along the name for CLASS methods, where the vtab
5595 procedure pointer component has to be referenced. */
5603 /* Nothing matching found! */
5604 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5605 " '%s' at %L", genname, &e->where);
5609 /* Make sure that we have the right specific instance for the name. */
5610 derived = get_declared_from_expr (NULL, NULL, e);
5612 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5614 e->value.compcall.tbp = st->n.tb;
5620 /* Resolve a call to a type-bound subroutine. */
5623 resolve_typebound_call (gfc_code* c, const char **name)
5625 gfc_actual_arglist* newactual;
5626 gfc_symtree* target;
5628 /* Check that's really a SUBROUTINE. */
5629 if (!c->expr1->value.compcall.tbp->subroutine)
5631 gfc_error ("'%s' at %L should be a SUBROUTINE",
5632 c->expr1->value.compcall.name, &c->loc);
5636 if (check_typebound_baseobject (c->expr1) == FAILURE)
5639 /* Pass along the name for CLASS methods, where the vtab
5640 procedure pointer component has to be referenced. */
5642 *name = c->expr1->value.compcall.name;
5644 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5647 /* Transform into an ordinary EXEC_CALL for now. */
5649 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5652 c->ext.actual = newactual;
5653 c->symtree = target;
5654 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5656 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5658 gfc_free_expr (c->expr1);
5659 c->expr1 = gfc_get_expr ();
5660 c->expr1->expr_type = EXPR_FUNCTION;
5661 c->expr1->symtree = target;
5662 c->expr1->where = c->loc;
5664 return resolve_call (c);
5668 /* Resolve a component-call expression. */
5670 resolve_compcall (gfc_expr* e, const char **name)
5672 gfc_actual_arglist* newactual;
5673 gfc_symtree* target;
5675 /* Check that's really a FUNCTION. */
5676 if (!e->value.compcall.tbp->function)
5678 gfc_error ("'%s' at %L should be a FUNCTION",
5679 e->value.compcall.name, &e->where);
5683 /* These must not be assign-calls! */
5684 gcc_assert (!e->value.compcall.assign);
5686 if (check_typebound_baseobject (e) == FAILURE)
5689 /* Pass along the name for CLASS methods, where the vtab
5690 procedure pointer component has to be referenced. */
5692 *name = e->value.compcall.name;
5694 if (resolve_typebound_generic_call (e, name) == FAILURE)
5696 gcc_assert (!e->value.compcall.tbp->is_generic);
5698 /* Take the rank from the function's symbol. */
5699 if (e->value.compcall.tbp->u.specific->n.sym->as)
5700 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5702 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5703 arglist to the TBP's binding target. */
5705 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5708 e->value.function.actual = newactual;
5709 e->value.function.name = NULL;
5710 e->value.function.esym = target->n.sym;
5711 e->value.function.isym = NULL;
5712 e->symtree = target;
5713 e->ts = target->n.sym->ts;
5714 e->expr_type = EXPR_FUNCTION;
5716 /* Resolution is not necessary if this is a class subroutine; this
5717 function only has to identify the specific proc. Resolution of
5718 the call will be done next in resolve_typebound_call. */
5719 return gfc_resolve_expr (e);
5724 /* Resolve a typebound function, or 'method'. First separate all
5725 the non-CLASS references by calling resolve_compcall directly. */
5728 resolve_typebound_function (gfc_expr* e)
5730 gfc_symbol *declared;
5741 /* Deal with typebound operators for CLASS objects. */
5742 expr = e->value.compcall.base_object;
5743 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5744 && e->value.compcall.name)
5746 /* Since the typebound operators are generic, we have to ensure
5747 that any delays in resolution are corrected and that the vtab
5749 ts = expr->symtree->n.sym->ts;
5750 declared = ts.u.derived;
5751 c = gfc_find_component (declared, "$vptr", true, true);
5752 if (c->ts.u.derived == NULL)
5753 c->ts.u.derived = gfc_find_derived_vtab (declared);
5755 if (resolve_compcall (e, &name) == FAILURE)
5758 /* Use the generic name if it is there. */
5759 name = name ? name : e->value.function.esym->name;
5760 e->symtree = expr->symtree;
5761 expr->symtree->n.sym->ts.u.derived = declared;
5762 gfc_add_component_ref (e, "$vptr");
5763 gfc_add_component_ref (e, name);
5764 e->value.function.esym = NULL;
5769 return resolve_compcall (e, NULL);
5771 if (resolve_ref (e) == FAILURE)
5774 /* Get the CLASS declared type. */
5775 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5777 /* Weed out cases of the ultimate component being a derived type. */
5778 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5779 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5781 gfc_free_ref_list (new_ref);
5782 return resolve_compcall (e, NULL);
5785 c = gfc_find_component (declared, "$data", true, true);
5786 declared = c->ts.u.derived;
5788 /* Treat the call as if it is a typebound procedure, in order to roll
5789 out the correct name for the specific function. */
5790 if (resolve_compcall (e, &name) == FAILURE)
5794 /* Then convert the expression to a procedure pointer component call. */
5795 e->value.function.esym = NULL;
5801 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5802 gfc_add_component_ref (e, "$vptr");
5803 gfc_add_component_ref (e, name);
5805 /* Recover the typespec for the expression. This is really only
5806 necessary for generic procedures, where the additional call
5807 to gfc_add_component_ref seems to throw the collection of the
5808 correct typespec. */
5813 /* Resolve a typebound subroutine, or 'method'. First separate all
5814 the non-CLASS references by calling resolve_typebound_call
5818 resolve_typebound_subroutine (gfc_code *code)
5820 gfc_symbol *declared;
5829 st = code->expr1->symtree;
5831 /* Deal with typebound operators for CLASS objects. */
5832 expr = code->expr1->value.compcall.base_object;
5833 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5834 && code->expr1->value.compcall.name)
5836 /* Since the typebound operators are generic, we have to ensure
5837 that any delays in resolution are corrected and that the vtab
5839 ts = expr->symtree->n.sym->ts;
5840 declared = ts.u.derived;
5841 c = gfc_find_component (declared, "$vptr", true, true);
5842 if (c->ts.u.derived == NULL)
5843 c->ts.u.derived = gfc_find_derived_vtab (declared);
5845 if (resolve_typebound_call (code, &name) == FAILURE)
5848 /* Use the generic name if it is there. */
5849 name = name ? name : code->expr1->value.function.esym->name;
5850 code->expr1->symtree = expr->symtree;
5851 expr->symtree->n.sym->ts.u.derived = declared;
5852 gfc_add_component_ref (code->expr1, "$vptr");
5853 gfc_add_component_ref (code->expr1, name);
5854 code->expr1->value.function.esym = NULL;
5859 return resolve_typebound_call (code, NULL);
5861 if (resolve_ref (code->expr1) == FAILURE)
5864 /* Get the CLASS declared type. */
5865 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5867 /* Weed out cases of the ultimate component being a derived type. */
5868 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5869 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5871 gfc_free_ref_list (new_ref);
5872 return resolve_typebound_call (code, NULL);
5875 if (resolve_typebound_call (code, &name) == FAILURE)
5877 ts = code->expr1->ts;
5879 /* Then convert the expression to a procedure pointer component call. */
5880 code->expr1->value.function.esym = NULL;
5881 code->expr1->symtree = st;
5884 code->expr1->ref = new_ref;
5886 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5887 gfc_add_component_ref (code->expr1, "$vptr");
5888 gfc_add_component_ref (code->expr1, name);
5890 /* Recover the typespec for the expression. This is really only
5891 necessary for generic procedures, where the additional call
5892 to gfc_add_component_ref seems to throw the collection of the
5893 correct typespec. */
5894 code->expr1->ts = ts;
5899 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5902 resolve_ppc_call (gfc_code* c)
5904 gfc_component *comp;
5907 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5910 c->resolved_sym = c->expr1->symtree->n.sym;
5911 c->expr1->expr_type = EXPR_VARIABLE;
5913 if (!comp->attr.subroutine)
5914 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5916 if (resolve_ref (c->expr1) == FAILURE)
5919 if (update_ppc_arglist (c->expr1) == FAILURE)
5922 c->ext.actual = c->expr1->value.compcall.actual;
5924 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5925 comp->formal == NULL) == FAILURE)
5928 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5934 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5937 resolve_expr_ppc (gfc_expr* e)
5939 gfc_component *comp;
5942 b = gfc_is_proc_ptr_comp (e, &comp);
5945 /* Convert to EXPR_FUNCTION. */
5946 e->expr_type = EXPR_FUNCTION;
5947 e->value.function.isym = NULL;
5948 e->value.function.actual = e->value.compcall.actual;
5950 if (comp->as != NULL)
5951 e->rank = comp->as->rank;
5953 if (!comp->attr.function)
5954 gfc_add_function (&comp->attr, comp->name, &e->where);
5956 if (resolve_ref (e) == FAILURE)
5959 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5960 comp->formal == NULL) == FAILURE)
5963 if (update_ppc_arglist (e) == FAILURE)
5966 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5973 gfc_is_expandable_expr (gfc_expr *e)
5975 gfc_constructor *con;
5977 if (e->expr_type == EXPR_ARRAY)
5979 /* Traverse the constructor looking for variables that are flavor
5980 parameter. Parameters must be expanded since they are fully used at
5982 con = gfc_constructor_first (e->value.constructor);
5983 for (; con; con = gfc_constructor_next (con))
5985 if (con->expr->expr_type == EXPR_VARIABLE
5986 && con->expr->symtree
5987 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5988 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5990 if (con->expr->expr_type == EXPR_ARRAY
5991 && gfc_is_expandable_expr (con->expr))
5999 /* Resolve an expression. That is, make sure that types of operands agree
6000 with their operators, intrinsic operators are converted to function calls
6001 for overloaded types and unresolved function references are resolved. */
6004 gfc_resolve_expr (gfc_expr *e)
6012 /* inquiry_argument only applies to variables. */
6013 inquiry_save = inquiry_argument;
6014 if (e->expr_type != EXPR_VARIABLE)
6015 inquiry_argument = false;
6017 switch (e->expr_type)
6020 t = resolve_operator (e);
6026 if (check_host_association (e))
6027 t = resolve_function (e);
6030 t = resolve_variable (e);
6032 expression_rank (e);
6035 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6036 && e->ref->type != REF_SUBSTRING)
6037 gfc_resolve_substring_charlen (e);
6042 t = resolve_typebound_function (e);
6045 case EXPR_SUBSTRING:
6046 t = resolve_ref (e);
6055 t = resolve_expr_ppc (e);
6060 if (resolve_ref (e) == FAILURE)
6063 t = gfc_resolve_array_constructor (e);
6064 /* Also try to expand a constructor. */
6067 expression_rank (e);
6068 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6069 gfc_expand_constructor (e, false);
6072 /* This provides the opportunity for the length of constructors with
6073 character valued function elements to propagate the string length
6074 to the expression. */
6075 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6077 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6078 here rather then add a duplicate test for it above. */
6079 gfc_expand_constructor (e, false);
6080 t = gfc_resolve_character_array_constructor (e);
6085 case EXPR_STRUCTURE:
6086 t = resolve_ref (e);
6090 t = resolve_structure_cons (e, 0);
6094 t = gfc_simplify_expr (e, 0);
6098 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6101 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6104 inquiry_argument = inquiry_save;
6110 /* Resolve an expression from an iterator. They must be scalar and have
6111 INTEGER or (optionally) REAL type. */
6114 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6115 const char *name_msgid)
6117 if (gfc_resolve_expr (expr) == FAILURE)
6120 if (expr->rank != 0)
6122 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6126 if (expr->ts.type != BT_INTEGER)
6128 if (expr->ts.type == BT_REAL)
6131 return gfc_notify_std (GFC_STD_F95_DEL,
6132 "Deleted feature: %s at %L must be integer",
6133 _(name_msgid), &expr->where);
6136 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6143 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6151 /* Resolve the expressions in an iterator structure. If REAL_OK is
6152 false allow only INTEGER type iterators, otherwise allow REAL types. */
6155 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6157 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6161 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
6163 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
6168 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6169 "Start expression in DO loop") == FAILURE)
6172 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6173 "End expression in DO loop") == FAILURE)
6176 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6177 "Step expression in DO loop") == FAILURE)
6180 if (iter->step->expr_type == EXPR_CONSTANT)
6182 if ((iter->step->ts.type == BT_INTEGER
6183 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6184 || (iter->step->ts.type == BT_REAL
6185 && mpfr_sgn (iter->step->value.real) == 0))
6187 gfc_error ("Step expression in DO loop at %L cannot be zero",
6188 &iter->step->where);
6193 /* Convert start, end, and step to the same type as var. */
6194 if (iter->start->ts.kind != iter->var->ts.kind
6195 || iter->start->ts.type != iter->var->ts.type)
6196 gfc_convert_type (iter->start, &iter->var->ts, 2);
6198 if (iter->end->ts.kind != iter->var->ts.kind
6199 || iter->end->ts.type != iter->var->ts.type)
6200 gfc_convert_type (iter->end, &iter->var->ts, 2);
6202 if (iter->step->ts.kind != iter->var->ts.kind
6203 || iter->step->ts.type != iter->var->ts.type)
6204 gfc_convert_type (iter->step, &iter->var->ts, 2);
6206 if (iter->start->expr_type == EXPR_CONSTANT
6207 && iter->end->expr_type == EXPR_CONSTANT
6208 && iter->step->expr_type == EXPR_CONSTANT)
6211 if (iter->start->ts.type == BT_INTEGER)
6213 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6214 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6218 sgn = mpfr_sgn (iter->step->value.real);
6219 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6221 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6222 gfc_warning ("DO loop at %L will be executed zero times",
6223 &iter->step->where);
6230 /* Traversal function for find_forall_index. f == 2 signals that
6231 that variable itself is not to be checked - only the references. */
6234 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6236 if (expr->expr_type != EXPR_VARIABLE)
6239 /* A scalar assignment */
6240 if (!expr->ref || *f == 1)
6242 if (expr->symtree->n.sym == sym)
6254 /* Check whether the FORALL index appears in the expression or not.
6255 Returns SUCCESS if SYM is found in EXPR. */
6258 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6260 if (gfc_traverse_expr (expr, sym, forall_index, f))
6267 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6268 to be a scalar INTEGER variable. The subscripts and stride are scalar
6269 INTEGERs, and if stride is a constant it must be nonzero.
6270 Furthermore "A subscript or stride in a forall-triplet-spec shall
6271 not contain a reference to any index-name in the
6272 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6275 resolve_forall_iterators (gfc_forall_iterator *it)
6277 gfc_forall_iterator *iter, *iter2;
6279 for (iter = it; iter; iter = iter->next)
6281 if (gfc_resolve_expr (iter->var) == SUCCESS
6282 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6283 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6286 if (gfc_resolve_expr (iter->start) == SUCCESS
6287 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6288 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6289 &iter->start->where);
6290 if (iter->var->ts.kind != iter->start->ts.kind)
6291 gfc_convert_type (iter->start, &iter->var->ts, 2);
6293 if (gfc_resolve_expr (iter->end) == SUCCESS
6294 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6295 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6297 if (iter->var->ts.kind != iter->end->ts.kind)
6298 gfc_convert_type (iter->end, &iter->var->ts, 2);
6300 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6302 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6303 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6304 &iter->stride->where, "INTEGER");
6306 if (iter->stride->expr_type == EXPR_CONSTANT
6307 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6308 gfc_error ("FORALL stride expression at %L cannot be zero",
6309 &iter->stride->where);
6311 if (iter->var->ts.kind != iter->stride->ts.kind)
6312 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6315 for (iter = it; iter; iter = iter->next)
6316 for (iter2 = iter; iter2; iter2 = iter2->next)
6318 if (find_forall_index (iter2->start,
6319 iter->var->symtree->n.sym, 0) == SUCCESS
6320 || find_forall_index (iter2->end,
6321 iter->var->symtree->n.sym, 0) == SUCCESS
6322 || find_forall_index (iter2->stride,
6323 iter->var->symtree->n.sym, 0) == SUCCESS)
6324 gfc_error ("FORALL index '%s' may not appear in triplet "
6325 "specification at %L", iter->var->symtree->name,
6326 &iter2->start->where);
6331 /* Given a pointer to a symbol that is a derived type, see if it's
6332 inaccessible, i.e. if it's defined in another module and the components are
6333 PRIVATE. The search is recursive if necessary. Returns zero if no
6334 inaccessible components are found, nonzero otherwise. */
6337 derived_inaccessible (gfc_symbol *sym)
6341 if (sym->attr.use_assoc && sym->attr.private_comp)
6344 for (c = sym->components; c; c = c->next)
6346 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6354 /* Resolve the argument of a deallocate expression. The expression must be
6355 a pointer or a full array. */
6358 resolve_deallocate_expr (gfc_expr *e)
6360 symbol_attribute attr;
6361 int allocatable, pointer, check_intent_in;
6366 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6367 check_intent_in = 1;
6369 if (gfc_resolve_expr (e) == FAILURE)
6372 if (e->expr_type != EXPR_VARIABLE)
6375 sym = e->symtree->n.sym;
6377 if (sym->ts.type == BT_CLASS)
6379 allocatable = CLASS_DATA (sym)->attr.allocatable;
6380 pointer = CLASS_DATA (sym)->attr.class_pointer;
6384 allocatable = sym->attr.allocatable;
6385 pointer = sym->attr.pointer;
6387 for (ref = e->ref; ref; ref = ref->next)
6390 check_intent_in = 0;
6395 if (ref->u.ar.type != AR_FULL)
6400 c = ref->u.c.component;
6401 if (c->ts.type == BT_CLASS)
6403 allocatable = CLASS_DATA (c)->attr.allocatable;
6404 pointer = CLASS_DATA (c)->attr.class_pointer;
6408 allocatable = c->attr.allocatable;
6409 pointer = c->attr.pointer;
6419 attr = gfc_expr_attr (e);
6421 if (allocatable == 0 && attr.pointer == 0)
6424 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6429 if (check_intent_in && sym->attr.intent == INTENT_IN)
6431 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
6432 sym->name, &e->where);
6436 if (e->ts.type == BT_CLASS)
6438 /* Only deallocate the DATA component. */
6439 gfc_add_component_ref (e, "$data");
6446 /* Returns true if the expression e contains a reference to the symbol sym. */
6448 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6450 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6457 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6459 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6463 /* Given the expression node e for an allocatable/pointer of derived type to be
6464 allocated, get the expression node to be initialized afterwards (needed for
6465 derived types with default initializers, and derived types with allocatable
6466 components that need nullification.) */
6469 gfc_expr_to_initialize (gfc_expr *e)
6475 result = gfc_copy_expr (e);
6477 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6478 for (ref = result->ref; ref; ref = ref->next)
6479 if (ref->type == REF_ARRAY && ref->next == NULL)
6481 ref->u.ar.type = AR_FULL;
6483 for (i = 0; i < ref->u.ar.dimen; i++)
6484 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6486 result->rank = ref->u.ar.dimen;
6494 /* Used in resolve_allocate_expr to check that a allocation-object and
6495 a source-expr are conformable. This does not catch all possible
6496 cases; in particular a runtime checking is needed. */
6499 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6502 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6504 /* First compare rank. */
6505 if (tail && e1->rank != tail->u.ar.as->rank)
6507 gfc_error ("Source-expr at %L must be scalar or have the "
6508 "same rank as the allocate-object at %L",
6509 &e1->where, &e2->where);
6520 for (i = 0; i < e1->rank; i++)
6522 if (tail->u.ar.end[i])
6524 mpz_set (s, tail->u.ar.end[i]->value.integer);
6525 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6526 mpz_add_ui (s, s, 1);
6530 mpz_set (s, tail->u.ar.start[i]->value.integer);
6533 if (mpz_cmp (e1->shape[i], s) != 0)
6535 gfc_error ("Source-expr at %L and allocate-object at %L must "
6536 "have the same shape", &e1->where, &e2->where);
6549 /* Resolve the expression in an ALLOCATE statement, doing the additional
6550 checks to see whether the expression is OK or not. The expression must
6551 have a trailing array reference that gives the size of the array. */
6554 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6556 int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
6558 symbol_attribute attr;
6559 gfc_ref *ref, *ref2;
6561 gfc_symbol *sym = NULL;
6565 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6566 check_intent_in = 1;
6568 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6569 checking of coarrays. */
6570 for (ref = e->ref; ref; ref = ref->next)
6571 if (ref->next == NULL)
6574 if (ref && ref->type == REF_ARRAY)
6575 ref->u.ar.in_allocate = true;
6577 if (gfc_resolve_expr (e) == FAILURE)
6580 /* Make sure the expression is allocatable or a pointer. If it is
6581 pointer, the next-to-last reference must be a pointer. */
6585 sym = e->symtree->n.sym;
6587 /* Check whether ultimate component is abstract and CLASS. */
6590 if (e->expr_type != EXPR_VARIABLE)
6593 attr = gfc_expr_attr (e);
6594 pointer = attr.pointer;
6595 dimension = attr.dimension;
6596 codimension = attr.codimension;
6600 if (sym->ts.type == BT_CLASS)
6602 allocatable = CLASS_DATA (sym)->attr.allocatable;
6603 pointer = CLASS_DATA (sym)->attr.class_pointer;
6604 dimension = CLASS_DATA (sym)->attr.dimension;
6605 codimension = CLASS_DATA (sym)->attr.codimension;
6606 is_abstract = CLASS_DATA (sym)->attr.abstract;
6610 allocatable = sym->attr.allocatable;
6611 pointer = sym->attr.pointer;
6612 dimension = sym->attr.dimension;
6613 codimension = sym->attr.codimension;
6616 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6619 check_intent_in = 0;
6624 if (ref->next != NULL)
6630 if (gfc_is_coindexed (e))
6632 gfc_error ("Coindexed allocatable object at %L",
6637 c = ref->u.c.component;
6638 if (c->ts.type == BT_CLASS)
6640 allocatable = CLASS_DATA (c)->attr.allocatable;
6641 pointer = CLASS_DATA (c)->attr.class_pointer;
6642 dimension = CLASS_DATA (c)->attr.dimension;
6643 codimension = CLASS_DATA (c)->attr.codimension;
6644 is_abstract = CLASS_DATA (c)->attr.abstract;
6648 allocatable = c->attr.allocatable;
6649 pointer = c->attr.pointer;
6650 dimension = c->attr.dimension;
6651 codimension = c->attr.codimension;
6652 is_abstract = c->attr.abstract;
6664 if (allocatable == 0 && pointer == 0)
6666 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6671 /* Some checks for the SOURCE tag. */
6674 /* Check F03:C631. */
6675 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6677 gfc_error ("Type of entity at %L is type incompatible with "
6678 "source-expr at %L", &e->where, &code->expr3->where);
6682 /* Check F03:C632 and restriction following Note 6.18. */
6683 if (code->expr3->rank > 0
6684 && conformable_arrays (code->expr3, e) == FAILURE)
6687 /* Check F03:C633. */
6688 if (code->expr3->ts.kind != e->ts.kind)
6690 gfc_error ("The allocate-object at %L and the source-expr at %L "
6691 "shall have the same kind type parameter",
6692 &e->where, &code->expr3->where);
6697 /* Check F08:C629. */
6698 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6701 gcc_assert (e->ts.type == BT_CLASS);
6702 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6703 "type-spec or source-expr", sym->name, &e->where);
6707 if (check_intent_in && sym->attr.intent == INTENT_IN)
6709 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
6710 sym->name, &e->where);
6714 if (!code->expr3 || code->expr3->mold)
6716 /* Add default initializer for those derived types that need them. */
6717 gfc_expr *init_e = NULL;
6720 if (code->ext.alloc.ts.type == BT_DERIVED)
6721 ts = code->ext.alloc.ts;
6722 else if (code->expr3)
6723 ts = code->expr3->ts;
6727 if (ts.type == BT_DERIVED)
6728 init_e = gfc_default_initializer (&ts);
6729 /* FIXME: Use default init of dynamic type (cf. PR 44541). */
6730 else if (e->ts.type == BT_CLASS)
6731 init_e = gfc_default_initializer (&ts.u.derived->components->ts);
6735 gfc_code *init_st = gfc_get_code ();
6736 init_st->loc = code->loc;
6737 init_st->op = EXEC_INIT_ASSIGN;
6738 init_st->expr1 = gfc_expr_to_initialize (e);
6739 init_st->expr2 = init_e;
6740 init_st->next = code->next;
6741 code->next = init_st;
6745 if (e->ts.type == BT_CLASS)
6747 /* Make sure the vtab symbol is present when
6748 the module variables are generated. */
6749 gfc_typespec ts = e->ts;
6751 ts = code->expr3->ts;
6752 else if (code->ext.alloc.ts.type == BT_DERIVED)
6753 ts = code->ext.alloc.ts;
6754 gfc_find_derived_vtab (ts.u.derived);
6757 if (pointer || (dimension == 0 && codimension == 0))
6760 /* Make sure the next-to-last reference node is an array specification. */
6762 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6763 || (dimension && ref2->u.ar.dimen == 0))
6765 gfc_error ("Array specification required in ALLOCATE statement "
6766 "at %L", &e->where);
6770 /* Make sure that the array section reference makes sense in the
6771 context of an ALLOCATE specification. */
6775 if (codimension && ar->codimen == 0)
6777 gfc_error ("Coarray specification required in ALLOCATE statement "
6778 "at %L", &e->where);
6782 for (i = 0; i < ar->dimen; i++)
6784 if (ref2->u.ar.type == AR_ELEMENT)
6787 switch (ar->dimen_type[i])
6793 if (ar->start[i] != NULL
6794 && ar->end[i] != NULL
6795 && ar->stride[i] == NULL)
6798 /* Fall Through... */
6803 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6809 for (a = code->ext.alloc.list; a; a = a->next)
6811 sym = a->expr->symtree->n.sym;
6813 /* TODO - check derived type components. */
6814 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6817 if ((ar->start[i] != NULL
6818 && gfc_find_sym_in_expr (sym, ar->start[i]))
6819 || (ar->end[i] != NULL
6820 && gfc_find_sym_in_expr (sym, ar->end[i])))
6822 gfc_error ("'%s' must not appear in the array specification at "
6823 "%L in the same ALLOCATE statement where it is "
6824 "itself allocated", sym->name, &ar->where);
6830 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6832 if (ar->dimen_type[i] == DIMEN_ELEMENT
6833 || ar->dimen_type[i] == DIMEN_RANGE)
6835 if (i == (ar->dimen + ar->codimen - 1))
6837 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6838 "statement at %L", &e->where);
6844 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6845 && ar->stride[i] == NULL)
6848 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6853 if (codimension && ar->as->rank == 0)
6855 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6856 "at %L", &e->where);
6868 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6870 gfc_expr *stat, *errmsg, *pe, *qe;
6871 gfc_alloc *a, *p, *q;
6873 stat = code->expr1 ? code->expr1 : NULL;
6875 errmsg = code->expr2 ? code->expr2 : NULL;
6877 /* Check the stat variable. */
6880 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
6881 gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
6882 stat->symtree->n.sym->name, &stat->where);
6884 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
6885 gfc_error ("Illegal stat-variable at %L for a PURE procedure",
6888 if ((stat->ts.type != BT_INTEGER
6889 && !(stat->ref && (stat->ref->type == REF_ARRAY
6890 || stat->ref->type == REF_COMPONENT)))
6892 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6893 "variable", &stat->where);
6895 for (p = code->ext.alloc.list; p; p = p->next)
6896 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6898 gfc_ref *ref1, *ref2;
6901 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6902 ref1 = ref1->next, ref2 = ref2->next)
6904 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6906 if (ref1->u.c.component->name != ref2->u.c.component->name)
6915 gfc_error ("Stat-variable at %L shall not be %sd within "
6916 "the same %s statement", &stat->where, fcn, fcn);
6922 /* Check the errmsg variable. */
6926 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6929 if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
6930 gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
6931 errmsg->symtree->n.sym->name, &errmsg->where);
6933 if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
6934 gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
6937 if ((errmsg->ts.type != BT_CHARACTER
6939 && (errmsg->ref->type == REF_ARRAY
6940 || errmsg->ref->type == REF_COMPONENT)))
6941 || errmsg->rank > 0 )
6942 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6943 "variable", &errmsg->where);
6945 for (p = code->ext.alloc.list; p; p = p->next)
6946 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6948 gfc_ref *ref1, *ref2;
6951 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6952 ref1 = ref1->next, ref2 = ref2->next)
6954 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6956 if (ref1->u.c.component->name != ref2->u.c.component->name)
6965 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6966 "the same %s statement", &errmsg->where, fcn, fcn);
6972 /* Check that an allocate-object appears only once in the statement.
6973 FIXME: Checking derived types is disabled. */
6974 for (p = code->ext.alloc.list; p; p = p->next)
6977 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6978 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6980 for (q = p->next; q; q = q->next)
6983 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6984 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6985 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6986 gfc_error ("Allocate-object at %L also appears at %L",
6987 &pe->where, &qe->where);
6992 if (strcmp (fcn, "ALLOCATE") == 0)
6994 for (a = code->ext.alloc.list; a; a = a->next)
6995 resolve_allocate_expr (a->expr, code);
6999 for (a = code->ext.alloc.list; a; a = a->next)
7000 resolve_deallocate_expr (a->expr);
7005 /************ SELECT CASE resolution subroutines ************/
7007 /* Callback function for our mergesort variant. Determines interval
7008 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7009 op1 > op2. Assumes we're not dealing with the default case.
7010 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7011 There are nine situations to check. */
7014 compare_cases (const gfc_case *op1, const gfc_case *op2)
7018 if (op1->low == NULL) /* op1 = (:L) */
7020 /* op2 = (:N), so overlap. */
7022 /* op2 = (M:) or (M:N), L < M */
7023 if (op2->low != NULL
7024 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7027 else if (op1->high == NULL) /* op1 = (K:) */
7029 /* op2 = (M:), so overlap. */
7031 /* op2 = (:N) or (M:N), K > N */
7032 if (op2->high != NULL
7033 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7036 else /* op1 = (K:L) */
7038 if (op2->low == NULL) /* op2 = (:N), K > N */
7039 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7041 else if (op2->high == NULL) /* op2 = (M:), L < M */
7042 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7044 else /* op2 = (M:N) */
7048 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7051 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7060 /* Merge-sort a double linked case list, detecting overlap in the
7061 process. LIST is the head of the double linked case list before it
7062 is sorted. Returns the head of the sorted list if we don't see any
7063 overlap, or NULL otherwise. */
7066 check_case_overlap (gfc_case *list)
7068 gfc_case *p, *q, *e, *tail;
7069 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7071 /* If the passed list was empty, return immediately. */
7078 /* Loop unconditionally. The only exit from this loop is a return
7079 statement, when we've finished sorting the case list. */
7086 /* Count the number of merges we do in this pass. */
7089 /* Loop while there exists a merge to be done. */
7094 /* Count this merge. */
7097 /* Cut the list in two pieces by stepping INSIZE places
7098 forward in the list, starting from P. */
7101 for (i = 0; i < insize; i++)
7110 /* Now we have two lists. Merge them! */
7111 while (psize > 0 || (qsize > 0 && q != NULL))
7113 /* See from which the next case to merge comes from. */
7116 /* P is empty so the next case must come from Q. */
7121 else if (qsize == 0 || q == NULL)
7130 cmp = compare_cases (p, q);
7133 /* The whole case range for P is less than the
7141 /* The whole case range for Q is greater than
7142 the case range for P. */
7149 /* The cases overlap, or they are the same
7150 element in the list. Either way, we must
7151 issue an error and get the next case from P. */
7152 /* FIXME: Sort P and Q by line number. */
7153 gfc_error ("CASE label at %L overlaps with CASE "
7154 "label at %L", &p->where, &q->where);
7162 /* Add the next element to the merged list. */
7171 /* P has now stepped INSIZE places along, and so has Q. So
7172 they're the same. */
7177 /* If we have done only one merge or none at all, we've
7178 finished sorting the cases. */
7187 /* Otherwise repeat, merging lists twice the size. */
7193 /* Check to see if an expression is suitable for use in a CASE statement.
7194 Makes sure that all case expressions are scalar constants of the same
7195 type. Return FAILURE if anything is wrong. */
7198 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7200 if (e == NULL) return SUCCESS;
7202 if (e->ts.type != case_expr->ts.type)
7204 gfc_error ("Expression in CASE statement at %L must be of type %s",
7205 &e->where, gfc_basic_typename (case_expr->ts.type));
7209 /* C805 (R808) For a given case-construct, each case-value shall be of
7210 the same type as case-expr. For character type, length differences
7211 are allowed, but the kind type parameters shall be the same. */
7213 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7215 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7216 &e->where, case_expr->ts.kind);
7220 /* Convert the case value kind to that of case expression kind,
7223 if (e->ts.kind != case_expr->ts.kind)
7224 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7228 gfc_error ("Expression in CASE statement at %L must be scalar",
7237 /* Given a completely parsed select statement, we:
7239 - Validate all expressions and code within the SELECT.
7240 - Make sure that the selection expression is not of the wrong type.
7241 - Make sure that no case ranges overlap.
7242 - Eliminate unreachable cases and unreachable code resulting from
7243 removing case labels.
7245 The standard does allow unreachable cases, e.g. CASE (5:3). But
7246 they are a hassle for code generation, and to prevent that, we just
7247 cut them out here. This is not necessary for overlapping cases
7248 because they are illegal and we never even try to generate code.
7250 We have the additional caveat that a SELECT construct could have
7251 been a computed GOTO in the source code. Fortunately we can fairly
7252 easily work around that here: The case_expr for a "real" SELECT CASE
7253 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7254 we have to do is make sure that the case_expr is a scalar integer
7258 resolve_select (gfc_code *code)
7261 gfc_expr *case_expr;
7262 gfc_case *cp, *default_case, *tail, *head;
7263 int seen_unreachable;
7269 if (code->expr1 == NULL)
7271 /* This was actually a computed GOTO statement. */
7272 case_expr = code->expr2;
7273 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7274 gfc_error ("Selection expression in computed GOTO statement "
7275 "at %L must be a scalar integer expression",
7278 /* Further checking is not necessary because this SELECT was built
7279 by the compiler, so it should always be OK. Just move the
7280 case_expr from expr2 to expr so that we can handle computed
7281 GOTOs as normal SELECTs from here on. */
7282 code->expr1 = code->expr2;
7287 case_expr = code->expr1;
7289 type = case_expr->ts.type;
7290 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7292 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7293 &case_expr->where, gfc_typename (&case_expr->ts));
7295 /* Punt. Going on here just produce more garbage error messages. */
7299 if (case_expr->rank != 0)
7301 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7302 "expression", &case_expr->where);
7309 /* Raise a warning if an INTEGER case value exceeds the range of
7310 the case-expr. Later, all expressions will be promoted to the
7311 largest kind of all case-labels. */
7313 if (type == BT_INTEGER)
7314 for (body = code->block; body; body = body->block)
7315 for (cp = body->ext.case_list; cp; cp = cp->next)
7318 && gfc_check_integer_range (cp->low->value.integer,
7319 case_expr->ts.kind) != ARITH_OK)
7320 gfc_warning ("Expression in CASE statement at %L is "
7321 "not in the range of %s", &cp->low->where,
7322 gfc_typename (&case_expr->ts));
7325 && cp->low != cp->high
7326 && gfc_check_integer_range (cp->high->value.integer,
7327 case_expr->ts.kind) != ARITH_OK)
7328 gfc_warning ("Expression in CASE statement at %L is "
7329 "not in the range of %s", &cp->high->where,
7330 gfc_typename (&case_expr->ts));
7333 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7334 of the SELECT CASE expression and its CASE values. Walk the lists
7335 of case values, and if we find a mismatch, promote case_expr to
7336 the appropriate kind. */
7338 if (type == BT_LOGICAL || type == BT_INTEGER)
7340 for (body = code->block; body; body = body->block)
7342 /* Walk the case label list. */
7343 for (cp = body->ext.case_list; cp; cp = cp->next)
7345 /* Intercept the DEFAULT case. It does not have a kind. */
7346 if (cp->low == NULL && cp->high == NULL)
7349 /* Unreachable case ranges are discarded, so ignore. */
7350 if (cp->low != NULL && cp->high != NULL
7351 && cp->low != cp->high
7352 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7356 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7357 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7359 if (cp->high != NULL
7360 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7361 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7366 /* Assume there is no DEFAULT case. */
7367 default_case = NULL;
7372 for (body = code->block; body; body = body->block)
7374 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7376 seen_unreachable = 0;
7378 /* Walk the case label list, making sure that all case labels
7380 for (cp = body->ext.case_list; cp; cp = cp->next)
7382 /* Count the number of cases in the whole construct. */
7385 /* Intercept the DEFAULT case. */
7386 if (cp->low == NULL && cp->high == NULL)
7388 if (default_case != NULL)
7390 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7391 "by a second DEFAULT CASE at %L",
7392 &default_case->where, &cp->where);
7403 /* Deal with single value cases and case ranges. Errors are
7404 issued from the validation function. */
7405 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7406 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7412 if (type == BT_LOGICAL
7413 && ((cp->low == NULL || cp->high == NULL)
7414 || cp->low != cp->high))
7416 gfc_error ("Logical range in CASE statement at %L is not "
7417 "allowed", &cp->low->where);
7422 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7425 value = cp->low->value.logical == 0 ? 2 : 1;
7426 if (value & seen_logical)
7428 gfc_error ("Constant logical value in CASE statement "
7429 "is repeated at %L",
7434 seen_logical |= value;
7437 if (cp->low != NULL && cp->high != NULL
7438 && cp->low != cp->high
7439 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7441 if (gfc_option.warn_surprising)
7442 gfc_warning ("Range specification at %L can never "
7443 "be matched", &cp->where);
7445 cp->unreachable = 1;
7446 seen_unreachable = 1;
7450 /* If the case range can be matched, it can also overlap with
7451 other cases. To make sure it does not, we put it in a
7452 double linked list here. We sort that with a merge sort
7453 later on to detect any overlapping cases. */
7457 head->right = head->left = NULL;
7462 tail->right->left = tail;
7469 /* It there was a failure in the previous case label, give up
7470 for this case label list. Continue with the next block. */
7474 /* See if any case labels that are unreachable have been seen.
7475 If so, we eliminate them. This is a bit of a kludge because
7476 the case lists for a single case statement (label) is a
7477 single forward linked lists. */
7478 if (seen_unreachable)
7480 /* Advance until the first case in the list is reachable. */
7481 while (body->ext.case_list != NULL
7482 && body->ext.case_list->unreachable)
7484 gfc_case *n = body->ext.case_list;
7485 body->ext.case_list = body->ext.case_list->next;
7487 gfc_free_case_list (n);
7490 /* Strip all other unreachable cases. */
7491 if (body->ext.case_list)
7493 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7495 if (cp->next->unreachable)
7497 gfc_case *n = cp->next;
7498 cp->next = cp->next->next;
7500 gfc_free_case_list (n);
7507 /* See if there were overlapping cases. If the check returns NULL,
7508 there was overlap. In that case we don't do anything. If head
7509 is non-NULL, we prepend the DEFAULT case. The sorted list can
7510 then used during code generation for SELECT CASE constructs with
7511 a case expression of a CHARACTER type. */
7514 head = check_case_overlap (head);
7516 /* Prepend the default_case if it is there. */
7517 if (head != NULL && default_case)
7519 default_case->left = NULL;
7520 default_case->right = head;
7521 head->left = default_case;
7525 /* Eliminate dead blocks that may be the result if we've seen
7526 unreachable case labels for a block. */
7527 for (body = code; body && body->block; body = body->block)
7529 if (body->block->ext.case_list == NULL)
7531 /* Cut the unreachable block from the code chain. */
7532 gfc_code *c = body->block;
7533 body->block = c->block;
7535 /* Kill the dead block, but not the blocks below it. */
7537 gfc_free_statements (c);
7541 /* More than two cases is legal but insane for logical selects.
7542 Issue a warning for it. */
7543 if (gfc_option.warn_surprising && type == BT_LOGICAL
7545 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7550 /* Check if a derived type is extensible. */
7553 gfc_type_is_extensible (gfc_symbol *sym)
7555 return !(sym->attr.is_bind_c || sym->attr.sequence);
7559 /* Resolve an associate name: Resolve target and ensure the type-spec is
7560 correct as well as possibly the array-spec. */
7563 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7568 gcc_assert (sym->assoc);
7569 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7571 /* If this is for SELECT TYPE, the target may not yet be set. In that
7572 case, return. Resolution will be called later manually again when
7574 target = sym->assoc->target;
7577 gcc_assert (!sym->assoc->dangling);
7579 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7582 /* For variable targets, we get some attributes from the target. */
7583 if (target->expr_type == EXPR_VARIABLE)
7587 gcc_assert (target->symtree);
7588 tsym = target->symtree->n.sym;
7590 sym->attr.asynchronous = tsym->attr.asynchronous;
7591 sym->attr.volatile_ = tsym->attr.volatile_;
7593 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7596 sym->ts = target->ts;
7597 gcc_assert (sym->ts.type != BT_UNKNOWN);
7599 /* See if this is a valid association-to-variable. */
7600 to_var = (target->expr_type == EXPR_VARIABLE
7601 && !gfc_has_vector_subscript (target));
7602 if (sym->assoc->variable && !to_var)
7604 if (target->expr_type == EXPR_VARIABLE)
7605 gfc_error ("'%s' at %L associated to vector-indexed target can not"
7606 " be used in a variable definition context",
7607 sym->name, &sym->declared_at);
7609 gfc_error ("'%s' at %L associated to expression can not"
7610 " be used in a variable definition context",
7611 sym->name, &sym->declared_at);
7615 sym->assoc->variable = to_var;
7617 /* Finally resolve if this is an array or not. */
7618 if (sym->attr.dimension && target->rank == 0)
7620 gfc_error ("Associate-name '%s' at %L is used as array",
7621 sym->name, &sym->declared_at);
7622 sym->attr.dimension = 0;
7625 if (target->rank > 0)
7626 sym->attr.dimension = 1;
7628 if (sym->attr.dimension)
7630 sym->as = gfc_get_array_spec ();
7631 sym->as->rank = target->rank;
7632 sym->as->type = AS_DEFERRED;
7634 /* Target must not be coindexed, thus the associate-variable
7636 sym->as->corank = 0;
7641 /* Resolve a SELECT TYPE statement. */
7644 resolve_select_type (gfc_code *code)
7646 gfc_symbol *selector_type;
7647 gfc_code *body, *new_st, *if_st, *tail;
7648 gfc_code *class_is = NULL, *default_case = NULL;
7651 char name[GFC_MAX_SYMBOL_LEN];
7655 ns = code->ext.block.ns;
7658 /* Check for F03:C813. */
7659 if (code->expr1->ts.type != BT_CLASS
7660 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7662 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7663 "at %L", &code->loc);
7669 if (code->expr1->symtree->n.sym->attr.untyped)
7670 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7671 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7674 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7676 /* Loop over TYPE IS / CLASS IS cases. */
7677 for (body = code->block; body; body = body->block)
7679 c = body->ext.case_list;
7681 /* Check F03:C815. */
7682 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7683 && !gfc_type_is_extensible (c->ts.u.derived))
7685 gfc_error ("Derived type '%s' at %L must be extensible",
7686 c->ts.u.derived->name, &c->where);
7691 /* Check F03:C816. */
7692 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7693 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7695 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7696 c->ts.u.derived->name, &c->where, selector_type->name);
7701 /* Intercept the DEFAULT case. */
7702 if (c->ts.type == BT_UNKNOWN)
7704 /* Check F03:C818. */
7707 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7708 "by a second DEFAULT CASE at %L",
7709 &default_case->ext.case_list->where, &c->where);
7714 default_case = body;
7721 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7722 target if present. */
7723 code->op = EXEC_BLOCK;
7726 gfc_association_list* assoc;
7728 assoc = gfc_get_association_list ();
7729 assoc->st = code->expr1->symtree;
7730 assoc->target = gfc_copy_expr (code->expr2);
7731 /* assoc->variable will be set by resolve_assoc_var. */
7733 code->ext.block.assoc = assoc;
7734 code->expr1->symtree->n.sym->assoc = assoc;
7736 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7739 code->ext.block.assoc = NULL;
7741 /* Add EXEC_SELECT to switch on type. */
7742 new_st = gfc_get_code ();
7743 new_st->op = code->op;
7744 new_st->expr1 = code->expr1;
7745 new_st->expr2 = code->expr2;
7746 new_st->block = code->block;
7747 code->expr1 = code->expr2 = NULL;
7752 ns->code->next = new_st;
7754 code->op = EXEC_SELECT;
7755 gfc_add_component_ref (code->expr1, "$vptr");
7756 gfc_add_component_ref (code->expr1, "$hash");
7758 /* Loop over TYPE IS / CLASS IS cases. */
7759 for (body = code->block; body; body = body->block)
7761 c = body->ext.case_list;
7763 if (c->ts.type == BT_DERIVED)
7764 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7765 c->ts.u.derived->hash_value);
7767 else if (c->ts.type == BT_UNKNOWN)
7770 /* Associate temporary to selector. This should only be done
7771 when this case is actually true, so build a new ASSOCIATE
7772 that does precisely this here (instead of using the
7775 if (c->ts.type == BT_CLASS)
7776 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
7778 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
7779 st = gfc_find_symtree (ns->sym_root, name);
7780 gcc_assert (st->n.sym->assoc);
7781 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7782 if (c->ts.type == BT_DERIVED)
7783 gfc_add_component_ref (st->n.sym->assoc->target, "$data");
7785 new_st = gfc_get_code ();
7786 new_st->op = EXEC_BLOCK;
7787 new_st->ext.block.ns = gfc_build_block_ns (ns);
7788 new_st->ext.block.ns->code = body->next;
7789 body->next = new_st;
7791 /* Chain in the new list only if it is marked as dangling. Otherwise
7792 there is a CASE label overlap and this is already used. Just ignore,
7793 the error is diagonsed elsewhere. */
7794 if (st->n.sym->assoc->dangling)
7796 new_st->ext.block.assoc = st->n.sym->assoc;
7797 st->n.sym->assoc->dangling = 0;
7800 resolve_assoc_var (st->n.sym, false);
7803 /* Take out CLASS IS cases for separate treatment. */
7805 while (body && body->block)
7807 if (body->block->ext.case_list->ts.type == BT_CLASS)
7809 /* Add to class_is list. */
7810 if (class_is == NULL)
7812 class_is = body->block;
7817 for (tail = class_is; tail->block; tail = tail->block) ;
7818 tail->block = body->block;
7821 /* Remove from EXEC_SELECT list. */
7822 body->block = body->block->block;
7835 /* Add a default case to hold the CLASS IS cases. */
7836 for (tail = code; tail->block; tail = tail->block) ;
7837 tail->block = gfc_get_code ();
7839 tail->op = EXEC_SELECT_TYPE;
7840 tail->ext.case_list = gfc_get_case ();
7841 tail->ext.case_list->ts.type = BT_UNKNOWN;
7843 default_case = tail;
7846 /* More than one CLASS IS block? */
7847 if (class_is->block)
7851 /* Sort CLASS IS blocks by extension level. */
7855 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7858 /* F03:C817 (check for doubles). */
7859 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7860 == c2->ext.case_list->ts.u.derived->hash_value)
7862 gfc_error ("Double CLASS IS block in SELECT TYPE "
7863 "statement at %L", &c2->ext.case_list->where);
7866 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7867 < c2->ext.case_list->ts.u.derived->attr.extension)
7870 (*c1)->block = c2->block;
7880 /* Generate IF chain. */
7881 if_st = gfc_get_code ();
7882 if_st->op = EXEC_IF;
7884 for (body = class_is; body; body = body->block)
7886 new_st->block = gfc_get_code ();
7887 new_st = new_st->block;
7888 new_st->op = EXEC_IF;
7889 /* Set up IF condition: Call _gfortran_is_extension_of. */
7890 new_st->expr1 = gfc_get_expr ();
7891 new_st->expr1->expr_type = EXPR_FUNCTION;
7892 new_st->expr1->ts.type = BT_LOGICAL;
7893 new_st->expr1->ts.kind = 4;
7894 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7895 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7896 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7897 /* Set up arguments. */
7898 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7899 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7900 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7901 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7902 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7903 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7904 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7905 new_st->next = body->next;
7907 if (default_case->next)
7909 new_st->block = gfc_get_code ();
7910 new_st = new_st->block;
7911 new_st->op = EXEC_IF;
7912 new_st->next = default_case->next;
7915 /* Replace CLASS DEFAULT code by the IF chain. */
7916 default_case->next = if_st;
7919 resolve_select (code);
7924 /* Resolve a transfer statement. This is making sure that:
7925 -- a derived type being transferred has only non-pointer components
7926 -- a derived type being transferred doesn't have private components, unless
7927 it's being transferred from the module where the type was defined
7928 -- we're not trying to transfer a whole assumed size array. */
7931 resolve_transfer (gfc_code *code)
7940 while (exp != NULL && exp->expr_type == EXPR_OP
7941 && exp->value.op.op == INTRINSIC_PARENTHESES)
7942 exp = exp->value.op.op1;
7944 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7945 && exp->expr_type != EXPR_FUNCTION))
7948 sym = exp->symtree->n.sym;
7951 /* Go to actual component transferred. */
7952 for (ref = code->expr1->ref; ref; ref = ref->next)
7953 if (ref->type == REF_COMPONENT)
7954 ts = &ref->u.c.component->ts;
7956 if (ts->type == BT_DERIVED)
7958 /* Check that transferred derived type doesn't contain POINTER
7960 if (ts->u.derived->attr.pointer_comp)
7962 gfc_error ("Data transfer element at %L cannot have "
7963 "POINTER components", &code->loc);
7967 if (ts->u.derived->attr.alloc_comp)
7969 gfc_error ("Data transfer element at %L cannot have "
7970 "ALLOCATABLE components", &code->loc);
7974 if (derived_inaccessible (ts->u.derived))
7976 gfc_error ("Data transfer element at %L cannot have "
7977 "PRIVATE components",&code->loc);
7982 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7983 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7985 gfc_error ("Data transfer element at %L cannot be a full reference to "
7986 "an assumed-size array", &code->loc);
7992 /*********** Toplevel code resolution subroutines ***********/
7994 /* Find the set of labels that are reachable from this block. We also
7995 record the last statement in each block. */
7998 find_reachable_labels (gfc_code *block)
8005 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8007 /* Collect labels in this block. We don't keep those corresponding
8008 to END {IF|SELECT}, these are checked in resolve_branch by going
8009 up through the code_stack. */
8010 for (c = block; c; c = c->next)
8012 if (c->here && c->op != EXEC_END_BLOCK)
8013 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8016 /* Merge with labels from parent block. */
8019 gcc_assert (cs_base->prev->reachable_labels);
8020 bitmap_ior_into (cs_base->reachable_labels,
8021 cs_base->prev->reachable_labels);
8027 resolve_sync (gfc_code *code)
8029 /* Check imageset. The * case matches expr1 == NULL. */
8032 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8033 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8034 "INTEGER expression", &code->expr1->where);
8035 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8036 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8037 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8038 &code->expr1->where);
8039 else if (code->expr1->expr_type == EXPR_ARRAY
8040 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8042 gfc_constructor *cons;
8043 cons = gfc_constructor_first (code->expr1->value.constructor);
8044 for (; cons; cons = gfc_constructor_next (cons))
8045 if (cons->expr->expr_type == EXPR_CONSTANT
8046 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8047 gfc_error ("Imageset argument at %L must between 1 and "
8048 "num_images()", &cons->expr->where);
8054 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8055 || code->expr2->expr_type != EXPR_VARIABLE))
8056 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8057 &code->expr2->where);
8061 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8062 || code->expr3->expr_type != EXPR_VARIABLE))
8063 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8064 &code->expr3->where);
8068 /* Given a branch to a label, see if the branch is conforming.
8069 The code node describes where the branch is located. */
8072 resolve_branch (gfc_st_label *label, gfc_code *code)
8079 /* Step one: is this a valid branching target? */
8081 if (label->defined == ST_LABEL_UNKNOWN)
8083 gfc_error ("Label %d referenced at %L is never defined", label->value,
8088 if (label->defined != ST_LABEL_TARGET)
8090 gfc_error ("Statement at %L is not a valid branch target statement "
8091 "for the branch statement at %L", &label->where, &code->loc);
8095 /* Step two: make sure this branch is not a branch to itself ;-) */
8097 if (code->here == label)
8099 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8103 /* Step three: See if the label is in the same block as the
8104 branching statement. The hard work has been done by setting up
8105 the bitmap reachable_labels. */
8107 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8109 /* Check now whether there is a CRITICAL construct; if so, check
8110 whether the label is still visible outside of the CRITICAL block,
8111 which is invalid. */
8112 for (stack = cs_base; stack; stack = stack->prev)
8113 if (stack->current->op == EXEC_CRITICAL
8114 && bitmap_bit_p (stack->reachable_labels, label->value))
8115 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8116 " at %L", &code->loc, &label->where);
8121 /* Step four: If we haven't found the label in the bitmap, it may
8122 still be the label of the END of the enclosing block, in which
8123 case we find it by going up the code_stack. */
8125 for (stack = cs_base; stack; stack = stack->prev)
8127 if (stack->current->next && stack->current->next->here == label)
8129 if (stack->current->op == EXEC_CRITICAL)
8131 /* Note: A label at END CRITICAL does not leave the CRITICAL
8132 construct as END CRITICAL is still part of it. */
8133 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8134 " at %L", &code->loc, &label->where);
8141 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8145 /* The label is not in an enclosing block, so illegal. This was
8146 allowed in Fortran 66, so we allow it as extension. No
8147 further checks are necessary in this case. */
8148 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8149 "as the GOTO statement at %L", &label->where,
8155 /* Check whether EXPR1 has the same shape as EXPR2. */
8158 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8160 mpz_t shape[GFC_MAX_DIMENSIONS];
8161 mpz_t shape2[GFC_MAX_DIMENSIONS];
8162 gfc_try result = FAILURE;
8165 /* Compare the rank. */
8166 if (expr1->rank != expr2->rank)
8169 /* Compare the size of each dimension. */
8170 for (i=0; i<expr1->rank; i++)
8172 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8175 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8178 if (mpz_cmp (shape[i], shape2[i]))
8182 /* When either of the two expression is an assumed size array, we
8183 ignore the comparison of dimension sizes. */
8188 for (i--; i >= 0; i--)
8190 mpz_clear (shape[i]);
8191 mpz_clear (shape2[i]);
8197 /* Check whether a WHERE assignment target or a WHERE mask expression
8198 has the same shape as the outmost WHERE mask expression. */
8201 resolve_where (gfc_code *code, gfc_expr *mask)
8207 cblock = code->block;
8209 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8210 In case of nested WHERE, only the outmost one is stored. */
8211 if (mask == NULL) /* outmost WHERE */
8213 else /* inner WHERE */
8220 /* Check if the mask-expr has a consistent shape with the
8221 outmost WHERE mask-expr. */
8222 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8223 gfc_error ("WHERE mask at %L has inconsistent shape",
8224 &cblock->expr1->where);
8227 /* the assignment statement of a WHERE statement, or the first
8228 statement in where-body-construct of a WHERE construct */
8229 cnext = cblock->next;
8234 /* WHERE assignment statement */
8237 /* Check shape consistent for WHERE assignment target. */
8238 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8239 gfc_error ("WHERE assignment target at %L has "
8240 "inconsistent shape", &cnext->expr1->where);
8244 case EXEC_ASSIGN_CALL:
8245 resolve_call (cnext);
8246 if (!cnext->resolved_sym->attr.elemental)
8247 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8248 &cnext->ext.actual->expr->where);
8251 /* WHERE or WHERE construct is part of a where-body-construct */
8253 resolve_where (cnext, e);
8257 gfc_error ("Unsupported statement inside WHERE at %L",
8260 /* the next statement within the same where-body-construct */
8261 cnext = cnext->next;
8263 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8264 cblock = cblock->block;
8269 /* Resolve assignment in FORALL construct.
8270 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8271 FORALL index variables. */
8274 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8278 for (n = 0; n < nvar; n++)
8280 gfc_symbol *forall_index;
8282 forall_index = var_expr[n]->symtree->n.sym;
8284 /* Check whether the assignment target is one of the FORALL index
8286 if ((code->expr1->expr_type == EXPR_VARIABLE)
8287 && (code->expr1->symtree->n.sym == forall_index))
8288 gfc_error ("Assignment to a FORALL index variable at %L",
8289 &code->expr1->where);
8292 /* If one of the FORALL index variables doesn't appear in the
8293 assignment variable, then there could be a many-to-one
8294 assignment. Emit a warning rather than an error because the
8295 mask could be resolving this problem. */
8296 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8297 gfc_warning ("The FORALL with index '%s' is not used on the "
8298 "left side of the assignment at %L and so might "
8299 "cause multiple assignment to this object",
8300 var_expr[n]->symtree->name, &code->expr1->where);
8306 /* Resolve WHERE statement in FORALL construct. */
8309 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8310 gfc_expr **var_expr)
8315 cblock = code->block;
8318 /* the assignment statement of a WHERE statement, or the first
8319 statement in where-body-construct of a WHERE construct */
8320 cnext = cblock->next;
8325 /* WHERE assignment statement */
8327 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8330 /* WHERE operator assignment statement */
8331 case EXEC_ASSIGN_CALL:
8332 resolve_call (cnext);
8333 if (!cnext->resolved_sym->attr.elemental)
8334 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8335 &cnext->ext.actual->expr->where);
8338 /* WHERE or WHERE construct is part of a where-body-construct */
8340 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8344 gfc_error ("Unsupported statement inside WHERE at %L",
8347 /* the next statement within the same where-body-construct */
8348 cnext = cnext->next;
8350 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8351 cblock = cblock->block;
8356 /* Traverse the FORALL body to check whether the following errors exist:
8357 1. For assignment, check if a many-to-one assignment happens.
8358 2. For WHERE statement, check the WHERE body to see if there is any
8359 many-to-one assignment. */
8362 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8366 c = code->block->next;
8372 case EXEC_POINTER_ASSIGN:
8373 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8376 case EXEC_ASSIGN_CALL:
8380 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8381 there is no need to handle it here. */
8385 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8390 /* The next statement in the FORALL body. */
8396 /* Counts the number of iterators needed inside a forall construct, including
8397 nested forall constructs. This is used to allocate the needed memory
8398 in gfc_resolve_forall. */
8401 gfc_count_forall_iterators (gfc_code *code)
8403 int max_iters, sub_iters, current_iters;
8404 gfc_forall_iterator *fa;
8406 gcc_assert(code->op == EXEC_FORALL);
8410 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8413 code = code->block->next;
8417 if (code->op == EXEC_FORALL)
8419 sub_iters = gfc_count_forall_iterators (code);
8420 if (sub_iters > max_iters)
8421 max_iters = sub_iters;
8426 return current_iters + max_iters;
8430 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8431 gfc_resolve_forall_body to resolve the FORALL body. */
8434 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8436 static gfc_expr **var_expr;
8437 static int total_var = 0;
8438 static int nvar = 0;
8440 gfc_forall_iterator *fa;
8445 /* Start to resolve a FORALL construct */
8446 if (forall_save == 0)
8448 /* Count the total number of FORALL index in the nested FORALL
8449 construct in order to allocate the VAR_EXPR with proper size. */
8450 total_var = gfc_count_forall_iterators (code);
8452 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8453 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8456 /* The information about FORALL iterator, including FORALL index start, end
8457 and stride. The FORALL index can not appear in start, end or stride. */
8458 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8460 /* Check if any outer FORALL index name is the same as the current
8462 for (i = 0; i < nvar; i++)
8464 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8466 gfc_error ("An outer FORALL construct already has an index "
8467 "with this name %L", &fa->var->where);
8471 /* Record the current FORALL index. */
8472 var_expr[nvar] = gfc_copy_expr (fa->var);
8476 /* No memory leak. */
8477 gcc_assert (nvar <= total_var);
8480 /* Resolve the FORALL body. */
8481 gfc_resolve_forall_body (code, nvar, var_expr);
8483 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8484 gfc_resolve_blocks (code->block, ns);
8488 /* Free only the VAR_EXPRs allocated in this frame. */
8489 for (i = nvar; i < tmp; i++)
8490 gfc_free_expr (var_expr[i]);
8494 /* We are in the outermost FORALL construct. */
8495 gcc_assert (forall_save == 0);
8497 /* VAR_EXPR is not needed any more. */
8498 gfc_free (var_expr);
8504 /* Resolve a BLOCK construct statement. */
8507 resolve_block_construct (gfc_code* code)
8509 /* Resolve the BLOCK's namespace. */
8510 gfc_resolve (code->ext.block.ns);
8512 /* For an ASSOCIATE block, the associations (and their targets) are already
8513 resolved during resolve_symbol. */
8517 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8520 static void resolve_code (gfc_code *, gfc_namespace *);
8523 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8527 for (; b; b = b->block)
8529 t = gfc_resolve_expr (b->expr1);
8530 if (gfc_resolve_expr (b->expr2) == FAILURE)
8536 if (t == SUCCESS && b->expr1 != NULL
8537 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8538 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8545 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8546 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8551 resolve_branch (b->label1, b);
8555 resolve_block_construct (b);
8559 case EXEC_SELECT_TYPE:
8570 case EXEC_OMP_ATOMIC:
8571 case EXEC_OMP_CRITICAL:
8573 case EXEC_OMP_MASTER:
8574 case EXEC_OMP_ORDERED:
8575 case EXEC_OMP_PARALLEL:
8576 case EXEC_OMP_PARALLEL_DO:
8577 case EXEC_OMP_PARALLEL_SECTIONS:
8578 case EXEC_OMP_PARALLEL_WORKSHARE:
8579 case EXEC_OMP_SECTIONS:
8580 case EXEC_OMP_SINGLE:
8582 case EXEC_OMP_TASKWAIT:
8583 case EXEC_OMP_WORKSHARE:
8587 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8590 resolve_code (b->next, ns);
8595 /* Does everything to resolve an ordinary assignment. Returns true
8596 if this is an interface assignment. */
8598 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8608 if (gfc_extend_assign (code, ns) == SUCCESS)
8612 if (code->op == EXEC_ASSIGN_CALL)
8614 lhs = code->ext.actual->expr;
8615 rhsptr = &code->ext.actual->next->expr;
8619 gfc_actual_arglist* args;
8620 gfc_typebound_proc* tbp;
8622 gcc_assert (code->op == EXEC_COMPCALL);
8624 args = code->expr1->value.compcall.actual;
8626 rhsptr = &args->next->expr;
8628 tbp = code->expr1->value.compcall.tbp;
8629 gcc_assert (!tbp->is_generic);
8632 /* Make a temporary rhs when there is a default initializer
8633 and rhs is the same symbol as the lhs. */
8634 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8635 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8636 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8637 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8638 *rhsptr = gfc_get_parentheses (*rhsptr);
8647 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8648 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8649 &code->loc) == FAILURE)
8652 /* Handle the case of a BOZ literal on the RHS. */
8653 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8656 if (gfc_option.warn_surprising)
8657 gfc_warning ("BOZ literal at %L is bitwise transferred "
8658 "non-integer symbol '%s'", &code->loc,
8659 lhs->symtree->n.sym->name);
8661 if (!gfc_convert_boz (rhs, &lhs->ts))
8663 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8665 if (rc == ARITH_UNDERFLOW)
8666 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8667 ". This check can be disabled with the option "
8668 "-fno-range-check", &rhs->where);
8669 else if (rc == ARITH_OVERFLOW)
8670 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8671 ". This check can be disabled with the option "
8672 "-fno-range-check", &rhs->where);
8673 else if (rc == ARITH_NAN)
8674 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8675 ". This check can be disabled with the option "
8676 "-fno-range-check", &rhs->where);
8682 if (lhs->ts.type == BT_CHARACTER
8683 && gfc_option.warn_character_truncation)
8685 if (lhs->ts.u.cl != NULL
8686 && lhs->ts.u.cl->length != NULL
8687 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8688 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8690 if (rhs->expr_type == EXPR_CONSTANT)
8691 rlen = rhs->value.character.length;
8693 else if (rhs->ts.u.cl != NULL
8694 && rhs->ts.u.cl->length != NULL
8695 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8696 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8698 if (rlen && llen && rlen > llen)
8699 gfc_warning_now ("CHARACTER expression will be truncated "
8700 "in assignment (%d/%d) at %L",
8701 llen, rlen, &code->loc);
8704 /* Ensure that a vector index expression for the lvalue is evaluated
8705 to a temporary if the lvalue symbol is referenced in it. */
8708 for (ref = lhs->ref; ref; ref= ref->next)
8709 if (ref->type == REF_ARRAY)
8711 for (n = 0; n < ref->u.ar.dimen; n++)
8712 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8713 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8714 ref->u.ar.start[n]))
8716 = gfc_get_parentheses (ref->u.ar.start[n]);
8720 if (gfc_pure (NULL))
8722 if (gfc_impure_variable (lhs->symtree->n.sym))
8724 gfc_error ("Cannot assign to variable '%s' in PURE "
8726 lhs->symtree->n.sym->name,
8731 if (lhs->ts.type == BT_DERIVED
8732 && lhs->expr_type == EXPR_VARIABLE
8733 && lhs->ts.u.derived->attr.pointer_comp
8734 && rhs->expr_type == EXPR_VARIABLE
8735 && (gfc_impure_variable (rhs->symtree->n.sym)
8736 || gfc_is_coindexed (rhs)))
8739 if (gfc_is_coindexed (rhs))
8740 gfc_error ("Coindexed expression at %L is assigned to "
8741 "a derived type variable with a POINTER "
8742 "component in a PURE procedure",
8745 gfc_error ("The impure variable at %L is assigned to "
8746 "a derived type variable with a POINTER "
8747 "component in a PURE procedure (12.6)",
8752 /* Fortran 2008, C1283. */
8753 if (gfc_is_coindexed (lhs))
8755 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8756 "procedure", &rhs->where);
8762 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8763 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8764 if (lhs->ts.type == BT_CLASS)
8766 gfc_error ("Variable must not be polymorphic in assignment at %L",
8771 /* F2008, Section 7.2.1.2. */
8772 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8774 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8775 "component in assignment at %L", &lhs->where);
8779 gfc_check_assign (lhs, rhs, 1);
8784 /* Given a block of code, recursively resolve everything pointed to by this
8788 resolve_code (gfc_code *code, gfc_namespace *ns)
8790 int omp_workshare_save;
8795 frame.prev = cs_base;
8799 find_reachable_labels (code);
8801 for (; code; code = code->next)
8803 frame.current = code;
8804 forall_save = forall_flag;
8806 if (code->op == EXEC_FORALL)
8809 gfc_resolve_forall (code, ns, forall_save);
8812 else if (code->block)
8814 omp_workshare_save = -1;
8817 case EXEC_OMP_PARALLEL_WORKSHARE:
8818 omp_workshare_save = omp_workshare_flag;
8819 omp_workshare_flag = 1;
8820 gfc_resolve_omp_parallel_blocks (code, ns);
8822 case EXEC_OMP_PARALLEL:
8823 case EXEC_OMP_PARALLEL_DO:
8824 case EXEC_OMP_PARALLEL_SECTIONS:
8826 omp_workshare_save = omp_workshare_flag;
8827 omp_workshare_flag = 0;
8828 gfc_resolve_omp_parallel_blocks (code, ns);
8831 gfc_resolve_omp_do_blocks (code, ns);
8833 case EXEC_SELECT_TYPE:
8834 gfc_current_ns = code->ext.block.ns;
8835 gfc_resolve_blocks (code->block, gfc_current_ns);
8836 gfc_current_ns = ns;
8838 case EXEC_OMP_WORKSHARE:
8839 omp_workshare_save = omp_workshare_flag;
8840 omp_workshare_flag = 1;
8843 gfc_resolve_blocks (code->block, ns);
8847 if (omp_workshare_save != -1)
8848 omp_workshare_flag = omp_workshare_save;
8852 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8853 t = gfc_resolve_expr (code->expr1);
8854 forall_flag = forall_save;
8856 if (gfc_resolve_expr (code->expr2) == FAILURE)
8859 if (code->op == EXEC_ALLOCATE
8860 && gfc_resolve_expr (code->expr3) == FAILURE)
8866 case EXEC_END_BLOCK:
8870 case EXEC_ERROR_STOP:
8874 case EXEC_ASSIGN_CALL:
8879 case EXEC_SYNC_IMAGES:
8880 case EXEC_SYNC_MEMORY:
8881 resolve_sync (code);
8885 /* Keep track of which entry we are up to. */
8886 current_entry_id = code->ext.entry->id;
8890 resolve_where (code, NULL);
8894 if (code->expr1 != NULL)
8896 if (code->expr1->ts.type != BT_INTEGER)
8897 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8898 "INTEGER variable", &code->expr1->where);
8899 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8900 gfc_error ("Variable '%s' has not been assigned a target "
8901 "label at %L", code->expr1->symtree->n.sym->name,
8902 &code->expr1->where);
8905 resolve_branch (code->label1, code);
8909 if (code->expr1 != NULL
8910 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8911 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8912 "INTEGER return specifier", &code->expr1->where);
8915 case EXEC_INIT_ASSIGN:
8916 case EXEC_END_PROCEDURE:
8923 if (resolve_ordinary_assign (code, ns))
8925 if (code->op == EXEC_COMPCALL)
8932 case EXEC_LABEL_ASSIGN:
8933 if (code->label1->defined == ST_LABEL_UNKNOWN)
8934 gfc_error ("Label %d referenced at %L is never defined",
8935 code->label1->value, &code->label1->where);
8937 && (code->expr1->expr_type != EXPR_VARIABLE
8938 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8939 || code->expr1->symtree->n.sym->ts.kind
8940 != gfc_default_integer_kind
8941 || code->expr1->symtree->n.sym->as != NULL))
8942 gfc_error ("ASSIGN statement at %L requires a scalar "
8943 "default INTEGER variable", &code->expr1->where);
8946 case EXEC_POINTER_ASSIGN:
8950 gfc_check_pointer_assign (code->expr1, code->expr2);
8953 case EXEC_ARITHMETIC_IF:
8955 && code->expr1->ts.type != BT_INTEGER
8956 && code->expr1->ts.type != BT_REAL)
8957 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8958 "expression", &code->expr1->where);
8960 resolve_branch (code->label1, code);
8961 resolve_branch (code->label2, code);
8962 resolve_branch (code->label3, code);
8966 if (t == SUCCESS && code->expr1 != NULL
8967 && (code->expr1->ts.type != BT_LOGICAL
8968 || code->expr1->rank != 0))
8969 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8970 &code->expr1->where);
8975 resolve_call (code);
8980 resolve_typebound_subroutine (code);
8984 resolve_ppc_call (code);
8988 /* Select is complicated. Also, a SELECT construct could be
8989 a transformed computed GOTO. */
8990 resolve_select (code);
8993 case EXEC_SELECT_TYPE:
8994 resolve_select_type (code);
8998 resolve_block_construct (code);
9002 if (code->ext.iterator != NULL)
9004 gfc_iterator *iter = code->ext.iterator;
9005 if (gfc_resolve_iterator (iter, true) != FAILURE)
9006 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9011 if (code->expr1 == NULL)
9012 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9014 && (code->expr1->rank != 0
9015 || code->expr1->ts.type != BT_LOGICAL))
9016 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9017 "a scalar LOGICAL expression", &code->expr1->where);
9022 resolve_allocate_deallocate (code, "ALLOCATE");
9026 case EXEC_DEALLOCATE:
9028 resolve_allocate_deallocate (code, "DEALLOCATE");
9033 if (gfc_resolve_open (code->ext.open) == FAILURE)
9036 resolve_branch (code->ext.open->err, code);
9040 if (gfc_resolve_close (code->ext.close) == FAILURE)
9043 resolve_branch (code->ext.close->err, code);
9046 case EXEC_BACKSPACE:
9050 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9053 resolve_branch (code->ext.filepos->err, code);
9057 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9060 resolve_branch (code->ext.inquire->err, code);
9064 gcc_assert (code->ext.inquire != NULL);
9065 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9068 resolve_branch (code->ext.inquire->err, code);
9072 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9075 resolve_branch (code->ext.wait->err, code);
9076 resolve_branch (code->ext.wait->end, code);
9077 resolve_branch (code->ext.wait->eor, code);
9082 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9085 resolve_branch (code->ext.dt->err, code);
9086 resolve_branch (code->ext.dt->end, code);
9087 resolve_branch (code->ext.dt->eor, code);
9091 resolve_transfer (code);
9095 resolve_forall_iterators (code->ext.forall_iterator);
9097 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
9098 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
9099 "expression", &code->expr1->where);
9102 case EXEC_OMP_ATOMIC:
9103 case EXEC_OMP_BARRIER:
9104 case EXEC_OMP_CRITICAL:
9105 case EXEC_OMP_FLUSH:
9107 case EXEC_OMP_MASTER:
9108 case EXEC_OMP_ORDERED:
9109 case EXEC_OMP_SECTIONS:
9110 case EXEC_OMP_SINGLE:
9111 case EXEC_OMP_TASKWAIT:
9112 case EXEC_OMP_WORKSHARE:
9113 gfc_resolve_omp_directive (code, ns);
9116 case EXEC_OMP_PARALLEL:
9117 case EXEC_OMP_PARALLEL_DO:
9118 case EXEC_OMP_PARALLEL_SECTIONS:
9119 case EXEC_OMP_PARALLEL_WORKSHARE:
9121 omp_workshare_save = omp_workshare_flag;
9122 omp_workshare_flag = 0;
9123 gfc_resolve_omp_directive (code, ns);
9124 omp_workshare_flag = omp_workshare_save;
9128 gfc_internal_error ("resolve_code(): Bad statement code");
9132 cs_base = frame.prev;
9136 /* Resolve initial values and make sure they are compatible with
9140 resolve_values (gfc_symbol *sym)
9144 if (sym->value == NULL)
9147 if (sym->value->expr_type == EXPR_STRUCTURE)
9148 t= resolve_structure_cons (sym->value, 1);
9150 t = gfc_resolve_expr (sym->value);
9155 gfc_check_assign_symbol (sym, sym->value);
9159 /* Verify the binding labels for common blocks that are BIND(C). The label
9160 for a BIND(C) common block must be identical in all scoping units in which
9161 the common block is declared. Further, the binding label can not collide
9162 with any other global entity in the program. */
9165 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9167 if (comm_block_tree->n.common->is_bind_c == 1)
9169 gfc_gsymbol *binding_label_gsym;
9170 gfc_gsymbol *comm_name_gsym;
9172 /* See if a global symbol exists by the common block's name. It may
9173 be NULL if the common block is use-associated. */
9174 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9175 comm_block_tree->n.common->name);
9176 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9177 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9178 "with the global entity '%s' at %L",
9179 comm_block_tree->n.common->binding_label,
9180 comm_block_tree->n.common->name,
9181 &(comm_block_tree->n.common->where),
9182 comm_name_gsym->name, &(comm_name_gsym->where));
9183 else if (comm_name_gsym != NULL
9184 && strcmp (comm_name_gsym->name,
9185 comm_block_tree->n.common->name) == 0)
9187 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9189 if (comm_name_gsym->binding_label == NULL)
9190 /* No binding label for common block stored yet; save this one. */
9191 comm_name_gsym->binding_label =
9192 comm_block_tree->n.common->binding_label;
9194 if (strcmp (comm_name_gsym->binding_label,
9195 comm_block_tree->n.common->binding_label) != 0)
9197 /* Common block names match but binding labels do not. */
9198 gfc_error ("Binding label '%s' for common block '%s' at %L "
9199 "does not match the binding label '%s' for common "
9201 comm_block_tree->n.common->binding_label,
9202 comm_block_tree->n.common->name,
9203 &(comm_block_tree->n.common->where),
9204 comm_name_gsym->binding_label,
9205 comm_name_gsym->name,
9206 &(comm_name_gsym->where));
9211 /* There is no binding label (NAME="") so we have nothing further to
9212 check and nothing to add as a global symbol for the label. */
9213 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9216 binding_label_gsym =
9217 gfc_find_gsymbol (gfc_gsym_root,
9218 comm_block_tree->n.common->binding_label);
9219 if (binding_label_gsym == NULL)
9221 /* Need to make a global symbol for the binding label to prevent
9222 it from colliding with another. */
9223 binding_label_gsym =
9224 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9225 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9226 binding_label_gsym->type = GSYM_COMMON;
9230 /* If comm_name_gsym is NULL, the name common block is use
9231 associated and the name could be colliding. */
9232 if (binding_label_gsym->type != GSYM_COMMON)
9233 gfc_error ("Binding label '%s' for common block '%s' at %L "
9234 "collides with the global entity '%s' at %L",
9235 comm_block_tree->n.common->binding_label,
9236 comm_block_tree->n.common->name,
9237 &(comm_block_tree->n.common->where),
9238 binding_label_gsym->name,
9239 &(binding_label_gsym->where));
9240 else if (comm_name_gsym != NULL
9241 && (strcmp (binding_label_gsym->name,
9242 comm_name_gsym->binding_label) != 0)
9243 && (strcmp (binding_label_gsym->sym_name,
9244 comm_name_gsym->name) != 0))
9245 gfc_error ("Binding label '%s' for common block '%s' at %L "
9246 "collides with global entity '%s' at %L",
9247 binding_label_gsym->name, binding_label_gsym->sym_name,
9248 &(comm_block_tree->n.common->where),
9249 comm_name_gsym->name, &(comm_name_gsym->where));
9257 /* Verify any BIND(C) derived types in the namespace so we can report errors
9258 for them once, rather than for each variable declared of that type. */
9261 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9263 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9264 && derived_sym->attr.is_bind_c == 1)
9265 verify_bind_c_derived_type (derived_sym);
9271 /* Verify that any binding labels used in a given namespace do not collide
9272 with the names or binding labels of any global symbols. */
9275 gfc_verify_binding_labels (gfc_symbol *sym)
9279 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9280 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9282 gfc_gsymbol *bind_c_sym;
9284 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9285 if (bind_c_sym != NULL
9286 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9288 if (sym->attr.if_source == IFSRC_DECL
9289 && (bind_c_sym->type != GSYM_SUBROUTINE
9290 && bind_c_sym->type != GSYM_FUNCTION)
9291 && ((sym->attr.contained == 1
9292 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9293 || (sym->attr.use_assoc == 1
9294 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9296 /* Make sure global procedures don't collide with anything. */
9297 gfc_error ("Binding label '%s' at %L collides with the global "
9298 "entity '%s' at %L", sym->binding_label,
9299 &(sym->declared_at), bind_c_sym->name,
9300 &(bind_c_sym->where));
9303 else if (sym->attr.contained == 0
9304 && (sym->attr.if_source == IFSRC_IFBODY
9305 && sym->attr.flavor == FL_PROCEDURE)
9306 && (bind_c_sym->sym_name != NULL
9307 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9309 /* Make sure procedures in interface bodies don't collide. */
9310 gfc_error ("Binding label '%s' in interface body at %L collides "
9311 "with the global entity '%s' at %L",
9313 &(sym->declared_at), bind_c_sym->name,
9314 &(bind_c_sym->where));
9317 else if (sym->attr.contained == 0
9318 && sym->attr.if_source == IFSRC_UNKNOWN)
9319 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9320 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9321 || sym->attr.use_assoc == 0)
9323 gfc_error ("Binding label '%s' at %L collides with global "
9324 "entity '%s' at %L", sym->binding_label,
9325 &(sym->declared_at), bind_c_sym->name,
9326 &(bind_c_sym->where));
9331 /* Clear the binding label to prevent checking multiple times. */
9332 sym->binding_label[0] = '\0';
9334 else if (bind_c_sym == NULL)
9336 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9337 bind_c_sym->where = sym->declared_at;
9338 bind_c_sym->sym_name = sym->name;
9340 if (sym->attr.use_assoc == 1)
9341 bind_c_sym->mod_name = sym->module;
9343 if (sym->ns->proc_name != NULL)
9344 bind_c_sym->mod_name = sym->ns->proc_name->name;
9346 if (sym->attr.contained == 0)
9348 if (sym->attr.subroutine)
9349 bind_c_sym->type = GSYM_SUBROUTINE;
9350 else if (sym->attr.function)
9351 bind_c_sym->type = GSYM_FUNCTION;
9359 /* Resolve an index expression. */
9362 resolve_index_expr (gfc_expr *e)
9364 if (gfc_resolve_expr (e) == FAILURE)
9367 if (gfc_simplify_expr (e, 0) == FAILURE)
9370 if (gfc_specification_expr (e) == FAILURE)
9376 /* Resolve a charlen structure. */
9379 resolve_charlen (gfc_charlen *cl)
9388 specification_expr = 1;
9390 if (resolve_index_expr (cl->length) == FAILURE)
9392 specification_expr = 0;
9396 /* "If the character length parameter value evaluates to a negative
9397 value, the length of character entities declared is zero." */
9398 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9400 if (gfc_option.warn_surprising)
9401 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9402 " the length has been set to zero",
9403 &cl->length->where, i);
9404 gfc_replace_expr (cl->length,
9405 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9408 /* Check that the character length is not too large. */
9409 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9410 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9411 && cl->length->ts.type == BT_INTEGER
9412 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9414 gfc_error ("String length at %L is too large", &cl->length->where);
9422 /* Test for non-constant shape arrays. */
9425 is_non_constant_shape_array (gfc_symbol *sym)
9431 not_constant = false;
9432 if (sym->as != NULL)
9434 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9435 has not been simplified; parameter array references. Do the
9436 simplification now. */
9437 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9439 e = sym->as->lower[i];
9440 if (e && (resolve_index_expr (e) == FAILURE
9441 || !gfc_is_constant_expr (e)))
9442 not_constant = true;
9443 e = sym->as->upper[i];
9444 if (e && (resolve_index_expr (e) == FAILURE
9445 || !gfc_is_constant_expr (e)))
9446 not_constant = true;
9449 return not_constant;
9452 /* Given a symbol and an initialization expression, add code to initialize
9453 the symbol to the function entry. */
9455 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9459 gfc_namespace *ns = sym->ns;
9461 /* Search for the function namespace if this is a contained
9462 function without an explicit result. */
9463 if (sym->attr.function && sym == sym->result
9464 && sym->name != sym->ns->proc_name->name)
9467 for (;ns; ns = ns->sibling)
9468 if (strcmp (ns->proc_name->name, sym->name) == 0)
9474 gfc_free_expr (init);
9478 /* Build an l-value expression for the result. */
9479 lval = gfc_lval_expr_from_sym (sym);
9481 /* Add the code at scope entry. */
9482 init_st = gfc_get_code ();
9483 init_st->next = ns->code;
9486 /* Assign the default initializer to the l-value. */
9487 init_st->loc = sym->declared_at;
9488 init_st->op = EXEC_INIT_ASSIGN;
9489 init_st->expr1 = lval;
9490 init_st->expr2 = init;
9493 /* Assign the default initializer to a derived type variable or result. */
9496 apply_default_init (gfc_symbol *sym)
9498 gfc_expr *init = NULL;
9500 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9503 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9504 init = gfc_default_initializer (&sym->ts);
9509 build_init_assign (sym, init);
9512 /* Build an initializer for a local integer, real, complex, logical, or
9513 character variable, based on the command line flags finit-local-zero,
9514 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9515 null if the symbol should not have a default initialization. */
9517 build_default_init_expr (gfc_symbol *sym)
9520 gfc_expr *init_expr;
9523 /* These symbols should never have a default initialization. */
9524 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9525 || sym->attr.external
9527 || sym->attr.pointer
9528 || sym->attr.in_equivalence
9529 || sym->attr.in_common
9532 || sym->attr.cray_pointee
9533 || sym->attr.cray_pointer)
9536 /* Now we'll try to build an initializer expression. */
9537 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9540 /* We will only initialize integers, reals, complex, logicals, and
9541 characters, and only if the corresponding command-line flags
9542 were set. Otherwise, we free init_expr and return null. */
9543 switch (sym->ts.type)
9546 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9547 mpz_set_si (init_expr->value.integer,
9548 gfc_option.flag_init_integer_value);
9551 gfc_free_expr (init_expr);
9557 switch (gfc_option.flag_init_real)
9559 case GFC_INIT_REAL_SNAN:
9560 init_expr->is_snan = 1;
9562 case GFC_INIT_REAL_NAN:
9563 mpfr_set_nan (init_expr->value.real);
9566 case GFC_INIT_REAL_INF:
9567 mpfr_set_inf (init_expr->value.real, 1);
9570 case GFC_INIT_REAL_NEG_INF:
9571 mpfr_set_inf (init_expr->value.real, -1);
9574 case GFC_INIT_REAL_ZERO:
9575 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9579 gfc_free_expr (init_expr);
9586 switch (gfc_option.flag_init_real)
9588 case GFC_INIT_REAL_SNAN:
9589 init_expr->is_snan = 1;
9591 case GFC_INIT_REAL_NAN:
9592 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9593 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9596 case GFC_INIT_REAL_INF:
9597 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9598 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9601 case GFC_INIT_REAL_NEG_INF:
9602 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9603 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9606 case GFC_INIT_REAL_ZERO:
9607 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9611 gfc_free_expr (init_expr);
9618 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9619 init_expr->value.logical = 0;
9620 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9621 init_expr->value.logical = 1;
9624 gfc_free_expr (init_expr);
9630 /* For characters, the length must be constant in order to
9631 create a default initializer. */
9632 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9633 && sym->ts.u.cl->length
9634 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9636 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9637 init_expr->value.character.length = char_len;
9638 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9639 for (i = 0; i < char_len; i++)
9640 init_expr->value.character.string[i]
9641 = (unsigned char) gfc_option.flag_init_character_value;
9645 gfc_free_expr (init_expr);
9651 gfc_free_expr (init_expr);
9657 /* Add an initialization expression to a local variable. */
9659 apply_default_init_local (gfc_symbol *sym)
9661 gfc_expr *init = NULL;
9663 /* The symbol should be a variable or a function return value. */
9664 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9665 || (sym->attr.function && sym->result != sym))
9668 /* Try to build the initializer expression. If we can't initialize
9669 this symbol, then init will be NULL. */
9670 init = build_default_init_expr (sym);
9674 /* For saved variables, we don't want to add an initializer at
9675 function entry, so we just add a static initializer. */
9676 if (sym->attr.save || sym->ns->save_all
9677 || gfc_option.flag_max_stack_var_size == 0)
9679 /* Don't clobber an existing initializer! */
9680 gcc_assert (sym->value == NULL);
9685 build_init_assign (sym, init);
9688 /* Resolution of common features of flavors variable and procedure. */
9691 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9693 /* Constraints on deferred shape variable. */
9694 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9696 if (sym->attr.allocatable)
9698 if (sym->attr.dimension)
9700 gfc_error ("Allocatable array '%s' at %L must have "
9701 "a deferred shape", sym->name, &sym->declared_at);
9704 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9705 "may not be ALLOCATABLE", sym->name,
9706 &sym->declared_at) == FAILURE)
9710 if (sym->attr.pointer && sym->attr.dimension)
9712 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9713 sym->name, &sym->declared_at);
9719 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9720 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9722 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9723 sym->name, &sym->declared_at);
9728 /* Constraints on polymorphic variables. */
9729 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9732 if (sym->attr.class_ok
9733 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9735 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9736 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9742 /* Assume that use associated symbols were checked in the module ns.
9743 Class-variables that are associate-names are also something special
9744 and excepted from the test. */
9745 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9747 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9748 "or pointer", sym->name, &sym->declared_at);
9757 /* Additional checks for symbols with flavor variable and derived
9758 type. To be called from resolve_fl_variable. */
9761 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9763 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9765 /* Check to see if a derived type is blocked from being host
9766 associated by the presence of another class I symbol in the same
9767 namespace. 14.6.1.3 of the standard and the discussion on
9768 comp.lang.fortran. */
9769 if (sym->ns != sym->ts.u.derived->ns
9770 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9773 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9774 if (s && s->attr.flavor != FL_DERIVED)
9776 gfc_error ("The type '%s' cannot be host associated at %L "
9777 "because it is blocked by an incompatible object "
9778 "of the same name declared at %L",
9779 sym->ts.u.derived->name, &sym->declared_at,
9785 /* 4th constraint in section 11.3: "If an object of a type for which
9786 component-initialization is specified (R429) appears in the
9787 specification-part of a module and does not have the ALLOCATABLE
9788 or POINTER attribute, the object shall have the SAVE attribute."
9790 The check for initializers is performed with
9791 gfc_has_default_initializer because gfc_default_initializer generates
9792 a hidden default for allocatable components. */
9793 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9794 && sym->ns->proc_name->attr.flavor == FL_MODULE
9795 && !sym->ns->save_all && !sym->attr.save
9796 && !sym->attr.pointer && !sym->attr.allocatable
9797 && gfc_has_default_initializer (sym->ts.u.derived)
9798 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9799 "module variable '%s' at %L, needed due to "
9800 "the default initialization", sym->name,
9801 &sym->declared_at) == FAILURE)
9804 /* Assign default initializer. */
9805 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9806 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9808 sym->value = gfc_default_initializer (&sym->ts);
9815 /* Resolve symbols with flavor variable. */
9818 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9820 int no_init_flag, automatic_flag;
9822 const char *auto_save_msg;
9824 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9827 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9830 /* Set this flag to check that variables are parameters of all entries.
9831 This check is effected by the call to gfc_resolve_expr through
9832 is_non_constant_shape_array. */
9833 specification_expr = 1;
9835 if (sym->ns->proc_name
9836 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9837 || sym->ns->proc_name->attr.is_main_program)
9838 && !sym->attr.use_assoc
9839 && !sym->attr.allocatable
9840 && !sym->attr.pointer
9841 && is_non_constant_shape_array (sym))
9843 /* The shape of a main program or module array needs to be
9845 gfc_error ("The module or main program array '%s' at %L must "
9846 "have constant shape", sym->name, &sym->declared_at);
9847 specification_expr = 0;
9851 if (sym->ts.type == BT_CHARACTER)
9853 /* Make sure that character string variables with assumed length are
9855 e = sym->ts.u.cl->length;
9856 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
9858 gfc_error ("Entity with assumed character length at %L must be a "
9859 "dummy argument or a PARAMETER", &sym->declared_at);
9863 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9865 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9869 if (!gfc_is_constant_expr (e)
9870 && !(e->expr_type == EXPR_VARIABLE
9871 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9872 && sym->ns->proc_name
9873 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9874 || sym->ns->proc_name->attr.is_main_program)
9875 && !sym->attr.use_assoc)
9877 gfc_error ("'%s' at %L must have constant character length "
9878 "in this context", sym->name, &sym->declared_at);
9883 if (sym->value == NULL && sym->attr.referenced)
9884 apply_default_init_local (sym); /* Try to apply a default initialization. */
9886 /* Determine if the symbol may not have an initializer. */
9887 no_init_flag = automatic_flag = 0;
9888 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9889 || sym->attr.intrinsic || sym->attr.result)
9891 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9892 && is_non_constant_shape_array (sym))
9894 no_init_flag = automatic_flag = 1;
9896 /* Also, they must not have the SAVE attribute.
9897 SAVE_IMPLICIT is checked below. */
9898 if (sym->attr.save == SAVE_EXPLICIT)
9900 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9905 /* Ensure that any initializer is simplified. */
9907 gfc_simplify_expr (sym->value, 1);
9909 /* Reject illegal initializers. */
9910 if (!sym->mark && sym->value)
9912 if (sym->attr.allocatable)
9913 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9914 sym->name, &sym->declared_at);
9915 else if (sym->attr.external)
9916 gfc_error ("External '%s' at %L cannot have an initializer",
9917 sym->name, &sym->declared_at);
9918 else if (sym->attr.dummy
9919 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9920 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9921 sym->name, &sym->declared_at);
9922 else if (sym->attr.intrinsic)
9923 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9924 sym->name, &sym->declared_at);
9925 else if (sym->attr.result)
9926 gfc_error ("Function result '%s' at %L cannot have an initializer",
9927 sym->name, &sym->declared_at);
9928 else if (automatic_flag)
9929 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9930 sym->name, &sym->declared_at);
9937 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9938 return resolve_fl_variable_derived (sym, no_init_flag);
9944 /* Resolve a procedure. */
9947 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9949 gfc_formal_arglist *arg;
9951 if (sym->attr.function
9952 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9955 if (sym->ts.type == BT_CHARACTER)
9957 gfc_charlen *cl = sym->ts.u.cl;
9959 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9960 && resolve_charlen (cl) == FAILURE)
9963 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9964 && sym->attr.proc == PROC_ST_FUNCTION)
9966 gfc_error ("Character-valued statement function '%s' at %L must "
9967 "have constant length", sym->name, &sym->declared_at);
9972 /* Ensure that derived type for are not of a private type. Internal
9973 module procedures are excluded by 2.2.3.3 - i.e., they are not
9974 externally accessible and can access all the objects accessible in
9976 if (!(sym->ns->parent
9977 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9978 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9980 gfc_interface *iface;
9982 for (arg = sym->formal; arg; arg = arg->next)
9985 && arg->sym->ts.type == BT_DERIVED
9986 && !arg->sym->ts.u.derived->attr.use_assoc
9987 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9988 arg->sym->ts.u.derived->ns->default_access)
9989 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9990 "PRIVATE type and cannot be a dummy argument"
9991 " of '%s', which is PUBLIC at %L",
9992 arg->sym->name, sym->name, &sym->declared_at)
9995 /* Stop this message from recurring. */
9996 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10001 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10002 PRIVATE to the containing module. */
10003 for (iface = sym->generic; iface; iface = iface->next)
10005 for (arg = iface->sym->formal; arg; arg = arg->next)
10008 && arg->sym->ts.type == BT_DERIVED
10009 && !arg->sym->ts.u.derived->attr.use_assoc
10010 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10011 arg->sym->ts.u.derived->ns->default_access)
10012 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10013 "'%s' in PUBLIC interface '%s' at %L "
10014 "takes dummy arguments of '%s' which is "
10015 "PRIVATE", iface->sym->name, sym->name,
10016 &iface->sym->declared_at,
10017 gfc_typename (&arg->sym->ts)) == FAILURE)
10019 /* Stop this message from recurring. */
10020 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10026 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10027 PRIVATE to the containing module. */
10028 for (iface = sym->generic; iface; iface = iface->next)
10030 for (arg = iface->sym->formal; arg; arg = arg->next)
10033 && arg->sym->ts.type == BT_DERIVED
10034 && !arg->sym->ts.u.derived->attr.use_assoc
10035 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10036 arg->sym->ts.u.derived->ns->default_access)
10037 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10038 "'%s' in PUBLIC interface '%s' at %L "
10039 "takes dummy arguments of '%s' which is "
10040 "PRIVATE", iface->sym->name, sym->name,
10041 &iface->sym->declared_at,
10042 gfc_typename (&arg->sym->ts)) == FAILURE)
10044 /* Stop this message from recurring. */
10045 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10052 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10053 && !sym->attr.proc_pointer)
10055 gfc_error ("Function '%s' at %L cannot have an initializer",
10056 sym->name, &sym->declared_at);
10060 /* An external symbol may not have an initializer because it is taken to be
10061 a procedure. Exception: Procedure Pointers. */
10062 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10064 gfc_error ("External object '%s' at %L may not have an initializer",
10065 sym->name, &sym->declared_at);
10069 /* An elemental function is required to return a scalar 12.7.1 */
10070 if (sym->attr.elemental && sym->attr.function && sym->as)
10072 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10073 "result", sym->name, &sym->declared_at);
10074 /* Reset so that the error only occurs once. */
10075 sym->attr.elemental = 0;
10079 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10080 char-len-param shall not be array-valued, pointer-valued, recursive
10081 or pure. ....snip... A character value of * may only be used in the
10082 following ways: (i) Dummy arg of procedure - dummy associates with
10083 actual length; (ii) To declare a named constant; or (iii) External
10084 function - but length must be declared in calling scoping unit. */
10085 if (sym->attr.function
10086 && sym->ts.type == BT_CHARACTER
10087 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10089 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10090 || (sym->attr.recursive) || (sym->attr.pure))
10092 if (sym->as && sym->as->rank)
10093 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10094 "array-valued", sym->name, &sym->declared_at);
10096 if (sym->attr.pointer)
10097 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10098 "pointer-valued", sym->name, &sym->declared_at);
10100 if (sym->attr.pure)
10101 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10102 "pure", sym->name, &sym->declared_at);
10104 if (sym->attr.recursive)
10105 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10106 "recursive", sym->name, &sym->declared_at);
10111 /* Appendix B.2 of the standard. Contained functions give an
10112 error anyway. Fixed-form is likely to be F77/legacy. */
10113 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10114 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10115 "CHARACTER(*) function '%s' at %L",
10116 sym->name, &sym->declared_at);
10119 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10121 gfc_formal_arglist *curr_arg;
10122 int has_non_interop_arg = 0;
10124 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10125 sym->common_block) == FAILURE)
10127 /* Clear these to prevent looking at them again if there was an
10129 sym->attr.is_bind_c = 0;
10130 sym->attr.is_c_interop = 0;
10131 sym->ts.is_c_interop = 0;
10135 /* So far, no errors have been found. */
10136 sym->attr.is_c_interop = 1;
10137 sym->ts.is_c_interop = 1;
10140 curr_arg = sym->formal;
10141 while (curr_arg != NULL)
10143 /* Skip implicitly typed dummy args here. */
10144 if (curr_arg->sym->attr.implicit_type == 0)
10145 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10146 /* If something is found to fail, record the fact so we
10147 can mark the symbol for the procedure as not being
10148 BIND(C) to try and prevent multiple errors being
10150 has_non_interop_arg = 1;
10152 curr_arg = curr_arg->next;
10155 /* See if any of the arguments were not interoperable and if so, clear
10156 the procedure symbol to prevent duplicate error messages. */
10157 if (has_non_interop_arg != 0)
10159 sym->attr.is_c_interop = 0;
10160 sym->ts.is_c_interop = 0;
10161 sym->attr.is_bind_c = 0;
10165 if (!sym->attr.proc_pointer)
10167 if (sym->attr.save == SAVE_EXPLICIT)
10169 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10170 "in '%s' at %L", sym->name, &sym->declared_at);
10173 if (sym->attr.intent)
10175 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10176 "in '%s' at %L", sym->name, &sym->declared_at);
10179 if (sym->attr.subroutine && sym->attr.result)
10181 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10182 "in '%s' at %L", sym->name, &sym->declared_at);
10185 if (sym->attr.external && sym->attr.function
10186 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10187 || sym->attr.contained))
10189 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10190 "in '%s' at %L", sym->name, &sym->declared_at);
10193 if (strcmp ("ppr@", sym->name) == 0)
10195 gfc_error ("Procedure pointer result '%s' at %L "
10196 "is missing the pointer attribute",
10197 sym->ns->proc_name->name, &sym->declared_at);
10206 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10207 been defined and we now know their defined arguments, check that they fulfill
10208 the requirements of the standard for procedures used as finalizers. */
10211 gfc_resolve_finalizers (gfc_symbol* derived)
10213 gfc_finalizer* list;
10214 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10215 gfc_try result = SUCCESS;
10216 bool seen_scalar = false;
10218 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10221 /* Walk over the list of finalizer-procedures, check them, and if any one
10222 does not fit in with the standard's definition, print an error and remove
10223 it from the list. */
10224 prev_link = &derived->f2k_derived->finalizers;
10225 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10231 /* Skip this finalizer if we already resolved it. */
10232 if (list->proc_tree)
10234 prev_link = &(list->next);
10238 /* Check this exists and is a SUBROUTINE. */
10239 if (!list->proc_sym->attr.subroutine)
10241 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10242 list->proc_sym->name, &list->where);
10246 /* We should have exactly one argument. */
10247 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10249 gfc_error ("FINAL procedure at %L must have exactly one argument",
10253 arg = list->proc_sym->formal->sym;
10255 /* This argument must be of our type. */
10256 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10258 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10259 &arg->declared_at, derived->name);
10263 /* It must neither be a pointer nor allocatable nor optional. */
10264 if (arg->attr.pointer)
10266 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10267 &arg->declared_at);
10270 if (arg->attr.allocatable)
10272 gfc_error ("Argument of FINAL procedure at %L must not be"
10273 " ALLOCATABLE", &arg->declared_at);
10276 if (arg->attr.optional)
10278 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10279 &arg->declared_at);
10283 /* It must not be INTENT(OUT). */
10284 if (arg->attr.intent == INTENT_OUT)
10286 gfc_error ("Argument of FINAL procedure at %L must not be"
10287 " INTENT(OUT)", &arg->declared_at);
10291 /* Warn if the procedure is non-scalar and not assumed shape. */
10292 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10293 && arg->as->type != AS_ASSUMED_SHAPE)
10294 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10295 " shape argument", &arg->declared_at);
10297 /* Check that it does not match in kind and rank with a FINAL procedure
10298 defined earlier. To really loop over the *earlier* declarations,
10299 we need to walk the tail of the list as new ones were pushed at the
10301 /* TODO: Handle kind parameters once they are implemented. */
10302 my_rank = (arg->as ? arg->as->rank : 0);
10303 for (i = list->next; i; i = i->next)
10305 /* Argument list might be empty; that is an error signalled earlier,
10306 but we nevertheless continued resolving. */
10307 if (i->proc_sym->formal)
10309 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10310 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10311 if (i_rank == my_rank)
10313 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10314 " rank (%d) as '%s'",
10315 list->proc_sym->name, &list->where, my_rank,
10316 i->proc_sym->name);
10322 /* Is this the/a scalar finalizer procedure? */
10323 if (!arg->as || arg->as->rank == 0)
10324 seen_scalar = true;
10326 /* Find the symtree for this procedure. */
10327 gcc_assert (!list->proc_tree);
10328 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10330 prev_link = &list->next;
10333 /* Remove wrong nodes immediately from the list so we don't risk any
10334 troubles in the future when they might fail later expectations. */
10338 *prev_link = list->next;
10339 gfc_free_finalizer (i);
10342 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10343 were nodes in the list, must have been for arrays. It is surely a good
10344 idea to have a scalar version there if there's something to finalize. */
10345 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10346 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10347 " defined at %L, suggest also scalar one",
10348 derived->name, &derived->declared_at);
10350 /* TODO: Remove this error when finalization is finished. */
10351 gfc_error ("Finalization at %L is not yet implemented",
10352 &derived->declared_at);
10358 /* Check that it is ok for the typebound procedure proc to override the
10362 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10365 const gfc_symbol* proc_target;
10366 const gfc_symbol* old_target;
10367 unsigned proc_pass_arg, old_pass_arg, argpos;
10368 gfc_formal_arglist* proc_formal;
10369 gfc_formal_arglist* old_formal;
10371 /* This procedure should only be called for non-GENERIC proc. */
10372 gcc_assert (!proc->n.tb->is_generic);
10374 /* If the overwritten procedure is GENERIC, this is an error. */
10375 if (old->n.tb->is_generic)
10377 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10378 old->name, &proc->n.tb->where);
10382 where = proc->n.tb->where;
10383 proc_target = proc->n.tb->u.specific->n.sym;
10384 old_target = old->n.tb->u.specific->n.sym;
10386 /* Check that overridden binding is not NON_OVERRIDABLE. */
10387 if (old->n.tb->non_overridable)
10389 gfc_error ("'%s' at %L overrides a procedure binding declared"
10390 " NON_OVERRIDABLE", proc->name, &where);
10394 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10395 if (!old->n.tb->deferred && proc->n.tb->deferred)
10397 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10398 " non-DEFERRED binding", proc->name, &where);
10402 /* If the overridden binding is PURE, the overriding must be, too. */
10403 if (old_target->attr.pure && !proc_target->attr.pure)
10405 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10406 proc->name, &where);
10410 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10411 is not, the overriding must not be either. */
10412 if (old_target->attr.elemental && !proc_target->attr.elemental)
10414 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10415 " ELEMENTAL", proc->name, &where);
10418 if (!old_target->attr.elemental && proc_target->attr.elemental)
10420 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10421 " be ELEMENTAL, either", proc->name, &where);
10425 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10427 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10429 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10430 " SUBROUTINE", proc->name, &where);
10434 /* If the overridden binding is a FUNCTION, the overriding must also be a
10435 FUNCTION and have the same characteristics. */
10436 if (old_target->attr.function)
10438 if (!proc_target->attr.function)
10440 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10441 " FUNCTION", proc->name, &where);
10445 /* FIXME: Do more comprehensive checking (including, for instance, the
10446 rank and array-shape). */
10447 gcc_assert (proc_target->result && old_target->result);
10448 if (!gfc_compare_types (&proc_target->result->ts,
10449 &old_target->result->ts))
10451 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10452 " matching result types", proc->name, &where);
10457 /* If the overridden binding is PUBLIC, the overriding one must not be
10459 if (old->n.tb->access == ACCESS_PUBLIC
10460 && proc->n.tb->access == ACCESS_PRIVATE)
10462 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10463 " PRIVATE", proc->name, &where);
10467 /* Compare the formal argument lists of both procedures. This is also abused
10468 to find the position of the passed-object dummy arguments of both
10469 bindings as at least the overridden one might not yet be resolved and we
10470 need those positions in the check below. */
10471 proc_pass_arg = old_pass_arg = 0;
10472 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10474 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10477 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10478 proc_formal && old_formal;
10479 proc_formal = proc_formal->next, old_formal = old_formal->next)
10481 if (proc->n.tb->pass_arg
10482 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10483 proc_pass_arg = argpos;
10484 if (old->n.tb->pass_arg
10485 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10486 old_pass_arg = argpos;
10488 /* Check that the names correspond. */
10489 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10491 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10492 " to match the corresponding argument of the overridden"
10493 " procedure", proc_formal->sym->name, proc->name, &where,
10494 old_formal->sym->name);
10498 /* Check that the types correspond if neither is the passed-object
10500 /* FIXME: Do more comprehensive testing here. */
10501 if (proc_pass_arg != argpos && old_pass_arg != argpos
10502 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10504 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10505 "in respect to the overridden procedure",
10506 proc_formal->sym->name, proc->name, &where);
10512 if (proc_formal || old_formal)
10514 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10515 " the overridden procedure", proc->name, &where);
10519 /* If the overridden binding is NOPASS, the overriding one must also be
10521 if (old->n.tb->nopass && !proc->n.tb->nopass)
10523 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10524 " NOPASS", proc->name, &where);
10528 /* If the overridden binding is PASS(x), the overriding one must also be
10529 PASS and the passed-object dummy arguments must correspond. */
10530 if (!old->n.tb->nopass)
10532 if (proc->n.tb->nopass)
10534 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10535 " PASS", proc->name, &where);
10539 if (proc_pass_arg != old_pass_arg)
10541 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10542 " the same position as the passed-object dummy argument of"
10543 " the overridden procedure", proc->name, &where);
10552 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10555 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10556 const char* generic_name, locus where)
10561 gcc_assert (t1->specific && t2->specific);
10562 gcc_assert (!t1->specific->is_generic);
10563 gcc_assert (!t2->specific->is_generic);
10565 sym1 = t1->specific->u.specific->n.sym;
10566 sym2 = t2->specific->u.specific->n.sym;
10571 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10572 if (sym1->attr.subroutine != sym2->attr.subroutine
10573 || sym1->attr.function != sym2->attr.function)
10575 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10576 " GENERIC '%s' at %L",
10577 sym1->name, sym2->name, generic_name, &where);
10581 /* Compare the interfaces. */
10582 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10584 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10585 sym1->name, sym2->name, generic_name, &where);
10593 /* Worker function for resolving a generic procedure binding; this is used to
10594 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10596 The difference between those cases is finding possible inherited bindings
10597 that are overridden, as one has to look for them in tb_sym_root,
10598 tb_uop_root or tb_op, respectively. Thus the caller must already find
10599 the super-type and set p->overridden correctly. */
10602 resolve_tb_generic_targets (gfc_symbol* super_type,
10603 gfc_typebound_proc* p, const char* name)
10605 gfc_tbp_generic* target;
10606 gfc_symtree* first_target;
10607 gfc_symtree* inherited;
10609 gcc_assert (p && p->is_generic);
10611 /* Try to find the specific bindings for the symtrees in our target-list. */
10612 gcc_assert (p->u.generic);
10613 for (target = p->u.generic; target; target = target->next)
10614 if (!target->specific)
10616 gfc_typebound_proc* overridden_tbp;
10617 gfc_tbp_generic* g;
10618 const char* target_name;
10620 target_name = target->specific_st->name;
10622 /* Defined for this type directly. */
10623 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10625 target->specific = target->specific_st->n.tb;
10626 goto specific_found;
10629 /* Look for an inherited specific binding. */
10632 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10637 gcc_assert (inherited->n.tb);
10638 target->specific = inherited->n.tb;
10639 goto specific_found;
10643 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10644 " at %L", target_name, name, &p->where);
10647 /* Once we've found the specific binding, check it is not ambiguous with
10648 other specifics already found or inherited for the same GENERIC. */
10650 gcc_assert (target->specific);
10652 /* This must really be a specific binding! */
10653 if (target->specific->is_generic)
10655 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10656 " '%s' is GENERIC, too", name, &p->where, target_name);
10660 /* Check those already resolved on this type directly. */
10661 for (g = p->u.generic; g; g = g->next)
10662 if (g != target && g->specific
10663 && check_generic_tbp_ambiguity (target, g, name, p->where)
10667 /* Check for ambiguity with inherited specific targets. */
10668 for (overridden_tbp = p->overridden; overridden_tbp;
10669 overridden_tbp = overridden_tbp->overridden)
10670 if (overridden_tbp->is_generic)
10672 for (g = overridden_tbp->u.generic; g; g = g->next)
10674 gcc_assert (g->specific);
10675 if (check_generic_tbp_ambiguity (target, g,
10676 name, p->where) == FAILURE)
10682 /* If we attempt to "overwrite" a specific binding, this is an error. */
10683 if (p->overridden && !p->overridden->is_generic)
10685 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10686 " the same name", name, &p->where);
10690 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10691 all must have the same attributes here. */
10692 first_target = p->u.generic->specific->u.specific;
10693 gcc_assert (first_target);
10694 p->subroutine = first_target->n.sym->attr.subroutine;
10695 p->function = first_target->n.sym->attr.function;
10701 /* Resolve a GENERIC procedure binding for a derived type. */
10704 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10706 gfc_symbol* super_type;
10708 /* Find the overridden binding if any. */
10709 st->n.tb->overridden = NULL;
10710 super_type = gfc_get_derived_super_type (derived);
10713 gfc_symtree* overridden;
10714 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10717 if (overridden && overridden->n.tb)
10718 st->n.tb->overridden = overridden->n.tb;
10721 /* Resolve using worker function. */
10722 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10726 /* Retrieve the target-procedure of an operator binding and do some checks in
10727 common for intrinsic and user-defined type-bound operators. */
10730 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10732 gfc_symbol* target_proc;
10734 gcc_assert (target->specific && !target->specific->is_generic);
10735 target_proc = target->specific->u.specific->n.sym;
10736 gcc_assert (target_proc);
10738 /* All operator bindings must have a passed-object dummy argument. */
10739 if (target->specific->nopass)
10741 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10745 return target_proc;
10749 /* Resolve a type-bound intrinsic operator. */
10752 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10753 gfc_typebound_proc* p)
10755 gfc_symbol* super_type;
10756 gfc_tbp_generic* target;
10758 /* If there's already an error here, do nothing (but don't fail again). */
10762 /* Operators should always be GENERIC bindings. */
10763 gcc_assert (p->is_generic);
10765 /* Look for an overridden binding. */
10766 super_type = gfc_get_derived_super_type (derived);
10767 if (super_type && super_type->f2k_derived)
10768 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10771 p->overridden = NULL;
10773 /* Resolve general GENERIC properties using worker function. */
10774 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10777 /* Check the targets to be procedures of correct interface. */
10778 for (target = p->u.generic; target; target = target->next)
10780 gfc_symbol* target_proc;
10782 target_proc = get_checked_tb_operator_target (target, p->where);
10786 if (!gfc_check_operator_interface (target_proc, op, p->where))
10798 /* Resolve a type-bound user operator (tree-walker callback). */
10800 static gfc_symbol* resolve_bindings_derived;
10801 static gfc_try resolve_bindings_result;
10803 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10806 resolve_typebound_user_op (gfc_symtree* stree)
10808 gfc_symbol* super_type;
10809 gfc_tbp_generic* target;
10811 gcc_assert (stree && stree->n.tb);
10813 if (stree->n.tb->error)
10816 /* Operators should always be GENERIC bindings. */
10817 gcc_assert (stree->n.tb->is_generic);
10819 /* Find overridden procedure, if any. */
10820 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10821 if (super_type && super_type->f2k_derived)
10823 gfc_symtree* overridden;
10824 overridden = gfc_find_typebound_user_op (super_type, NULL,
10825 stree->name, true, NULL);
10827 if (overridden && overridden->n.tb)
10828 stree->n.tb->overridden = overridden->n.tb;
10831 stree->n.tb->overridden = NULL;
10833 /* Resolve basically using worker function. */
10834 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10838 /* Check the targets to be functions of correct interface. */
10839 for (target = stree->n.tb->u.generic; target; target = target->next)
10841 gfc_symbol* target_proc;
10843 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10847 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10854 resolve_bindings_result = FAILURE;
10855 stree->n.tb->error = 1;
10859 /* Resolve the type-bound procedures for a derived type. */
10862 resolve_typebound_procedure (gfc_symtree* stree)
10866 gfc_symbol* me_arg;
10867 gfc_symbol* super_type;
10868 gfc_component* comp;
10870 gcc_assert (stree);
10872 /* Undefined specific symbol from GENERIC target definition. */
10876 if (stree->n.tb->error)
10879 /* If this is a GENERIC binding, use that routine. */
10880 if (stree->n.tb->is_generic)
10882 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10888 /* Get the target-procedure to check it. */
10889 gcc_assert (!stree->n.tb->is_generic);
10890 gcc_assert (stree->n.tb->u.specific);
10891 proc = stree->n.tb->u.specific->n.sym;
10892 where = stree->n.tb->where;
10894 /* Default access should already be resolved from the parser. */
10895 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10897 /* It should be a module procedure or an external procedure with explicit
10898 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10899 if ((!proc->attr.subroutine && !proc->attr.function)
10900 || (proc->attr.proc != PROC_MODULE
10901 && proc->attr.if_source != IFSRC_IFBODY)
10902 || (proc->attr.abstract && !stree->n.tb->deferred))
10904 gfc_error ("'%s' must be a module procedure or an external procedure with"
10905 " an explicit interface at %L", proc->name, &where);
10908 stree->n.tb->subroutine = proc->attr.subroutine;
10909 stree->n.tb->function = proc->attr.function;
10911 /* Find the super-type of the current derived type. We could do this once and
10912 store in a global if speed is needed, but as long as not I believe this is
10913 more readable and clearer. */
10914 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10916 /* If PASS, resolve and check arguments if not already resolved / loaded
10917 from a .mod file. */
10918 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10920 if (stree->n.tb->pass_arg)
10922 gfc_formal_arglist* i;
10924 /* If an explicit passing argument name is given, walk the arg-list
10925 and look for it. */
10928 stree->n.tb->pass_arg_num = 1;
10929 for (i = proc->formal; i; i = i->next)
10931 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10936 ++stree->n.tb->pass_arg_num;
10941 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10943 proc->name, stree->n.tb->pass_arg, &where,
10944 stree->n.tb->pass_arg);
10950 /* Otherwise, take the first one; there should in fact be at least
10952 stree->n.tb->pass_arg_num = 1;
10955 gfc_error ("Procedure '%s' with PASS at %L must have at"
10956 " least one argument", proc->name, &where);
10959 me_arg = proc->formal->sym;
10962 /* Now check that the argument-type matches and the passed-object
10963 dummy argument is generally fine. */
10965 gcc_assert (me_arg);
10967 if (me_arg->ts.type != BT_CLASS)
10969 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10970 " at %L", proc->name, &where);
10974 if (CLASS_DATA (me_arg)->ts.u.derived
10975 != resolve_bindings_derived)
10977 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10978 " the derived-type '%s'", me_arg->name, proc->name,
10979 me_arg->name, &where, resolve_bindings_derived->name);
10983 gcc_assert (me_arg->ts.type == BT_CLASS);
10984 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
10986 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
10987 " scalar", proc->name, &where);
10990 if (CLASS_DATA (me_arg)->attr.allocatable)
10992 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10993 " be ALLOCATABLE", proc->name, &where);
10996 if (CLASS_DATA (me_arg)->attr.class_pointer)
10998 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10999 " be POINTER", proc->name, &where);
11004 /* If we are extending some type, check that we don't override a procedure
11005 flagged NON_OVERRIDABLE. */
11006 stree->n.tb->overridden = NULL;
11009 gfc_symtree* overridden;
11010 overridden = gfc_find_typebound_proc (super_type, NULL,
11011 stree->name, true, NULL);
11013 if (overridden && overridden->n.tb)
11014 stree->n.tb->overridden = overridden->n.tb;
11016 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11020 /* See if there's a name collision with a component directly in this type. */
11021 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11022 if (!strcmp (comp->name, stree->name))
11024 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11026 stree->name, &where, resolve_bindings_derived->name);
11030 /* Try to find a name collision with an inherited component. */
11031 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11033 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11034 " component of '%s'",
11035 stree->name, &where, resolve_bindings_derived->name);
11039 stree->n.tb->error = 0;
11043 resolve_bindings_result = FAILURE;
11044 stree->n.tb->error = 1;
11049 resolve_typebound_procedures (gfc_symbol* derived)
11053 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11056 resolve_bindings_derived = derived;
11057 resolve_bindings_result = SUCCESS;
11059 /* Make sure the vtab has been generated. */
11060 gfc_find_derived_vtab (derived);
11062 if (derived->f2k_derived->tb_sym_root)
11063 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11064 &resolve_typebound_procedure);
11066 if (derived->f2k_derived->tb_uop_root)
11067 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11068 &resolve_typebound_user_op);
11070 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11072 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11073 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11075 resolve_bindings_result = FAILURE;
11078 return resolve_bindings_result;
11082 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11083 to give all identical derived types the same backend_decl. */
11085 add_dt_to_dt_list (gfc_symbol *derived)
11087 gfc_dt_list *dt_list;
11089 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11090 if (derived == dt_list->derived)
11093 if (dt_list == NULL)
11095 dt_list = gfc_get_dt_list ();
11096 dt_list->next = gfc_derived_types;
11097 dt_list->derived = derived;
11098 gfc_derived_types = dt_list;
11103 /* Ensure that a derived-type is really not abstract, meaning that every
11104 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11107 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11112 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11114 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11117 if (st->n.tb && st->n.tb->deferred)
11119 gfc_symtree* overriding;
11120 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11123 gcc_assert (overriding->n.tb);
11124 if (overriding->n.tb->deferred)
11126 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11127 " '%s' is DEFERRED and not overridden",
11128 sub->name, &sub->declared_at, st->name);
11137 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11139 /* The algorithm used here is to recursively travel up the ancestry of sub
11140 and for each ancestor-type, check all bindings. If any of them is
11141 DEFERRED, look it up starting from sub and see if the found (overriding)
11142 binding is not DEFERRED.
11143 This is not the most efficient way to do this, but it should be ok and is
11144 clearer than something sophisticated. */
11146 gcc_assert (ancestor && !sub->attr.abstract);
11148 if (!ancestor->attr.abstract)
11151 /* Walk bindings of this ancestor. */
11152 if (ancestor->f2k_derived)
11155 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11160 /* Find next ancestor type and recurse on it. */
11161 ancestor = gfc_get_derived_super_type (ancestor);
11163 return ensure_not_abstract (sub, ancestor);
11169 /* Resolve the components of a derived type. */
11172 resolve_fl_derived (gfc_symbol *sym)
11174 gfc_symbol* super_type;
11177 super_type = gfc_get_derived_super_type (sym);
11179 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11181 /* Fix up incomplete CLASS symbols. */
11182 gfc_component *data = gfc_find_component (sym, "$data", true, true);
11183 gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
11184 if (vptr->ts.u.derived == NULL)
11186 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11188 vptr->ts.u.derived = vtab->ts.u.derived;
11193 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11195 gfc_error ("As extending type '%s' at %L has a coarray component, "
11196 "parent type '%s' shall also have one", sym->name,
11197 &sym->declared_at, super_type->name);
11201 /* Ensure the extended type gets resolved before we do. */
11202 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11205 /* An ABSTRACT type must be extensible. */
11206 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11208 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11209 sym->name, &sym->declared_at);
11213 for (c = sym->components; c != NULL; c = c->next)
11216 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11217 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11219 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11220 "deferred shape", c->name, &c->loc);
11225 if (c->attr.codimension && c->ts.type == BT_DERIVED
11226 && c->ts.u.derived->ts.is_iso_c)
11228 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11229 "shall not be a coarray", c->name, &c->loc);
11234 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11235 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11236 || c->attr.allocatable))
11238 gfc_error ("Component '%s' at %L with coarray component "
11239 "shall be a nonpointer, nonallocatable scalar",
11245 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11247 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11248 "is not an array pointer", c->name, &c->loc);
11252 if (c->attr.proc_pointer && c->ts.interface)
11254 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11255 gfc_error ("Interface '%s', used by procedure pointer component "
11256 "'%s' at %L, is declared in a later PROCEDURE statement",
11257 c->ts.interface->name, c->name, &c->loc);
11259 /* Get the attributes from the interface (now resolved). */
11260 if (c->ts.interface->attr.if_source
11261 || c->ts.interface->attr.intrinsic)
11263 gfc_symbol *ifc = c->ts.interface;
11265 if (ifc->formal && !ifc->formal_ns)
11266 resolve_symbol (ifc);
11268 if (ifc->attr.intrinsic)
11269 resolve_intrinsic (ifc, &ifc->declared_at);
11273 c->ts = ifc->result->ts;
11274 c->attr.allocatable = ifc->result->attr.allocatable;
11275 c->attr.pointer = ifc->result->attr.pointer;
11276 c->attr.dimension = ifc->result->attr.dimension;
11277 c->as = gfc_copy_array_spec (ifc->result->as);
11282 c->attr.allocatable = ifc->attr.allocatable;
11283 c->attr.pointer = ifc->attr.pointer;
11284 c->attr.dimension = ifc->attr.dimension;
11285 c->as = gfc_copy_array_spec (ifc->as);
11287 c->ts.interface = ifc;
11288 c->attr.function = ifc->attr.function;
11289 c->attr.subroutine = ifc->attr.subroutine;
11290 gfc_copy_formal_args_ppc (c, ifc);
11292 c->attr.pure = ifc->attr.pure;
11293 c->attr.elemental = ifc->attr.elemental;
11294 c->attr.recursive = ifc->attr.recursive;
11295 c->attr.always_explicit = ifc->attr.always_explicit;
11296 c->attr.ext_attr |= ifc->attr.ext_attr;
11297 /* Replace symbols in array spec. */
11301 for (i = 0; i < c->as->rank; i++)
11303 gfc_expr_replace_comp (c->as->lower[i], c);
11304 gfc_expr_replace_comp (c->as->upper[i], c);
11307 /* Copy char length. */
11308 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11310 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11311 gfc_expr_replace_comp (cl->length, c);
11312 if (cl->length && !cl->resolved
11313 && gfc_resolve_expr (cl->length) == FAILURE)
11318 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11320 gfc_error ("Interface '%s' of procedure pointer component "
11321 "'%s' at %L must be explicit", c->ts.interface->name,
11326 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11328 /* Since PPCs are not implicitly typed, a PPC without an explicit
11329 interface must be a subroutine. */
11330 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11333 /* Procedure pointer components: Check PASS arg. */
11334 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11335 && !sym->attr.vtype)
11337 gfc_symbol* me_arg;
11339 if (c->tb->pass_arg)
11341 gfc_formal_arglist* i;
11343 /* If an explicit passing argument name is given, walk the arg-list
11344 and look for it. */
11347 c->tb->pass_arg_num = 1;
11348 for (i = c->formal; i; i = i->next)
11350 if (!strcmp (i->sym->name, c->tb->pass_arg))
11355 c->tb->pass_arg_num++;
11360 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11361 "at %L has no argument '%s'", c->name,
11362 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11369 /* Otherwise, take the first one; there should in fact be at least
11371 c->tb->pass_arg_num = 1;
11374 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11375 "must have at least one argument",
11380 me_arg = c->formal->sym;
11383 /* Now check that the argument-type matches. */
11384 gcc_assert (me_arg);
11385 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11386 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11387 || (me_arg->ts.type == BT_CLASS
11388 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11390 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11391 " the derived type '%s'", me_arg->name, c->name,
11392 me_arg->name, &c->loc, sym->name);
11397 /* Check for C453. */
11398 if (me_arg->attr.dimension)
11400 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11401 "must be scalar", me_arg->name, c->name, me_arg->name,
11407 if (me_arg->attr.pointer)
11409 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11410 "may not have the POINTER attribute", me_arg->name,
11411 c->name, me_arg->name, &c->loc);
11416 if (me_arg->attr.allocatable)
11418 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11419 "may not be ALLOCATABLE", me_arg->name, c->name,
11420 me_arg->name, &c->loc);
11425 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11426 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11427 " at %L", c->name, &c->loc);
11431 /* Check type-spec if this is not the parent-type component. */
11432 if ((!sym->attr.extension || c != sym->components)
11433 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11436 /* If this type is an extension, set the accessibility of the parent
11438 if (super_type && c == sym->components
11439 && strcmp (super_type->name, c->name) == 0)
11440 c->attr.access = super_type->attr.access;
11442 /* If this type is an extension, see if this component has the same name
11443 as an inherited type-bound procedure. */
11444 if (super_type && !sym->attr.is_class
11445 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11447 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11448 " inherited type-bound procedure",
11449 c->name, sym->name, &c->loc);
11453 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11455 if (c->ts.u.cl->length == NULL
11456 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11457 || !gfc_is_constant_expr (c->ts.u.cl->length))
11459 gfc_error ("Character length of component '%s' needs to "
11460 "be a constant specification expression at %L",
11462 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11467 if (c->ts.type == BT_DERIVED
11468 && sym->component_access != ACCESS_PRIVATE
11469 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11470 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11471 && !c->ts.u.derived->attr.use_assoc
11472 && !gfc_check_access (c->ts.u.derived->attr.access,
11473 c->ts.u.derived->ns->default_access)
11474 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11475 "is a PRIVATE type and cannot be a component of "
11476 "'%s', which is PUBLIC at %L", c->name,
11477 sym->name, &sym->declared_at) == FAILURE)
11480 if (sym->attr.sequence)
11482 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11484 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11485 "not have the SEQUENCE attribute",
11486 c->ts.u.derived->name, &sym->declared_at);
11491 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
11492 && c->ts.u.derived->components == NULL
11493 && !c->ts.u.derived->attr.zero_comp)
11495 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11496 "that has not been declared", c->name, sym->name,
11501 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11502 && CLASS_DATA (c)->ts.u.derived->components == NULL
11503 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11505 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11506 "that has not been declared", c->name, sym->name,
11512 if (c->ts.type == BT_CLASS
11513 && !(CLASS_DATA (c)->attr.class_pointer
11514 || CLASS_DATA (c)->attr.allocatable))
11516 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11517 "or pointer", c->name, &c->loc);
11521 /* Ensure that all the derived type components are put on the
11522 derived type list; even in formal namespaces, where derived type
11523 pointer components might not have been declared. */
11524 if (c->ts.type == BT_DERIVED
11526 && c->ts.u.derived->components
11528 && sym != c->ts.u.derived)
11529 add_dt_to_dt_list (c->ts.u.derived);
11531 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11532 || c->attr.proc_pointer
11533 || c->attr.allocatable)) == FAILURE)
11537 /* Resolve the type-bound procedures. */
11538 if (resolve_typebound_procedures (sym) == FAILURE)
11541 /* Resolve the finalizer procedures. */
11542 if (gfc_resolve_finalizers (sym) == FAILURE)
11545 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11546 all DEFERRED bindings are overridden. */
11547 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11548 && !sym->attr.is_class
11549 && ensure_not_abstract (sym, super_type) == FAILURE)
11552 /* Add derived type to the derived type list. */
11553 add_dt_to_dt_list (sym);
11560 resolve_fl_namelist (gfc_symbol *sym)
11565 /* Reject PRIVATE objects in a PUBLIC namelist. */
11566 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11568 for (nl = sym->namelist; nl; nl = nl->next)
11570 if (!nl->sym->attr.use_assoc
11571 && !is_sym_host_assoc (nl->sym, sym->ns)
11572 && !gfc_check_access(nl->sym->attr.access,
11573 nl->sym->ns->default_access))
11575 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11576 "cannot be member of PUBLIC namelist '%s' at %L",
11577 nl->sym->name, sym->name, &sym->declared_at);
11581 /* Types with private components that came here by USE-association. */
11582 if (nl->sym->ts.type == BT_DERIVED
11583 && derived_inaccessible (nl->sym->ts.u.derived))
11585 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11586 "components and cannot be member of namelist '%s' at %L",
11587 nl->sym->name, sym->name, &sym->declared_at);
11591 /* Types with private components that are defined in the same module. */
11592 if (nl->sym->ts.type == BT_DERIVED
11593 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11594 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11595 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11596 nl->sym->ns->default_access))
11598 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11599 "cannot be a member of PUBLIC namelist '%s' at %L",
11600 nl->sym->name, sym->name, &sym->declared_at);
11606 for (nl = sym->namelist; nl; nl = nl->next)
11608 /* Reject namelist arrays of assumed shape. */
11609 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11610 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11611 "must not have assumed shape in namelist "
11612 "'%s' at %L", nl->sym->name, sym->name,
11613 &sym->declared_at) == FAILURE)
11616 /* Reject namelist arrays that are not constant shape. */
11617 if (is_non_constant_shape_array (nl->sym))
11619 gfc_error ("NAMELIST array object '%s' must have constant "
11620 "shape in namelist '%s' at %L", nl->sym->name,
11621 sym->name, &sym->declared_at);
11625 /* Namelist objects cannot have allocatable or pointer components. */
11626 if (nl->sym->ts.type != BT_DERIVED)
11629 if (nl->sym->ts.u.derived->attr.alloc_comp)
11631 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11632 "have ALLOCATABLE components",
11633 nl->sym->name, sym->name, &sym->declared_at);
11637 if (nl->sym->ts.u.derived->attr.pointer_comp)
11639 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11640 "have POINTER components",
11641 nl->sym->name, sym->name, &sym->declared_at);
11647 /* 14.1.2 A module or internal procedure represent local entities
11648 of the same type as a namelist member and so are not allowed. */
11649 for (nl = sym->namelist; nl; nl = nl->next)
11651 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11654 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11655 if ((nl->sym == sym->ns->proc_name)
11657 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11661 if (nl->sym && nl->sym->name)
11662 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11663 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11665 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11666 "attribute in '%s' at %L", nlsym->name,
11667 &sym->declared_at);
11677 resolve_fl_parameter (gfc_symbol *sym)
11679 /* A parameter array's shape needs to be constant. */
11680 if (sym->as != NULL
11681 && (sym->as->type == AS_DEFERRED
11682 || is_non_constant_shape_array (sym)))
11684 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11685 "or of deferred shape", sym->name, &sym->declared_at);
11689 /* Make sure a parameter that has been implicitly typed still
11690 matches the implicit type, since PARAMETER statements can precede
11691 IMPLICIT statements. */
11692 if (sym->attr.implicit_type
11693 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11696 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11697 "later IMPLICIT type", sym->name, &sym->declared_at);
11701 /* Make sure the types of derived parameters are consistent. This
11702 type checking is deferred until resolution because the type may
11703 refer to a derived type from the host. */
11704 if (sym->ts.type == BT_DERIVED
11705 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11707 gfc_error ("Incompatible derived type in PARAMETER at %L",
11708 &sym->value->where);
11715 /* Do anything necessary to resolve a symbol. Right now, we just
11716 assume that an otherwise unknown symbol is a variable. This sort
11717 of thing commonly happens for symbols in module. */
11720 resolve_symbol (gfc_symbol *sym)
11722 int check_constant, mp_flag;
11723 gfc_symtree *symtree;
11724 gfc_symtree *this_symtree;
11728 /* Avoid double resolution of function result symbols. */
11729 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11730 && (sym->ns != gfc_current_ns))
11733 if (sym->attr.flavor == FL_UNKNOWN)
11736 /* If we find that a flavorless symbol is an interface in one of the
11737 parent namespaces, find its symtree in this namespace, free the
11738 symbol and set the symtree to point to the interface symbol. */
11739 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11741 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11742 if (symtree && symtree->n.sym->generic)
11744 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11746 gfc_release_symbol (sym);
11747 symtree->n.sym->refs++;
11748 this_symtree->n.sym = symtree->n.sym;
11753 /* Otherwise give it a flavor according to such attributes as
11755 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11756 sym->attr.flavor = FL_VARIABLE;
11759 sym->attr.flavor = FL_PROCEDURE;
11760 if (sym->attr.dimension)
11761 sym->attr.function = 1;
11765 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11766 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11768 if (sym->attr.procedure && sym->ts.interface
11769 && sym->attr.if_source != IFSRC_DECL
11770 && resolve_procedure_interface (sym) == FAILURE)
11773 if (sym->attr.is_protected && !sym->attr.proc_pointer
11774 && (sym->attr.procedure || sym->attr.external))
11776 if (sym->attr.external)
11777 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11778 "at %L", &sym->declared_at);
11780 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11781 "at %L", &sym->declared_at);
11788 if (sym->attr.contiguous
11789 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11790 && !sym->attr.pointer)))
11792 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11793 "array pointer or an assumed-shape array", sym->name,
11794 &sym->declared_at);
11798 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11801 /* Symbols that are module procedures with results (functions) have
11802 the types and array specification copied for type checking in
11803 procedures that call them, as well as for saving to a module
11804 file. These symbols can't stand the scrutiny that their results
11806 mp_flag = (sym->result != NULL && sym->result != sym);
11808 /* Make sure that the intrinsic is consistent with its internal
11809 representation. This needs to be done before assigning a default
11810 type to avoid spurious warnings. */
11811 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11812 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11815 /* Resolve associate names. */
11817 resolve_assoc_var (sym, true);
11819 /* Assign default type to symbols that need one and don't have one. */
11820 if (sym->ts.type == BT_UNKNOWN)
11822 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11823 gfc_set_default_type (sym, 1, NULL);
11825 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11826 && !sym->attr.function && !sym->attr.subroutine
11827 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11828 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11830 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11832 /* The specific case of an external procedure should emit an error
11833 in the case that there is no implicit type. */
11835 gfc_set_default_type (sym, sym->attr.external, NULL);
11838 /* Result may be in another namespace. */
11839 resolve_symbol (sym->result);
11841 if (!sym->result->attr.proc_pointer)
11843 sym->ts = sym->result->ts;
11844 sym->as = gfc_copy_array_spec (sym->result->as);
11845 sym->attr.dimension = sym->result->attr.dimension;
11846 sym->attr.pointer = sym->result->attr.pointer;
11847 sym->attr.allocatable = sym->result->attr.allocatable;
11848 sym->attr.contiguous = sym->result->attr.contiguous;
11854 /* Assumed size arrays and assumed shape arrays must be dummy
11855 arguments. Array-spec's of implied-shape should have been resolved to
11856 AS_EXPLICIT already. */
11860 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11861 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11862 || sym->as->type == AS_ASSUMED_SHAPE)
11863 && sym->attr.dummy == 0)
11865 if (sym->as->type == AS_ASSUMED_SIZE)
11866 gfc_error ("Assumed size array at %L must be a dummy argument",
11867 &sym->declared_at);
11869 gfc_error ("Assumed shape array at %L must be a dummy argument",
11870 &sym->declared_at);
11875 /* Make sure symbols with known intent or optional are really dummy
11876 variable. Because of ENTRY statement, this has to be deferred
11877 until resolution time. */
11879 if (!sym->attr.dummy
11880 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11882 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11886 if (sym->attr.value && !sym->attr.dummy)
11888 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11889 "it is not a dummy argument", sym->name, &sym->declared_at);
11893 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11895 gfc_charlen *cl = sym->ts.u.cl;
11896 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11898 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11899 "attribute must have constant length",
11900 sym->name, &sym->declared_at);
11904 if (sym->ts.is_c_interop
11905 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11907 gfc_error ("C interoperable character dummy variable '%s' at %L "
11908 "with VALUE attribute must have length one",
11909 sym->name, &sym->declared_at);
11914 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11915 do this for something that was implicitly typed because that is handled
11916 in gfc_set_default_type. Handle dummy arguments and procedure
11917 definitions separately. Also, anything that is use associated is not
11918 handled here but instead is handled in the module it is declared in.
11919 Finally, derived type definitions are allowed to be BIND(C) since that
11920 only implies that they're interoperable, and they are checked fully for
11921 interoperability when a variable is declared of that type. */
11922 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11923 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11924 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11926 gfc_try t = SUCCESS;
11928 /* First, make sure the variable is declared at the
11929 module-level scope (J3/04-007, Section 15.3). */
11930 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11931 sym->attr.in_common == 0)
11933 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11934 "is neither a COMMON block nor declared at the "
11935 "module level scope", sym->name, &(sym->declared_at));
11938 else if (sym->common_head != NULL)
11940 t = verify_com_block_vars_c_interop (sym->common_head);
11944 /* If type() declaration, we need to verify that the components
11945 of the given type are all C interoperable, etc. */
11946 if (sym->ts.type == BT_DERIVED &&
11947 sym->ts.u.derived->attr.is_c_interop != 1)
11949 /* Make sure the user marked the derived type as BIND(C). If
11950 not, call the verify routine. This could print an error
11951 for the derived type more than once if multiple variables
11952 of that type are declared. */
11953 if (sym->ts.u.derived->attr.is_bind_c != 1)
11954 verify_bind_c_derived_type (sym->ts.u.derived);
11958 /* Verify the variable itself as C interoperable if it
11959 is BIND(C). It is not possible for this to succeed if
11960 the verify_bind_c_derived_type failed, so don't have to handle
11961 any error returned by verify_bind_c_derived_type. */
11962 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11963 sym->common_block);
11968 /* clear the is_bind_c flag to prevent reporting errors more than
11969 once if something failed. */
11970 sym->attr.is_bind_c = 0;
11975 /* If a derived type symbol has reached this point, without its
11976 type being declared, we have an error. Notice that most
11977 conditions that produce undefined derived types have already
11978 been dealt with. However, the likes of:
11979 implicit type(t) (t) ..... call foo (t) will get us here if
11980 the type is not declared in the scope of the implicit
11981 statement. Change the type to BT_UNKNOWN, both because it is so
11982 and to prevent an ICE. */
11983 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
11984 && !sym->ts.u.derived->attr.zero_comp)
11986 gfc_error ("The derived type '%s' at %L is of type '%s', "
11987 "which has not been defined", sym->name,
11988 &sym->declared_at, sym->ts.u.derived->name);
11989 sym->ts.type = BT_UNKNOWN;
11993 /* Make sure that the derived type has been resolved and that the
11994 derived type is visible in the symbol's namespace, if it is a
11995 module function and is not PRIVATE. */
11996 if (sym->ts.type == BT_DERIVED
11997 && sym->ts.u.derived->attr.use_assoc
11998 && sym->ns->proc_name
11999 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12003 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12006 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12007 if (!ds && sym->attr.function
12008 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12010 symtree = gfc_new_symtree (&sym->ns->sym_root,
12011 sym->ts.u.derived->name);
12012 symtree->n.sym = sym->ts.u.derived;
12013 sym->ts.u.derived->refs++;
12017 /* Unless the derived-type declaration is use associated, Fortran 95
12018 does not allow public entries of private derived types.
12019 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12020 161 in 95-006r3. */
12021 if (sym->ts.type == BT_DERIVED
12022 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12023 && !sym->ts.u.derived->attr.use_assoc
12024 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12025 && !gfc_check_access (sym->ts.u.derived->attr.access,
12026 sym->ts.u.derived->ns->default_access)
12027 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12028 "of PRIVATE derived type '%s'",
12029 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12030 : "variable", sym->name, &sym->declared_at,
12031 sym->ts.u.derived->name) == FAILURE)
12034 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12035 default initialization is defined (5.1.2.4.4). */
12036 if (sym->ts.type == BT_DERIVED
12038 && sym->attr.intent == INTENT_OUT
12040 && sym->as->type == AS_ASSUMED_SIZE)
12042 for (c = sym->ts.u.derived->components; c; c = c->next)
12044 if (c->initializer)
12046 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12047 "ASSUMED SIZE and so cannot have a default initializer",
12048 sym->name, &sym->declared_at);
12055 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12056 || sym->attr.codimension)
12057 && sym->attr.result)
12058 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12059 "a coarray component", sym->name, &sym->declared_at);
12062 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12063 && sym->ts.u.derived->ts.is_iso_c)
12064 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12065 "shall not be a coarray", sym->name, &sym->declared_at);
12068 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12069 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12070 || sym->attr.allocatable))
12071 gfc_error ("Variable '%s' at %L with coarray component "
12072 "shall be a nonpointer, nonallocatable scalar",
12073 sym->name, &sym->declared_at);
12075 /* F2008, C526. The function-result case was handled above. */
12076 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12077 || sym->attr.codimension)
12078 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12079 || sym->ns->proc_name->attr.flavor == FL_MODULE
12080 || sym->ns->proc_name->attr.is_main_program
12081 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12082 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12083 "component and is not ALLOCATABLE, SAVE nor a "
12084 "dummy argument", sym->name, &sym->declared_at);
12085 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12086 else if (sym->attr.codimension && !sym->attr.allocatable
12087 && sym->as && sym->as->cotype == AS_DEFERRED)
12088 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12089 "deferred shape", sym->name, &sym->declared_at);
12090 else if (sym->attr.codimension && sym->attr.allocatable
12091 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12092 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12093 "deferred shape", sym->name, &sym->declared_at);
12097 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12098 || (sym->attr.codimension && sym->attr.allocatable))
12099 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12100 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12101 "allocatable coarray or have coarray components",
12102 sym->name, &sym->declared_at);
12104 if (sym->attr.codimension && sym->attr.dummy
12105 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12106 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12107 "procedure '%s'", sym->name, &sym->declared_at,
12108 sym->ns->proc_name->name);
12110 switch (sym->attr.flavor)
12113 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12118 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12123 if (resolve_fl_namelist (sym) == FAILURE)
12128 if (resolve_fl_parameter (sym) == FAILURE)
12136 /* Resolve array specifier. Check as well some constraints
12137 on COMMON blocks. */
12139 check_constant = sym->attr.in_common && !sym->attr.pointer;
12141 /* Set the formal_arg_flag so that check_conflict will not throw
12142 an error for host associated variables in the specification
12143 expression for an array_valued function. */
12144 if (sym->attr.function && sym->as)
12145 formal_arg_flag = 1;
12147 gfc_resolve_array_spec (sym->as, check_constant);
12149 formal_arg_flag = 0;
12151 /* Resolve formal namespaces. */
12152 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12153 && !sym->attr.contained && !sym->attr.intrinsic)
12154 gfc_resolve (sym->formal_ns);
12156 /* Make sure the formal namespace is present. */
12157 if (sym->formal && !sym->formal_ns)
12159 gfc_formal_arglist *formal = sym->formal;
12160 while (formal && !formal->sym)
12161 formal = formal->next;
12165 sym->formal_ns = formal->sym->ns;
12166 sym->formal_ns->refs++;
12170 /* Check threadprivate restrictions. */
12171 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12172 && (!sym->attr.in_common
12173 && sym->module == NULL
12174 && (sym->ns->proc_name == NULL
12175 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12176 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12178 /* If we have come this far we can apply default-initializers, as
12179 described in 14.7.5, to those variables that have not already
12180 been assigned one. */
12181 if (sym->ts.type == BT_DERIVED
12182 && sym->attr.referenced
12183 && sym->ns == gfc_current_ns
12185 && !sym->attr.allocatable
12186 && !sym->attr.alloc_comp)
12188 symbol_attribute *a = &sym->attr;
12190 if ((!a->save && !a->dummy && !a->pointer
12191 && !a->in_common && !a->use_assoc
12192 && !(a->function && sym != sym->result))
12193 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12194 apply_default_init (sym);
12197 /* If this symbol has a type-spec, check it. */
12198 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12199 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12200 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12206 /************* Resolve DATA statements *************/
12210 gfc_data_value *vnode;
12216 /* Advance the values structure to point to the next value in the data list. */
12219 next_data_value (void)
12221 while (mpz_cmp_ui (values.left, 0) == 0)
12224 if (values.vnode->next == NULL)
12227 values.vnode = values.vnode->next;
12228 mpz_set (values.left, values.vnode->repeat);
12236 check_data_variable (gfc_data_variable *var, locus *where)
12242 ar_type mark = AR_UNKNOWN;
12244 mpz_t section_index[GFC_MAX_DIMENSIONS];
12250 if (gfc_resolve_expr (var->expr) == FAILURE)
12254 mpz_init_set_si (offset, 0);
12257 if (e->expr_type != EXPR_VARIABLE)
12258 gfc_internal_error ("check_data_variable(): Bad expression");
12260 sym = e->symtree->n.sym;
12262 if (sym->ns->is_block_data && !sym->attr.in_common)
12264 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12265 sym->name, &sym->declared_at);
12268 if (e->ref == NULL && sym->as)
12270 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12271 " declaration", sym->name, where);
12275 has_pointer = sym->attr.pointer;
12277 for (ref = e->ref; ref; ref = ref->next)
12279 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12282 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12284 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12290 && ref->type == REF_ARRAY
12291 && ref->u.ar.type != AR_FULL)
12293 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12294 "be a full array", sym->name, where);
12299 if (e->rank == 0 || has_pointer)
12301 mpz_init_set_ui (size, 1);
12308 /* Find the array section reference. */
12309 for (ref = e->ref; ref; ref = ref->next)
12311 if (ref->type != REF_ARRAY)
12313 if (ref->u.ar.type == AR_ELEMENT)
12319 /* Set marks according to the reference pattern. */
12320 switch (ref->u.ar.type)
12328 /* Get the start position of array section. */
12329 gfc_get_section_index (ar, section_index, &offset);
12334 gcc_unreachable ();
12337 if (gfc_array_size (e, &size) == FAILURE)
12339 gfc_error ("Nonconstant array section at %L in DATA statement",
12341 mpz_clear (offset);
12348 while (mpz_cmp_ui (size, 0) > 0)
12350 if (next_data_value () == FAILURE)
12352 gfc_error ("DATA statement at %L has more variables than values",
12358 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12362 /* If we have more than one element left in the repeat count,
12363 and we have more than one element left in the target variable,
12364 then create a range assignment. */
12365 /* FIXME: Only done for full arrays for now, since array sections
12367 if (mark == AR_FULL && ref && ref->next == NULL
12368 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12372 if (mpz_cmp (size, values.left) >= 0)
12374 mpz_init_set (range, values.left);
12375 mpz_sub (size, size, values.left);
12376 mpz_set_ui (values.left, 0);
12380 mpz_init_set (range, size);
12381 mpz_sub (values.left, values.left, size);
12382 mpz_set_ui (size, 0);
12385 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12388 mpz_add (offset, offset, range);
12395 /* Assign initial value to symbol. */
12398 mpz_sub_ui (values.left, values.left, 1);
12399 mpz_sub_ui (size, size, 1);
12401 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12405 if (mark == AR_FULL)
12406 mpz_add_ui (offset, offset, 1);
12408 /* Modify the array section indexes and recalculate the offset
12409 for next element. */
12410 else if (mark == AR_SECTION)
12411 gfc_advance_section (section_index, ar, &offset);
12415 if (mark == AR_SECTION)
12417 for (i = 0; i < ar->dimen; i++)
12418 mpz_clear (section_index[i]);
12422 mpz_clear (offset);
12428 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12430 /* Iterate over a list of elements in a DATA statement. */
12433 traverse_data_list (gfc_data_variable *var, locus *where)
12436 iterator_stack frame;
12437 gfc_expr *e, *start, *end, *step;
12438 gfc_try retval = SUCCESS;
12440 mpz_init (frame.value);
12443 start = gfc_copy_expr (var->iter.start);
12444 end = gfc_copy_expr (var->iter.end);
12445 step = gfc_copy_expr (var->iter.step);
12447 if (gfc_simplify_expr (start, 1) == FAILURE
12448 || start->expr_type != EXPR_CONSTANT)
12450 gfc_error ("start of implied-do loop at %L could not be "
12451 "simplified to a constant value", &start->where);
12455 if (gfc_simplify_expr (end, 1) == FAILURE
12456 || end->expr_type != EXPR_CONSTANT)
12458 gfc_error ("end of implied-do loop at %L could not be "
12459 "simplified to a constant value", &start->where);
12463 if (gfc_simplify_expr (step, 1) == FAILURE
12464 || step->expr_type != EXPR_CONSTANT)
12466 gfc_error ("step of implied-do loop at %L could not be "
12467 "simplified to a constant value", &start->where);
12472 mpz_set (trip, end->value.integer);
12473 mpz_sub (trip, trip, start->value.integer);
12474 mpz_add (trip, trip, step->value.integer);
12476 mpz_div (trip, trip, step->value.integer);
12478 mpz_set (frame.value, start->value.integer);
12480 frame.prev = iter_stack;
12481 frame.variable = var->iter.var->symtree;
12482 iter_stack = &frame;
12484 while (mpz_cmp_ui (trip, 0) > 0)
12486 if (traverse_data_var (var->list, where) == FAILURE)
12492 e = gfc_copy_expr (var->expr);
12493 if (gfc_simplify_expr (e, 1) == FAILURE)
12500 mpz_add (frame.value, frame.value, step->value.integer);
12502 mpz_sub_ui (trip, trip, 1);
12506 mpz_clear (frame.value);
12509 gfc_free_expr (start);
12510 gfc_free_expr (end);
12511 gfc_free_expr (step);
12513 iter_stack = frame.prev;
12518 /* Type resolve variables in the variable list of a DATA statement. */
12521 traverse_data_var (gfc_data_variable *var, locus *where)
12525 for (; var; var = var->next)
12527 if (var->expr == NULL)
12528 t = traverse_data_list (var, where);
12530 t = check_data_variable (var, where);
12540 /* Resolve the expressions and iterators associated with a data statement.
12541 This is separate from the assignment checking because data lists should
12542 only be resolved once. */
12545 resolve_data_variables (gfc_data_variable *d)
12547 for (; d; d = d->next)
12549 if (d->list == NULL)
12551 if (gfc_resolve_expr (d->expr) == FAILURE)
12556 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12559 if (resolve_data_variables (d->list) == FAILURE)
12568 /* Resolve a single DATA statement. We implement this by storing a pointer to
12569 the value list into static variables, and then recursively traversing the
12570 variables list, expanding iterators and such. */
12573 resolve_data (gfc_data *d)
12576 if (resolve_data_variables (d->var) == FAILURE)
12579 values.vnode = d->value;
12580 if (d->value == NULL)
12581 mpz_set_ui (values.left, 0);
12583 mpz_set (values.left, d->value->repeat);
12585 if (traverse_data_var (d->var, &d->where) == FAILURE)
12588 /* At this point, we better not have any values left. */
12590 if (next_data_value () == SUCCESS)
12591 gfc_error ("DATA statement at %L has more values than variables",
12596 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12597 accessed by host or use association, is a dummy argument to a pure function,
12598 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12599 is storage associated with any such variable, shall not be used in the
12600 following contexts: (clients of this function). */
12602 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12603 procedure. Returns zero if assignment is OK, nonzero if there is a
12606 gfc_impure_variable (gfc_symbol *sym)
12611 if (sym->attr.use_assoc || sym->attr.in_common)
12614 /* Check if the symbol's ns is inside the pure procedure. */
12615 for (ns = gfc_current_ns; ns; ns = ns->parent)
12619 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12623 proc = sym->ns->proc_name;
12624 if (sym->attr.dummy && gfc_pure (proc)
12625 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12627 proc->attr.function))
12630 /* TODO: Sort out what can be storage associated, if anything, and include
12631 it here. In principle equivalences should be scanned but it does not
12632 seem to be possible to storage associate an impure variable this way. */
12637 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12638 current namespace is inside a pure procedure. */
12641 gfc_pure (gfc_symbol *sym)
12643 symbol_attribute attr;
12648 /* Check if the current namespace or one of its parents
12649 belongs to a pure procedure. */
12650 for (ns = gfc_current_ns; ns; ns = ns->parent)
12652 sym = ns->proc_name;
12656 if (attr.flavor == FL_PROCEDURE && attr.pure)
12664 return attr.flavor == FL_PROCEDURE && attr.pure;
12668 /* Test whether the current procedure is elemental or not. */
12671 gfc_elemental (gfc_symbol *sym)
12673 symbol_attribute attr;
12676 sym = gfc_current_ns->proc_name;
12681 return attr.flavor == FL_PROCEDURE && attr.elemental;
12685 /* Warn about unused labels. */
12688 warn_unused_fortran_label (gfc_st_label *label)
12693 warn_unused_fortran_label (label->left);
12695 if (label->defined == ST_LABEL_UNKNOWN)
12698 switch (label->referenced)
12700 case ST_LABEL_UNKNOWN:
12701 gfc_warning ("Label %d at %L defined but not used", label->value,
12705 case ST_LABEL_BAD_TARGET:
12706 gfc_warning ("Label %d at %L defined but cannot be used",
12707 label->value, &label->where);
12714 warn_unused_fortran_label (label->right);
12718 /* Returns the sequence type of a symbol or sequence. */
12721 sequence_type (gfc_typespec ts)
12730 if (ts.u.derived->components == NULL)
12731 return SEQ_NONDEFAULT;
12733 result = sequence_type (ts.u.derived->components->ts);
12734 for (c = ts.u.derived->components->next; c; c = c->next)
12735 if (sequence_type (c->ts) != result)
12741 if (ts.kind != gfc_default_character_kind)
12742 return SEQ_NONDEFAULT;
12744 return SEQ_CHARACTER;
12747 if (ts.kind != gfc_default_integer_kind)
12748 return SEQ_NONDEFAULT;
12750 return SEQ_NUMERIC;
12753 if (!(ts.kind == gfc_default_real_kind
12754 || ts.kind == gfc_default_double_kind))
12755 return SEQ_NONDEFAULT;
12757 return SEQ_NUMERIC;
12760 if (ts.kind != gfc_default_complex_kind)
12761 return SEQ_NONDEFAULT;
12763 return SEQ_NUMERIC;
12766 if (ts.kind != gfc_default_logical_kind)
12767 return SEQ_NONDEFAULT;
12769 return SEQ_NUMERIC;
12772 return SEQ_NONDEFAULT;
12777 /* Resolve derived type EQUIVALENCE object. */
12780 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12782 gfc_component *c = derived->components;
12787 /* Shall not be an object of nonsequence derived type. */
12788 if (!derived->attr.sequence)
12790 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12791 "attribute to be an EQUIVALENCE object", sym->name,
12796 /* Shall not have allocatable components. */
12797 if (derived->attr.alloc_comp)
12799 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12800 "components to be an EQUIVALENCE object",sym->name,
12805 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12807 gfc_error ("Derived type variable '%s' at %L with default "
12808 "initialization cannot be in EQUIVALENCE with a variable "
12809 "in COMMON", sym->name, &e->where);
12813 for (; c ; c = c->next)
12815 if (c->ts.type == BT_DERIVED
12816 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12819 /* Shall not be an object of sequence derived type containing a pointer
12820 in the structure. */
12821 if (c->attr.pointer)
12823 gfc_error ("Derived type variable '%s' at %L with pointer "
12824 "component(s) cannot be an EQUIVALENCE object",
12825 sym->name, &e->where);
12833 /* Resolve equivalence object.
12834 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12835 an allocatable array, an object of nonsequence derived type, an object of
12836 sequence derived type containing a pointer at any level of component
12837 selection, an automatic object, a function name, an entry name, a result
12838 name, a named constant, a structure component, or a subobject of any of
12839 the preceding objects. A substring shall not have length zero. A
12840 derived type shall not have components with default initialization nor
12841 shall two objects of an equivalence group be initialized.
12842 Either all or none of the objects shall have an protected attribute.
12843 The simple constraints are done in symbol.c(check_conflict) and the rest
12844 are implemented here. */
12847 resolve_equivalence (gfc_equiv *eq)
12850 gfc_symbol *first_sym;
12853 locus *last_where = NULL;
12854 seq_type eq_type, last_eq_type;
12855 gfc_typespec *last_ts;
12856 int object, cnt_protected;
12859 last_ts = &eq->expr->symtree->n.sym->ts;
12861 first_sym = eq->expr->symtree->n.sym;
12865 for (object = 1; eq; eq = eq->eq, object++)
12869 e->ts = e->symtree->n.sym->ts;
12870 /* match_varspec might not know yet if it is seeing
12871 array reference or substring reference, as it doesn't
12873 if (e->ref && e->ref->type == REF_ARRAY)
12875 gfc_ref *ref = e->ref;
12876 sym = e->symtree->n.sym;
12878 if (sym->attr.dimension)
12880 ref->u.ar.as = sym->as;
12884 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12885 if (e->ts.type == BT_CHARACTER
12887 && ref->type == REF_ARRAY
12888 && ref->u.ar.dimen == 1
12889 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12890 && ref->u.ar.stride[0] == NULL)
12892 gfc_expr *start = ref->u.ar.start[0];
12893 gfc_expr *end = ref->u.ar.end[0];
12896 /* Optimize away the (:) reference. */
12897 if (start == NULL && end == NULL)
12900 e->ref = ref->next;
12902 e->ref->next = ref->next;
12907 ref->type = REF_SUBSTRING;
12909 start = gfc_get_int_expr (gfc_default_integer_kind,
12911 ref->u.ss.start = start;
12912 if (end == NULL && e->ts.u.cl)
12913 end = gfc_copy_expr (e->ts.u.cl->length);
12914 ref->u.ss.end = end;
12915 ref->u.ss.length = e->ts.u.cl;
12922 /* Any further ref is an error. */
12925 gcc_assert (ref->type == REF_ARRAY);
12926 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12932 if (gfc_resolve_expr (e) == FAILURE)
12935 sym = e->symtree->n.sym;
12937 if (sym->attr.is_protected)
12939 if (cnt_protected > 0 && cnt_protected != object)
12941 gfc_error ("Either all or none of the objects in the "
12942 "EQUIVALENCE set at %L shall have the "
12943 "PROTECTED attribute",
12948 /* Shall not equivalence common block variables in a PURE procedure. */
12949 if (sym->ns->proc_name
12950 && sym->ns->proc_name->attr.pure
12951 && sym->attr.in_common)
12953 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
12954 "object in the pure procedure '%s'",
12955 sym->name, &e->where, sym->ns->proc_name->name);
12959 /* Shall not be a named constant. */
12960 if (e->expr_type == EXPR_CONSTANT)
12962 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
12963 "object", sym->name, &e->where);
12967 if (e->ts.type == BT_DERIVED
12968 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
12971 /* Check that the types correspond correctly:
12973 A numeric sequence structure may be equivalenced to another sequence
12974 structure, an object of default integer type, default real type, double
12975 precision real type, default logical type such that components of the
12976 structure ultimately only become associated to objects of the same
12977 kind. A character sequence structure may be equivalenced to an object
12978 of default character kind or another character sequence structure.
12979 Other objects may be equivalenced only to objects of the same type and
12980 kind parameters. */
12982 /* Identical types are unconditionally OK. */
12983 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
12984 goto identical_types;
12986 last_eq_type = sequence_type (*last_ts);
12987 eq_type = sequence_type (sym->ts);
12989 /* Since the pair of objects is not of the same type, mixed or
12990 non-default sequences can be rejected. */
12992 msg = "Sequence %s with mixed components in EQUIVALENCE "
12993 "statement at %L with different type objects";
12995 && last_eq_type == SEQ_MIXED
12996 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
12998 || (eq_type == SEQ_MIXED
12999 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13000 &e->where) == FAILURE))
13003 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13004 "statement at %L with objects of different type";
13006 && last_eq_type == SEQ_NONDEFAULT
13007 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13008 last_where) == FAILURE)
13009 || (eq_type == SEQ_NONDEFAULT
13010 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13011 &e->where) == FAILURE))
13014 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13015 "EQUIVALENCE statement at %L";
13016 if (last_eq_type == SEQ_CHARACTER
13017 && eq_type != SEQ_CHARACTER
13018 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13019 &e->where) == FAILURE)
13022 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13023 "EQUIVALENCE statement at %L";
13024 if (last_eq_type == SEQ_NUMERIC
13025 && eq_type != SEQ_NUMERIC
13026 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13027 &e->where) == FAILURE)
13032 last_where = &e->where;
13037 /* Shall not be an automatic array. */
13038 if (e->ref->type == REF_ARRAY
13039 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13041 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13042 "an EQUIVALENCE object", sym->name, &e->where);
13049 /* Shall not be a structure component. */
13050 if (r->type == REF_COMPONENT)
13052 gfc_error ("Structure component '%s' at %L cannot be an "
13053 "EQUIVALENCE object",
13054 r->u.c.component->name, &e->where);
13058 /* A substring shall not have length zero. */
13059 if (r->type == REF_SUBSTRING)
13061 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13063 gfc_error ("Substring at %L has length zero",
13064 &r->u.ss.start->where);
13074 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13077 resolve_fntype (gfc_namespace *ns)
13079 gfc_entry_list *el;
13082 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13085 /* If there are any entries, ns->proc_name is the entry master
13086 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13088 sym = ns->entries->sym;
13090 sym = ns->proc_name;
13091 if (sym->result == sym
13092 && sym->ts.type == BT_UNKNOWN
13093 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13094 && !sym->attr.untyped)
13096 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13097 sym->name, &sym->declared_at);
13098 sym->attr.untyped = 1;
13101 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13102 && !sym->attr.contained
13103 && !gfc_check_access (sym->ts.u.derived->attr.access,
13104 sym->ts.u.derived->ns->default_access)
13105 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13107 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13108 "%L of PRIVATE type '%s'", sym->name,
13109 &sym->declared_at, sym->ts.u.derived->name);
13113 for (el = ns->entries->next; el; el = el->next)
13115 if (el->sym->result == el->sym
13116 && el->sym->ts.type == BT_UNKNOWN
13117 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13118 && !el->sym->attr.untyped)
13120 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13121 el->sym->name, &el->sym->declared_at);
13122 el->sym->attr.untyped = 1;
13128 /* 12.3.2.1.1 Defined operators. */
13131 check_uop_procedure (gfc_symbol *sym, locus where)
13133 gfc_formal_arglist *formal;
13135 if (!sym->attr.function)
13137 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13138 sym->name, &where);
13142 if (sym->ts.type == BT_CHARACTER
13143 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13144 && !(sym->result && sym->result->ts.u.cl
13145 && sym->result->ts.u.cl->length))
13147 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13148 "character length", sym->name, &where);
13152 formal = sym->formal;
13153 if (!formal || !formal->sym)
13155 gfc_error ("User operator procedure '%s' at %L must have at least "
13156 "one argument", sym->name, &where);
13160 if (formal->sym->attr.intent != INTENT_IN)
13162 gfc_error ("First argument of operator interface at %L must be "
13163 "INTENT(IN)", &where);
13167 if (formal->sym->attr.optional)
13169 gfc_error ("First argument of operator interface at %L cannot be "
13170 "optional", &where);
13174 formal = formal->next;
13175 if (!formal || !formal->sym)
13178 if (formal->sym->attr.intent != INTENT_IN)
13180 gfc_error ("Second argument of operator interface at %L must be "
13181 "INTENT(IN)", &where);
13185 if (formal->sym->attr.optional)
13187 gfc_error ("Second argument of operator interface at %L cannot be "
13188 "optional", &where);
13194 gfc_error ("Operator interface at %L must have, at most, two "
13195 "arguments", &where);
13203 gfc_resolve_uops (gfc_symtree *symtree)
13205 gfc_interface *itr;
13207 if (symtree == NULL)
13210 gfc_resolve_uops (symtree->left);
13211 gfc_resolve_uops (symtree->right);
13213 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13214 check_uop_procedure (itr->sym, itr->sym->declared_at);
13218 /* Examine all of the expressions associated with a program unit,
13219 assign types to all intermediate expressions, make sure that all
13220 assignments are to compatible types and figure out which names
13221 refer to which functions or subroutines. It doesn't check code
13222 block, which is handled by resolve_code. */
13225 resolve_types (gfc_namespace *ns)
13231 gfc_namespace* old_ns = gfc_current_ns;
13233 /* Check that all IMPLICIT types are ok. */
13234 if (!ns->seen_implicit_none)
13237 for (letter = 0; letter != GFC_LETTERS; ++letter)
13238 if (ns->set_flag[letter]
13239 && resolve_typespec_used (&ns->default_type[letter],
13240 &ns->implicit_loc[letter],
13245 gfc_current_ns = ns;
13247 resolve_entries (ns);
13249 resolve_common_vars (ns->blank_common.head, false);
13250 resolve_common_blocks (ns->common_root);
13252 resolve_contained_functions (ns);
13254 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13256 for (cl = ns->cl_list; cl; cl = cl->next)
13257 resolve_charlen (cl);
13259 gfc_traverse_ns (ns, resolve_symbol);
13261 resolve_fntype (ns);
13263 for (n = ns->contained; n; n = n->sibling)
13265 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13266 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13267 "also be PURE", n->proc_name->name,
13268 &n->proc_name->declared_at);
13274 gfc_check_interfaces (ns);
13276 gfc_traverse_ns (ns, resolve_values);
13282 for (d = ns->data; d; d = d->next)
13286 gfc_traverse_ns (ns, gfc_formalize_init_value);
13288 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13290 if (ns->common_root != NULL)
13291 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13293 for (eq = ns->equiv; eq; eq = eq->next)
13294 resolve_equivalence (eq);
13296 /* Warn about unused labels. */
13297 if (warn_unused_label)
13298 warn_unused_fortran_label (ns->st_labels);
13300 gfc_resolve_uops (ns->uop_root);
13302 gfc_current_ns = old_ns;
13306 /* Call resolve_code recursively. */
13309 resolve_codes (gfc_namespace *ns)
13312 bitmap_obstack old_obstack;
13314 for (n = ns->contained; n; n = n->sibling)
13317 gfc_current_ns = ns;
13319 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13320 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13323 /* Set to an out of range value. */
13324 current_entry_id = -1;
13326 old_obstack = labels_obstack;
13327 bitmap_obstack_initialize (&labels_obstack);
13329 resolve_code (ns->code, ns);
13331 bitmap_obstack_release (&labels_obstack);
13332 labels_obstack = old_obstack;
13336 /* This function is called after a complete program unit has been compiled.
13337 Its purpose is to examine all of the expressions associated with a program
13338 unit, assign types to all intermediate expressions, make sure that all
13339 assignments are to compatible types and figure out which names refer to
13340 which functions or subroutines. */
13343 gfc_resolve (gfc_namespace *ns)
13345 gfc_namespace *old_ns;
13346 code_stack *old_cs_base;
13352 old_ns = gfc_current_ns;
13353 old_cs_base = cs_base;
13355 resolve_types (ns);
13356 resolve_codes (ns);
13358 gfc_current_ns = old_ns;
13359 cs_base = old_cs_base;
13362 gfc_run_passes (ns);