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 /* Resolve types of formal argument lists. These have to be done early so that
130 the formal argument lists of module procedures can be copied to the
131 containing module before the individual procedures are resolved
132 individually. We also resolve argument lists of procedures in interface
133 blocks because they are self-contained scoping units.
135 Since a dummy argument cannot be a non-dummy procedure, the only
136 resort left for untyped names are the IMPLICIT types. */
139 resolve_formal_arglist (gfc_symbol *proc)
141 gfc_formal_arglist *f;
145 if (proc->result != NULL)
150 if (gfc_elemental (proc)
151 || sym->attr.pointer || sym->attr.allocatable
152 || (sym->as && sym->as->rank > 0))
154 proc->attr.always_explicit = 1;
155 sym->attr.always_explicit = 1;
160 for (f = proc->formal; f; f = f->next)
166 /* Alternate return placeholder. */
167 if (gfc_elemental (proc))
168 gfc_error ("Alternate return specifier in elemental subroutine "
169 "'%s' at %L is not allowed", proc->name,
171 if (proc->attr.function)
172 gfc_error ("Alternate return specifier in function "
173 "'%s' at %L is not allowed", proc->name,
178 if (sym->attr.if_source != IFSRC_UNKNOWN)
179 resolve_formal_arglist (sym);
181 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
183 if (gfc_pure (proc) && !gfc_pure (sym))
185 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
186 "also be PURE", sym->name, &sym->declared_at);
190 if (gfc_elemental (proc))
192 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
193 "procedure", &sym->declared_at);
197 if (sym->attr.function
198 && sym->ts.type == BT_UNKNOWN
199 && sym->attr.intrinsic)
201 gfc_intrinsic_sym *isym;
202 isym = gfc_find_function (sym->name);
203 if (isym == NULL || !isym->specific)
205 gfc_error ("Unable to find a specific INTRINSIC procedure "
206 "for the reference '%s' at %L", sym->name,
215 if (sym->ts.type == BT_UNKNOWN)
217 if (!sym->attr.function || sym->result == sym)
218 gfc_set_default_type (sym, 1, sym->ns);
221 gfc_resolve_array_spec (sym->as, 0);
223 /* We can't tell if an array with dimension (:) is assumed or deferred
224 shape until we know if it has the pointer or allocatable attributes.
226 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
227 && !(sym->attr.pointer || sym->attr.allocatable))
229 sym->as->type = AS_ASSUMED_SHAPE;
230 for (i = 0; i < sym->as->rank; i++)
231 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
235 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
236 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
237 || sym->attr.optional)
239 proc->attr.always_explicit = 1;
241 proc->result->attr.always_explicit = 1;
244 /* If the flavor is unknown at this point, it has to be a variable.
245 A procedure specification would have already set the type. */
247 if (sym->attr.flavor == FL_UNKNOWN)
248 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
250 if (gfc_pure (proc) && !sym->attr.pointer
251 && sym->attr.flavor != FL_PROCEDURE)
253 if (proc->attr.function && sym->attr.intent != INTENT_IN)
254 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
255 "INTENT(IN)", sym->name, proc->name,
258 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
259 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
260 "have its INTENT specified", sym->name, proc->name,
264 if (gfc_elemental (proc))
267 if (sym->attr.codimension)
269 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
270 "procedure", sym->name, &sym->declared_at);
276 gfc_error ("Argument '%s' of elemental procedure at %L must "
277 "be scalar", sym->name, &sym->declared_at);
281 if (sym->attr.pointer)
283 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
284 "have the POINTER attribute", sym->name,
289 if (sym->attr.flavor == FL_PROCEDURE)
291 gfc_error ("Dummy procedure '%s' not allowed in elemental "
292 "procedure '%s' at %L", sym->name, proc->name,
298 /* Each dummy shall be specified to be scalar. */
299 if (proc->attr.proc == PROC_ST_FUNCTION)
303 gfc_error ("Argument '%s' of statement function at %L must "
304 "be scalar", sym->name, &sym->declared_at);
308 if (sym->ts.type == BT_CHARACTER)
310 gfc_charlen *cl = sym->ts.u.cl;
311 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
313 gfc_error ("Character-valued argument '%s' of statement "
314 "function at %L must have constant length",
315 sym->name, &sym->declared_at);
325 /* Work function called when searching for symbols that have argument lists
326 associated with them. */
329 find_arglists (gfc_symbol *sym)
331 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
334 resolve_formal_arglist (sym);
338 /* Given a namespace, resolve all formal argument lists within the namespace.
342 resolve_formal_arglists (gfc_namespace *ns)
347 gfc_traverse_ns (ns, find_arglists);
352 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
356 /* If this namespace is not a function or an entry master function,
358 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
359 || sym->attr.entry_master)
362 /* Try to find out of what the return type is. */
363 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
365 t = gfc_set_default_type (sym->result, 0, ns);
367 if (t == FAILURE && !sym->result->attr.untyped)
369 if (sym->result == sym)
370 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
371 sym->name, &sym->declared_at);
372 else if (!sym->result->attr.proc_pointer)
373 gfc_error ("Result '%s' of contained function '%s' at %L has "
374 "no IMPLICIT type", sym->result->name, sym->name,
375 &sym->result->declared_at);
376 sym->result->attr.untyped = 1;
380 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
381 type, lists the only ways a character length value of * can be used:
382 dummy arguments of procedures, named constants, and function results
383 in external functions. Internal function results and results of module
384 procedures are not on this list, ergo, not permitted. */
386 if (sym->result->ts.type == BT_CHARACTER)
388 gfc_charlen *cl = sym->result->ts.u.cl;
389 if (!cl || !cl->length)
391 /* See if this is a module-procedure and adapt error message
394 gcc_assert (ns->parent && ns->parent->proc_name);
395 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
397 gfc_error ("Character-valued %s '%s' at %L must not be"
399 module_proc ? _("module procedure")
400 : _("internal function"),
401 sym->name, &sym->declared_at);
407 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
408 introduce duplicates. */
411 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
413 gfc_formal_arglist *f, *new_arglist;
416 for (; new_args != NULL; new_args = new_args->next)
418 new_sym = new_args->sym;
419 /* See if this arg is already in the formal argument list. */
420 for (f = proc->formal; f; f = f->next)
422 if (new_sym == f->sym)
429 /* Add a new argument. Argument order is not important. */
430 new_arglist = gfc_get_formal_arglist ();
431 new_arglist->sym = new_sym;
432 new_arglist->next = proc->formal;
433 proc->formal = new_arglist;
438 /* Flag the arguments that are not present in all entries. */
441 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
443 gfc_formal_arglist *f, *head;
446 for (f = proc->formal; f; f = f->next)
451 for (new_args = head; new_args; new_args = new_args->next)
453 if (new_args->sym == f->sym)
460 f->sym->attr.not_always_present = 1;
465 /* Resolve alternate entry points. If a symbol has multiple entry points we
466 create a new master symbol for the main routine, and turn the existing
467 symbol into an entry point. */
470 resolve_entries (gfc_namespace *ns)
472 gfc_namespace *old_ns;
476 char name[GFC_MAX_SYMBOL_LEN + 1];
477 static int master_count = 0;
479 if (ns->proc_name == NULL)
482 /* No need to do anything if this procedure doesn't have alternate entry
487 /* We may already have resolved alternate entry points. */
488 if (ns->proc_name->attr.entry_master)
491 /* If this isn't a procedure something has gone horribly wrong. */
492 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
494 /* Remember the current namespace. */
495 old_ns = gfc_current_ns;
499 /* Add the main entry point to the list of entry points. */
500 el = gfc_get_entry_list ();
501 el->sym = ns->proc_name;
503 el->next = ns->entries;
505 ns->proc_name->attr.entry = 1;
507 /* If it is a module function, it needs to be in the right namespace
508 so that gfc_get_fake_result_decl can gather up the results. The
509 need for this arose in get_proc_name, where these beasts were
510 left in their own namespace, to keep prior references linked to
511 the entry declaration.*/
512 if (ns->proc_name->attr.function
513 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
516 /* Do the same for entries where the master is not a module
517 procedure. These are retained in the module namespace because
518 of the module procedure declaration. */
519 for (el = el->next; el; el = el->next)
520 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
521 && el->sym->attr.mod_proc)
525 /* Add an entry statement for it. */
532 /* Create a new symbol for the master function. */
533 /* Give the internal function a unique name (within this file).
534 Also include the function name so the user has some hope of figuring
535 out what is going on. */
536 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
537 master_count++, ns->proc_name->name);
538 gfc_get_ha_symbol (name, &proc);
539 gcc_assert (proc != NULL);
541 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
542 if (ns->proc_name->attr.subroutine)
543 gfc_add_subroutine (&proc->attr, proc->name, NULL);
547 gfc_typespec *ts, *fts;
548 gfc_array_spec *as, *fas;
549 gfc_add_function (&proc->attr, proc->name, NULL);
551 fas = ns->entries->sym->as;
552 fas = fas ? fas : ns->entries->sym->result->as;
553 fts = &ns->entries->sym->result->ts;
554 if (fts->type == BT_UNKNOWN)
555 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
556 for (el = ns->entries->next; el; el = el->next)
558 ts = &el->sym->result->ts;
560 as = as ? as : el->sym->result->as;
561 if (ts->type == BT_UNKNOWN)
562 ts = gfc_get_default_type (el->sym->result->name, NULL);
564 if (! gfc_compare_types (ts, fts)
565 || (el->sym->result->attr.dimension
566 != ns->entries->sym->result->attr.dimension)
567 || (el->sym->result->attr.pointer
568 != ns->entries->sym->result->attr.pointer))
570 else if (as && fas && ns->entries->sym->result != el->sym->result
571 && gfc_compare_array_spec (as, fas) == 0)
572 gfc_error ("Function %s at %L has entries with mismatched "
573 "array specifications", ns->entries->sym->name,
574 &ns->entries->sym->declared_at);
575 /* The characteristics need to match and thus both need to have
576 the same string length, i.e. both len=*, or both len=4.
577 Having both len=<variable> is also possible, but difficult to
578 check at compile time. */
579 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
580 && (((ts->u.cl->length && !fts->u.cl->length)
581 ||(!ts->u.cl->length && fts->u.cl->length))
583 && ts->u.cl->length->expr_type
584 != fts->u.cl->length->expr_type)
586 && ts->u.cl->length->expr_type == EXPR_CONSTANT
587 && mpz_cmp (ts->u.cl->length->value.integer,
588 fts->u.cl->length->value.integer) != 0)))
589 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
590 "entries returning variables of different "
591 "string lengths", ns->entries->sym->name,
592 &ns->entries->sym->declared_at);
597 sym = ns->entries->sym->result;
598 /* All result types the same. */
600 if (sym->attr.dimension)
601 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
602 if (sym->attr.pointer)
603 gfc_add_pointer (&proc->attr, NULL);
607 /* Otherwise the result will be passed through a union by
609 proc->attr.mixed_entry_master = 1;
610 for (el = ns->entries; el; el = el->next)
612 sym = el->sym->result;
613 if (sym->attr.dimension)
615 if (el == ns->entries)
616 gfc_error ("FUNCTION result %s can't be an array in "
617 "FUNCTION %s at %L", sym->name,
618 ns->entries->sym->name, &sym->declared_at);
620 gfc_error ("ENTRY result %s can't be an array in "
621 "FUNCTION %s at %L", sym->name,
622 ns->entries->sym->name, &sym->declared_at);
624 else if (sym->attr.pointer)
626 if (el == ns->entries)
627 gfc_error ("FUNCTION result %s can't be a POINTER in "
628 "FUNCTION %s at %L", sym->name,
629 ns->entries->sym->name, &sym->declared_at);
631 gfc_error ("ENTRY result %s can't be a POINTER in "
632 "FUNCTION %s at %L", sym->name,
633 ns->entries->sym->name, &sym->declared_at);
638 if (ts->type == BT_UNKNOWN)
639 ts = gfc_get_default_type (sym->name, NULL);
643 if (ts->kind == gfc_default_integer_kind)
647 if (ts->kind == gfc_default_real_kind
648 || ts->kind == gfc_default_double_kind)
652 if (ts->kind == gfc_default_complex_kind)
656 if (ts->kind == gfc_default_logical_kind)
660 /* We will issue error elsewhere. */
668 if (el == ns->entries)
669 gfc_error ("FUNCTION result %s can't be of type %s "
670 "in FUNCTION %s at %L", sym->name,
671 gfc_typename (ts), ns->entries->sym->name,
674 gfc_error ("ENTRY result %s can't be of type %s "
675 "in FUNCTION %s at %L", sym->name,
676 gfc_typename (ts), ns->entries->sym->name,
683 proc->attr.access = ACCESS_PRIVATE;
684 proc->attr.entry_master = 1;
686 /* Merge all the entry point arguments. */
687 for (el = ns->entries; el; el = el->next)
688 merge_argument_lists (proc, el->sym->formal);
690 /* Check the master formal arguments for any that are not
691 present in all entry points. */
692 for (el = ns->entries; el; el = el->next)
693 check_argument_lists (proc, el->sym->formal);
695 /* Use the master function for the function body. */
696 ns->proc_name = proc;
698 /* Finalize the new symbols. */
699 gfc_commit_symbols ();
701 /* Restore the original namespace. */
702 gfc_current_ns = old_ns;
706 /* Resolve common variables. */
708 resolve_common_vars (gfc_symbol *sym, bool named_common)
710 gfc_symbol *csym = sym;
712 for (; csym; csym = csym->common_next)
714 if (csym->value || csym->attr.data)
716 if (!csym->ns->is_block_data)
717 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
718 "but only in BLOCK DATA initialization is "
719 "allowed", csym->name, &csym->declared_at);
720 else if (!named_common)
721 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
722 "in a blank COMMON but initialization is only "
723 "allowed in named common blocks", csym->name,
727 if (csym->ts.type != BT_DERIVED)
730 if (!(csym->ts.u.derived->attr.sequence
731 || csym->ts.u.derived->attr.is_bind_c))
732 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
733 "has neither the SEQUENCE nor the BIND(C) "
734 "attribute", csym->name, &csym->declared_at);
735 if (csym->ts.u.derived->attr.alloc_comp)
736 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
737 "has an ultimate component that is "
738 "allocatable", csym->name, &csym->declared_at);
739 if (gfc_has_default_initializer (csym->ts.u.derived))
740 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
741 "may not have default initializer", csym->name,
744 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
745 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
749 /* Resolve common blocks. */
751 resolve_common_blocks (gfc_symtree *common_root)
755 if (common_root == NULL)
758 if (common_root->left)
759 resolve_common_blocks (common_root->left);
760 if (common_root->right)
761 resolve_common_blocks (common_root->right);
763 resolve_common_vars (common_root->n.common->head, true);
765 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
769 if (sym->attr.flavor == FL_PARAMETER)
770 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
771 sym->name, &common_root->n.common->where, &sym->declared_at);
773 if (sym->attr.intrinsic)
774 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
775 sym->name, &common_root->n.common->where);
776 else if (sym->attr.result
777 || gfc_is_function_return_value (sym, gfc_current_ns))
778 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
779 "that is also a function result", sym->name,
780 &common_root->n.common->where);
781 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
782 && sym->attr.proc != PROC_ST_FUNCTION)
783 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
784 "that is also a global procedure", sym->name,
785 &common_root->n.common->where);
789 /* Resolve contained function types. Because contained functions can call one
790 another, they have to be worked out before any of the contained procedures
793 The good news is that if a function doesn't already have a type, the only
794 way it can get one is through an IMPLICIT type or a RESULT variable, because
795 by definition contained functions are contained namespace they're contained
796 in, not in a sibling or parent namespace. */
799 resolve_contained_functions (gfc_namespace *ns)
801 gfc_namespace *child;
804 resolve_formal_arglists (ns);
806 for (child = ns->contained; child; child = child->sibling)
808 /* Resolve alternate entry points first. */
809 resolve_entries (child);
811 /* Then check function return types. */
812 resolve_contained_fntype (child->proc_name, child);
813 for (el = child->entries; el; el = el->next)
814 resolve_contained_fntype (el->sym, child);
819 /* Resolve all of the elements of a structure constructor and make sure that
820 the types are correct. */
823 resolve_structure_cons (gfc_expr *expr)
825 gfc_constructor *cons;
831 cons = gfc_constructor_first (expr->value.constructor);
832 /* A constructor may have references if it is the result of substituting a
833 parameter variable. In this case we just pull out the component we
836 comp = expr->ref->u.c.sym->components;
838 comp = expr->ts.u.derived->components;
840 /* See if the user is trying to invoke a structure constructor for one of
841 the iso_c_binding derived types. */
842 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
843 && expr->ts.u.derived->ts.is_iso_c && cons
844 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
846 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
847 expr->ts.u.derived->name, &(expr->where));
851 /* Return if structure constructor is c_null_(fun)prt. */
852 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
853 && expr->ts.u.derived->ts.is_iso_c && cons
854 && cons->expr && cons->expr->expr_type == EXPR_NULL)
857 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
864 if (gfc_resolve_expr (cons->expr) == FAILURE)
870 rank = comp->as ? comp->as->rank : 0;
871 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
872 && (comp->attr.allocatable || cons->expr->rank))
874 gfc_error ("The rank of the element in the derived type "
875 "constructor at %L does not match that of the "
876 "component (%d/%d)", &cons->expr->where,
877 cons->expr->rank, rank);
881 /* If we don't have the right type, try to convert it. */
883 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
886 if (strcmp (comp->name, "$extends") == 0)
888 /* Can afford to be brutal with the $extends initializer.
889 The derived type can get lost because it is PRIVATE
890 but it is not usage constrained by the standard. */
891 cons->expr->ts = comp->ts;
894 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
895 gfc_error ("The element in the derived type constructor at %L, "
896 "for pointer component '%s', is %s but should be %s",
897 &cons->expr->where, comp->name,
898 gfc_basic_typename (cons->expr->ts.type),
899 gfc_basic_typename (comp->ts.type));
901 t = gfc_convert_type (cons->expr, &comp->ts, 1);
904 if (cons->expr->expr_type == EXPR_NULL
905 && !(comp->attr.pointer || comp->attr.allocatable
906 || comp->attr.proc_pointer
907 || (comp->ts.type == BT_CLASS
908 && (comp->ts.u.derived->components->attr.pointer
909 || comp->ts.u.derived->components->attr.allocatable))))
912 gfc_error ("The NULL in the derived type constructor at %L is "
913 "being applied to component '%s', which is neither "
914 "a POINTER nor ALLOCATABLE", &cons->expr->where,
918 if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
921 a = gfc_expr_attr (cons->expr);
923 if (!a.pointer && !a.target)
926 gfc_error ("The element in the derived type constructor at %L, "
927 "for pointer component '%s' should be a POINTER or "
928 "a TARGET", &cons->expr->where, comp->name);
931 /* F2003, C1272 (3). */
932 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
933 && (gfc_impure_variable (cons->expr->symtree->n.sym)
934 || gfc_is_coindexed (cons->expr)))
937 gfc_error ("Invalid expression in the derived type constructor for "
938 "pointer component '%s' at %L in PURE procedure",
939 comp->name, &cons->expr->where);
947 /****************** Expression name resolution ******************/
949 /* Returns 0 if a symbol was not declared with a type or
950 attribute declaration statement, nonzero otherwise. */
953 was_declared (gfc_symbol *sym)
959 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
962 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
963 || a.optional || a.pointer || a.save || a.target || a.volatile_
964 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
965 || a.asynchronous || a.codimension)
972 /* Determine if a symbol is generic or not. */
975 generic_sym (gfc_symbol *sym)
979 if (sym->attr.generic ||
980 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
983 if (was_declared (sym) || sym->ns->parent == NULL)
986 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
993 return generic_sym (s);
1000 /* Determine if a symbol is specific or not. */
1003 specific_sym (gfc_symbol *sym)
1007 if (sym->attr.if_source == IFSRC_IFBODY
1008 || sym->attr.proc == PROC_MODULE
1009 || sym->attr.proc == PROC_INTERNAL
1010 || sym->attr.proc == PROC_ST_FUNCTION
1011 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1012 || sym->attr.external)
1015 if (was_declared (sym) || sym->ns->parent == NULL)
1018 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1020 return (s == NULL) ? 0 : specific_sym (s);
1024 /* Figure out if the procedure is specific, generic or unknown. */
1027 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1031 procedure_kind (gfc_symbol *sym)
1033 if (generic_sym (sym))
1034 return PTYPE_GENERIC;
1036 if (specific_sym (sym))
1037 return PTYPE_SPECIFIC;
1039 return PTYPE_UNKNOWN;
1042 /* Check references to assumed size arrays. The flag need_full_assumed_size
1043 is nonzero when matching actual arguments. */
1045 static int need_full_assumed_size = 0;
1048 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1050 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1053 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1054 What should it be? */
1055 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1056 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1057 && (e->ref->u.ar.type == AR_FULL))
1059 gfc_error ("The upper bound in the last dimension must "
1060 "appear in the reference to the assumed size "
1061 "array '%s' at %L", sym->name, &e->where);
1068 /* Look for bad assumed size array references in argument expressions
1069 of elemental and array valued intrinsic procedures. Since this is
1070 called from procedure resolution functions, it only recurses at
1074 resolve_assumed_size_actual (gfc_expr *e)
1079 switch (e->expr_type)
1082 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1087 if (resolve_assumed_size_actual (e->value.op.op1)
1088 || resolve_assumed_size_actual (e->value.op.op2))
1099 /* Check a generic procedure, passed as an actual argument, to see if
1100 there is a matching specific name. If none, it is an error, and if
1101 more than one, the reference is ambiguous. */
1103 count_specific_procs (gfc_expr *e)
1110 sym = e->symtree->n.sym;
1112 for (p = sym->generic; p; p = p->next)
1113 if (strcmp (sym->name, p->sym->name) == 0)
1115 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1121 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1125 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1126 "argument at %L", sym->name, &e->where);
1132 /* See if a call to sym could possibly be a not allowed RECURSION because of
1133 a missing RECURIVE declaration. This means that either sym is the current
1134 context itself, or sym is the parent of a contained procedure calling its
1135 non-RECURSIVE containing procedure.
1136 This also works if sym is an ENTRY. */
1139 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1141 gfc_symbol* proc_sym;
1142 gfc_symbol* context_proc;
1143 gfc_namespace* real_context;
1145 if (sym->attr.flavor == FL_PROGRAM)
1148 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1150 /* If we've got an ENTRY, find real procedure. */
1151 if (sym->attr.entry && sym->ns->entries)
1152 proc_sym = sym->ns->entries->sym;
1156 /* If sym is RECURSIVE, all is well of course. */
1157 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1160 /* Find the context procedure's "real" symbol if it has entries.
1161 We look for a procedure symbol, so recurse on the parents if we don't
1162 find one (like in case of a BLOCK construct). */
1163 for (real_context = context; ; real_context = real_context->parent)
1165 /* We should find something, eventually! */
1166 gcc_assert (real_context);
1168 context_proc = (real_context->entries ? real_context->entries->sym
1169 : real_context->proc_name);
1171 /* In some special cases, there may not be a proc_name, like for this
1173 real(bad_kind()) function foo () ...
1174 when checking the call to bad_kind ().
1175 In these cases, we simply return here and assume that the
1180 if (context_proc->attr.flavor != FL_LABEL)
1184 /* A call from sym's body to itself is recursion, of course. */
1185 if (context_proc == proc_sym)
1188 /* The same is true if context is a contained procedure and sym the
1190 if (context_proc->attr.contained)
1192 gfc_symbol* parent_proc;
1194 gcc_assert (context->parent);
1195 parent_proc = (context->parent->entries ? context->parent->entries->sym
1196 : context->parent->proc_name);
1198 if (parent_proc == proc_sym)
1206 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1207 its typespec and formal argument list. */
1210 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1212 gfc_intrinsic_sym* isym;
1218 /* We already know this one is an intrinsic, so we don't call
1219 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1220 gfc_find_subroutine directly to check whether it is a function or
1223 if ((isym = gfc_find_function (sym->name)))
1225 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1226 && !sym->attr.implicit_type)
1227 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1228 " ignored", sym->name, &sym->declared_at);
1230 if (!sym->attr.function &&
1231 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1236 else if ((isym = gfc_find_subroutine (sym->name)))
1238 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1240 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1241 " specifier", sym->name, &sym->declared_at);
1245 if (!sym->attr.subroutine &&
1246 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1251 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1256 gfc_copy_formal_args_intr (sym, isym);
1258 /* Check it is actually available in the standard settings. */
1259 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1262 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1263 " available in the current standard settings but %s. Use"
1264 " an appropriate -std=* option or enable -fall-intrinsics"
1265 " in order to use it.",
1266 sym->name, &sym->declared_at, symstd);
1274 /* Resolve a procedure expression, like passing it to a called procedure or as
1275 RHS for a procedure pointer assignment. */
1278 resolve_procedure_expression (gfc_expr* expr)
1282 if (expr->expr_type != EXPR_VARIABLE)
1284 gcc_assert (expr->symtree);
1286 sym = expr->symtree->n.sym;
1288 if (sym->attr.intrinsic)
1289 resolve_intrinsic (sym, &expr->where);
1291 if (sym->attr.flavor != FL_PROCEDURE
1292 || (sym->attr.function && sym->result == sym))
1295 /* A non-RECURSIVE procedure that is used as procedure expression within its
1296 own body is in danger of being called recursively. */
1297 if (is_illegal_recursion (sym, gfc_current_ns))
1298 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1299 " itself recursively. Declare it RECURSIVE or use"
1300 " -frecursive", sym->name, &expr->where);
1306 /* Resolve an actual argument list. Most of the time, this is just
1307 resolving the expressions in the list.
1308 The exception is that we sometimes have to decide whether arguments
1309 that look like procedure arguments are really simple variable
1313 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1314 bool no_formal_args)
1317 gfc_symtree *parent_st;
1319 int save_need_full_assumed_size;
1320 gfc_component *comp;
1322 for (; arg; arg = arg->next)
1327 /* Check the label is a valid branching target. */
1330 if (arg->label->defined == ST_LABEL_UNKNOWN)
1332 gfc_error ("Label %d referenced at %L is never defined",
1333 arg->label->value, &arg->label->where);
1340 if (gfc_is_proc_ptr_comp (e, &comp))
1343 if (e->expr_type == EXPR_PPC)
1345 if (comp->as != NULL)
1346 e->rank = comp->as->rank;
1347 e->expr_type = EXPR_FUNCTION;
1349 if (gfc_resolve_expr (e) == FAILURE)
1354 if (e->expr_type == EXPR_VARIABLE
1355 && e->symtree->n.sym->attr.generic
1357 && count_specific_procs (e) != 1)
1360 if (e->ts.type != BT_PROCEDURE)
1362 save_need_full_assumed_size = need_full_assumed_size;
1363 if (e->expr_type != EXPR_VARIABLE)
1364 need_full_assumed_size = 0;
1365 if (gfc_resolve_expr (e) != SUCCESS)
1367 need_full_assumed_size = save_need_full_assumed_size;
1371 /* See if the expression node should really be a variable reference. */
1373 sym = e->symtree->n.sym;
1375 if (sym->attr.flavor == FL_PROCEDURE
1376 || sym->attr.intrinsic
1377 || sym->attr.external)
1381 /* If a procedure is not already determined to be something else
1382 check if it is intrinsic. */
1383 if (!sym->attr.intrinsic
1384 && !(sym->attr.external || sym->attr.use_assoc
1385 || sym->attr.if_source == IFSRC_IFBODY)
1386 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1387 sym->attr.intrinsic = 1;
1389 if (sym->attr.proc == PROC_ST_FUNCTION)
1391 gfc_error ("Statement function '%s' at %L is not allowed as an "
1392 "actual argument", sym->name, &e->where);
1395 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1396 sym->attr.subroutine);
1397 if (sym->attr.intrinsic && actual_ok == 0)
1399 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1400 "actual argument", sym->name, &e->where);
1403 if (sym->attr.contained && !sym->attr.use_assoc
1404 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1406 gfc_error ("Internal procedure '%s' is not allowed as an "
1407 "actual argument at %L", sym->name, &e->where);
1410 if (sym->attr.elemental && !sym->attr.intrinsic)
1412 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1413 "allowed as an actual argument at %L", sym->name,
1417 /* Check if a generic interface has a specific procedure
1418 with the same name before emitting an error. */
1419 if (sym->attr.generic && count_specific_procs (e) != 1)
1422 /* Just in case a specific was found for the expression. */
1423 sym = e->symtree->n.sym;
1425 /* If the symbol is the function that names the current (or
1426 parent) scope, then we really have a variable reference. */
1428 if (gfc_is_function_return_value (sym, sym->ns))
1431 /* If all else fails, see if we have a specific intrinsic. */
1432 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1434 gfc_intrinsic_sym *isym;
1436 isym = gfc_find_function (sym->name);
1437 if (isym == NULL || !isym->specific)
1439 gfc_error ("Unable to find a specific INTRINSIC procedure "
1440 "for the reference '%s' at %L", sym->name,
1445 sym->attr.intrinsic = 1;
1446 sym->attr.function = 1;
1449 if (gfc_resolve_expr (e) == FAILURE)
1454 /* See if the name is a module procedure in a parent unit. */
1456 if (was_declared (sym) || sym->ns->parent == NULL)
1459 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1461 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1465 if (parent_st == NULL)
1468 sym = parent_st->n.sym;
1469 e->symtree = parent_st; /* Point to the right thing. */
1471 if (sym->attr.flavor == FL_PROCEDURE
1472 || sym->attr.intrinsic
1473 || sym->attr.external)
1475 if (gfc_resolve_expr (e) == FAILURE)
1481 e->expr_type = EXPR_VARIABLE;
1483 if (sym->as != NULL)
1485 e->rank = sym->as->rank;
1486 e->ref = gfc_get_ref ();
1487 e->ref->type = REF_ARRAY;
1488 e->ref->u.ar.type = AR_FULL;
1489 e->ref->u.ar.as = sym->as;
1492 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1493 primary.c (match_actual_arg). If above code determines that it
1494 is a variable instead, it needs to be resolved as it was not
1495 done at the beginning of this function. */
1496 save_need_full_assumed_size = need_full_assumed_size;
1497 if (e->expr_type != EXPR_VARIABLE)
1498 need_full_assumed_size = 0;
1499 if (gfc_resolve_expr (e) != SUCCESS)
1501 need_full_assumed_size = save_need_full_assumed_size;
1504 /* Check argument list functions %VAL, %LOC and %REF. There is
1505 nothing to do for %REF. */
1506 if (arg->name && arg->name[0] == '%')
1508 if (strncmp ("%VAL", arg->name, 4) == 0)
1510 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1512 gfc_error ("By-value argument at %L is not of numeric "
1519 gfc_error ("By-value argument at %L cannot be an array or "
1520 "an array section", &e->where);
1524 /* Intrinsics are still PROC_UNKNOWN here. However,
1525 since same file external procedures are not resolvable
1526 in gfortran, it is a good deal easier to leave them to
1528 if (ptype != PROC_UNKNOWN
1529 && ptype != PROC_DUMMY
1530 && ptype != PROC_EXTERNAL
1531 && ptype != PROC_MODULE)
1533 gfc_error ("By-value argument at %L is not allowed "
1534 "in this context", &e->where);
1539 /* Statement functions have already been excluded above. */
1540 else if (strncmp ("%LOC", arg->name, 4) == 0
1541 && e->ts.type == BT_PROCEDURE)
1543 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1545 gfc_error ("Passing internal procedure at %L by location "
1546 "not allowed", &e->where);
1552 /* Fortran 2008, C1237. */
1553 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1554 && gfc_has_ultimate_pointer (e))
1556 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1557 "component", &e->where);
1566 /* Do the checks of the actual argument list that are specific to elemental
1567 procedures. If called with c == NULL, we have a function, otherwise if
1568 expr == NULL, we have a subroutine. */
1571 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1573 gfc_actual_arglist *arg0;
1574 gfc_actual_arglist *arg;
1575 gfc_symbol *esym = NULL;
1576 gfc_intrinsic_sym *isym = NULL;
1578 gfc_intrinsic_arg *iformal = NULL;
1579 gfc_formal_arglist *eformal = NULL;
1580 bool formal_optional = false;
1581 bool set_by_optional = false;
1585 /* Is this an elemental procedure? */
1586 if (expr && expr->value.function.actual != NULL)
1588 if (expr->value.function.esym != NULL
1589 && expr->value.function.esym->attr.elemental)
1591 arg0 = expr->value.function.actual;
1592 esym = expr->value.function.esym;
1594 else if (expr->value.function.isym != NULL
1595 && expr->value.function.isym->elemental)
1597 arg0 = expr->value.function.actual;
1598 isym = expr->value.function.isym;
1603 else if (c && c->ext.actual != NULL)
1605 arg0 = c->ext.actual;
1607 if (c->resolved_sym)
1608 esym = c->resolved_sym;
1610 esym = c->symtree->n.sym;
1613 if (!esym->attr.elemental)
1619 /* The rank of an elemental is the rank of its array argument(s). */
1620 for (arg = arg0; arg; arg = arg->next)
1622 if (arg->expr != NULL && arg->expr->rank > 0)
1624 rank = arg->expr->rank;
1625 if (arg->expr->expr_type == EXPR_VARIABLE
1626 && arg->expr->symtree->n.sym->attr.optional)
1627 set_by_optional = true;
1629 /* Function specific; set the result rank and shape. */
1633 if (!expr->shape && arg->expr->shape)
1635 expr->shape = gfc_get_shape (rank);
1636 for (i = 0; i < rank; i++)
1637 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1644 /* If it is an array, it shall not be supplied as an actual argument
1645 to an elemental procedure unless an array of the same rank is supplied
1646 as an actual argument corresponding to a nonoptional dummy argument of
1647 that elemental procedure(12.4.1.5). */
1648 formal_optional = false;
1650 iformal = isym->formal;
1652 eformal = esym->formal;
1654 for (arg = arg0; arg; arg = arg->next)
1658 if (eformal->sym && eformal->sym->attr.optional)
1659 formal_optional = true;
1660 eformal = eformal->next;
1662 else if (isym && iformal)
1664 if (iformal->optional)
1665 formal_optional = true;
1666 iformal = iformal->next;
1669 formal_optional = true;
1671 if (pedantic && arg->expr != NULL
1672 && arg->expr->expr_type == EXPR_VARIABLE
1673 && arg->expr->symtree->n.sym->attr.optional
1676 && (set_by_optional || arg->expr->rank != rank)
1677 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1679 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1680 "MISSING, it cannot be the actual argument of an "
1681 "ELEMENTAL procedure unless there is a non-optional "
1682 "argument with the same rank (12.4.1.5)",
1683 arg->expr->symtree->n.sym->name, &arg->expr->where);
1688 for (arg = arg0; arg; arg = arg->next)
1690 if (arg->expr == NULL || arg->expr->rank == 0)
1693 /* Being elemental, the last upper bound of an assumed size array
1694 argument must be present. */
1695 if (resolve_assumed_size_actual (arg->expr))
1698 /* Elemental procedure's array actual arguments must conform. */
1701 if (gfc_check_conformance (arg->expr, e,
1702 "elemental procedure") == FAILURE)
1709 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1710 is an array, the intent inout/out variable needs to be also an array. */
1711 if (rank > 0 && esym && expr == NULL)
1712 for (eformal = esym->formal, arg = arg0; arg && eformal;
1713 arg = arg->next, eformal = eformal->next)
1714 if ((eformal->sym->attr.intent == INTENT_OUT
1715 || eformal->sym->attr.intent == INTENT_INOUT)
1716 && arg->expr && arg->expr->rank == 0)
1718 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1719 "ELEMENTAL subroutine '%s' is a scalar, but another "
1720 "actual argument is an array", &arg->expr->where,
1721 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1722 : "INOUT", eformal->sym->name, esym->name);
1729 /* Go through each actual argument in ACTUAL and see if it can be
1730 implemented as an inlined, non-copying intrinsic. FNSYM is the
1731 function being called, or NULL if not known. */
1734 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1736 gfc_actual_arglist *ap;
1739 for (ap = actual; ap; ap = ap->next)
1741 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1742 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1744 ap->expr->inline_noncopying_intrinsic = 1;
1748 /* This function does the checking of references to global procedures
1749 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1750 77 and 95 standards. It checks for a gsymbol for the name, making
1751 one if it does not already exist. If it already exists, then the
1752 reference being resolved must correspond to the type of gsymbol.
1753 Otherwise, the new symbol is equipped with the attributes of the
1754 reference. The corresponding code that is called in creating
1755 global entities is parse.c.
1757 In addition, for all but -std=legacy, the gsymbols are used to
1758 check the interfaces of external procedures from the same file.
1759 The namespace of the gsymbol is resolved and then, once this is
1760 done the interface is checked. */
1764 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1766 if (!gsym_ns->proc_name->attr.recursive)
1769 if (sym->ns == gsym_ns)
1772 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1779 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1781 if (gsym_ns->entries)
1783 gfc_entry_list *entry = gsym_ns->entries;
1785 for (; entry; entry = entry->next)
1787 if (strcmp (sym->name, entry->sym->name) == 0)
1789 if (strcmp (gsym_ns->proc_name->name,
1790 sym->ns->proc_name->name) == 0)
1794 && strcmp (gsym_ns->proc_name->name,
1795 sym->ns->parent->proc_name->name) == 0)
1804 resolve_global_procedure (gfc_symbol *sym, locus *where,
1805 gfc_actual_arglist **actual, int sub)
1809 enum gfc_symbol_type type;
1811 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1813 gsym = gfc_get_gsymbol (sym->name);
1815 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1816 gfc_global_used (gsym, where);
1818 if (gfc_option.flag_whole_file
1819 && sym->attr.if_source == IFSRC_UNKNOWN
1820 && gsym->type != GSYM_UNKNOWN
1822 && gsym->ns->resolved != -1
1823 && gsym->ns->proc_name
1824 && not_in_recursive (sym, gsym->ns)
1825 && not_entry_self_reference (sym, gsym->ns))
1827 /* Make sure that translation for the gsymbol occurs before
1828 the procedure currently being resolved. */
1829 ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
1830 for (; ns && ns != gsym->ns; ns = ns->sibling)
1832 if (ns->sibling == gsym->ns)
1834 ns->sibling = gsym->ns->sibling;
1835 gsym->ns->sibling = gfc_global_ns_list;
1836 gfc_global_ns_list = gsym->ns;
1841 if (!gsym->ns->resolved)
1843 gfc_dt_list *old_dt_list;
1845 /* Stash away derived types so that the backend_decls do not
1847 old_dt_list = gfc_derived_types;
1848 gfc_derived_types = NULL;
1850 gfc_resolve (gsym->ns);
1852 /* Store the new derived types with the global namespace. */
1853 if (gfc_derived_types)
1854 gsym->ns->derived_types = gfc_derived_types;
1856 /* Restore the derived types of this namespace. */
1857 gfc_derived_types = old_dt_list;
1860 if (gsym->ns->proc_name->attr.function
1861 && gsym->ns->proc_name->as
1862 && gsym->ns->proc_name->as->rank
1863 && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
1864 gfc_error ("The reference to function '%s' at %L either needs an "
1865 "explicit INTERFACE or the rank is incorrect", sym->name,
1868 /* Non-assumed length character functions. */
1869 if (sym->attr.function && sym->ts.type == BT_CHARACTER
1870 && gsym->ns->proc_name->ts.u.cl->length != NULL)
1872 gfc_charlen *cl = sym->ts.u.cl;
1874 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
1875 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
1877 gfc_error ("Nonconstant character-length function '%s' at %L "
1878 "must have an explicit interface", sym->name,
1883 if (gfc_option.flag_whole_file == 1
1884 || ((gfc_option.warn_std & GFC_STD_LEGACY)
1886 !(gfc_option.warn_std & GFC_STD_GNU)))
1887 gfc_errors_to_warnings (1);
1889 gfc_procedure_use (gsym->ns->proc_name, actual, where);
1891 gfc_errors_to_warnings (0);
1894 if (gsym->type == GSYM_UNKNOWN)
1897 gsym->where = *where;
1904 /************* Function resolution *************/
1906 /* Resolve a function call known to be generic.
1907 Section 14.1.2.4.1. */
1910 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1914 if (sym->attr.generic)
1916 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1919 expr->value.function.name = s->name;
1920 expr->value.function.esym = s;
1922 if (s->ts.type != BT_UNKNOWN)
1924 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1925 expr->ts = s->result->ts;
1928 expr->rank = s->as->rank;
1929 else if (s->result != NULL && s->result->as != NULL)
1930 expr->rank = s->result->as->rank;
1932 gfc_set_sym_referenced (expr->value.function.esym);
1937 /* TODO: Need to search for elemental references in generic
1941 if (sym->attr.intrinsic)
1942 return gfc_intrinsic_func_interface (expr, 0);
1949 resolve_generic_f (gfc_expr *expr)
1954 sym = expr->symtree->n.sym;
1958 m = resolve_generic_f0 (expr, sym);
1961 else if (m == MATCH_ERROR)
1965 if (sym->ns->parent == NULL)
1967 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1971 if (!generic_sym (sym))
1975 /* Last ditch attempt. See if the reference is to an intrinsic
1976 that possesses a matching interface. 14.1.2.4 */
1977 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1979 gfc_error ("There is no specific function for the generic '%s' at %L",
1980 expr->symtree->n.sym->name, &expr->where);
1984 m = gfc_intrinsic_func_interface (expr, 0);
1988 gfc_error ("Generic function '%s' at %L is not consistent with a "
1989 "specific intrinsic interface", expr->symtree->n.sym->name,
1996 /* Resolve a function call known to be specific. */
1999 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2003 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2005 if (sym->attr.dummy)
2007 sym->attr.proc = PROC_DUMMY;
2011 sym->attr.proc = PROC_EXTERNAL;
2015 if (sym->attr.proc == PROC_MODULE
2016 || sym->attr.proc == PROC_ST_FUNCTION
2017 || sym->attr.proc == PROC_INTERNAL)
2020 if (sym->attr.intrinsic)
2022 m = gfc_intrinsic_func_interface (expr, 1);
2026 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2027 "with an intrinsic", sym->name, &expr->where);
2035 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2038 expr->ts = sym->result->ts;
2041 expr->value.function.name = sym->name;
2042 expr->value.function.esym = sym;
2043 if (sym->as != NULL)
2044 expr->rank = sym->as->rank;
2051 resolve_specific_f (gfc_expr *expr)
2056 sym = expr->symtree->n.sym;
2060 m = resolve_specific_f0 (sym, expr);
2063 if (m == MATCH_ERROR)
2066 if (sym->ns->parent == NULL)
2069 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2075 gfc_error ("Unable to resolve the specific function '%s' at %L",
2076 expr->symtree->n.sym->name, &expr->where);
2082 /* Resolve a procedure call not known to be generic nor specific. */
2085 resolve_unknown_f (gfc_expr *expr)
2090 sym = expr->symtree->n.sym;
2092 if (sym->attr.dummy)
2094 sym->attr.proc = PROC_DUMMY;
2095 expr->value.function.name = sym->name;
2099 /* See if we have an intrinsic function reference. */
2101 if (gfc_is_intrinsic (sym, 0, expr->where))
2103 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2108 /* The reference is to an external name. */
2110 sym->attr.proc = PROC_EXTERNAL;
2111 expr->value.function.name = sym->name;
2112 expr->value.function.esym = expr->symtree->n.sym;
2114 if (sym->as != NULL)
2115 expr->rank = sym->as->rank;
2117 /* Type of the expression is either the type of the symbol or the
2118 default type of the symbol. */
2121 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2123 if (sym->ts.type != BT_UNKNOWN)
2127 ts = gfc_get_default_type (sym->name, sym->ns);
2129 if (ts->type == BT_UNKNOWN)
2131 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2132 sym->name, &expr->where);
2143 /* Return true, if the symbol is an external procedure. */
2145 is_external_proc (gfc_symbol *sym)
2147 if (!sym->attr.dummy && !sym->attr.contained
2148 && !(sym->attr.intrinsic
2149 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2150 && sym->attr.proc != PROC_ST_FUNCTION
2151 && !sym->attr.use_assoc
2159 /* Figure out if a function reference is pure or not. Also set the name
2160 of the function for a potential error message. Return nonzero if the
2161 function is PURE, zero if not. */
2163 pure_stmt_function (gfc_expr *, gfc_symbol *);
2166 pure_function (gfc_expr *e, const char **name)
2172 if (e->symtree != NULL
2173 && e->symtree->n.sym != NULL
2174 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2175 return pure_stmt_function (e, e->symtree->n.sym);
2177 if (e->value.function.esym)
2179 pure = gfc_pure (e->value.function.esym);
2180 *name = e->value.function.esym->name;
2182 else if (e->value.function.isym)
2184 pure = e->value.function.isym->pure
2185 || e->value.function.isym->elemental;
2186 *name = e->value.function.isym->name;
2190 /* Implicit functions are not pure. */
2192 *name = e->value.function.name;
2200 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2201 int *f ATTRIBUTE_UNUSED)
2205 /* Don't bother recursing into other statement functions
2206 since they will be checked individually for purity. */
2207 if (e->expr_type != EXPR_FUNCTION
2209 || e->symtree->n.sym == sym
2210 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2213 return pure_function (e, &name) ? false : true;
2218 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2220 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2225 is_scalar_expr_ptr (gfc_expr *expr)
2227 gfc_try retval = SUCCESS;
2232 /* See if we have a gfc_ref, which means we have a substring, array
2233 reference, or a component. */
2234 if (expr->ref != NULL)
2237 while (ref->next != NULL)
2243 if (ref->u.ss.length != NULL
2244 && ref->u.ss.length->length != NULL
2246 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2248 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2250 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2251 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2252 if (end - start + 1 != 1)
2259 if (ref->u.ar.type == AR_ELEMENT)
2261 else if (ref->u.ar.type == AR_FULL)
2263 /* The user can give a full array if the array is of size 1. */
2264 if (ref->u.ar.as != NULL
2265 && ref->u.ar.as->rank == 1
2266 && ref->u.ar.as->type == AS_EXPLICIT
2267 && ref->u.ar.as->lower[0] != NULL
2268 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2269 && ref->u.ar.as->upper[0] != NULL
2270 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2272 /* If we have a character string, we need to check if
2273 its length is one. */
2274 if (expr->ts.type == BT_CHARACTER)
2276 if (expr->ts.u.cl == NULL
2277 || expr->ts.u.cl->length == NULL
2278 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2284 /* We have constant lower and upper bounds. If the
2285 difference between is 1, it can be considered a
2287 start = (int) mpz_get_si
2288 (ref->u.ar.as->lower[0]->value.integer);
2289 end = (int) mpz_get_si
2290 (ref->u.ar.as->upper[0]->value.integer);
2291 if (end - start + 1 != 1)
2306 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2308 /* Character string. Make sure it's of length 1. */
2309 if (expr->ts.u.cl == NULL
2310 || expr->ts.u.cl->length == NULL
2311 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2314 else if (expr->rank != 0)
2321 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2322 and, in the case of c_associated, set the binding label based on
2326 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2327 gfc_symbol **new_sym)
2329 char name[GFC_MAX_SYMBOL_LEN + 1];
2330 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2331 int optional_arg = 0, is_pointer = 0;
2332 gfc_try retval = SUCCESS;
2333 gfc_symbol *args_sym;
2334 gfc_typespec *arg_ts;
2336 if (args->expr->expr_type == EXPR_CONSTANT
2337 || args->expr->expr_type == EXPR_OP
2338 || args->expr->expr_type == EXPR_NULL)
2340 gfc_error ("Argument to '%s' at %L is not a variable",
2341 sym->name, &(args->expr->where));
2345 args_sym = args->expr->symtree->n.sym;
2347 /* The typespec for the actual arg should be that stored in the expr
2348 and not necessarily that of the expr symbol (args_sym), because
2349 the actual expression could be a part-ref of the expr symbol. */
2350 arg_ts = &(args->expr->ts);
2352 is_pointer = gfc_is_data_pointer (args->expr);
2354 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2356 /* If the user gave two args then they are providing something for
2357 the optional arg (the second cptr). Therefore, set the name and
2358 binding label to the c_associated for two cptrs. Otherwise,
2359 set c_associated to expect one cptr. */
2363 sprintf (name, "%s_2", sym->name);
2364 sprintf (binding_label, "%s_2", sym->binding_label);
2370 sprintf (name, "%s_1", sym->name);
2371 sprintf (binding_label, "%s_1", sym->binding_label);
2375 /* Get a new symbol for the version of c_associated that
2377 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2379 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2380 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2382 sprintf (name, "%s", sym->name);
2383 sprintf (binding_label, "%s", sym->binding_label);
2385 /* Error check the call. */
2386 if (args->next != NULL)
2388 gfc_error_now ("More actual than formal arguments in '%s' "
2389 "call at %L", name, &(args->expr->where));
2392 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2394 /* Make sure we have either the target or pointer attribute. */
2395 if (!args_sym->attr.target && !is_pointer)
2397 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2398 "a TARGET or an associated pointer",
2400 sym->name, &(args->expr->where));
2404 /* See if we have interoperable type and type param. */
2405 if (verify_c_interop (arg_ts) == SUCCESS
2406 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2408 if (args_sym->attr.target == 1)
2410 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2411 has the target attribute and is interoperable. */
2412 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2413 allocatable variable that has the TARGET attribute and
2414 is not an array of zero size. */
2415 if (args_sym->attr.allocatable == 1)
2417 if (args_sym->attr.dimension != 0
2418 && (args_sym->as && args_sym->as->rank == 0))
2420 gfc_error_now ("Allocatable variable '%s' used as a "
2421 "parameter to '%s' at %L must not be "
2422 "an array of zero size",
2423 args_sym->name, sym->name,
2424 &(args->expr->where));
2430 /* A non-allocatable target variable with C
2431 interoperable type and type parameters must be
2433 if (args_sym && args_sym->attr.dimension)
2435 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2437 gfc_error ("Assumed-shape array '%s' at %L "
2438 "cannot be an argument to the "
2439 "procedure '%s' because "
2440 "it is not C interoperable",
2442 &(args->expr->where), sym->name);
2445 else if (args_sym->as->type == AS_DEFERRED)
2447 gfc_error ("Deferred-shape array '%s' at %L "
2448 "cannot be an argument to the "
2449 "procedure '%s' because "
2450 "it is not C interoperable",
2452 &(args->expr->where), sym->name);
2457 /* Make sure it's not a character string. Arrays of
2458 any type should be ok if the variable is of a C
2459 interoperable type. */
2460 if (arg_ts->type == BT_CHARACTER)
2461 if (arg_ts->u.cl != NULL
2462 && (arg_ts->u.cl->length == NULL
2463 || arg_ts->u.cl->length->expr_type
2466 (arg_ts->u.cl->length->value.integer, 1)
2468 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2470 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2471 "at %L must have a length of 1",
2472 args_sym->name, sym->name,
2473 &(args->expr->where));
2479 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2481 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2483 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2484 "associated scalar POINTER", args_sym->name,
2485 sym->name, &(args->expr->where));
2491 /* The parameter is not required to be C interoperable. If it
2492 is not C interoperable, it must be a nonpolymorphic scalar
2493 with no length type parameters. It still must have either
2494 the pointer or target attribute, and it can be
2495 allocatable (but must be allocated when c_loc is called). */
2496 if (args->expr->rank != 0
2497 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2499 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2500 "scalar", args_sym->name, sym->name,
2501 &(args->expr->where));
2504 else if (arg_ts->type == BT_CHARACTER
2505 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2507 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2508 "%L must have a length of 1",
2509 args_sym->name, sym->name,
2510 &(args->expr->where));
2515 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2517 if (args_sym->attr.flavor != FL_PROCEDURE)
2519 /* TODO: Update this error message to allow for procedure
2520 pointers once they are implemented. */
2521 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2523 args_sym->name, sym->name,
2524 &(args->expr->where));
2527 else if (args_sym->attr.is_bind_c != 1)
2529 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2531 args_sym->name, sym->name,
2532 &(args->expr->where));
2537 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2542 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2543 "iso_c_binding function: '%s'!\n", sym->name);
2550 /* Resolve a function call, which means resolving the arguments, then figuring
2551 out which entity the name refers to. */
2552 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2553 to INTENT(OUT) or INTENT(INOUT). */
2556 resolve_function (gfc_expr *expr)
2558 gfc_actual_arglist *arg;
2563 procedure_type p = PROC_INTRINSIC;
2564 bool no_formal_args;
2568 sym = expr->symtree->n.sym;
2570 /* If this is a procedure pointer component, it has already been resolved. */
2571 if (gfc_is_proc_ptr_comp (expr, NULL))
2574 if (sym && sym->attr.intrinsic
2575 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2578 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2580 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2584 /* If this ia a deferred TBP with an abstract interface (which may
2585 of course be referenced), expr->value.function.esym will be set. */
2586 if (sym && sym->attr.abstract && !expr->value.function.esym)
2588 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2589 sym->name, &expr->where);
2593 /* Switch off assumed size checking and do this again for certain kinds
2594 of procedure, once the procedure itself is resolved. */
2595 need_full_assumed_size++;
2597 if (expr->symtree && expr->symtree->n.sym)
2598 p = expr->symtree->n.sym->attr.proc;
2600 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2601 inquiry_argument = true;
2602 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2604 if (resolve_actual_arglist (expr->value.function.actual,
2605 p, no_formal_args) == FAILURE)
2607 inquiry_argument = false;
2611 inquiry_argument = false;
2613 /* Need to setup the call to the correct c_associated, depending on
2614 the number of cptrs to user gives to compare. */
2615 if (sym && sym->attr.is_iso_c == 1)
2617 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2621 /* Get the symtree for the new symbol (resolved func).
2622 the old one will be freed later, when it's no longer used. */
2623 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2626 /* Resume assumed_size checking. */
2627 need_full_assumed_size--;
2629 /* If the procedure is external, check for usage. */
2630 if (sym && is_external_proc (sym))
2631 resolve_global_procedure (sym, &expr->where,
2632 &expr->value.function.actual, 0);
2634 if (sym && sym->ts.type == BT_CHARACTER
2636 && sym->ts.u.cl->length == NULL
2638 && expr->value.function.esym == NULL
2639 && !sym->attr.contained)
2641 /* Internal procedures are taken care of in resolve_contained_fntype. */
2642 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2643 "be used at %L since it is not a dummy argument",
2644 sym->name, &expr->where);
2648 /* See if function is already resolved. */
2650 if (expr->value.function.name != NULL)
2652 if (expr->ts.type == BT_UNKNOWN)
2658 /* Apply the rules of section 14.1.2. */
2660 switch (procedure_kind (sym))
2663 t = resolve_generic_f (expr);
2666 case PTYPE_SPECIFIC:
2667 t = resolve_specific_f (expr);
2671 t = resolve_unknown_f (expr);
2675 gfc_internal_error ("resolve_function(): bad function type");
2679 /* If the expression is still a function (it might have simplified),
2680 then we check to see if we are calling an elemental function. */
2682 if (expr->expr_type != EXPR_FUNCTION)
2685 temp = need_full_assumed_size;
2686 need_full_assumed_size = 0;
2688 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2691 if (omp_workshare_flag
2692 && expr->value.function.esym
2693 && ! gfc_elemental (expr->value.function.esym))
2695 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2696 "in WORKSHARE construct", expr->value.function.esym->name,
2701 #define GENERIC_ID expr->value.function.isym->id
2702 else if (expr->value.function.actual != NULL
2703 && expr->value.function.isym != NULL
2704 && GENERIC_ID != GFC_ISYM_LBOUND
2705 && GENERIC_ID != GFC_ISYM_LEN
2706 && GENERIC_ID != GFC_ISYM_LOC
2707 && GENERIC_ID != GFC_ISYM_PRESENT)
2709 /* Array intrinsics must also have the last upper bound of an
2710 assumed size array argument. UBOUND and SIZE have to be
2711 excluded from the check if the second argument is anything
2714 for (arg = expr->value.function.actual; arg; arg = arg->next)
2716 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2717 && arg->next != NULL && arg->next->expr)
2719 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2722 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2725 if ((int)mpz_get_si (arg->next->expr->value.integer)
2730 if (arg->expr != NULL
2731 && arg->expr->rank > 0
2732 && resolve_assumed_size_actual (arg->expr))
2738 need_full_assumed_size = temp;
2741 if (!pure_function (expr, &name) && name)
2745 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2746 "FORALL %s", name, &expr->where,
2747 forall_flag == 2 ? "mask" : "block");
2750 else if (gfc_pure (NULL))
2752 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2753 "procedure within a PURE procedure", name, &expr->where);
2758 /* Functions without the RECURSIVE attribution are not allowed to
2759 * call themselves. */
2760 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2763 esym = expr->value.function.esym;
2765 if (is_illegal_recursion (esym, gfc_current_ns))
2767 if (esym->attr.entry && esym->ns->entries)
2768 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2769 " function '%s' is not RECURSIVE",
2770 esym->name, &expr->where, esym->ns->entries->sym->name);
2772 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
2773 " is not RECURSIVE", esym->name, &expr->where);
2779 /* Character lengths of use associated functions may contains references to
2780 symbols not referenced from the current program unit otherwise. Make sure
2781 those symbols are marked as referenced. */
2783 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2784 && expr->value.function.esym->attr.use_assoc)
2786 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
2790 && !((expr->value.function.esym
2791 && expr->value.function.esym->attr.elemental)
2793 (expr->value.function.isym
2794 && expr->value.function.isym->elemental)))
2795 find_noncopying_intrinsics (expr->value.function.esym,
2796 expr->value.function.actual);
2798 /* Make sure that the expression has a typespec that works. */
2799 if (expr->ts.type == BT_UNKNOWN)
2801 if (expr->symtree->n.sym->result
2802 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
2803 && !expr->symtree->n.sym->result->attr.proc_pointer)
2804 expr->ts = expr->symtree->n.sym->result->ts;
2811 /************* Subroutine resolution *************/
2814 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2820 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2821 sym->name, &c->loc);
2822 else if (gfc_pure (NULL))
2823 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2829 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2833 if (sym->attr.generic)
2835 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2838 c->resolved_sym = s;
2839 pure_subroutine (c, s);
2843 /* TODO: Need to search for elemental references in generic interface. */
2846 if (sym->attr.intrinsic)
2847 return gfc_intrinsic_sub_interface (c, 0);
2854 resolve_generic_s (gfc_code *c)
2859 sym = c->symtree->n.sym;
2863 m = resolve_generic_s0 (c, sym);
2866 else if (m == MATCH_ERROR)
2870 if (sym->ns->parent == NULL)
2872 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2876 if (!generic_sym (sym))
2880 /* Last ditch attempt. See if the reference is to an intrinsic
2881 that possesses a matching interface. 14.1.2.4 */
2882 sym = c->symtree->n.sym;
2884 if (!gfc_is_intrinsic (sym, 1, c->loc))
2886 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2887 sym->name, &c->loc);
2891 m = gfc_intrinsic_sub_interface (c, 0);
2895 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2896 "intrinsic subroutine interface", sym->name, &c->loc);
2902 /* Set the name and binding label of the subroutine symbol in the call
2903 expression represented by 'c' to include the type and kind of the
2904 second parameter. This function is for resolving the appropriate
2905 version of c_f_pointer() and c_f_procpointer(). For example, a
2906 call to c_f_pointer() for a default integer pointer could have a
2907 name of c_f_pointer_i4. If no second arg exists, which is an error
2908 for these two functions, it defaults to the generic symbol's name
2909 and binding label. */
2912 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2913 char *name, char *binding_label)
2915 gfc_expr *arg = NULL;
2919 /* The second arg of c_f_pointer and c_f_procpointer determines
2920 the type and kind for the procedure name. */
2921 arg = c->ext.actual->next->expr;
2925 /* Set up the name to have the given symbol's name,
2926 plus the type and kind. */
2927 /* a derived type is marked with the type letter 'u' */
2928 if (arg->ts.type == BT_DERIVED)
2931 kind = 0; /* set the kind as 0 for now */
2935 type = gfc_type_letter (arg->ts.type);
2936 kind = arg->ts.kind;
2939 if (arg->ts.type == BT_CHARACTER)
2940 /* Kind info for character strings not needed. */
2943 sprintf (name, "%s_%c%d", sym->name, type, kind);
2944 /* Set up the binding label as the given symbol's label plus
2945 the type and kind. */
2946 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2950 /* If the second arg is missing, set the name and label as
2951 was, cause it should at least be found, and the missing
2952 arg error will be caught by compare_parameters(). */
2953 sprintf (name, "%s", sym->name);
2954 sprintf (binding_label, "%s", sym->binding_label);
2961 /* Resolve a generic version of the iso_c_binding procedure given
2962 (sym) to the specific one based on the type and kind of the
2963 argument(s). Currently, this function resolves c_f_pointer() and
2964 c_f_procpointer based on the type and kind of the second argument
2965 (FPTR). Other iso_c_binding procedures aren't specially handled.
2966 Upon successfully exiting, c->resolved_sym will hold the resolved
2967 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2971 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2973 gfc_symbol *new_sym;
2974 /* this is fine, since we know the names won't use the max */
2975 char name[GFC_MAX_SYMBOL_LEN + 1];
2976 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2977 /* default to success; will override if find error */
2978 match m = MATCH_YES;
2980 /* Make sure the actual arguments are in the necessary order (based on the
2981 formal args) before resolving. */
2982 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2984 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2985 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2987 set_name_and_label (c, sym, name, binding_label);
2989 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2991 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2993 /* Make sure we got a third arg if the second arg has non-zero
2994 rank. We must also check that the type and rank are
2995 correct since we short-circuit this check in
2996 gfc_procedure_use() (called above to sort actual args). */
2997 if (c->ext.actual->next->expr->rank != 0)
2999 if(c->ext.actual->next->next == NULL
3000 || c->ext.actual->next->next->expr == NULL)
3003 gfc_error ("Missing SHAPE parameter for call to %s "
3004 "at %L", sym->name, &(c->loc));
3006 else if (c->ext.actual->next->next->expr->ts.type
3008 || c->ext.actual->next->next->expr->rank != 1)
3011 gfc_error ("SHAPE parameter for call to %s at %L must "
3012 "be a rank 1 INTEGER array", sym->name,
3019 if (m != MATCH_ERROR)
3021 /* the 1 means to add the optional arg to formal list */
3022 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3024 /* for error reporting, say it's declared where the original was */
3025 new_sym->declared_at = sym->declared_at;
3030 /* no differences for c_loc or c_funloc */
3034 /* set the resolved symbol */
3035 if (m != MATCH_ERROR)
3036 c->resolved_sym = new_sym;
3038 c->resolved_sym = sym;
3044 /* Resolve a subroutine call known to be specific. */
3047 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3051 if(sym->attr.is_iso_c)
3053 m = gfc_iso_c_sub_interface (c,sym);
3057 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3059 if (sym->attr.dummy)
3061 sym->attr.proc = PROC_DUMMY;
3065 sym->attr.proc = PROC_EXTERNAL;
3069 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3072 if (sym->attr.intrinsic)
3074 m = gfc_intrinsic_sub_interface (c, 1);
3078 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3079 "with an intrinsic", sym->name, &c->loc);
3087 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3089 c->resolved_sym = sym;
3090 pure_subroutine (c, sym);
3097 resolve_specific_s (gfc_code *c)
3102 sym = c->symtree->n.sym;
3106 m = resolve_specific_s0 (c, sym);
3109 if (m == MATCH_ERROR)
3112 if (sym->ns->parent == NULL)
3115 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3121 sym = c->symtree->n.sym;
3122 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3123 sym->name, &c->loc);
3129 /* Resolve a subroutine call not known to be generic nor specific. */
3132 resolve_unknown_s (gfc_code *c)
3136 sym = c->symtree->n.sym;
3138 if (sym->attr.dummy)
3140 sym->attr.proc = PROC_DUMMY;
3144 /* See if we have an intrinsic function reference. */
3146 if (gfc_is_intrinsic (sym, 1, c->loc))
3148 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3153 /* The reference is to an external name. */
3156 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3158 c->resolved_sym = sym;
3160 pure_subroutine (c, sym);
3166 /* Resolve a subroutine call. Although it was tempting to use the same code
3167 for functions, subroutines and functions are stored differently and this
3168 makes things awkward. */
3171 resolve_call (gfc_code *c)
3174 procedure_type ptype = PROC_INTRINSIC;
3175 gfc_symbol *csym, *sym;
3176 bool no_formal_args;
3178 csym = c->symtree ? c->symtree->n.sym : NULL;
3180 if (csym && csym->ts.type != BT_UNKNOWN)
3182 gfc_error ("'%s' at %L has a type, which is not consistent with "
3183 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3187 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3190 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3191 sym = st ? st->n.sym : NULL;
3192 if (sym && csym != sym
3193 && sym->ns == gfc_current_ns
3194 && sym->attr.flavor == FL_PROCEDURE
3195 && sym->attr.contained)
3198 if (csym->attr.generic)
3199 c->symtree->n.sym = sym;
3202 csym = c->symtree->n.sym;
3206 /* If this ia a deferred TBP with an abstract interface
3207 (which may of course be referenced), c->expr1 will be set. */
3208 if (csym && csym->attr.abstract && !c->expr1)
3210 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3211 csym->name, &c->loc);
3215 /* Subroutines without the RECURSIVE attribution are not allowed to
3216 * call themselves. */
3217 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3219 if (csym->attr.entry && csym->ns->entries)
3220 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3221 " subroutine '%s' is not RECURSIVE",
3222 csym->name, &c->loc, csym->ns->entries->sym->name);
3224 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3225 " is not RECURSIVE", csym->name, &c->loc);
3230 /* Switch off assumed size checking and do this again for certain kinds
3231 of procedure, once the procedure itself is resolved. */
3232 need_full_assumed_size++;
3235 ptype = csym->attr.proc;
3237 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3238 if (resolve_actual_arglist (c->ext.actual, ptype,
3239 no_formal_args) == FAILURE)
3242 /* Resume assumed_size checking. */
3243 need_full_assumed_size--;
3245 /* If external, check for usage. */
3246 if (csym && is_external_proc (csym))
3247 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3250 if (c->resolved_sym == NULL)
3252 c->resolved_isym = NULL;
3253 switch (procedure_kind (csym))
3256 t = resolve_generic_s (c);
3259 case PTYPE_SPECIFIC:
3260 t = resolve_specific_s (c);
3264 t = resolve_unknown_s (c);
3268 gfc_internal_error ("resolve_subroutine(): bad function type");
3272 /* Some checks of elemental subroutine actual arguments. */
3273 if (resolve_elemental_actual (NULL, c) == FAILURE)
3276 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
3277 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3282 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3283 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3284 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3285 if their shapes do not match. If either op1->shape or op2->shape is
3286 NULL, return SUCCESS. */
3289 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3296 if (op1->shape != NULL && op2->shape != NULL)
3298 for (i = 0; i < op1->rank; i++)
3300 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3302 gfc_error ("Shapes for operands at %L and %L are not conformable",
3303 &op1->where, &op2->where);
3314 /* Resolve an operator expression node. This can involve replacing the
3315 operation with a user defined function call. */
3318 resolve_operator (gfc_expr *e)
3320 gfc_expr *op1, *op2;
3322 bool dual_locus_error;
3325 /* Resolve all subnodes-- give them types. */
3327 switch (e->value.op.op)
3330 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3333 /* Fall through... */
3336 case INTRINSIC_UPLUS:
3337 case INTRINSIC_UMINUS:
3338 case INTRINSIC_PARENTHESES:
3339 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3344 /* Typecheck the new node. */
3346 op1 = e->value.op.op1;
3347 op2 = e->value.op.op2;
3348 dual_locus_error = false;
3350 if ((op1 && op1->expr_type == EXPR_NULL)
3351 || (op2 && op2->expr_type == EXPR_NULL))
3353 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3357 switch (e->value.op.op)
3359 case INTRINSIC_UPLUS:
3360 case INTRINSIC_UMINUS:
3361 if (op1->ts.type == BT_INTEGER
3362 || op1->ts.type == BT_REAL
3363 || op1->ts.type == BT_COMPLEX)
3369 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3370 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3373 case INTRINSIC_PLUS:
3374 case INTRINSIC_MINUS:
3375 case INTRINSIC_TIMES:
3376 case INTRINSIC_DIVIDE:
3377 case INTRINSIC_POWER:
3378 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3380 gfc_type_convert_binary (e, 1);
3385 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3386 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3387 gfc_typename (&op2->ts));
3390 case INTRINSIC_CONCAT:
3391 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3392 && op1->ts.kind == op2->ts.kind)
3394 e->ts.type = BT_CHARACTER;
3395 e->ts.kind = op1->ts.kind;
3400 _("Operands of string concatenation operator at %%L are %s/%s"),
3401 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3407 case INTRINSIC_NEQV:
3408 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3410 e->ts.type = BT_LOGICAL;
3411 e->ts.kind = gfc_kind_max (op1, op2);
3412 if (op1->ts.kind < e->ts.kind)
3413 gfc_convert_type (op1, &e->ts, 2);
3414 else if (op2->ts.kind < e->ts.kind)
3415 gfc_convert_type (op2, &e->ts, 2);
3419 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3420 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3421 gfc_typename (&op2->ts));
3426 if (op1->ts.type == BT_LOGICAL)
3428 e->ts.type = BT_LOGICAL;
3429 e->ts.kind = op1->ts.kind;
3433 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3434 gfc_typename (&op1->ts));
3438 case INTRINSIC_GT_OS:
3440 case INTRINSIC_GE_OS:
3442 case INTRINSIC_LT_OS:
3444 case INTRINSIC_LE_OS:
3445 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3447 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3451 /* Fall through... */
3454 case INTRINSIC_EQ_OS:
3456 case INTRINSIC_NE_OS:
3457 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3458 && op1->ts.kind == op2->ts.kind)
3460 e->ts.type = BT_LOGICAL;
3461 e->ts.kind = gfc_default_logical_kind;
3465 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3467 gfc_type_convert_binary (e, 1);
3469 e->ts.type = BT_LOGICAL;
3470 e->ts.kind = gfc_default_logical_kind;
3474 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3476 _("Logicals at %%L must be compared with %s instead of %s"),
3477 (e->value.op.op == INTRINSIC_EQ
3478 || e->value.op.op == INTRINSIC_EQ_OS)
3479 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3482 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3483 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3484 gfc_typename (&op2->ts));
3488 case INTRINSIC_USER:
3489 if (e->value.op.uop->op == NULL)
3490 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3491 else if (op2 == NULL)
3492 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3493 e->value.op.uop->name, gfc_typename (&op1->ts));
3495 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3496 e->value.op.uop->name, gfc_typename (&op1->ts),
3497 gfc_typename (&op2->ts));
3501 case INTRINSIC_PARENTHESES:
3503 if (e->ts.type == BT_CHARACTER)
3504 e->ts.u.cl = op1->ts.u.cl;
3508 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3511 /* Deal with arrayness of an operand through an operator. */
3515 switch (e->value.op.op)
3517 case INTRINSIC_PLUS:
3518 case INTRINSIC_MINUS:
3519 case INTRINSIC_TIMES:
3520 case INTRINSIC_DIVIDE:
3521 case INTRINSIC_POWER:
3522 case INTRINSIC_CONCAT:
3526 case INTRINSIC_NEQV:
3528 case INTRINSIC_EQ_OS:
3530 case INTRINSIC_NE_OS:
3532 case INTRINSIC_GT_OS:
3534 case INTRINSIC_GE_OS:
3536 case INTRINSIC_LT_OS:
3538 case INTRINSIC_LE_OS:
3540 if (op1->rank == 0 && op2->rank == 0)
3543 if (op1->rank == 0 && op2->rank != 0)
3545 e->rank = op2->rank;
3547 if (e->shape == NULL)
3548 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3551 if (op1->rank != 0 && op2->rank == 0)
3553 e->rank = op1->rank;
3555 if (e->shape == NULL)
3556 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3559 if (op1->rank != 0 && op2->rank != 0)
3561 if (op1->rank == op2->rank)
3563 e->rank = op1->rank;
3564 if (e->shape == NULL)
3566 t = compare_shapes(op1, op2);
3570 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3575 /* Allow higher level expressions to work. */
3578 /* Try user-defined operators, and otherwise throw an error. */
3579 dual_locus_error = true;
3581 _("Inconsistent ranks for operator at %%L and %%L"));
3588 case INTRINSIC_PARENTHESES:
3590 case INTRINSIC_UPLUS:
3591 case INTRINSIC_UMINUS:
3592 /* Simply copy arrayness attribute */
3593 e->rank = op1->rank;
3595 if (e->shape == NULL)
3596 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3604 /* Attempt to simplify the expression. */
3607 t = gfc_simplify_expr (e, 0);
3608 /* Some calls do not succeed in simplification and return FAILURE
3609 even though there is no error; e.g. variable references to
3610 PARAMETER arrays. */
3611 if (!gfc_is_constant_expr (e))
3620 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3627 if (dual_locus_error)
3628 gfc_error (msg, &op1->where, &op2->where);
3630 gfc_error (msg, &e->where);
3636 /************** Array resolution subroutines **************/
3639 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3642 /* Compare two integer expressions. */
3645 compare_bound (gfc_expr *a, gfc_expr *b)
3649 if (a == NULL || a->expr_type != EXPR_CONSTANT
3650 || b == NULL || b->expr_type != EXPR_CONSTANT)
3653 /* If either of the types isn't INTEGER, we must have
3654 raised an error earlier. */
3656 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3659 i = mpz_cmp (a->value.integer, b->value.integer);
3669 /* Compare an integer expression with an integer. */
3672 compare_bound_int (gfc_expr *a, int b)
3676 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3679 if (a->ts.type != BT_INTEGER)
3680 gfc_internal_error ("compare_bound_int(): Bad expression");
3682 i = mpz_cmp_si (a->value.integer, b);
3692 /* Compare an integer expression with a mpz_t. */
3695 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3699 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3702 if (a->ts.type != BT_INTEGER)
3703 gfc_internal_error ("compare_bound_int(): Bad expression");
3705 i = mpz_cmp (a->value.integer, b);
3715 /* Compute the last value of a sequence given by a triplet.
3716 Return 0 if it wasn't able to compute the last value, or if the
3717 sequence if empty, and 1 otherwise. */
3720 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3721 gfc_expr *stride, mpz_t last)
3725 if (start == NULL || start->expr_type != EXPR_CONSTANT
3726 || end == NULL || end->expr_type != EXPR_CONSTANT
3727 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3730 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3731 || (stride != NULL && stride->ts.type != BT_INTEGER))
3734 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3736 if (compare_bound (start, end) == CMP_GT)
3738 mpz_set (last, end->value.integer);
3742 if (compare_bound_int (stride, 0) == CMP_GT)
3744 /* Stride is positive */
3745 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3750 /* Stride is negative */
3751 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3756 mpz_sub (rem, end->value.integer, start->value.integer);
3757 mpz_tdiv_r (rem, rem, stride->value.integer);
3758 mpz_sub (last, end->value.integer, rem);
3765 /* Compare a single dimension of an array reference to the array
3769 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3773 if (ar->dimen_type[i] == DIMEN_STAR)
3775 gcc_assert (ar->stride[i] == NULL);
3776 /* This implies [*] as [*:] and [*:3] are not possible. */
3777 if (ar->start[i] == NULL)
3779 gcc_assert (ar->end[i] == NULL);
3784 /* Given start, end and stride values, calculate the minimum and
3785 maximum referenced indexes. */
3787 switch (ar->dimen_type[i])
3794 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3797 gfc_warning ("Array reference at %L is out of bounds "
3798 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3799 mpz_get_si (ar->start[i]->value.integer),
3800 mpz_get_si (as->lower[i]->value.integer), i+1);
3802 gfc_warning ("Array reference at %L is out of bounds "
3803 "(%ld < %ld) in codimension %d", &ar->c_where[i],
3804 mpz_get_si (ar->start[i]->value.integer),
3805 mpz_get_si (as->lower[i]->value.integer),
3809 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3812 gfc_warning ("Array reference at %L is out of bounds "
3813 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3814 mpz_get_si (ar->start[i]->value.integer),
3815 mpz_get_si (as->upper[i]->value.integer), i+1);
3817 gfc_warning ("Array reference at %L is out of bounds "
3818 "(%ld > %ld) in codimension %d", &ar->c_where[i],
3819 mpz_get_si (ar->start[i]->value.integer),
3820 mpz_get_si (as->upper[i]->value.integer),
3829 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3830 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3832 comparison comp_start_end = compare_bound (AR_START, AR_END);
3834 /* Check for zero stride, which is not allowed. */
3835 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3837 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3841 /* if start == len || (stride > 0 && start < len)
3842 || (stride < 0 && start > len),
3843 then the array section contains at least one element. In this
3844 case, there is an out-of-bounds access if
3845 (start < lower || start > upper). */
3846 if (compare_bound (AR_START, AR_END) == CMP_EQ
3847 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3848 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3849 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3850 && comp_start_end == CMP_GT))
3852 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3854 gfc_warning ("Lower array reference at %L is out of bounds "
3855 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3856 mpz_get_si (AR_START->value.integer),
3857 mpz_get_si (as->lower[i]->value.integer), i+1);
3860 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3862 gfc_warning ("Lower array reference at %L is out of bounds "
3863 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3864 mpz_get_si (AR_START->value.integer),
3865 mpz_get_si (as->upper[i]->value.integer), i+1);
3870 /* If we can compute the highest index of the array section,
3871 then it also has to be between lower and upper. */
3872 mpz_init (last_value);
3873 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3876 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3878 gfc_warning ("Upper array reference at %L is out of bounds "
3879 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3880 mpz_get_si (last_value),
3881 mpz_get_si (as->lower[i]->value.integer), i+1);
3882 mpz_clear (last_value);
3885 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3887 gfc_warning ("Upper array reference at %L is out of bounds "
3888 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3889 mpz_get_si (last_value),
3890 mpz_get_si (as->upper[i]->value.integer), i+1);
3891 mpz_clear (last_value);
3895 mpz_clear (last_value);
3903 gfc_internal_error ("check_dimension(): Bad array reference");
3910 /* Compare an array reference with an array specification. */
3913 compare_spec_to_ref (gfc_array_ref *ar)
3920 /* TODO: Full array sections are only allowed as actual parameters. */
3921 if (as->type == AS_ASSUMED_SIZE
3922 && (/*ar->type == AR_FULL
3923 ||*/ (ar->type == AR_SECTION
3924 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3926 gfc_error ("Rightmost upper bound of assumed size array section "
3927 "not specified at %L", &ar->where);
3931 if (ar->type == AR_FULL)
3934 if (as->rank != ar->dimen)
3936 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3937 &ar->where, ar->dimen, as->rank);
3941 /* ar->codimen == 0 is a local array. */
3942 if (as->corank != ar->codimen && ar->codimen != 0)
3944 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
3945 &ar->where, ar->codimen, as->corank);
3949 for (i = 0; i < as->rank; i++)
3950 if (check_dimension (i, ar, as) == FAILURE)
3953 /* Local access has no coarray spec. */
3954 if (ar->codimen != 0)
3955 for (i = as->rank; i < as->rank + as->corank; i++)
3957 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
3959 gfc_error ("Coindex of codimension %d must be a scalar at %L",
3960 i + 1 - as->rank, &ar->where);
3963 if (check_dimension (i, ar, as) == FAILURE)
3971 /* Resolve one part of an array index. */
3974 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
3975 int force_index_integer_kind)
3982 if (gfc_resolve_expr (index) == FAILURE)
3985 if (check_scalar && index->rank != 0)
3987 gfc_error ("Array index at %L must be scalar", &index->where);
3991 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3993 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3994 &index->where, gfc_basic_typename (index->ts.type));
3998 if (index->ts.type == BT_REAL)
3999 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4000 &index->where) == FAILURE)
4003 if ((index->ts.kind != gfc_index_integer_kind
4004 && force_index_integer_kind)
4005 || index->ts.type != BT_INTEGER)
4008 ts.type = BT_INTEGER;
4009 ts.kind = gfc_index_integer_kind;
4011 gfc_convert_type_warn (index, &ts, 2, 0);
4017 /* Resolve one part of an array index. */
4020 gfc_resolve_index (gfc_expr *index, int check_scalar)
4022 return gfc_resolve_index_1 (index, check_scalar, 1);
4025 /* Resolve a dim argument to an intrinsic function. */
4028 gfc_resolve_dim_arg (gfc_expr *dim)
4033 if (gfc_resolve_expr (dim) == FAILURE)
4038 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4043 if (dim->ts.type != BT_INTEGER)
4045 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4049 if (dim->ts.kind != gfc_index_integer_kind)
4054 ts.type = BT_INTEGER;
4055 ts.kind = gfc_index_integer_kind;
4057 gfc_convert_type_warn (dim, &ts, 2, 0);
4063 /* Given an expression that contains array references, update those array
4064 references to point to the right array specifications. While this is
4065 filled in during matching, this information is difficult to save and load
4066 in a module, so we take care of it here.
4068 The idea here is that the original array reference comes from the
4069 base symbol. We traverse the list of reference structures, setting
4070 the stored reference to references. Component references can
4071 provide an additional array specification. */
4074 find_array_spec (gfc_expr *e)
4078 gfc_symbol *derived;
4081 if (e->symtree->n.sym->ts.type == BT_CLASS)
4082 as = e->symtree->n.sym->ts.u.derived->components->as;
4084 as = e->symtree->n.sym->as;
4087 for (ref = e->ref; ref; ref = ref->next)
4092 gfc_internal_error ("find_array_spec(): Missing spec");
4099 if (derived == NULL)
4100 derived = e->symtree->n.sym->ts.u.derived;
4102 if (derived->attr.is_class)
4103 derived = derived->components->ts.u.derived;
4105 c = derived->components;
4107 for (; c; c = c->next)
4108 if (c == ref->u.c.component)
4110 /* Track the sequence of component references. */
4111 if (c->ts.type == BT_DERIVED)
4112 derived = c->ts.u.derived;
4117 gfc_internal_error ("find_array_spec(): Component not found");
4119 if (c->attr.dimension)
4122 gfc_internal_error ("find_array_spec(): unused as(1)");
4133 gfc_internal_error ("find_array_spec(): unused as(2)");
4137 /* Resolve an array reference. */
4140 resolve_array_ref (gfc_array_ref *ar)
4142 int i, check_scalar;
4145 for (i = 0; i < ar->dimen + ar->codimen; i++)
4147 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4149 /* Do not force gfc_index_integer_kind for the start. We can
4150 do fine with any integer kind. This avoids temporary arrays
4151 created for indexing with a vector. */
4152 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4154 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4156 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4161 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4165 ar->dimen_type[i] = DIMEN_ELEMENT;
4169 ar->dimen_type[i] = DIMEN_VECTOR;
4170 if (e->expr_type == EXPR_VARIABLE
4171 && e->symtree->n.sym->ts.type == BT_DERIVED)
4172 ar->start[i] = gfc_get_parentheses (e);
4176 gfc_error ("Array index at %L is an array of rank %d",
4177 &ar->c_where[i], e->rank);
4182 if (ar->type == AR_FULL && ar->as->rank == 0)
4183 ar->type = AR_ELEMENT;
4185 /* If the reference type is unknown, figure out what kind it is. */
4187 if (ar->type == AR_UNKNOWN)
4189 ar->type = AR_ELEMENT;
4190 for (i = 0; i < ar->dimen; i++)
4191 if (ar->dimen_type[i] == DIMEN_RANGE
4192 || ar->dimen_type[i] == DIMEN_VECTOR)
4194 ar->type = AR_SECTION;
4199 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4207 resolve_substring (gfc_ref *ref)
4209 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4211 if (ref->u.ss.start != NULL)
4213 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4216 if (ref->u.ss.start->ts.type != BT_INTEGER)
4218 gfc_error ("Substring start index at %L must be of type INTEGER",
4219 &ref->u.ss.start->where);
4223 if (ref->u.ss.start->rank != 0)
4225 gfc_error ("Substring start index at %L must be scalar",
4226 &ref->u.ss.start->where);
4230 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4231 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4232 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4234 gfc_error ("Substring start index at %L is less than one",
4235 &ref->u.ss.start->where);
4240 if (ref->u.ss.end != NULL)
4242 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4245 if (ref->u.ss.end->ts.type != BT_INTEGER)
4247 gfc_error ("Substring end index at %L must be of type INTEGER",
4248 &ref->u.ss.end->where);
4252 if (ref->u.ss.end->rank != 0)
4254 gfc_error ("Substring end index at %L must be scalar",
4255 &ref->u.ss.end->where);
4259 if (ref->u.ss.length != NULL
4260 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4261 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4262 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4264 gfc_error ("Substring end index at %L exceeds the string length",
4265 &ref->u.ss.start->where);
4269 if (compare_bound_mpz_t (ref->u.ss.end,
4270 gfc_integer_kinds[k].huge) == CMP_GT
4271 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4272 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4274 gfc_error ("Substring end index at %L is too large",
4275 &ref->u.ss.end->where);
4284 /* This function supplies missing substring charlens. */
4287 gfc_resolve_substring_charlen (gfc_expr *e)
4290 gfc_expr *start, *end;
4292 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4293 if (char_ref->type == REF_SUBSTRING)
4299 gcc_assert (char_ref->next == NULL);
4303 if (e->ts.u.cl->length)
4304 gfc_free_expr (e->ts.u.cl->length);
4305 else if (e->expr_type == EXPR_VARIABLE
4306 && e->symtree->n.sym->attr.dummy)
4310 e->ts.type = BT_CHARACTER;
4311 e->ts.kind = gfc_default_character_kind;
4314 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4316 if (char_ref->u.ss.start)
4317 start = gfc_copy_expr (char_ref->u.ss.start);
4319 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4321 if (char_ref->u.ss.end)
4322 end = gfc_copy_expr (char_ref->u.ss.end);
4323 else if (e->expr_type == EXPR_VARIABLE)
4324 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4331 /* Length = (end - start +1). */
4332 e->ts.u.cl->length = gfc_subtract (end, start);
4333 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4334 gfc_get_int_expr (gfc_default_integer_kind,
4337 e->ts.u.cl->length->ts.type = BT_INTEGER;
4338 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4340 /* Make sure that the length is simplified. */
4341 gfc_simplify_expr (e->ts.u.cl->length, 1);
4342 gfc_resolve_expr (e->ts.u.cl->length);
4346 /* Resolve subtype references. */
4349 resolve_ref (gfc_expr *expr)
4351 int current_part_dimension, n_components, seen_part_dimension;
4354 for (ref = expr->ref; ref; ref = ref->next)
4355 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4357 find_array_spec (expr);
4361 for (ref = expr->ref; ref; ref = ref->next)
4365 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4373 resolve_substring (ref);
4377 /* Check constraints on part references. */
4379 current_part_dimension = 0;
4380 seen_part_dimension = 0;
4383 for (ref = expr->ref; ref; ref = ref->next)
4388 switch (ref->u.ar.type)
4391 /* Coarray scalar. */
4392 if (ref->u.ar.as->rank == 0)
4394 current_part_dimension = 0;
4399 current_part_dimension = 1;
4403 current_part_dimension = 0;
4407 gfc_internal_error ("resolve_ref(): Bad array reference");
4413 if (current_part_dimension || seen_part_dimension)
4416 if (ref->u.c.component->attr.pointer
4417 || ref->u.c.component->attr.proc_pointer)
4419 gfc_error ("Component to the right of a part reference "
4420 "with nonzero rank must not have the POINTER "
4421 "attribute at %L", &expr->where);
4424 else if (ref->u.c.component->attr.allocatable)
4426 gfc_error ("Component to the right of a part reference "
4427 "with nonzero rank must not have the ALLOCATABLE "
4428 "attribute at %L", &expr->where);
4440 if (((ref->type == REF_COMPONENT && n_components > 1)
4441 || ref->next == NULL)
4442 && current_part_dimension
4443 && seen_part_dimension)
4445 gfc_error ("Two or more part references with nonzero rank must "
4446 "not be specified at %L", &expr->where);
4450 if (ref->type == REF_COMPONENT)
4452 if (current_part_dimension)
4453 seen_part_dimension = 1;
4455 /* reset to make sure */
4456 current_part_dimension = 0;
4464 /* Given an expression, determine its shape. This is easier than it sounds.
4465 Leaves the shape array NULL if it is not possible to determine the shape. */
4468 expression_shape (gfc_expr *e)
4470 mpz_t array[GFC_MAX_DIMENSIONS];
4473 if (e->rank == 0 || e->shape != NULL)
4476 for (i = 0; i < e->rank; i++)
4477 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4480 e->shape = gfc_get_shape (e->rank);
4482 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4487 for (i--; i >= 0; i--)
4488 mpz_clear (array[i]);
4492 /* Given a variable expression node, compute the rank of the expression by
4493 examining the base symbol and any reference structures it may have. */
4496 expression_rank (gfc_expr *e)
4501 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4502 could lead to serious confusion... */
4503 gcc_assert (e->expr_type != EXPR_COMPCALL);
4507 if (e->expr_type == EXPR_ARRAY)
4509 /* Constructors can have a rank different from one via RESHAPE(). */
4511 if (e->symtree == NULL)
4517 e->rank = (e->symtree->n.sym->as == NULL)
4518 ? 0 : e->symtree->n.sym->as->rank;
4524 for (ref = e->ref; ref; ref = ref->next)
4526 if (ref->type != REF_ARRAY)
4529 if (ref->u.ar.type == AR_FULL)
4531 rank = ref->u.ar.as->rank;
4535 if (ref->u.ar.type == AR_SECTION)
4537 /* Figure out the rank of the section. */
4539 gfc_internal_error ("expression_rank(): Two array specs");
4541 for (i = 0; i < ref->u.ar.dimen; i++)
4542 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4543 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4553 expression_shape (e);
4557 /* Resolve a variable expression. */
4560 resolve_variable (gfc_expr *e)
4567 if (e->symtree == NULL)
4570 if (e->ref && resolve_ref (e) == FAILURE)
4573 sym = e->symtree->n.sym;
4574 if (sym->attr.flavor == FL_PROCEDURE
4575 && (!sym->attr.function
4576 || (sym->attr.function && sym->result
4577 && sym->result->attr.proc_pointer
4578 && !sym->result->attr.function)))
4580 e->ts.type = BT_PROCEDURE;
4581 goto resolve_procedure;
4584 if (sym->ts.type != BT_UNKNOWN)
4585 gfc_variable_attr (e, &e->ts);
4588 /* Must be a simple variable reference. */
4589 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4594 if (check_assumed_size_reference (sym, e))
4597 /* Deal with forward references to entries during resolve_code, to
4598 satisfy, at least partially, 12.5.2.5. */
4599 if (gfc_current_ns->entries
4600 && current_entry_id == sym->entry_id
4603 && cs_base->current->op != EXEC_ENTRY)
4605 gfc_entry_list *entry;
4606 gfc_formal_arglist *formal;
4610 /* If the symbol is a dummy... */
4611 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4613 entry = gfc_current_ns->entries;
4616 /* ...test if the symbol is a parameter of previous entries. */
4617 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4618 for (formal = entry->sym->formal; formal; formal = formal->next)
4620 if (formal->sym && sym->name == formal->sym->name)
4624 /* If it has not been seen as a dummy, this is an error. */
4627 if (specification_expr)
4628 gfc_error ("Variable '%s', used in a specification expression"
4629 ", is referenced at %L before the ENTRY statement "
4630 "in which it is a parameter",
4631 sym->name, &cs_base->current->loc);
4633 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4634 "statement in which it is a parameter",
4635 sym->name, &cs_base->current->loc);
4640 /* Now do the same check on the specification expressions. */
4641 specification_expr = 1;
4642 if (sym->ts.type == BT_CHARACTER
4643 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4647 for (n = 0; n < sym->as->rank; n++)
4649 specification_expr = 1;
4650 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4652 specification_expr = 1;
4653 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4656 specification_expr = 0;
4659 /* Update the symbol's entry level. */
4660 sym->entry_id = current_entry_id + 1;
4664 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
4667 /* F2008, C617 and C1229. */
4668 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
4669 && gfc_is_coindexed (e))
4671 gfc_ref *ref, *ref2 = NULL;
4673 if (e->ts.type == BT_CLASS)
4675 gfc_error ("Polymorphic subobject of coindexed object at %L",
4680 for (ref = e->ref; ref; ref = ref->next)
4682 if (ref->type == REF_COMPONENT)
4684 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
4688 for ( ; ref; ref = ref->next)
4689 if (ref->type == REF_COMPONENT)
4692 /* Expression itself is coindexed object. */
4696 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
4697 for ( ; c; c = c->next)
4698 if (c->attr.allocatable && c->ts.type == BT_CLASS)
4700 gfc_error ("Coindexed object with polymorphic allocatable "
4701 "subcomponent at %L", &e->where);
4712 /* Checks to see that the correct symbol has been host associated.
4713 The only situation where this arises is that in which a twice
4714 contained function is parsed after the host association is made.
4715 Therefore, on detecting this, change the symbol in the expression
4716 and convert the array reference into an actual arglist if the old
4717 symbol is a variable. */
4719 check_host_association (gfc_expr *e)
4721 gfc_symbol *sym, *old_sym;
4725 gfc_actual_arglist *arg, *tail = NULL;
4726 bool retval = e->expr_type == EXPR_FUNCTION;
4728 /* If the expression is the result of substitution in
4729 interface.c(gfc_extend_expr) because there is no way in
4730 which the host association can be wrong. */
4731 if (e->symtree == NULL
4732 || e->symtree->n.sym == NULL
4733 || e->user_operator)
4736 old_sym = e->symtree->n.sym;
4738 if (gfc_current_ns->parent
4739 && old_sym->ns != gfc_current_ns)
4741 /* Use the 'USE' name so that renamed module symbols are
4742 correctly handled. */
4743 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
4745 if (sym && old_sym != sym
4746 && sym->ts.type == old_sym->ts.type
4747 && sym->attr.flavor == FL_PROCEDURE
4748 && sym->attr.contained)
4750 /* Clear the shape, since it might not be valid. */
4751 if (e->shape != NULL)
4753 for (n = 0; n < e->rank; n++)
4754 mpz_clear (e->shape[n]);
4756 gfc_free (e->shape);
4759 /* Give the expression the right symtree! */
4760 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
4761 gcc_assert (st != NULL);
4763 if (old_sym->attr.flavor == FL_PROCEDURE
4764 || e->expr_type == EXPR_FUNCTION)
4766 /* Original was function so point to the new symbol, since
4767 the actual argument list is already attached to the
4769 e->value.function.esym = NULL;
4774 /* Original was variable so convert array references into
4775 an actual arglist. This does not need any checking now
4776 since gfc_resolve_function will take care of it. */
4777 e->value.function.actual = NULL;
4778 e->expr_type = EXPR_FUNCTION;
4781 /* Ambiguity will not arise if the array reference is not
4782 the last reference. */
4783 for (ref = e->ref; ref; ref = ref->next)
4784 if (ref->type == REF_ARRAY && ref->next == NULL)
4787 gcc_assert (ref->type == REF_ARRAY);
4789 /* Grab the start expressions from the array ref and
4790 copy them into actual arguments. */
4791 for (n = 0; n < ref->u.ar.dimen; n++)
4793 arg = gfc_get_actual_arglist ();
4794 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
4795 if (e->value.function.actual == NULL)
4796 tail = e->value.function.actual = arg;
4804 /* Dump the reference list and set the rank. */
4805 gfc_free_ref_list (e->ref);
4807 e->rank = sym->as ? sym->as->rank : 0;
4810 gfc_resolve_expr (e);
4814 /* This might have changed! */
4815 return e->expr_type == EXPR_FUNCTION;
4820 gfc_resolve_character_operator (gfc_expr *e)
4822 gfc_expr *op1 = e->value.op.op1;
4823 gfc_expr *op2 = e->value.op.op2;
4824 gfc_expr *e1 = NULL;
4825 gfc_expr *e2 = NULL;
4827 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
4829 if (op1->ts.u.cl && op1->ts.u.cl->length)
4830 e1 = gfc_copy_expr (op1->ts.u.cl->length);
4831 else if (op1->expr_type == EXPR_CONSTANT)
4832 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4833 op1->value.character.length);
4835 if (op2->ts.u.cl && op2->ts.u.cl->length)
4836 e2 = gfc_copy_expr (op2->ts.u.cl->length);
4837 else if (op2->expr_type == EXPR_CONSTANT)
4838 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4839 op2->value.character.length);
4841 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4846 e->ts.u.cl->length = gfc_add (e1, e2);
4847 e->ts.u.cl->length->ts.type = BT_INTEGER;
4848 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4849 gfc_simplify_expr (e->ts.u.cl->length, 0);
4850 gfc_resolve_expr (e->ts.u.cl->length);
4856 /* Ensure that an character expression has a charlen and, if possible, a
4857 length expression. */
4860 fixup_charlen (gfc_expr *e)
4862 /* The cases fall through so that changes in expression type and the need
4863 for multiple fixes are picked up. In all circumstances, a charlen should
4864 be available for the middle end to hang a backend_decl on. */
4865 switch (e->expr_type)
4868 gfc_resolve_character_operator (e);
4871 if (e->expr_type == EXPR_ARRAY)
4872 gfc_resolve_character_array_constructor (e);
4874 case EXPR_SUBSTRING:
4875 if (!e->ts.u.cl && e->ref)
4876 gfc_resolve_substring_charlen (e);
4880 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4887 /* Update an actual argument to include the passed-object for type-bound
4888 procedures at the right position. */
4890 static gfc_actual_arglist*
4891 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
4894 gcc_assert (argpos > 0);
4898 gfc_actual_arglist* result;
4900 result = gfc_get_actual_arglist ();
4904 result->name = name;
4910 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
4912 lst = update_arglist_pass (NULL, po, argpos - 1, name);
4917 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4920 extract_compcall_passed_object (gfc_expr* e)
4924 gcc_assert (e->expr_type == EXPR_COMPCALL);
4926 if (e->value.compcall.base_object)
4927 po = gfc_copy_expr (e->value.compcall.base_object);
4930 po = gfc_get_expr ();
4931 po->expr_type = EXPR_VARIABLE;
4932 po->symtree = e->symtree;
4933 po->ref = gfc_copy_ref (e->ref);
4934 po->where = e->where;
4937 if (gfc_resolve_expr (po) == FAILURE)
4944 /* Update the arglist of an EXPR_COMPCALL expression to include the
4948 update_compcall_arglist (gfc_expr* e)
4951 gfc_typebound_proc* tbp;
4953 tbp = e->value.compcall.tbp;
4958 po = extract_compcall_passed_object (e);
4962 if (tbp->nopass || e->value.compcall.ignore_pass)
4968 gcc_assert (tbp->pass_arg_num > 0);
4969 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4977 /* Extract the passed object from a PPC call (a copy of it). */
4980 extract_ppc_passed_object (gfc_expr *e)
4985 po = gfc_get_expr ();
4986 po->expr_type = EXPR_VARIABLE;
4987 po->symtree = e->symtree;
4988 po->ref = gfc_copy_ref (e->ref);
4989 po->where = e->where;
4991 /* Remove PPC reference. */
4993 while ((*ref)->next)
4994 ref = &(*ref)->next;
4995 gfc_free_ref_list (*ref);
4998 if (gfc_resolve_expr (po) == FAILURE)
5005 /* Update the actual arglist of a procedure pointer component to include the
5009 update_ppc_arglist (gfc_expr* e)
5013 gfc_typebound_proc* tb;
5015 if (!gfc_is_proc_ptr_comp (e, &ppc))
5022 else if (tb->nopass)
5025 po = extract_ppc_passed_object (e);
5031 gfc_error ("Passed-object at %L must be scalar", &e->where);
5035 gcc_assert (tb->pass_arg_num > 0);
5036 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5044 /* Check that the object a TBP is called on is valid, i.e. it must not be
5045 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5048 check_typebound_baseobject (gfc_expr* e)
5052 base = extract_compcall_passed_object (e);
5056 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5058 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5060 gfc_error ("Base object for type-bound procedure call at %L is of"
5061 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5065 /* If the procedure called is NOPASS, the base object must be scalar. */
5066 if (e->value.compcall.tbp->nopass && base->rank > 0)
5068 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5069 " be scalar", &e->where);
5073 /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
5076 gfc_error ("Non-scalar base object at %L currently not implemented",
5085 /* Resolve a call to a type-bound procedure, either function or subroutine,
5086 statically from the data in an EXPR_COMPCALL expression. The adapted
5087 arglist and the target-procedure symtree are returned. */
5090 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5091 gfc_actual_arglist** actual)
5093 gcc_assert (e->expr_type == EXPR_COMPCALL);
5094 gcc_assert (!e->value.compcall.tbp->is_generic);
5096 /* Update the actual arglist for PASS. */
5097 if (update_compcall_arglist (e) == FAILURE)
5100 *actual = e->value.compcall.actual;
5101 *target = e->value.compcall.tbp->u.specific;
5103 gfc_free_ref_list (e->ref);
5105 e->value.compcall.actual = NULL;
5111 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5112 which of the specific bindings (if any) matches the arglist and transform
5113 the expression into a call of that binding. */
5116 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5118 gfc_typebound_proc* genproc;
5119 const char* genname;
5121 gcc_assert (e->expr_type == EXPR_COMPCALL);
5122 genname = e->value.compcall.name;
5123 genproc = e->value.compcall.tbp;
5125 if (!genproc->is_generic)
5128 /* Try the bindings on this type and in the inheritance hierarchy. */
5129 for (; genproc; genproc = genproc->overridden)
5133 gcc_assert (genproc->is_generic);
5134 for (g = genproc->u.generic; g; g = g->next)
5137 gfc_actual_arglist* args;
5140 gcc_assert (g->specific);
5142 if (g->specific->error)
5145 target = g->specific->u.specific->n.sym;
5147 /* Get the right arglist by handling PASS/NOPASS. */
5148 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5149 if (!g->specific->nopass)
5152 po = extract_compcall_passed_object (e);
5156 gcc_assert (g->specific->pass_arg_num > 0);
5157 gcc_assert (!g->specific->error);
5158 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5159 g->specific->pass_arg);
5161 resolve_actual_arglist (args, target->attr.proc,
5162 is_external_proc (target) && !target->formal);
5164 /* Check if this arglist matches the formal. */
5165 matches = gfc_arglist_matches_symbol (&args, target);
5167 /* Clean up and break out of the loop if we've found it. */
5168 gfc_free_actual_arglist (args);
5171 e->value.compcall.tbp = g->specific;
5172 /* Pass along the name for CLASS methods, where the vtab
5173 procedure pointer component has to be referenced. */
5175 *name = g->specific_st->name;
5181 /* Nothing matching found! */
5182 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5183 " '%s' at %L", genname, &e->where);
5191 /* Resolve a call to a type-bound subroutine. */
5194 resolve_typebound_call (gfc_code* c, const char **name)
5196 gfc_actual_arglist* newactual;
5197 gfc_symtree* target;
5199 /* Check that's really a SUBROUTINE. */
5200 if (!c->expr1->value.compcall.tbp->subroutine)
5202 gfc_error ("'%s' at %L should be a SUBROUTINE",
5203 c->expr1->value.compcall.name, &c->loc);
5207 if (check_typebound_baseobject (c->expr1) == FAILURE)
5210 /* Pass along the name for CLASS methods, where the vtab
5211 procedure pointer component has to be referenced. */
5213 *name = c->expr1->value.compcall.name;
5215 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5218 /* Transform into an ordinary EXEC_CALL for now. */
5220 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5223 c->ext.actual = newactual;
5224 c->symtree = target;
5225 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5227 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5229 gfc_free_expr (c->expr1);
5230 c->expr1 = gfc_get_expr ();
5231 c->expr1->expr_type = EXPR_FUNCTION;
5232 c->expr1->symtree = target;
5233 c->expr1->where = c->loc;
5235 return resolve_call (c);
5239 /* Resolve a component-call expression. */
5241 resolve_compcall (gfc_expr* e, const char **name)
5243 gfc_actual_arglist* newactual;
5244 gfc_symtree* target;
5246 /* Check that's really a FUNCTION. */
5247 if (!e->value.compcall.tbp->function)
5249 gfc_error ("'%s' at %L should be a FUNCTION",
5250 e->value.compcall.name, &e->where);
5254 /* These must not be assign-calls! */
5255 gcc_assert (!e->value.compcall.assign);
5257 if (check_typebound_baseobject (e) == FAILURE)
5260 /* Pass along the name for CLASS methods, where the vtab
5261 procedure pointer component has to be referenced. */
5263 *name = e->value.compcall.name;
5265 if (resolve_typebound_generic_call (e, name) == FAILURE)
5267 gcc_assert (!e->value.compcall.tbp->is_generic);
5269 /* Take the rank from the function's symbol. */
5270 if (e->value.compcall.tbp->u.specific->n.sym->as)
5271 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5273 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5274 arglist to the TBP's binding target. */
5276 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5279 e->value.function.actual = newactual;
5280 e->value.function.name = NULL;
5281 e->value.function.esym = target->n.sym;
5282 e->value.function.isym = NULL;
5283 e->symtree = target;
5284 e->ts = target->n.sym->ts;
5285 e->expr_type = EXPR_FUNCTION;
5287 /* Resolution is not necessary if this is a class subroutine; this
5288 function only has to identify the specific proc. Resolution of
5289 the call will be done next in resolve_typebound_call. */
5290 return gfc_resolve_expr (e);
5294 /* Get the ultimate declared type from an expression. In addition,
5295 return the last class/derived type reference and the copy of the
5298 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5301 gfc_symbol *declared;
5306 *new_ref = gfc_copy_ref (e->ref);
5307 for (ref = *new_ref; ref; ref = ref->next)
5309 if (ref->type != REF_COMPONENT)
5312 if (ref->u.c.component->ts.type == BT_CLASS
5313 || ref->u.c.component->ts.type == BT_DERIVED)
5315 declared = ref->u.c.component->ts.u.derived;
5320 if (declared == NULL)
5321 declared = e->symtree->n.sym->ts.u.derived;
5327 /* Resolve a typebound function, or 'method'. First separate all
5328 the non-CLASS references by calling resolve_compcall directly. */
5331 resolve_typebound_function (gfc_expr* e)
5333 gfc_symbol *declared;
5339 const char *genname;
5344 return resolve_compcall (e, NULL);
5346 /* Get the CLASS declared type. */
5347 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5349 /* Weed out cases of the ultimate component being a derived type. */
5350 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5351 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5353 gfc_free_ref_list (new_ref);
5354 return resolve_compcall (e, NULL);
5357 c = gfc_find_component (declared, "$data", true, true);
5358 declared = c->ts.u.derived;
5360 /* Keep the generic name so that the vtab reference can be made. */
5362 if (e->value.compcall.tbp->is_generic)
5363 genname = e->value.compcall.name;
5365 /* Treat the call as if it is a typebound procedure, in order to roll
5366 out the correct name for the specific function. */
5367 resolve_compcall (e, &name);
5370 /* Then convert the expression to a procedure pointer component call. */
5371 e->value.function.esym = NULL;
5376 gfc_free_ref_list (class_ref->next);
5380 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5381 gfc_add_component_ref (e, "$vptr");
5384 /* A generic procedure needs the subsidiary vtabs and vtypes for
5385 the specific procedures to have been build. */
5387 vtab = gfc_find_derived_vtab (declared, true);
5389 gfc_add_component_ref (e, genname);
5391 gfc_add_component_ref (e, name);
5393 /* Recover the typespec for the expression. This is really only
5394 necessary for generic procedures, where the additional call
5395 to gfc_add_component_ref seems to throw the collection of the
5396 correct typespec. */
5401 /* Resolve a typebound subroutine, or 'method'. First separate all
5402 the non-CLASS references by calling resolve_typebound_call
5406 resolve_typebound_subroutine (gfc_code *code)
5408 gfc_symbol *declared;
5413 const char *genname;
5417 st = code->expr1->symtree;
5419 return resolve_typebound_call (code, NULL);
5421 /* Get the CLASS declared type. */
5422 declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5424 /* Weed out cases of the ultimate component being a derived type. */
5425 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5426 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5428 gfc_free_ref_list (new_ref);
5429 return resolve_typebound_call (code, NULL);
5432 c = gfc_find_component (declared, "$data", true, true);
5433 declared = c->ts.u.derived;
5435 /* Keep the generic name so that the vtab reference can be made. */
5437 if (code->expr1->value.compcall.tbp->is_generic)
5438 genname = code->expr1->value.compcall.name;
5440 resolve_typebound_call (code, &name);
5441 ts = code->expr1->ts;
5443 /* Then convert the expression to a procedure pointer component call. */
5444 code->expr1->value.function.esym = NULL;
5445 code->expr1->symtree = st;
5449 gfc_free_ref_list (class_ref->next);
5450 code->expr1->ref = new_ref;
5453 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5454 gfc_add_component_ref (code->expr1, "$vptr");
5457 /* A generic procedure needs the subsidiary vtabs and vtypes for
5458 the specific procedures to have been build. */
5460 vtab = gfc_find_derived_vtab (declared, true);
5462 gfc_add_component_ref (code->expr1, genname);
5464 gfc_add_component_ref (code->expr1, name);
5466 /* Recover the typespec for the expression. This is really only
5467 necessary for generic procedures, where the additional call
5468 to gfc_add_component_ref seems to throw the collection of the
5469 correct typespec. */
5470 code->expr1->ts = ts;
5475 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5478 resolve_ppc_call (gfc_code* c)
5480 gfc_component *comp;
5483 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5486 c->resolved_sym = c->expr1->symtree->n.sym;
5487 c->expr1->expr_type = EXPR_VARIABLE;
5489 if (!comp->attr.subroutine)
5490 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5492 if (resolve_ref (c->expr1) == FAILURE)
5495 if (update_ppc_arglist (c->expr1) == FAILURE)
5498 c->ext.actual = c->expr1->value.compcall.actual;
5500 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5501 comp->formal == NULL) == FAILURE)
5504 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5510 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5513 resolve_expr_ppc (gfc_expr* e)
5515 gfc_component *comp;
5518 b = gfc_is_proc_ptr_comp (e, &comp);
5521 /* Convert to EXPR_FUNCTION. */
5522 e->expr_type = EXPR_FUNCTION;
5523 e->value.function.isym = NULL;
5524 e->value.function.actual = e->value.compcall.actual;
5526 if (comp->as != NULL)
5527 e->rank = comp->as->rank;
5529 if (!comp->attr.function)
5530 gfc_add_function (&comp->attr, comp->name, &e->where);
5532 if (resolve_ref (e) == FAILURE)
5535 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5536 comp->formal == NULL) == FAILURE)
5539 if (update_ppc_arglist (e) == FAILURE)
5542 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5549 gfc_is_expandable_expr (gfc_expr *e)
5551 gfc_constructor *con;
5553 if (e->expr_type == EXPR_ARRAY)
5555 /* Traverse the constructor looking for variables that are flavor
5556 parameter. Parameters must be expanded since they are fully used at
5558 con = gfc_constructor_first (e->value.constructor);
5559 for (; con; con = gfc_constructor_next (con))
5561 if (con->expr->expr_type == EXPR_VARIABLE
5562 && con->expr->symtree
5563 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5564 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5566 if (con->expr->expr_type == EXPR_ARRAY
5567 && gfc_is_expandable_expr (con->expr))
5575 /* Resolve an expression. That is, make sure that types of operands agree
5576 with their operators, intrinsic operators are converted to function calls
5577 for overloaded types and unresolved function references are resolved. */
5580 gfc_resolve_expr (gfc_expr *e)
5588 /* inquiry_argument only applies to variables. */
5589 inquiry_save = inquiry_argument;
5590 if (e->expr_type != EXPR_VARIABLE)
5591 inquiry_argument = false;
5593 switch (e->expr_type)
5596 t = resolve_operator (e);
5602 if (check_host_association (e))
5603 t = resolve_function (e);
5606 t = resolve_variable (e);
5608 expression_rank (e);
5611 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
5612 && e->ref->type != REF_SUBSTRING)
5613 gfc_resolve_substring_charlen (e);
5618 t = resolve_typebound_function (e);
5621 case EXPR_SUBSTRING:
5622 t = resolve_ref (e);
5631 t = resolve_expr_ppc (e);
5636 if (resolve_ref (e) == FAILURE)
5639 t = gfc_resolve_array_constructor (e);
5640 /* Also try to expand a constructor. */
5643 expression_rank (e);
5644 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
5645 gfc_expand_constructor (e);
5648 /* This provides the opportunity for the length of constructors with
5649 character valued function elements to propagate the string length
5650 to the expression. */
5651 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
5653 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
5654 here rather then add a duplicate test for it above. */
5655 gfc_expand_constructor (e);
5656 t = gfc_resolve_character_array_constructor (e);
5661 case EXPR_STRUCTURE:
5662 t = resolve_ref (e);
5666 t = resolve_structure_cons (e);
5670 t = gfc_simplify_expr (e, 0);
5674 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
5677 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
5680 inquiry_argument = inquiry_save;
5686 /* Resolve an expression from an iterator. They must be scalar and have
5687 INTEGER or (optionally) REAL type. */
5690 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
5691 const char *name_msgid)
5693 if (gfc_resolve_expr (expr) == FAILURE)
5696 if (expr->rank != 0)
5698 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
5702 if (expr->ts.type != BT_INTEGER)
5704 if (expr->ts.type == BT_REAL)
5707 return gfc_notify_std (GFC_STD_F95_DEL,
5708 "Deleted feature: %s at %L must be integer",
5709 _(name_msgid), &expr->where);
5712 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
5719 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
5727 /* Resolve the expressions in an iterator structure. If REAL_OK is
5728 false allow only INTEGER type iterators, otherwise allow REAL types. */
5731 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
5733 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
5737 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
5739 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
5744 if (gfc_resolve_iterator_expr (iter->start, real_ok,
5745 "Start expression in DO loop") == FAILURE)
5748 if (gfc_resolve_iterator_expr (iter->end, real_ok,
5749 "End expression in DO loop") == FAILURE)
5752 if (gfc_resolve_iterator_expr (iter->step, real_ok,
5753 "Step expression in DO loop") == FAILURE)
5756 if (iter->step->expr_type == EXPR_CONSTANT)
5758 if ((iter->step->ts.type == BT_INTEGER
5759 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
5760 || (iter->step->ts.type == BT_REAL
5761 && mpfr_sgn (iter->step->value.real) == 0))
5763 gfc_error ("Step expression in DO loop at %L cannot be zero",
5764 &iter->step->where);
5769 /* Convert start, end, and step to the same type as var. */
5770 if (iter->start->ts.kind != iter->var->ts.kind
5771 || iter->start->ts.type != iter->var->ts.type)
5772 gfc_convert_type (iter->start, &iter->var->ts, 2);
5774 if (iter->end->ts.kind != iter->var->ts.kind
5775 || iter->end->ts.type != iter->var->ts.type)
5776 gfc_convert_type (iter->end, &iter->var->ts, 2);
5778 if (iter->step->ts.kind != iter->var->ts.kind
5779 || iter->step->ts.type != iter->var->ts.type)
5780 gfc_convert_type (iter->step, &iter->var->ts, 2);
5782 if (iter->start->expr_type == EXPR_CONSTANT
5783 && iter->end->expr_type == EXPR_CONSTANT
5784 && iter->step->expr_type == EXPR_CONSTANT)
5787 if (iter->start->ts.type == BT_INTEGER)
5789 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
5790 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
5794 sgn = mpfr_sgn (iter->step->value.real);
5795 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
5797 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
5798 gfc_warning ("DO loop at %L will be executed zero times",
5799 &iter->step->where);
5806 /* Traversal function for find_forall_index. f == 2 signals that
5807 that variable itself is not to be checked - only the references. */
5810 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
5812 if (expr->expr_type != EXPR_VARIABLE)
5815 /* A scalar assignment */
5816 if (!expr->ref || *f == 1)
5818 if (expr->symtree->n.sym == sym)
5830 /* Check whether the FORALL index appears in the expression or not.
5831 Returns SUCCESS if SYM is found in EXPR. */
5834 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
5836 if (gfc_traverse_expr (expr, sym, forall_index, f))
5843 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
5844 to be a scalar INTEGER variable. The subscripts and stride are scalar
5845 INTEGERs, and if stride is a constant it must be nonzero.
5846 Furthermore "A subscript or stride in a forall-triplet-spec shall
5847 not contain a reference to any index-name in the
5848 forall-triplet-spec-list in which it appears." (7.5.4.1) */
5851 resolve_forall_iterators (gfc_forall_iterator *it)
5853 gfc_forall_iterator *iter, *iter2;
5855 for (iter = it; iter; iter = iter->next)
5857 if (gfc_resolve_expr (iter->var) == SUCCESS
5858 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
5859 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
5862 if (gfc_resolve_expr (iter->start) == SUCCESS
5863 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
5864 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
5865 &iter->start->where);
5866 if (iter->var->ts.kind != iter->start->ts.kind)
5867 gfc_convert_type (iter->start, &iter->var->ts, 2);
5869 if (gfc_resolve_expr (iter->end) == SUCCESS
5870 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
5871 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
5873 if (iter->var->ts.kind != iter->end->ts.kind)
5874 gfc_convert_type (iter->end, &iter->var->ts, 2);
5876 if (gfc_resolve_expr (iter->stride) == SUCCESS)
5878 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
5879 gfc_error ("FORALL stride expression at %L must be a scalar %s",
5880 &iter->stride->where, "INTEGER");
5882 if (iter->stride->expr_type == EXPR_CONSTANT
5883 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
5884 gfc_error ("FORALL stride expression at %L cannot be zero",
5885 &iter->stride->where);
5887 if (iter->var->ts.kind != iter->stride->ts.kind)
5888 gfc_convert_type (iter->stride, &iter->var->ts, 2);
5891 for (iter = it; iter; iter = iter->next)
5892 for (iter2 = iter; iter2; iter2 = iter2->next)
5894 if (find_forall_index (iter2->start,
5895 iter->var->symtree->n.sym, 0) == SUCCESS
5896 || find_forall_index (iter2->end,
5897 iter->var->symtree->n.sym, 0) == SUCCESS
5898 || find_forall_index (iter2->stride,
5899 iter->var->symtree->n.sym, 0) == SUCCESS)
5900 gfc_error ("FORALL index '%s' may not appear in triplet "
5901 "specification at %L", iter->var->symtree->name,
5902 &iter2->start->where);
5907 /* Given a pointer to a symbol that is a derived type, see if it's
5908 inaccessible, i.e. if it's defined in another module and the components are
5909 PRIVATE. The search is recursive if necessary. Returns zero if no
5910 inaccessible components are found, nonzero otherwise. */
5913 derived_inaccessible (gfc_symbol *sym)
5917 if (sym->attr.use_assoc && sym->attr.private_comp)
5920 for (c = sym->components; c; c = c->next)
5922 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
5930 /* Resolve the argument of a deallocate expression. The expression must be
5931 a pointer or a full array. */
5934 resolve_deallocate_expr (gfc_expr *e)
5936 symbol_attribute attr;
5937 int allocatable, pointer, check_intent_in;
5942 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5943 check_intent_in = 1;
5945 if (gfc_resolve_expr (e) == FAILURE)
5948 if (e->expr_type != EXPR_VARIABLE)
5951 sym = e->symtree->n.sym;
5953 if (sym->ts.type == BT_CLASS)
5955 allocatable = sym->ts.u.derived->components->attr.allocatable;
5956 pointer = sym->ts.u.derived->components->attr.pointer;
5960 allocatable = sym->attr.allocatable;
5961 pointer = sym->attr.pointer;
5963 for (ref = e->ref; ref; ref = ref->next)
5966 check_intent_in = 0;
5971 if (ref->u.ar.type != AR_FULL)
5976 c = ref->u.c.component;
5977 if (c->ts.type == BT_CLASS)
5979 allocatable = c->ts.u.derived->components->attr.allocatable;
5980 pointer = c->ts.u.derived->components->attr.pointer;
5984 allocatable = c->attr.allocatable;
5985 pointer = c->attr.pointer;
5995 attr = gfc_expr_attr (e);
5997 if (allocatable == 0 && attr.pointer == 0)
6000 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6004 if (check_intent_in && sym->attr.intent == INTENT_IN)
6006 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
6007 sym->name, &e->where);
6011 if (e->ts.type == BT_CLASS)
6013 /* Only deallocate the DATA component. */
6014 gfc_add_component_ref (e, "$data");
6021 /* Returns true if the expression e contains a reference to the symbol sym. */
6023 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6025 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6032 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6034 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6038 /* Given the expression node e for an allocatable/pointer of derived type to be
6039 allocated, get the expression node to be initialized afterwards (needed for
6040 derived types with default initializers, and derived types with allocatable
6041 components that need nullification.) */
6044 gfc_expr_to_initialize (gfc_expr *e)
6050 result = gfc_copy_expr (e);
6052 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6053 for (ref = result->ref; ref; ref = ref->next)
6054 if (ref->type == REF_ARRAY && ref->next == NULL)
6056 ref->u.ar.type = AR_FULL;
6058 for (i = 0; i < ref->u.ar.dimen; i++)
6059 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6061 result->rank = ref->u.ar.dimen;
6069 /* Used in resolve_allocate_expr to check that a allocation-object and
6070 a source-expr are conformable. This does not catch all possible
6071 cases; in particular a runtime checking is needed. */
6074 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6076 /* First compare rank. */
6077 if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
6079 gfc_error ("Source-expr at %L must be scalar or have the "
6080 "same rank as the allocate-object at %L",
6081 &e1->where, &e2->where);
6092 for (i = 0; i < e1->rank; i++)
6094 if (e2->ref->u.ar.end[i])
6096 mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
6097 mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
6098 mpz_add_ui (s, s, 1);
6102 mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
6105 if (mpz_cmp (e1->shape[i], s) != 0)
6107 gfc_error ("Source-expr at %L and allocate-object at %L must "
6108 "have the same shape", &e1->where, &e2->where);
6121 /* Resolve the expression in an ALLOCATE statement, doing the additional
6122 checks to see whether the expression is OK or not. The expression must
6123 have a trailing array reference that gives the size of the array. */
6126 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6128 int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
6130 symbol_attribute attr;
6131 gfc_ref *ref, *ref2;
6138 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6139 check_intent_in = 1;
6141 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6142 checking of coarrays. */
6143 for (ref = e->ref; ref; ref = ref->next)
6144 if (ref->next == NULL)
6147 if (ref && ref->type == REF_ARRAY)
6148 ref->u.ar.in_allocate = true;
6150 if (gfc_resolve_expr (e) == FAILURE)
6153 /* Make sure the expression is allocatable or a pointer. If it is
6154 pointer, the next-to-last reference must be a pointer. */
6158 sym = e->symtree->n.sym;
6160 /* Check whether ultimate component is abstract and CLASS. */
6163 if (e->expr_type != EXPR_VARIABLE)
6166 attr = gfc_expr_attr (e);
6167 pointer = attr.pointer;
6168 dimension = attr.dimension;
6169 codimension = attr.codimension;
6173 if (sym->ts.type == BT_CLASS)
6175 allocatable = sym->ts.u.derived->components->attr.allocatable;
6176 pointer = sym->ts.u.derived->components->attr.pointer;
6177 dimension = sym->ts.u.derived->components->attr.dimension;
6178 codimension = sym->ts.u.derived->components->attr.codimension;
6179 is_abstract = sym->ts.u.derived->components->attr.abstract;
6183 allocatable = sym->attr.allocatable;
6184 pointer = sym->attr.pointer;
6185 dimension = sym->attr.dimension;
6186 codimension = sym->attr.codimension;
6189 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6192 check_intent_in = 0;
6197 if (ref->next != NULL)
6203 if (gfc_is_coindexed (e))
6205 gfc_error ("Coindexed allocatable object at %L",
6210 c = ref->u.c.component;
6211 if (c->ts.type == BT_CLASS)
6213 allocatable = c->ts.u.derived->components->attr.allocatable;
6214 pointer = c->ts.u.derived->components->attr.pointer;
6215 dimension = c->ts.u.derived->components->attr.dimension;
6216 codimension = c->ts.u.derived->components->attr.codimension;
6217 is_abstract = c->ts.u.derived->components->attr.abstract;
6221 allocatable = c->attr.allocatable;
6222 pointer = c->attr.pointer;
6223 dimension = c->attr.dimension;
6224 codimension = c->attr.codimension;
6225 is_abstract = c->attr.abstract;
6237 if (allocatable == 0 && pointer == 0)
6239 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6244 /* Some checks for the SOURCE tag. */
6247 /* Check F03:C631. */
6248 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6250 gfc_error ("Type of entity at %L is type incompatible with "
6251 "source-expr at %L", &e->where, &code->expr3->where);
6255 /* Check F03:C632 and restriction following Note 6.18. */
6256 if (code->expr3->rank > 0
6257 && conformable_arrays (code->expr3, e) == FAILURE)
6260 /* Check F03:C633. */
6261 if (code->expr3->ts.kind != e->ts.kind)
6263 gfc_error ("The allocate-object at %L and the source-expr at %L "
6264 "shall have the same kind type parameter",
6265 &e->where, &code->expr3->where);
6269 else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
6271 gcc_assert (e->ts.type == BT_CLASS);
6272 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6273 "type-spec or SOURCE=", sym->name, &e->where);
6277 if (check_intent_in && sym->attr.intent == INTENT_IN)
6279 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
6280 sym->name, &e->where);
6286 /* Add default initializer for those derived types that need them. */
6287 if (e->ts.type == BT_DERIVED
6288 && (init_e = gfc_default_initializer (&e->ts)))
6290 gfc_code *init_st = gfc_get_code ();
6291 init_st->loc = code->loc;
6292 init_st->op = EXEC_INIT_ASSIGN;
6293 init_st->expr1 = gfc_expr_to_initialize (e);
6294 init_st->expr2 = init_e;
6295 init_st->next = code->next;
6296 code->next = init_st;
6298 else if (e->ts.type == BT_CLASS
6299 && ((code->ext.alloc.ts.type == BT_UNKNOWN
6300 && (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts)))
6301 || (code->ext.alloc.ts.type == BT_DERIVED
6302 && (init_e = gfc_default_initializer (&code->ext.alloc.ts)))))
6304 gfc_code *init_st = gfc_get_code ();
6305 init_st->loc = code->loc;
6306 init_st->op = EXEC_INIT_ASSIGN;
6307 init_st->expr1 = gfc_expr_to_initialize (e);
6308 init_st->expr2 = init_e;
6309 init_st->next = code->next;
6310 code->next = init_st;
6314 if (pointer || (dimension == 0 && codimension == 0))
6317 /* Make sure the next-to-last reference node is an array specification. */
6319 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6320 || (dimension && ref2->u.ar.dimen == 0))
6322 gfc_error ("Array specification required in ALLOCATE statement "
6323 "at %L", &e->where);
6327 /* Make sure that the array section reference makes sense in the
6328 context of an ALLOCATE specification. */
6332 if (codimension && ar->codimen == 0)
6334 gfc_error ("Coarray specification required in ALLOCATE statement "
6335 "at %L", &e->where);
6339 for (i = 0; i < ar->dimen; i++)
6341 if (ref2->u.ar.type == AR_ELEMENT)
6344 switch (ar->dimen_type[i])
6350 if (ar->start[i] != NULL
6351 && ar->end[i] != NULL
6352 && ar->stride[i] == NULL)
6355 /* Fall Through... */
6360 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6366 for (a = code->ext.alloc.list; a; a = a->next)
6368 sym = a->expr->symtree->n.sym;
6370 /* TODO - check derived type components. */
6371 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6374 if ((ar->start[i] != NULL
6375 && gfc_find_sym_in_expr (sym, ar->start[i]))
6376 || (ar->end[i] != NULL
6377 && gfc_find_sym_in_expr (sym, ar->end[i])))
6379 gfc_error ("'%s' must not appear in the array specification at "
6380 "%L in the same ALLOCATE statement where it is "
6381 "itself allocated", sym->name, &ar->where);
6387 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6389 if (ar->dimen_type[i] == DIMEN_ELEMENT
6390 || ar->dimen_type[i] == DIMEN_RANGE)
6392 if (i == (ar->dimen + ar->codimen - 1))
6394 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6395 "statement at %L", &e->where);
6401 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6402 && ar->stride[i] == NULL)
6405 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6410 if (codimension && ar->as->rank == 0)
6412 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6413 "at %L", &e->where);
6425 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6427 gfc_expr *stat, *errmsg, *pe, *qe;
6428 gfc_alloc *a, *p, *q;
6430 stat = code->expr1 ? code->expr1 : NULL;
6432 errmsg = code->expr2 ? code->expr2 : NULL;
6434 /* Check the stat variable. */
6437 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
6438 gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
6439 stat->symtree->n.sym->name, &stat->where);
6441 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
6442 gfc_error ("Illegal stat-variable at %L for a PURE procedure",
6445 if ((stat->ts.type != BT_INTEGER
6446 && !(stat->ref && (stat->ref->type == REF_ARRAY
6447 || stat->ref->type == REF_COMPONENT)))
6449 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6450 "variable", &stat->where);
6452 for (p = code->ext.alloc.list; p; p = p->next)
6453 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6454 gfc_error ("Stat-variable at %L shall not be %sd within "
6455 "the same %s statement", &stat->where, fcn, fcn);
6458 /* Check the errmsg variable. */
6462 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6465 if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
6466 gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
6467 errmsg->symtree->n.sym->name, &errmsg->where);
6469 if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
6470 gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
6473 if ((errmsg->ts.type != BT_CHARACTER
6475 && (errmsg->ref->type == REF_ARRAY
6476 || errmsg->ref->type == REF_COMPONENT)))
6477 || errmsg->rank > 0 )
6478 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6479 "variable", &errmsg->where);
6481 for (p = code->ext.alloc.list; p; p = p->next)
6482 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6483 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6484 "the same %s statement", &errmsg->where, fcn, fcn);
6487 /* Check that an allocate-object appears only once in the statement.
6488 FIXME: Checking derived types is disabled. */
6489 for (p = code->ext.alloc.list; p; p = p->next)
6492 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6493 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6495 for (q = p->next; q; q = q->next)
6498 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6499 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6500 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6501 gfc_error ("Allocate-object at %L also appears at %L",
6502 &pe->where, &qe->where);
6507 if (strcmp (fcn, "ALLOCATE") == 0)
6509 for (a = code->ext.alloc.list; a; a = a->next)
6510 resolve_allocate_expr (a->expr, code);
6514 for (a = code->ext.alloc.list; a; a = a->next)
6515 resolve_deallocate_expr (a->expr);
6520 /************ SELECT CASE resolution subroutines ************/
6522 /* Callback function for our mergesort variant. Determines interval
6523 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
6524 op1 > op2. Assumes we're not dealing with the default case.
6525 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
6526 There are nine situations to check. */
6529 compare_cases (const gfc_case *op1, const gfc_case *op2)
6533 if (op1->low == NULL) /* op1 = (:L) */
6535 /* op2 = (:N), so overlap. */
6537 /* op2 = (M:) or (M:N), L < M */
6538 if (op2->low != NULL
6539 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6542 else if (op1->high == NULL) /* op1 = (K:) */
6544 /* op2 = (M:), so overlap. */
6546 /* op2 = (:N) or (M:N), K > N */
6547 if (op2->high != NULL
6548 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6551 else /* op1 = (K:L) */
6553 if (op2->low == NULL) /* op2 = (:N), K > N */
6554 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6556 else if (op2->high == NULL) /* op2 = (M:), L < M */
6557 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6559 else /* op2 = (M:N) */
6563 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6566 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6575 /* Merge-sort a double linked case list, detecting overlap in the
6576 process. LIST is the head of the double linked case list before it
6577 is sorted. Returns the head of the sorted list if we don't see any
6578 overlap, or NULL otherwise. */
6581 check_case_overlap (gfc_case *list)
6583 gfc_case *p, *q, *e, *tail;
6584 int insize, nmerges, psize, qsize, cmp, overlap_seen;
6586 /* If the passed list was empty, return immediately. */
6593 /* Loop unconditionally. The only exit from this loop is a return
6594 statement, when we've finished sorting the case list. */
6601 /* Count the number of merges we do in this pass. */
6604 /* Loop while there exists a merge to be done. */
6609 /* Count this merge. */
6612 /* Cut the list in two pieces by stepping INSIZE places
6613 forward in the list, starting from P. */
6616 for (i = 0; i < insize; i++)
6625 /* Now we have two lists. Merge them! */
6626 while (psize > 0 || (qsize > 0 && q != NULL))
6628 /* See from which the next case to merge comes from. */
6631 /* P is empty so the next case must come from Q. */
6636 else if (qsize == 0 || q == NULL)
6645 cmp = compare_cases (p, q);
6648 /* The whole case range for P is less than the
6656 /* The whole case range for Q is greater than
6657 the case range for P. */
6664 /* The cases overlap, or they are the same
6665 element in the list. Either way, we must
6666 issue an error and get the next case from P. */
6667 /* FIXME: Sort P and Q by line number. */
6668 gfc_error ("CASE label at %L overlaps with CASE "
6669 "label at %L", &p->where, &q->where);
6677 /* Add the next element to the merged list. */
6686 /* P has now stepped INSIZE places along, and so has Q. So
6687 they're the same. */
6692 /* If we have done only one merge or none at all, we've
6693 finished sorting the cases. */
6702 /* Otherwise repeat, merging lists twice the size. */
6708 /* Check to see if an expression is suitable for use in a CASE statement.
6709 Makes sure that all case expressions are scalar constants of the same
6710 type. Return FAILURE if anything is wrong. */
6713 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
6715 if (e == NULL) return SUCCESS;
6717 if (e->ts.type != case_expr->ts.type)
6719 gfc_error ("Expression in CASE statement at %L must be of type %s",
6720 &e->where, gfc_basic_typename (case_expr->ts.type));
6724 /* C805 (R808) For a given case-construct, each case-value shall be of
6725 the same type as case-expr. For character type, length differences
6726 are allowed, but the kind type parameters shall be the same. */
6728 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
6730 gfc_error ("Expression in CASE statement at %L must be of kind %d",
6731 &e->where, case_expr->ts.kind);
6735 /* Convert the case value kind to that of case expression kind,
6738 if (e->ts.kind != case_expr->ts.kind)
6739 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
6743 gfc_error ("Expression in CASE statement at %L must be scalar",
6752 /* Given a completely parsed select statement, we:
6754 - Validate all expressions and code within the SELECT.
6755 - Make sure that the selection expression is not of the wrong type.
6756 - Make sure that no case ranges overlap.
6757 - Eliminate unreachable cases and unreachable code resulting from
6758 removing case labels.
6760 The standard does allow unreachable cases, e.g. CASE (5:3). But
6761 they are a hassle for code generation, and to prevent that, we just
6762 cut them out here. This is not necessary for overlapping cases
6763 because they are illegal and we never even try to generate code.
6765 We have the additional caveat that a SELECT construct could have
6766 been a computed GOTO in the source code. Fortunately we can fairly
6767 easily work around that here: The case_expr for a "real" SELECT CASE
6768 is in code->expr1, but for a computed GOTO it is in code->expr2. All
6769 we have to do is make sure that the case_expr is a scalar integer
6773 resolve_select (gfc_code *code)
6776 gfc_expr *case_expr;
6777 gfc_case *cp, *default_case, *tail, *head;
6778 int seen_unreachable;
6784 if (code->expr1 == NULL)
6786 /* This was actually a computed GOTO statement. */
6787 case_expr = code->expr2;
6788 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
6789 gfc_error ("Selection expression in computed GOTO statement "
6790 "at %L must be a scalar integer expression",
6793 /* Further checking is not necessary because this SELECT was built
6794 by the compiler, so it should always be OK. Just move the
6795 case_expr from expr2 to expr so that we can handle computed
6796 GOTOs as normal SELECTs from here on. */
6797 code->expr1 = code->expr2;
6802 case_expr = code->expr1;
6804 type = case_expr->ts.type;
6805 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
6807 gfc_error ("Argument of SELECT statement at %L cannot be %s",
6808 &case_expr->where, gfc_typename (&case_expr->ts));
6810 /* Punt. Going on here just produce more garbage error messages. */
6814 if (case_expr->rank != 0)
6816 gfc_error ("Argument of SELECT statement at %L must be a scalar "
6817 "expression", &case_expr->where);
6824 /* Raise a warning if an INTEGER case value exceeds the range of
6825 the case-expr. Later, all expressions will be promoted to the
6826 largest kind of all case-labels. */
6828 if (type == BT_INTEGER)
6829 for (body = code->block; body; body = body->block)
6830 for (cp = body->ext.case_list; cp; cp = cp->next)
6833 && gfc_check_integer_range (cp->low->value.integer,
6834 case_expr->ts.kind) != ARITH_OK)
6835 gfc_warning ("Expression in CASE statement at %L is "
6836 "not in the range of %s", &cp->low->where,
6837 gfc_typename (&case_expr->ts));
6840 && cp->low != cp->high
6841 && gfc_check_integer_range (cp->high->value.integer,
6842 case_expr->ts.kind) != ARITH_OK)
6843 gfc_warning ("Expression in CASE statement at %L is "
6844 "not in the range of %s", &cp->high->where,
6845 gfc_typename (&case_expr->ts));
6848 /* PR 19168 has a long discussion concerning a mismatch of the kinds
6849 of the SELECT CASE expression and its CASE values. Walk the lists
6850 of case values, and if we find a mismatch, promote case_expr to
6851 the appropriate kind. */
6853 if (type == BT_LOGICAL || type == BT_INTEGER)
6855 for (body = code->block; body; body = body->block)
6857 /* Walk the case label list. */
6858 for (cp = body->ext.case_list; cp; cp = cp->next)
6860 /* Intercept the DEFAULT case. It does not have a kind. */
6861 if (cp->low == NULL && cp->high == NULL)
6864 /* Unreachable case ranges are discarded, so ignore. */
6865 if (cp->low != NULL && cp->high != NULL
6866 && cp->low != cp->high
6867 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
6871 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
6872 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
6874 if (cp->high != NULL
6875 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
6876 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
6881 /* Assume there is no DEFAULT case. */
6882 default_case = NULL;
6887 for (body = code->block; body; body = body->block)
6889 /* Assume the CASE list is OK, and all CASE labels can be matched. */
6891 seen_unreachable = 0;
6893 /* Walk the case label list, making sure that all case labels
6895 for (cp = body->ext.case_list; cp; cp = cp->next)
6897 /* Count the number of cases in the whole construct. */
6900 /* Intercept the DEFAULT case. */
6901 if (cp->low == NULL && cp->high == NULL)
6903 if (default_case != NULL)
6905 gfc_error ("The DEFAULT CASE at %L cannot be followed "
6906 "by a second DEFAULT CASE at %L",
6907 &default_case->where, &cp->where);
6918 /* Deal with single value cases and case ranges. Errors are
6919 issued from the validation function. */
6920 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
6921 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
6927 if (type == BT_LOGICAL
6928 && ((cp->low == NULL || cp->high == NULL)
6929 || cp->low != cp->high))
6931 gfc_error ("Logical range in CASE statement at %L is not "
6932 "allowed", &cp->low->where);
6937 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
6940 value = cp->low->value.logical == 0 ? 2 : 1;
6941 if (value & seen_logical)
6943 gfc_error ("Constant logical value in CASE statement "
6944 "is repeated at %L",
6949 seen_logical |= value;
6952 if (cp->low != NULL && cp->high != NULL
6953 && cp->low != cp->high
6954 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
6956 if (gfc_option.warn_surprising)
6957 gfc_warning ("Range specification at %L can never "
6958 "be matched", &cp->where);
6960 cp->unreachable = 1;
6961 seen_unreachable = 1;
6965 /* If the case range can be matched, it can also overlap with
6966 other cases. To make sure it does not, we put it in a
6967 double linked list here. We sort that with a merge sort
6968 later on to detect any overlapping cases. */
6972 head->right = head->left = NULL;
6977 tail->right->left = tail;
6984 /* It there was a failure in the previous case label, give up
6985 for this case label list. Continue with the next block. */
6989 /* See if any case labels that are unreachable have been seen.
6990 If so, we eliminate them. This is a bit of a kludge because
6991 the case lists for a single case statement (label) is a
6992 single forward linked lists. */
6993 if (seen_unreachable)
6995 /* Advance until the first case in the list is reachable. */
6996 while (body->ext.case_list != NULL
6997 && body->ext.case_list->unreachable)
6999 gfc_case *n = body->ext.case_list;
7000 body->ext.case_list = body->ext.case_list->next;
7002 gfc_free_case_list (n);
7005 /* Strip all other unreachable cases. */
7006 if (body->ext.case_list)
7008 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7010 if (cp->next->unreachable)
7012 gfc_case *n = cp->next;
7013 cp->next = cp->next->next;
7015 gfc_free_case_list (n);
7022 /* See if there were overlapping cases. If the check returns NULL,
7023 there was overlap. In that case we don't do anything. If head
7024 is non-NULL, we prepend the DEFAULT case. The sorted list can
7025 then used during code generation for SELECT CASE constructs with
7026 a case expression of a CHARACTER type. */
7029 head = check_case_overlap (head);
7031 /* Prepend the default_case if it is there. */
7032 if (head != NULL && default_case)
7034 default_case->left = NULL;
7035 default_case->right = head;
7036 head->left = default_case;
7040 /* Eliminate dead blocks that may be the result if we've seen
7041 unreachable case labels for a block. */
7042 for (body = code; body && body->block; body = body->block)
7044 if (body->block->ext.case_list == NULL)
7046 /* Cut the unreachable block from the code chain. */
7047 gfc_code *c = body->block;
7048 body->block = c->block;
7050 /* Kill the dead block, but not the blocks below it. */
7052 gfc_free_statements (c);
7056 /* More than two cases is legal but insane for logical selects.
7057 Issue a warning for it. */
7058 if (gfc_option.warn_surprising && type == BT_LOGICAL
7060 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7065 /* Check if a derived type is extensible. */
7068 gfc_type_is_extensible (gfc_symbol *sym)
7070 return !(sym->attr.is_bind_c || sym->attr.sequence);
7074 /* Resolve a SELECT TYPE statement. */
7077 resolve_select_type (gfc_code *code)
7079 gfc_symbol *selector_type;
7080 gfc_code *body, *new_st, *if_st, *tail;
7081 gfc_code *class_is = NULL, *default_case = NULL;
7084 char name[GFC_MAX_SYMBOL_LEN];
7091 /* Check for F03:C813. */
7092 if (code->expr1->ts.type != BT_CLASS
7093 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7095 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7096 "at %L", &code->loc);
7102 if (code->expr1->symtree->n.sym->attr.untyped)
7103 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7104 selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
7107 selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
7109 /* Loop over TYPE IS / CLASS IS cases. */
7110 for (body = code->block; body; body = body->block)
7112 c = body->ext.case_list;
7114 /* Check F03:C815. */
7115 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7116 && !gfc_type_is_extensible (c->ts.u.derived))
7118 gfc_error ("Derived type '%s' at %L must be extensible",
7119 c->ts.u.derived->name, &c->where);
7124 /* Check F03:C816. */
7125 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7126 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7128 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7129 c->ts.u.derived->name, &c->where, selector_type->name);
7134 /* Intercept the DEFAULT case. */
7135 if (c->ts.type == BT_UNKNOWN)
7137 /* Check F03:C818. */
7140 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7141 "by a second DEFAULT CASE at %L",
7142 &default_case->ext.case_list->where, &c->where);
7147 default_case = body;
7156 /* Insert assignment for selector variable. */
7157 new_st = gfc_get_code ();
7158 new_st->op = EXEC_ASSIGN;
7159 new_st->expr1 = gfc_copy_expr (code->expr1);
7160 new_st->expr2 = gfc_copy_expr (code->expr2);
7164 /* Put SELECT TYPE statement inside a BLOCK. */
7165 new_st = gfc_get_code ();
7166 new_st->op = code->op;
7167 new_st->expr1 = code->expr1;
7168 new_st->expr2 = code->expr2;
7169 new_st->block = code->block;
7173 ns->code->next = new_st;
7174 code->op = EXEC_BLOCK;
7175 code->expr1 = code->expr2 = NULL;
7180 /* Transform to EXEC_SELECT. */
7181 code->op = EXEC_SELECT;
7182 gfc_add_component_ref (code->expr1, "$vptr");
7183 gfc_add_component_ref (code->expr1, "$hash");
7185 /* Loop over TYPE IS / CLASS IS cases. */
7186 for (body = code->block; body; body = body->block)
7188 c = body->ext.case_list;
7190 if (c->ts.type == BT_DERIVED)
7191 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7192 c->ts.u.derived->hash_value);
7194 else if (c->ts.type == BT_UNKNOWN)
7197 /* Assign temporary to selector. */
7198 if (c->ts.type == BT_CLASS)
7199 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
7201 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
7202 st = gfc_find_symtree (ns->sym_root, name);
7203 new_st = gfc_get_code ();
7204 new_st->expr1 = gfc_get_variable_expr (st);
7205 new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
7206 if (c->ts.type == BT_DERIVED)
7208 new_st->op = EXEC_POINTER_ASSIGN;
7209 gfc_add_component_ref (new_st->expr2, "$data");
7212 new_st->op = EXEC_POINTER_ASSIGN;
7213 new_st->next = body->next;
7214 body->next = new_st;
7217 /* Take out CLASS IS cases for separate treatment. */
7219 while (body && body->block)
7221 if (body->block->ext.case_list->ts.type == BT_CLASS)
7223 /* Add to class_is list. */
7224 if (class_is == NULL)
7226 class_is = body->block;
7231 for (tail = class_is; tail->block; tail = tail->block) ;
7232 tail->block = body->block;
7235 /* Remove from EXEC_SELECT list. */
7236 body->block = body->block->block;
7249 /* Add a default case to hold the CLASS IS cases. */
7250 for (tail = code; tail->block; tail = tail->block) ;
7251 tail->block = gfc_get_code ();
7253 tail->op = EXEC_SELECT_TYPE;
7254 tail->ext.case_list = gfc_get_case ();
7255 tail->ext.case_list->ts.type = BT_UNKNOWN;
7257 default_case = tail;
7260 /* More than one CLASS IS block? */
7261 if (class_is->block)
7265 /* Sort CLASS IS blocks by extension level. */
7269 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7272 /* F03:C817 (check for doubles). */
7273 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7274 == c2->ext.case_list->ts.u.derived->hash_value)
7276 gfc_error ("Double CLASS IS block in SELECT TYPE "
7277 "statement at %L", &c2->ext.case_list->where);
7280 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7281 < c2->ext.case_list->ts.u.derived->attr.extension)
7284 (*c1)->block = c2->block;
7294 /* Generate IF chain. */
7295 if_st = gfc_get_code ();
7296 if_st->op = EXEC_IF;
7298 for (body = class_is; body; body = body->block)
7300 new_st->block = gfc_get_code ();
7301 new_st = new_st->block;
7302 new_st->op = EXEC_IF;
7303 /* Set up IF condition: Call _gfortran_is_extension_of. */
7304 new_st->expr1 = gfc_get_expr ();
7305 new_st->expr1->expr_type = EXPR_FUNCTION;
7306 new_st->expr1->ts.type = BT_LOGICAL;
7307 new_st->expr1->ts.kind = 4;
7308 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7309 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7310 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7311 /* Set up arguments. */
7312 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7313 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7314 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7315 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true);
7316 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7317 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7318 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7319 new_st->next = body->next;
7321 if (default_case->next)
7323 new_st->block = gfc_get_code ();
7324 new_st = new_st->block;
7325 new_st->op = EXEC_IF;
7326 new_st->next = default_case->next;
7329 /* Replace CLASS DEFAULT code by the IF chain. */
7330 default_case->next = if_st;
7333 resolve_select (code);
7338 /* Resolve a transfer statement. This is making sure that:
7339 -- a derived type being transferred has only non-pointer components
7340 -- a derived type being transferred doesn't have private components, unless
7341 it's being transferred from the module where the type was defined
7342 -- we're not trying to transfer a whole assumed size array. */
7345 resolve_transfer (gfc_code *code)
7354 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
7357 sym = exp->symtree->n.sym;
7360 /* Go to actual component transferred. */
7361 for (ref = code->expr1->ref; ref; ref = ref->next)
7362 if (ref->type == REF_COMPONENT)
7363 ts = &ref->u.c.component->ts;
7365 if (ts->type == BT_DERIVED)
7367 /* Check that transferred derived type doesn't contain POINTER
7369 if (ts->u.derived->attr.pointer_comp)
7371 gfc_error ("Data transfer element at %L cannot have "
7372 "POINTER components", &code->loc);
7376 if (ts->u.derived->attr.alloc_comp)
7378 gfc_error ("Data transfer element at %L cannot have "
7379 "ALLOCATABLE components", &code->loc);
7383 if (derived_inaccessible (ts->u.derived))
7385 gfc_error ("Data transfer element at %L cannot have "
7386 "PRIVATE components",&code->loc);
7391 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7392 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7394 gfc_error ("Data transfer element at %L cannot be a full reference to "
7395 "an assumed-size array", &code->loc);
7401 /*********** Toplevel code resolution subroutines ***********/
7403 /* Find the set of labels that are reachable from this block. We also
7404 record the last statement in each block. */
7407 find_reachable_labels (gfc_code *block)
7414 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
7416 /* Collect labels in this block. We don't keep those corresponding
7417 to END {IF|SELECT}, these are checked in resolve_branch by going
7418 up through the code_stack. */
7419 for (c = block; c; c = c->next)
7421 if (c->here && c->op != EXEC_END_BLOCK)
7422 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
7425 /* Merge with labels from parent block. */
7428 gcc_assert (cs_base->prev->reachable_labels);
7429 bitmap_ior_into (cs_base->reachable_labels,
7430 cs_base->prev->reachable_labels);
7436 resolve_sync (gfc_code *code)
7438 /* Check imageset. The * case matches expr1 == NULL. */
7441 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
7442 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
7443 "INTEGER expression", &code->expr1->where);
7444 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
7445 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
7446 gfc_error ("Imageset argument at %L must between 1 and num_images()",
7447 &code->expr1->where);
7448 else if (code->expr1->expr_type == EXPR_ARRAY
7449 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
7451 gfc_constructor *cons;
7452 cons = gfc_constructor_first (code->expr1->value.constructor);
7453 for (; cons; cons = gfc_constructor_next (cons))
7454 if (cons->expr->expr_type == EXPR_CONSTANT
7455 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
7456 gfc_error ("Imageset argument at %L must between 1 and "
7457 "num_images()", &cons->expr->where);
7463 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
7464 || code->expr2->expr_type != EXPR_VARIABLE))
7465 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
7466 &code->expr2->where);
7470 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
7471 || code->expr3->expr_type != EXPR_VARIABLE))
7472 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
7473 &code->expr3->where);
7477 /* Given a branch to a label, see if the branch is conforming.
7478 The code node describes where the branch is located. */
7481 resolve_branch (gfc_st_label *label, gfc_code *code)
7488 /* Step one: is this a valid branching target? */
7490 if (label->defined == ST_LABEL_UNKNOWN)
7492 gfc_error ("Label %d referenced at %L is never defined", label->value,
7497 if (label->defined != ST_LABEL_TARGET)
7499 gfc_error ("Statement at %L is not a valid branch target statement "
7500 "for the branch statement at %L", &label->where, &code->loc);
7504 /* Step two: make sure this branch is not a branch to itself ;-) */
7506 if (code->here == label)
7508 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
7512 /* Step three: See if the label is in the same block as the
7513 branching statement. The hard work has been done by setting up
7514 the bitmap reachable_labels. */
7516 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
7518 /* Check now whether there is a CRITICAL construct; if so, check
7519 whether the label is still visible outside of the CRITICAL block,
7520 which is invalid. */
7521 for (stack = cs_base; stack; stack = stack->prev)
7522 if (stack->current->op == EXEC_CRITICAL
7523 && bitmap_bit_p (stack->reachable_labels, label->value))
7524 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
7525 " at %L", &code->loc, &label->where);
7530 /* Step four: If we haven't found the label in the bitmap, it may
7531 still be the label of the END of the enclosing block, in which
7532 case we find it by going up the code_stack. */
7534 for (stack = cs_base; stack; stack = stack->prev)
7536 if (stack->current->next && stack->current->next->here == label)
7538 if (stack->current->op == EXEC_CRITICAL)
7540 /* Note: A label at END CRITICAL does not leave the CRITICAL
7541 construct as END CRITICAL is still part of it. */
7542 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
7543 " at %L", &code->loc, &label->where);
7550 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
7554 /* The label is not in an enclosing block, so illegal. This was
7555 allowed in Fortran 66, so we allow it as extension. No
7556 further checks are necessary in this case. */
7557 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
7558 "as the GOTO statement at %L", &label->where,
7564 /* Check whether EXPR1 has the same shape as EXPR2. */
7567 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
7569 mpz_t shape[GFC_MAX_DIMENSIONS];
7570 mpz_t shape2[GFC_MAX_DIMENSIONS];
7571 gfc_try result = FAILURE;
7574 /* Compare the rank. */
7575 if (expr1->rank != expr2->rank)
7578 /* Compare the size of each dimension. */
7579 for (i=0; i<expr1->rank; i++)
7581 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
7584 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
7587 if (mpz_cmp (shape[i], shape2[i]))
7591 /* When either of the two expression is an assumed size array, we
7592 ignore the comparison of dimension sizes. */
7597 for (i--; i >= 0; i--)
7599 mpz_clear (shape[i]);
7600 mpz_clear (shape2[i]);
7606 /* Check whether a WHERE assignment target or a WHERE mask expression
7607 has the same shape as the outmost WHERE mask expression. */
7610 resolve_where (gfc_code *code, gfc_expr *mask)
7616 cblock = code->block;
7618 /* Store the first WHERE mask-expr of the WHERE statement or construct.
7619 In case of nested WHERE, only the outmost one is stored. */
7620 if (mask == NULL) /* outmost WHERE */
7622 else /* inner WHERE */
7629 /* Check if the mask-expr has a consistent shape with the
7630 outmost WHERE mask-expr. */
7631 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
7632 gfc_error ("WHERE mask at %L has inconsistent shape",
7633 &cblock->expr1->where);
7636 /* the assignment statement of a WHERE statement, or the first
7637 statement in where-body-construct of a WHERE construct */
7638 cnext = cblock->next;
7643 /* WHERE assignment statement */
7646 /* Check shape consistent for WHERE assignment target. */
7647 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
7648 gfc_error ("WHERE assignment target at %L has "
7649 "inconsistent shape", &cnext->expr1->where);
7653 case EXEC_ASSIGN_CALL:
7654 resolve_call (cnext);
7655 if (!cnext->resolved_sym->attr.elemental)
7656 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
7657 &cnext->ext.actual->expr->where);
7660 /* WHERE or WHERE construct is part of a where-body-construct */
7662 resolve_where (cnext, e);
7666 gfc_error ("Unsupported statement inside WHERE at %L",
7669 /* the next statement within the same where-body-construct */
7670 cnext = cnext->next;
7672 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
7673 cblock = cblock->block;
7678 /* Resolve assignment in FORALL construct.
7679 NVAR is the number of FORALL index variables, and VAR_EXPR records the
7680 FORALL index variables. */
7683 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
7687 for (n = 0; n < nvar; n++)
7689 gfc_symbol *forall_index;
7691 forall_index = var_expr[n]->symtree->n.sym;
7693 /* Check whether the assignment target is one of the FORALL index
7695 if ((code->expr1->expr_type == EXPR_VARIABLE)
7696 && (code->expr1->symtree->n.sym == forall_index))
7697 gfc_error ("Assignment to a FORALL index variable at %L",
7698 &code->expr1->where);
7701 /* If one of the FORALL index variables doesn't appear in the
7702 assignment variable, then there could be a many-to-one
7703 assignment. Emit a warning rather than an error because the
7704 mask could be resolving this problem. */
7705 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
7706 gfc_warning ("The FORALL with index '%s' is not used on the "
7707 "left side of the assignment at %L and so might "
7708 "cause multiple assignment to this object",
7709 var_expr[n]->symtree->name, &code->expr1->where);
7715 /* Resolve WHERE statement in FORALL construct. */
7718 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
7719 gfc_expr **var_expr)
7724 cblock = code->block;
7727 /* the assignment statement of a WHERE statement, or the first
7728 statement in where-body-construct of a WHERE construct */
7729 cnext = cblock->next;
7734 /* WHERE assignment statement */
7736 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
7739 /* WHERE operator assignment statement */
7740 case EXEC_ASSIGN_CALL:
7741 resolve_call (cnext);
7742 if (!cnext->resolved_sym->attr.elemental)
7743 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
7744 &cnext->ext.actual->expr->where);
7747 /* WHERE or WHERE construct is part of a where-body-construct */
7749 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
7753 gfc_error ("Unsupported statement inside WHERE at %L",
7756 /* the next statement within the same where-body-construct */
7757 cnext = cnext->next;
7759 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
7760 cblock = cblock->block;
7765 /* Traverse the FORALL body to check whether the following errors exist:
7766 1. For assignment, check if a many-to-one assignment happens.
7767 2. For WHERE statement, check the WHERE body to see if there is any
7768 many-to-one assignment. */
7771 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
7775 c = code->block->next;
7781 case EXEC_POINTER_ASSIGN:
7782 gfc_resolve_assign_in_forall (c, nvar, var_expr);
7785 case EXEC_ASSIGN_CALL:
7789 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
7790 there is no need to handle it here. */
7794 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
7799 /* The next statement in the FORALL body. */
7805 /* Counts the number of iterators needed inside a forall construct, including
7806 nested forall constructs. This is used to allocate the needed memory
7807 in gfc_resolve_forall. */
7810 gfc_count_forall_iterators (gfc_code *code)
7812 int max_iters, sub_iters, current_iters;
7813 gfc_forall_iterator *fa;
7815 gcc_assert(code->op == EXEC_FORALL);
7819 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
7822 code = code->block->next;
7826 if (code->op == EXEC_FORALL)
7828 sub_iters = gfc_count_forall_iterators (code);
7829 if (sub_iters > max_iters)
7830 max_iters = sub_iters;
7835 return current_iters + max_iters;
7839 /* Given a FORALL construct, first resolve the FORALL iterator, then call
7840 gfc_resolve_forall_body to resolve the FORALL body. */
7843 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
7845 static gfc_expr **var_expr;
7846 static int total_var = 0;
7847 static int nvar = 0;
7849 gfc_forall_iterator *fa;
7854 /* Start to resolve a FORALL construct */
7855 if (forall_save == 0)
7857 /* Count the total number of FORALL index in the nested FORALL
7858 construct in order to allocate the VAR_EXPR with proper size. */
7859 total_var = gfc_count_forall_iterators (code);
7861 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
7862 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
7865 /* The information about FORALL iterator, including FORALL index start, end
7866 and stride. The FORALL index can not appear in start, end or stride. */
7867 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
7869 /* Check if any outer FORALL index name is the same as the current
7871 for (i = 0; i < nvar; i++)
7873 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
7875 gfc_error ("An outer FORALL construct already has an index "
7876 "with this name %L", &fa->var->where);
7880 /* Record the current FORALL index. */
7881 var_expr[nvar] = gfc_copy_expr (fa->var);
7885 /* No memory leak. */
7886 gcc_assert (nvar <= total_var);
7889 /* Resolve the FORALL body. */
7890 gfc_resolve_forall_body (code, nvar, var_expr);
7892 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
7893 gfc_resolve_blocks (code->block, ns);
7897 /* Free only the VAR_EXPRs allocated in this frame. */
7898 for (i = nvar; i < tmp; i++)
7899 gfc_free_expr (var_expr[i]);
7903 /* We are in the outermost FORALL construct. */
7904 gcc_assert (forall_save == 0);
7906 /* VAR_EXPR is not needed any more. */
7907 gfc_free (var_expr);
7913 /* Resolve a BLOCK construct statement. */
7916 resolve_block_construct (gfc_code* code)
7918 /* Eventually, we may want to do some checks here or handle special stuff.
7919 But so far the only thing we can do is resolving the local namespace. */
7921 gfc_resolve (code->ext.ns);
7925 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
7928 static void resolve_code (gfc_code *, gfc_namespace *);
7931 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
7935 for (; b; b = b->block)
7937 t = gfc_resolve_expr (b->expr1);
7938 if (gfc_resolve_expr (b->expr2) == FAILURE)
7944 if (t == SUCCESS && b->expr1 != NULL
7945 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
7946 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7953 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
7954 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
7959 resolve_branch (b->label1, b);
7963 resolve_block_construct (b);
7967 case EXEC_SELECT_TYPE:
7978 case EXEC_OMP_ATOMIC:
7979 case EXEC_OMP_CRITICAL:
7981 case EXEC_OMP_MASTER:
7982 case EXEC_OMP_ORDERED:
7983 case EXEC_OMP_PARALLEL:
7984 case EXEC_OMP_PARALLEL_DO:
7985 case EXEC_OMP_PARALLEL_SECTIONS:
7986 case EXEC_OMP_PARALLEL_WORKSHARE:
7987 case EXEC_OMP_SECTIONS:
7988 case EXEC_OMP_SINGLE:
7990 case EXEC_OMP_TASKWAIT:
7991 case EXEC_OMP_WORKSHARE:
7995 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
7998 resolve_code (b->next, ns);
8003 /* Does everything to resolve an ordinary assignment. Returns true
8004 if this is an interface assignment. */
8006 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8016 if (gfc_extend_assign (code, ns) == SUCCESS)
8020 if (code->op == EXEC_ASSIGN_CALL)
8022 lhs = code->ext.actual->expr;
8023 rhsptr = &code->ext.actual->next->expr;
8027 gfc_actual_arglist* args;
8028 gfc_typebound_proc* tbp;
8030 gcc_assert (code->op == EXEC_COMPCALL);
8032 args = code->expr1->value.compcall.actual;
8034 rhsptr = &args->next->expr;
8036 tbp = code->expr1->value.compcall.tbp;
8037 gcc_assert (!tbp->is_generic);
8040 /* Make a temporary rhs when there is a default initializer
8041 and rhs is the same symbol as the lhs. */
8042 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8043 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8044 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8045 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8046 *rhsptr = gfc_get_parentheses (*rhsptr);
8055 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8056 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8057 &code->loc) == FAILURE)
8060 /* Handle the case of a BOZ literal on the RHS. */
8061 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8064 if (gfc_option.warn_surprising)
8065 gfc_warning ("BOZ literal at %L is bitwise transferred "
8066 "non-integer symbol '%s'", &code->loc,
8067 lhs->symtree->n.sym->name);
8069 if (!gfc_convert_boz (rhs, &lhs->ts))
8071 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8073 if (rc == ARITH_UNDERFLOW)
8074 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8075 ". This check can be disabled with the option "
8076 "-fno-range-check", &rhs->where);
8077 else if (rc == ARITH_OVERFLOW)
8078 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8079 ". This check can be disabled with the option "
8080 "-fno-range-check", &rhs->where);
8081 else if (rc == ARITH_NAN)
8082 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8083 ". This check can be disabled with the option "
8084 "-fno-range-check", &rhs->where);
8090 if (lhs->ts.type == BT_CHARACTER
8091 && gfc_option.warn_character_truncation)
8093 if (lhs->ts.u.cl != NULL
8094 && lhs->ts.u.cl->length != NULL
8095 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8096 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8098 if (rhs->expr_type == EXPR_CONSTANT)
8099 rlen = rhs->value.character.length;
8101 else if (rhs->ts.u.cl != NULL
8102 && rhs->ts.u.cl->length != NULL
8103 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8104 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8106 if (rlen && llen && rlen > llen)
8107 gfc_warning_now ("CHARACTER expression will be truncated "
8108 "in assignment (%d/%d) at %L",
8109 llen, rlen, &code->loc);
8112 /* Ensure that a vector index expression for the lvalue is evaluated
8113 to a temporary if the lvalue symbol is referenced in it. */
8116 for (ref = lhs->ref; ref; ref= ref->next)
8117 if (ref->type == REF_ARRAY)
8119 for (n = 0; n < ref->u.ar.dimen; n++)
8120 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8121 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8122 ref->u.ar.start[n]))
8124 = gfc_get_parentheses (ref->u.ar.start[n]);
8128 if (gfc_pure (NULL))
8130 if (gfc_impure_variable (lhs->symtree->n.sym))
8132 gfc_error ("Cannot assign to variable '%s' in PURE "
8134 lhs->symtree->n.sym->name,
8139 if (lhs->ts.type == BT_DERIVED
8140 && lhs->expr_type == EXPR_VARIABLE
8141 && lhs->ts.u.derived->attr.pointer_comp
8142 && rhs->expr_type == EXPR_VARIABLE
8143 && (gfc_impure_variable (rhs->symtree->n.sym)
8144 || gfc_is_coindexed (rhs)))
8147 if (gfc_is_coindexed (rhs))
8148 gfc_error ("Coindexed expression at %L is assigned to "
8149 "a derived type variable with a POINTER "
8150 "component in a PURE procedure",
8153 gfc_error ("The impure variable at %L is assigned to "
8154 "a derived type variable with a POINTER "
8155 "component in a PURE procedure (12.6)",
8160 /* Fortran 2008, C1283. */
8161 if (gfc_is_coindexed (lhs))
8163 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8164 "procedure", &rhs->where);
8170 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8171 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8172 if (lhs->ts.type == BT_CLASS)
8174 gfc_error ("Variable must not be polymorphic in assignment at %L",
8179 /* F2008, Section 7.2.1.2. */
8180 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8182 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8183 "component in assignment at %L", &lhs->where);
8187 gfc_check_assign (lhs, rhs, 1);
8192 /* Given a block of code, recursively resolve everything pointed to by this
8196 resolve_code (gfc_code *code, gfc_namespace *ns)
8198 int omp_workshare_save;
8203 frame.prev = cs_base;
8207 find_reachable_labels (code);
8209 for (; code; code = code->next)
8211 frame.current = code;
8212 forall_save = forall_flag;
8214 if (code->op == EXEC_FORALL)
8217 gfc_resolve_forall (code, ns, forall_save);
8220 else if (code->block)
8222 omp_workshare_save = -1;
8225 case EXEC_OMP_PARALLEL_WORKSHARE:
8226 omp_workshare_save = omp_workshare_flag;
8227 omp_workshare_flag = 1;
8228 gfc_resolve_omp_parallel_blocks (code, ns);
8230 case EXEC_OMP_PARALLEL:
8231 case EXEC_OMP_PARALLEL_DO:
8232 case EXEC_OMP_PARALLEL_SECTIONS:
8234 omp_workshare_save = omp_workshare_flag;
8235 omp_workshare_flag = 0;
8236 gfc_resolve_omp_parallel_blocks (code, ns);
8239 gfc_resolve_omp_do_blocks (code, ns);
8241 case EXEC_SELECT_TYPE:
8242 gfc_current_ns = code->ext.ns;
8243 gfc_resolve_blocks (code->block, gfc_current_ns);
8244 gfc_current_ns = ns;
8246 case EXEC_OMP_WORKSHARE:
8247 omp_workshare_save = omp_workshare_flag;
8248 omp_workshare_flag = 1;
8251 gfc_resolve_blocks (code->block, ns);
8255 if (omp_workshare_save != -1)
8256 omp_workshare_flag = omp_workshare_save;
8260 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8261 t = gfc_resolve_expr (code->expr1);
8262 forall_flag = forall_save;
8264 if (gfc_resolve_expr (code->expr2) == FAILURE)
8267 if (code->op == EXEC_ALLOCATE
8268 && gfc_resolve_expr (code->expr3) == FAILURE)
8274 case EXEC_END_BLOCK:
8278 case EXEC_ERROR_STOP:
8282 case EXEC_ASSIGN_CALL:
8287 case EXEC_SYNC_IMAGES:
8288 case EXEC_SYNC_MEMORY:
8289 resolve_sync (code);
8293 /* Keep track of which entry we are up to. */
8294 current_entry_id = code->ext.entry->id;
8298 resolve_where (code, NULL);
8302 if (code->expr1 != NULL)
8304 if (code->expr1->ts.type != BT_INTEGER)
8305 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8306 "INTEGER variable", &code->expr1->where);
8307 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8308 gfc_error ("Variable '%s' has not been assigned a target "
8309 "label at %L", code->expr1->symtree->n.sym->name,
8310 &code->expr1->where);
8313 resolve_branch (code->label1, code);
8317 if (code->expr1 != NULL
8318 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8319 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8320 "INTEGER return specifier", &code->expr1->where);
8323 case EXEC_INIT_ASSIGN:
8324 case EXEC_END_PROCEDURE:
8331 if (resolve_ordinary_assign (code, ns))
8333 if (code->op == EXEC_COMPCALL)
8340 case EXEC_LABEL_ASSIGN:
8341 if (code->label1->defined == ST_LABEL_UNKNOWN)
8342 gfc_error ("Label %d referenced at %L is never defined",
8343 code->label1->value, &code->label1->where);
8345 && (code->expr1->expr_type != EXPR_VARIABLE
8346 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8347 || code->expr1->symtree->n.sym->ts.kind
8348 != gfc_default_integer_kind
8349 || code->expr1->symtree->n.sym->as != NULL))
8350 gfc_error ("ASSIGN statement at %L requires a scalar "
8351 "default INTEGER variable", &code->expr1->where);
8354 case EXEC_POINTER_ASSIGN:
8358 gfc_check_pointer_assign (code->expr1, code->expr2);
8361 case EXEC_ARITHMETIC_IF:
8363 && code->expr1->ts.type != BT_INTEGER
8364 && code->expr1->ts.type != BT_REAL)
8365 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8366 "expression", &code->expr1->where);
8368 resolve_branch (code->label1, code);
8369 resolve_branch (code->label2, code);
8370 resolve_branch (code->label3, code);
8374 if (t == SUCCESS && code->expr1 != NULL
8375 && (code->expr1->ts.type != BT_LOGICAL
8376 || code->expr1->rank != 0))
8377 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8378 &code->expr1->where);
8383 resolve_call (code);
8388 resolve_typebound_subroutine (code);
8392 resolve_ppc_call (code);
8396 /* Select is complicated. Also, a SELECT construct could be
8397 a transformed computed GOTO. */
8398 resolve_select (code);
8401 case EXEC_SELECT_TYPE:
8402 resolve_select_type (code);
8406 gfc_resolve (code->ext.ns);
8410 if (code->ext.iterator != NULL)
8412 gfc_iterator *iter = code->ext.iterator;
8413 if (gfc_resolve_iterator (iter, true) != FAILURE)
8414 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
8419 if (code->expr1 == NULL)
8420 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
8422 && (code->expr1->rank != 0
8423 || code->expr1->ts.type != BT_LOGICAL))
8424 gfc_error ("Exit condition of DO WHILE loop at %L must be "
8425 "a scalar LOGICAL expression", &code->expr1->where);
8430 resolve_allocate_deallocate (code, "ALLOCATE");
8434 case EXEC_DEALLOCATE:
8436 resolve_allocate_deallocate (code, "DEALLOCATE");
8441 if (gfc_resolve_open (code->ext.open) == FAILURE)
8444 resolve_branch (code->ext.open->err, code);
8448 if (gfc_resolve_close (code->ext.close) == FAILURE)
8451 resolve_branch (code->ext.close->err, code);
8454 case EXEC_BACKSPACE:
8458 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
8461 resolve_branch (code->ext.filepos->err, code);
8465 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8468 resolve_branch (code->ext.inquire->err, code);
8472 gcc_assert (code->ext.inquire != NULL);
8473 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8476 resolve_branch (code->ext.inquire->err, code);
8480 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
8483 resolve_branch (code->ext.wait->err, code);
8484 resolve_branch (code->ext.wait->end, code);
8485 resolve_branch (code->ext.wait->eor, code);
8490 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
8493 resolve_branch (code->ext.dt->err, code);
8494 resolve_branch (code->ext.dt->end, code);
8495 resolve_branch (code->ext.dt->eor, code);
8499 resolve_transfer (code);
8503 resolve_forall_iterators (code->ext.forall_iterator);
8505 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
8506 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
8507 "expression", &code->expr1->where);
8510 case EXEC_OMP_ATOMIC:
8511 case EXEC_OMP_BARRIER:
8512 case EXEC_OMP_CRITICAL:
8513 case EXEC_OMP_FLUSH:
8515 case EXEC_OMP_MASTER:
8516 case EXEC_OMP_ORDERED:
8517 case EXEC_OMP_SECTIONS:
8518 case EXEC_OMP_SINGLE:
8519 case EXEC_OMP_TASKWAIT:
8520 case EXEC_OMP_WORKSHARE:
8521 gfc_resolve_omp_directive (code, ns);
8524 case EXEC_OMP_PARALLEL:
8525 case EXEC_OMP_PARALLEL_DO:
8526 case EXEC_OMP_PARALLEL_SECTIONS:
8527 case EXEC_OMP_PARALLEL_WORKSHARE:
8529 omp_workshare_save = omp_workshare_flag;
8530 omp_workshare_flag = 0;
8531 gfc_resolve_omp_directive (code, ns);
8532 omp_workshare_flag = omp_workshare_save;
8536 gfc_internal_error ("resolve_code(): Bad statement code");
8540 cs_base = frame.prev;
8544 /* Resolve initial values and make sure they are compatible with
8548 resolve_values (gfc_symbol *sym)
8550 if (sym->value == NULL)
8553 if (gfc_resolve_expr (sym->value) == FAILURE)
8556 gfc_check_assign_symbol (sym, sym->value);
8560 /* Verify the binding labels for common blocks that are BIND(C). The label
8561 for a BIND(C) common block must be identical in all scoping units in which
8562 the common block is declared. Further, the binding label can not collide
8563 with any other global entity in the program. */
8566 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
8568 if (comm_block_tree->n.common->is_bind_c == 1)
8570 gfc_gsymbol *binding_label_gsym;
8571 gfc_gsymbol *comm_name_gsym;
8573 /* See if a global symbol exists by the common block's name. It may
8574 be NULL if the common block is use-associated. */
8575 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
8576 comm_block_tree->n.common->name);
8577 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
8578 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
8579 "with the global entity '%s' at %L",
8580 comm_block_tree->n.common->binding_label,
8581 comm_block_tree->n.common->name,
8582 &(comm_block_tree->n.common->where),
8583 comm_name_gsym->name, &(comm_name_gsym->where));
8584 else if (comm_name_gsym != NULL
8585 && strcmp (comm_name_gsym->name,
8586 comm_block_tree->n.common->name) == 0)
8588 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
8590 if (comm_name_gsym->binding_label == NULL)
8591 /* No binding label for common block stored yet; save this one. */
8592 comm_name_gsym->binding_label =
8593 comm_block_tree->n.common->binding_label;
8595 if (strcmp (comm_name_gsym->binding_label,
8596 comm_block_tree->n.common->binding_label) != 0)
8598 /* Common block names match but binding labels do not. */
8599 gfc_error ("Binding label '%s' for common block '%s' at %L "
8600 "does not match the binding label '%s' for common "
8602 comm_block_tree->n.common->binding_label,
8603 comm_block_tree->n.common->name,
8604 &(comm_block_tree->n.common->where),
8605 comm_name_gsym->binding_label,
8606 comm_name_gsym->name,
8607 &(comm_name_gsym->where));
8612 /* There is no binding label (NAME="") so we have nothing further to
8613 check and nothing to add as a global symbol for the label. */
8614 if (comm_block_tree->n.common->binding_label[0] == '\0' )
8617 binding_label_gsym =
8618 gfc_find_gsymbol (gfc_gsym_root,
8619 comm_block_tree->n.common->binding_label);
8620 if (binding_label_gsym == NULL)
8622 /* Need to make a global symbol for the binding label to prevent
8623 it from colliding with another. */
8624 binding_label_gsym =
8625 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
8626 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
8627 binding_label_gsym->type = GSYM_COMMON;
8631 /* If comm_name_gsym is NULL, the name common block is use
8632 associated and the name could be colliding. */
8633 if (binding_label_gsym->type != GSYM_COMMON)
8634 gfc_error ("Binding label '%s' for common block '%s' at %L "
8635 "collides with the global entity '%s' at %L",
8636 comm_block_tree->n.common->binding_label,
8637 comm_block_tree->n.common->name,
8638 &(comm_block_tree->n.common->where),
8639 binding_label_gsym->name,
8640 &(binding_label_gsym->where));
8641 else if (comm_name_gsym != NULL
8642 && (strcmp (binding_label_gsym->name,
8643 comm_name_gsym->binding_label) != 0)
8644 && (strcmp (binding_label_gsym->sym_name,
8645 comm_name_gsym->name) != 0))
8646 gfc_error ("Binding label '%s' for common block '%s' at %L "
8647 "collides with global entity '%s' at %L",
8648 binding_label_gsym->name, binding_label_gsym->sym_name,
8649 &(comm_block_tree->n.common->where),
8650 comm_name_gsym->name, &(comm_name_gsym->where));
8658 /* Verify any BIND(C) derived types in the namespace so we can report errors
8659 for them once, rather than for each variable declared of that type. */
8662 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
8664 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
8665 && derived_sym->attr.is_bind_c == 1)
8666 verify_bind_c_derived_type (derived_sym);
8672 /* Verify that any binding labels used in a given namespace do not collide
8673 with the names or binding labels of any global symbols. */
8676 gfc_verify_binding_labels (gfc_symbol *sym)
8680 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
8681 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
8683 gfc_gsymbol *bind_c_sym;
8685 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
8686 if (bind_c_sym != NULL
8687 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
8689 if (sym->attr.if_source == IFSRC_DECL
8690 && (bind_c_sym->type != GSYM_SUBROUTINE
8691 && bind_c_sym->type != GSYM_FUNCTION)
8692 && ((sym->attr.contained == 1
8693 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
8694 || (sym->attr.use_assoc == 1
8695 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
8697 /* Make sure global procedures don't collide with anything. */
8698 gfc_error ("Binding label '%s' at %L collides with the global "
8699 "entity '%s' at %L", sym->binding_label,
8700 &(sym->declared_at), bind_c_sym->name,
8701 &(bind_c_sym->where));
8704 else if (sym->attr.contained == 0
8705 && (sym->attr.if_source == IFSRC_IFBODY
8706 && sym->attr.flavor == FL_PROCEDURE)
8707 && (bind_c_sym->sym_name != NULL
8708 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
8710 /* Make sure procedures in interface bodies don't collide. */
8711 gfc_error ("Binding label '%s' in interface body at %L collides "
8712 "with the global entity '%s' at %L",
8714 &(sym->declared_at), bind_c_sym->name,
8715 &(bind_c_sym->where));
8718 else if (sym->attr.contained == 0
8719 && sym->attr.if_source == IFSRC_UNKNOWN)
8720 if ((sym->attr.use_assoc && bind_c_sym->mod_name
8721 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
8722 || sym->attr.use_assoc == 0)
8724 gfc_error ("Binding label '%s' at %L collides with global "
8725 "entity '%s' at %L", sym->binding_label,
8726 &(sym->declared_at), bind_c_sym->name,
8727 &(bind_c_sym->where));
8732 /* Clear the binding label to prevent checking multiple times. */
8733 sym->binding_label[0] = '\0';
8735 else if (bind_c_sym == NULL)
8737 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
8738 bind_c_sym->where = sym->declared_at;
8739 bind_c_sym->sym_name = sym->name;
8741 if (sym->attr.use_assoc == 1)
8742 bind_c_sym->mod_name = sym->module;
8744 if (sym->ns->proc_name != NULL)
8745 bind_c_sym->mod_name = sym->ns->proc_name->name;
8747 if (sym->attr.contained == 0)
8749 if (sym->attr.subroutine)
8750 bind_c_sym->type = GSYM_SUBROUTINE;
8751 else if (sym->attr.function)
8752 bind_c_sym->type = GSYM_FUNCTION;
8760 /* Resolve an index expression. */
8763 resolve_index_expr (gfc_expr *e)
8765 if (gfc_resolve_expr (e) == FAILURE)
8768 if (gfc_simplify_expr (e, 0) == FAILURE)
8771 if (gfc_specification_expr (e) == FAILURE)
8777 /* Resolve a charlen structure. */
8780 resolve_charlen (gfc_charlen *cl)
8789 specification_expr = 1;
8791 if (resolve_index_expr (cl->length) == FAILURE)
8793 specification_expr = 0;
8797 /* "If the character length parameter value evaluates to a negative
8798 value, the length of character entities declared is zero." */
8799 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
8801 if (gfc_option.warn_surprising)
8802 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
8803 " the length has been set to zero",
8804 &cl->length->where, i);
8805 gfc_replace_expr (cl->length,
8806 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
8809 /* Check that the character length is not too large. */
8810 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
8811 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
8812 && cl->length->ts.type == BT_INTEGER
8813 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
8815 gfc_error ("String length at %L is too large", &cl->length->where);
8823 /* Test for non-constant shape arrays. */
8826 is_non_constant_shape_array (gfc_symbol *sym)
8832 not_constant = false;
8833 if (sym->as != NULL)
8835 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
8836 has not been simplified; parameter array references. Do the
8837 simplification now. */
8838 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
8840 e = sym->as->lower[i];
8841 if (e && (resolve_index_expr (e) == FAILURE
8842 || !gfc_is_constant_expr (e)))
8843 not_constant = true;
8844 e = sym->as->upper[i];
8845 if (e && (resolve_index_expr (e) == FAILURE
8846 || !gfc_is_constant_expr (e)))
8847 not_constant = true;
8850 return not_constant;
8853 /* Given a symbol and an initialization expression, add code to initialize
8854 the symbol to the function entry. */
8856 build_init_assign (gfc_symbol *sym, gfc_expr *init)
8860 gfc_namespace *ns = sym->ns;
8862 /* Search for the function namespace if this is a contained
8863 function without an explicit result. */
8864 if (sym->attr.function && sym == sym->result
8865 && sym->name != sym->ns->proc_name->name)
8868 for (;ns; ns = ns->sibling)
8869 if (strcmp (ns->proc_name->name, sym->name) == 0)
8875 gfc_free_expr (init);
8879 /* Build an l-value expression for the result. */
8880 lval = gfc_lval_expr_from_sym (sym);
8882 /* Add the code at scope entry. */
8883 init_st = gfc_get_code ();
8884 init_st->next = ns->code;
8887 /* Assign the default initializer to the l-value. */
8888 init_st->loc = sym->declared_at;
8889 init_st->op = EXEC_INIT_ASSIGN;
8890 init_st->expr1 = lval;
8891 init_st->expr2 = init;
8894 /* Assign the default initializer to a derived type variable or result. */
8897 apply_default_init (gfc_symbol *sym)
8899 gfc_expr *init = NULL;
8901 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
8904 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
8905 init = gfc_default_initializer (&sym->ts);
8910 build_init_assign (sym, init);
8913 /* Build an initializer for a local integer, real, complex, logical, or
8914 character variable, based on the command line flags finit-local-zero,
8915 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
8916 null if the symbol should not have a default initialization. */
8918 build_default_init_expr (gfc_symbol *sym)
8921 gfc_expr *init_expr;
8924 /* These symbols should never have a default initialization. */
8925 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
8926 || sym->attr.external
8928 || sym->attr.pointer
8929 || sym->attr.in_equivalence
8930 || sym->attr.in_common
8933 || sym->attr.cray_pointee
8934 || sym->attr.cray_pointer)
8937 /* Now we'll try to build an initializer expression. */
8938 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
8941 /* We will only initialize integers, reals, complex, logicals, and
8942 characters, and only if the corresponding command-line flags
8943 were set. Otherwise, we free init_expr and return null. */
8944 switch (sym->ts.type)
8947 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
8948 mpz_init_set_si (init_expr->value.integer,
8949 gfc_option.flag_init_integer_value);
8952 gfc_free_expr (init_expr);
8958 mpfr_init (init_expr->value.real);
8959 switch (gfc_option.flag_init_real)
8961 case GFC_INIT_REAL_SNAN:
8962 init_expr->is_snan = 1;
8964 case GFC_INIT_REAL_NAN:
8965 mpfr_set_nan (init_expr->value.real);
8968 case GFC_INIT_REAL_INF:
8969 mpfr_set_inf (init_expr->value.real, 1);
8972 case GFC_INIT_REAL_NEG_INF:
8973 mpfr_set_inf (init_expr->value.real, -1);
8976 case GFC_INIT_REAL_ZERO:
8977 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
8981 gfc_free_expr (init_expr);
8988 mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
8989 switch (gfc_option.flag_init_real)
8991 case GFC_INIT_REAL_SNAN:
8992 init_expr->is_snan = 1;
8994 case GFC_INIT_REAL_NAN:
8995 mpfr_set_nan (mpc_realref (init_expr->value.complex));
8996 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
8999 case GFC_INIT_REAL_INF:
9000 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9001 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9004 case GFC_INIT_REAL_NEG_INF:
9005 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9006 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9009 case GFC_INIT_REAL_ZERO:
9010 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9014 gfc_free_expr (init_expr);
9021 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9022 init_expr->value.logical = 0;
9023 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9024 init_expr->value.logical = 1;
9027 gfc_free_expr (init_expr);
9033 /* For characters, the length must be constant in order to
9034 create a default initializer. */
9035 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9036 && sym->ts.u.cl->length
9037 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9039 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9040 init_expr->value.character.length = char_len;
9041 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9042 for (i = 0; i < char_len; i++)
9043 init_expr->value.character.string[i]
9044 = (unsigned char) gfc_option.flag_init_character_value;
9048 gfc_free_expr (init_expr);
9054 gfc_free_expr (init_expr);
9060 /* Add an initialization expression to a local variable. */
9062 apply_default_init_local (gfc_symbol *sym)
9064 gfc_expr *init = NULL;
9066 /* The symbol should be a variable or a function return value. */
9067 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9068 || (sym->attr.function && sym->result != sym))
9071 /* Try to build the initializer expression. If we can't initialize
9072 this symbol, then init will be NULL. */
9073 init = build_default_init_expr (sym);
9077 /* For saved variables, we don't want to add an initializer at
9078 function entry, so we just add a static initializer. */
9079 if (sym->attr.save || sym->ns->save_all
9080 || gfc_option.flag_max_stack_var_size == 0)
9082 /* Don't clobber an existing initializer! */
9083 gcc_assert (sym->value == NULL);
9088 build_init_assign (sym, init);
9091 /* Resolution of common features of flavors variable and procedure. */
9094 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9096 /* Constraints on deferred shape variable. */
9097 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9099 if (sym->attr.allocatable)
9101 if (sym->attr.dimension)
9103 gfc_error ("Allocatable array '%s' at %L must have "
9104 "a deferred shape", sym->name, &sym->declared_at);
9107 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9108 "may not be ALLOCATABLE", sym->name,
9109 &sym->declared_at) == FAILURE)
9113 if (sym->attr.pointer && sym->attr.dimension)
9115 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9116 sym->name, &sym->declared_at);
9123 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9124 && !sym->attr.dummy && sym->ts.type != BT_CLASS)
9126 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9127 sym->name, &sym->declared_at);
9132 /* Constraints on polymorphic variables. */
9133 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9136 if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
9138 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9139 sym->ts.u.derived->components->ts.u.derived->name,
9140 sym->name, &sym->declared_at);
9145 /* Assume that use associated symbols were checked in the module ns. */
9146 if (!sym->attr.class_ok && !sym->attr.use_assoc)
9148 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9149 "or pointer", sym->name, &sym->declared_at);
9158 /* Additional checks for symbols with flavor variable and derived
9159 type. To be called from resolve_fl_variable. */
9162 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9164 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9166 /* Check to see if a derived type is blocked from being host
9167 associated by the presence of another class I symbol in the same
9168 namespace. 14.6.1.3 of the standard and the discussion on
9169 comp.lang.fortran. */
9170 if (sym->ns != sym->ts.u.derived->ns
9171 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9174 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9175 if (s && s->attr.flavor != FL_DERIVED)
9177 gfc_error ("The type '%s' cannot be host associated at %L "
9178 "because it is blocked by an incompatible object "
9179 "of the same name declared at %L",
9180 sym->ts.u.derived->name, &sym->declared_at,
9186 /* 4th constraint in section 11.3: "If an object of a type for which
9187 component-initialization is specified (R429) appears in the
9188 specification-part of a module and does not have the ALLOCATABLE
9189 or POINTER attribute, the object shall have the SAVE attribute."
9191 The check for initializers is performed with
9192 gfc_has_default_initializer because gfc_default_initializer generates
9193 a hidden default for allocatable components. */
9194 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9195 && sym->ns->proc_name->attr.flavor == FL_MODULE
9196 && !sym->ns->save_all && !sym->attr.save
9197 && !sym->attr.pointer && !sym->attr.allocatable
9198 && gfc_has_default_initializer (sym->ts.u.derived)
9199 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9200 "module variable '%s' at %L, needed due to "
9201 "the default initialization", sym->name,
9202 &sym->declared_at) == FAILURE)
9205 /* Assign default initializer. */
9206 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9207 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9209 sym->value = gfc_default_initializer (&sym->ts);
9216 /* Resolve symbols with flavor variable. */
9219 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9221 int no_init_flag, automatic_flag;
9223 const char *auto_save_msg;
9225 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9228 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9231 /* Set this flag to check that variables are parameters of all entries.
9232 This check is effected by the call to gfc_resolve_expr through
9233 is_non_constant_shape_array. */
9234 specification_expr = 1;
9236 if (sym->ns->proc_name
9237 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9238 || sym->ns->proc_name->attr.is_main_program)
9239 && !sym->attr.use_assoc
9240 && !sym->attr.allocatable
9241 && !sym->attr.pointer
9242 && is_non_constant_shape_array (sym))
9244 /* The shape of a main program or module array needs to be
9246 gfc_error ("The module or main program array '%s' at %L must "
9247 "have constant shape", sym->name, &sym->declared_at);
9248 specification_expr = 0;
9252 if (sym->ts.type == BT_CHARACTER)
9254 /* Make sure that character string variables with assumed length are
9256 e = sym->ts.u.cl->length;
9257 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
9259 gfc_error ("Entity with assumed character length at %L must be a "
9260 "dummy argument or a PARAMETER", &sym->declared_at);
9264 if (e && sym->attr.save && !gfc_is_constant_expr (e))
9266 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9270 if (!gfc_is_constant_expr (e)
9271 && !(e->expr_type == EXPR_VARIABLE
9272 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9273 && sym->ns->proc_name
9274 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9275 || sym->ns->proc_name->attr.is_main_program)
9276 && !sym->attr.use_assoc)
9278 gfc_error ("'%s' at %L must have constant character length "
9279 "in this context", sym->name, &sym->declared_at);
9284 if (sym->value == NULL && sym->attr.referenced)
9285 apply_default_init_local (sym); /* Try to apply a default initialization. */
9287 /* Determine if the symbol may not have an initializer. */
9288 no_init_flag = automatic_flag = 0;
9289 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9290 || sym->attr.intrinsic || sym->attr.result)
9292 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9293 && is_non_constant_shape_array (sym))
9295 no_init_flag = automatic_flag = 1;
9297 /* Also, they must not have the SAVE attribute.
9298 SAVE_IMPLICIT is checked below. */
9299 if (sym->attr.save == SAVE_EXPLICIT)
9301 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9306 /* Ensure that any initializer is simplified. */
9308 gfc_simplify_expr (sym->value, 1);
9310 /* Reject illegal initializers. */
9311 if (!sym->mark && sym->value)
9313 if (sym->attr.allocatable)
9314 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9315 sym->name, &sym->declared_at);
9316 else if (sym->attr.external)
9317 gfc_error ("External '%s' at %L cannot have an initializer",
9318 sym->name, &sym->declared_at);
9319 else if (sym->attr.dummy
9320 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9321 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9322 sym->name, &sym->declared_at);
9323 else if (sym->attr.intrinsic)
9324 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9325 sym->name, &sym->declared_at);
9326 else if (sym->attr.result)
9327 gfc_error ("Function result '%s' at %L cannot have an initializer",
9328 sym->name, &sym->declared_at);
9329 else if (automatic_flag)
9330 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9331 sym->name, &sym->declared_at);
9338 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9339 return resolve_fl_variable_derived (sym, no_init_flag);
9345 /* Resolve a procedure. */
9348 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9350 gfc_formal_arglist *arg;
9352 if (sym->attr.function
9353 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9356 if (sym->ts.type == BT_CHARACTER)
9358 gfc_charlen *cl = sym->ts.u.cl;
9360 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9361 && resolve_charlen (cl) == FAILURE)
9364 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9365 && sym->attr.proc == PROC_ST_FUNCTION)
9367 gfc_error ("Character-valued statement function '%s' at %L must "
9368 "have constant length", sym->name, &sym->declared_at);
9373 /* Ensure that derived type for are not of a private type. Internal
9374 module procedures are excluded by 2.2.3.3 - i.e., they are not
9375 externally accessible and can access all the objects accessible in
9377 if (!(sym->ns->parent
9378 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9379 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9381 gfc_interface *iface;
9383 for (arg = sym->formal; arg; arg = arg->next)
9386 && arg->sym->ts.type == BT_DERIVED
9387 && !arg->sym->ts.u.derived->attr.use_assoc
9388 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9389 arg->sym->ts.u.derived->ns->default_access)
9390 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9391 "PRIVATE type and cannot be a dummy argument"
9392 " of '%s', which is PUBLIC at %L",
9393 arg->sym->name, sym->name, &sym->declared_at)
9396 /* Stop this message from recurring. */
9397 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9402 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9403 PRIVATE to the containing module. */
9404 for (iface = sym->generic; iface; iface = iface->next)
9406 for (arg = iface->sym->formal; arg; arg = arg->next)
9409 && arg->sym->ts.type == BT_DERIVED
9410 && !arg->sym->ts.u.derived->attr.use_assoc
9411 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9412 arg->sym->ts.u.derived->ns->default_access)
9413 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
9414 "'%s' in PUBLIC interface '%s' at %L "
9415 "takes dummy arguments of '%s' which is "
9416 "PRIVATE", iface->sym->name, sym->name,
9417 &iface->sym->declared_at,
9418 gfc_typename (&arg->sym->ts)) == FAILURE)
9420 /* Stop this message from recurring. */
9421 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9427 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9428 PRIVATE to the containing module. */
9429 for (iface = sym->generic; iface; iface = iface->next)
9431 for (arg = iface->sym->formal; arg; arg = arg->next)
9434 && arg->sym->ts.type == BT_DERIVED
9435 && !arg->sym->ts.u.derived->attr.use_assoc
9436 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9437 arg->sym->ts.u.derived->ns->default_access)
9438 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
9439 "'%s' in PUBLIC interface '%s' at %L "
9440 "takes dummy arguments of '%s' which is "
9441 "PRIVATE", iface->sym->name, sym->name,
9442 &iface->sym->declared_at,
9443 gfc_typename (&arg->sym->ts)) == FAILURE)
9445 /* Stop this message from recurring. */
9446 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9453 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
9454 && !sym->attr.proc_pointer)
9456 gfc_error ("Function '%s' at %L cannot have an initializer",
9457 sym->name, &sym->declared_at);
9461 /* An external symbol may not have an initializer because it is taken to be
9462 a procedure. Exception: Procedure Pointers. */
9463 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
9465 gfc_error ("External object '%s' at %L may not have an initializer",
9466 sym->name, &sym->declared_at);
9470 /* An elemental function is required to return a scalar 12.7.1 */
9471 if (sym->attr.elemental && sym->attr.function && sym->as)
9473 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
9474 "result", sym->name, &sym->declared_at);
9475 /* Reset so that the error only occurs once. */
9476 sym->attr.elemental = 0;
9480 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
9481 char-len-param shall not be array-valued, pointer-valued, recursive
9482 or pure. ....snip... A character value of * may only be used in the
9483 following ways: (i) Dummy arg of procedure - dummy associates with
9484 actual length; (ii) To declare a named constant; or (iii) External
9485 function - but length must be declared in calling scoping unit. */
9486 if (sym->attr.function
9487 && sym->ts.type == BT_CHARACTER
9488 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
9490 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
9491 || (sym->attr.recursive) || (sym->attr.pure))
9493 if (sym->as && sym->as->rank)
9494 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9495 "array-valued", sym->name, &sym->declared_at);
9497 if (sym->attr.pointer)
9498 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9499 "pointer-valued", sym->name, &sym->declared_at);
9502 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9503 "pure", sym->name, &sym->declared_at);
9505 if (sym->attr.recursive)
9506 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9507 "recursive", sym->name, &sym->declared_at);
9512 /* Appendix B.2 of the standard. Contained functions give an
9513 error anyway. Fixed-form is likely to be F77/legacy. */
9514 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
9515 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
9516 "CHARACTER(*) function '%s' at %L",
9517 sym->name, &sym->declared_at);
9520 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
9522 gfc_formal_arglist *curr_arg;
9523 int has_non_interop_arg = 0;
9525 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9526 sym->common_block) == FAILURE)
9528 /* Clear these to prevent looking at them again if there was an
9530 sym->attr.is_bind_c = 0;
9531 sym->attr.is_c_interop = 0;
9532 sym->ts.is_c_interop = 0;
9536 /* So far, no errors have been found. */
9537 sym->attr.is_c_interop = 1;
9538 sym->ts.is_c_interop = 1;
9541 curr_arg = sym->formal;
9542 while (curr_arg != NULL)
9544 /* Skip implicitly typed dummy args here. */
9545 if (curr_arg->sym->attr.implicit_type == 0)
9546 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
9547 /* If something is found to fail, record the fact so we
9548 can mark the symbol for the procedure as not being
9549 BIND(C) to try and prevent multiple errors being
9551 has_non_interop_arg = 1;
9553 curr_arg = curr_arg->next;
9556 /* See if any of the arguments were not interoperable and if so, clear
9557 the procedure symbol to prevent duplicate error messages. */
9558 if (has_non_interop_arg != 0)
9560 sym->attr.is_c_interop = 0;
9561 sym->ts.is_c_interop = 0;
9562 sym->attr.is_bind_c = 0;
9566 if (!sym->attr.proc_pointer)
9568 if (sym->attr.save == SAVE_EXPLICIT)
9570 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
9571 "in '%s' at %L", sym->name, &sym->declared_at);
9574 if (sym->attr.intent)
9576 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
9577 "in '%s' at %L", sym->name, &sym->declared_at);
9580 if (sym->attr.subroutine && sym->attr.result)
9582 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
9583 "in '%s' at %L", sym->name, &sym->declared_at);
9586 if (sym->attr.external && sym->attr.function
9587 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
9588 || sym->attr.contained))
9590 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
9591 "in '%s' at %L", sym->name, &sym->declared_at);
9594 if (strcmp ("ppr@", sym->name) == 0)
9596 gfc_error ("Procedure pointer result '%s' at %L "
9597 "is missing the pointer attribute",
9598 sym->ns->proc_name->name, &sym->declared_at);
9607 /* Resolve a list of finalizer procedures. That is, after they have hopefully
9608 been defined and we now know their defined arguments, check that they fulfill
9609 the requirements of the standard for procedures used as finalizers. */
9612 gfc_resolve_finalizers (gfc_symbol* derived)
9614 gfc_finalizer* list;
9615 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
9616 gfc_try result = SUCCESS;
9617 bool seen_scalar = false;
9619 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
9622 /* Walk over the list of finalizer-procedures, check them, and if any one
9623 does not fit in with the standard's definition, print an error and remove
9624 it from the list. */
9625 prev_link = &derived->f2k_derived->finalizers;
9626 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
9632 /* Skip this finalizer if we already resolved it. */
9633 if (list->proc_tree)
9635 prev_link = &(list->next);
9639 /* Check this exists and is a SUBROUTINE. */
9640 if (!list->proc_sym->attr.subroutine)
9642 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
9643 list->proc_sym->name, &list->where);
9647 /* We should have exactly one argument. */
9648 if (!list->proc_sym->formal || list->proc_sym->formal->next)
9650 gfc_error ("FINAL procedure at %L must have exactly one argument",
9654 arg = list->proc_sym->formal->sym;
9656 /* This argument must be of our type. */
9657 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
9659 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
9660 &arg->declared_at, derived->name);
9664 /* It must neither be a pointer nor allocatable nor optional. */
9665 if (arg->attr.pointer)
9667 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
9671 if (arg->attr.allocatable)
9673 gfc_error ("Argument of FINAL procedure at %L must not be"
9674 " ALLOCATABLE", &arg->declared_at);
9677 if (arg->attr.optional)
9679 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
9684 /* It must not be INTENT(OUT). */
9685 if (arg->attr.intent == INTENT_OUT)
9687 gfc_error ("Argument of FINAL procedure at %L must not be"
9688 " INTENT(OUT)", &arg->declared_at);
9692 /* Warn if the procedure is non-scalar and not assumed shape. */
9693 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
9694 && arg->as->type != AS_ASSUMED_SHAPE)
9695 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
9696 " shape argument", &arg->declared_at);
9698 /* Check that it does not match in kind and rank with a FINAL procedure
9699 defined earlier. To really loop over the *earlier* declarations,
9700 we need to walk the tail of the list as new ones were pushed at the
9702 /* TODO: Handle kind parameters once they are implemented. */
9703 my_rank = (arg->as ? arg->as->rank : 0);
9704 for (i = list->next; i; i = i->next)
9706 /* Argument list might be empty; that is an error signalled earlier,
9707 but we nevertheless continued resolving. */
9708 if (i->proc_sym->formal)
9710 gfc_symbol* i_arg = i->proc_sym->formal->sym;
9711 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
9712 if (i_rank == my_rank)
9714 gfc_error ("FINAL procedure '%s' declared at %L has the same"
9715 " rank (%d) as '%s'",
9716 list->proc_sym->name, &list->where, my_rank,
9723 /* Is this the/a scalar finalizer procedure? */
9724 if (!arg->as || arg->as->rank == 0)
9727 /* Find the symtree for this procedure. */
9728 gcc_assert (!list->proc_tree);
9729 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
9731 prev_link = &list->next;
9734 /* Remove wrong nodes immediately from the list so we don't risk any
9735 troubles in the future when they might fail later expectations. */
9739 *prev_link = list->next;
9740 gfc_free_finalizer (i);
9743 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
9744 were nodes in the list, must have been for arrays. It is surely a good
9745 idea to have a scalar version there if there's something to finalize. */
9746 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
9747 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
9748 " defined at %L, suggest also scalar one",
9749 derived->name, &derived->declared_at);
9751 /* TODO: Remove this error when finalization is finished. */
9752 gfc_error ("Finalization at %L is not yet implemented",
9753 &derived->declared_at);
9759 /* Check that it is ok for the typebound procedure proc to override the
9763 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
9766 const gfc_symbol* proc_target;
9767 const gfc_symbol* old_target;
9768 unsigned proc_pass_arg, old_pass_arg, argpos;
9769 gfc_formal_arglist* proc_formal;
9770 gfc_formal_arglist* old_formal;
9772 /* This procedure should only be called for non-GENERIC proc. */
9773 gcc_assert (!proc->n.tb->is_generic);
9775 /* If the overwritten procedure is GENERIC, this is an error. */
9776 if (old->n.tb->is_generic)
9778 gfc_error ("Can't overwrite GENERIC '%s' at %L",
9779 old->name, &proc->n.tb->where);
9783 where = proc->n.tb->where;
9784 proc_target = proc->n.tb->u.specific->n.sym;
9785 old_target = old->n.tb->u.specific->n.sym;
9787 /* Check that overridden binding is not NON_OVERRIDABLE. */
9788 if (old->n.tb->non_overridable)
9790 gfc_error ("'%s' at %L overrides a procedure binding declared"
9791 " NON_OVERRIDABLE", proc->name, &where);
9795 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
9796 if (!old->n.tb->deferred && proc->n.tb->deferred)
9798 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
9799 " non-DEFERRED binding", proc->name, &where);
9803 /* If the overridden binding is PURE, the overriding must be, too. */
9804 if (old_target->attr.pure && !proc_target->attr.pure)
9806 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
9807 proc->name, &where);
9811 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
9812 is not, the overriding must not be either. */
9813 if (old_target->attr.elemental && !proc_target->attr.elemental)
9815 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
9816 " ELEMENTAL", proc->name, &where);
9819 if (!old_target->attr.elemental && proc_target->attr.elemental)
9821 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
9822 " be ELEMENTAL, either", proc->name, &where);
9826 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
9828 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
9830 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
9831 " SUBROUTINE", proc->name, &where);
9835 /* If the overridden binding is a FUNCTION, the overriding must also be a
9836 FUNCTION and have the same characteristics. */
9837 if (old_target->attr.function)
9839 if (!proc_target->attr.function)
9841 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
9842 " FUNCTION", proc->name, &where);
9846 /* FIXME: Do more comprehensive checking (including, for instance, the
9847 rank and array-shape). */
9848 gcc_assert (proc_target->result && old_target->result);
9849 if (!gfc_compare_types (&proc_target->result->ts,
9850 &old_target->result->ts))
9852 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
9853 " matching result types", proc->name, &where);
9858 /* If the overridden binding is PUBLIC, the overriding one must not be
9860 if (old->n.tb->access == ACCESS_PUBLIC
9861 && proc->n.tb->access == ACCESS_PRIVATE)
9863 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
9864 " PRIVATE", proc->name, &where);
9868 /* Compare the formal argument lists of both procedures. This is also abused
9869 to find the position of the passed-object dummy arguments of both
9870 bindings as at least the overridden one might not yet be resolved and we
9871 need those positions in the check below. */
9872 proc_pass_arg = old_pass_arg = 0;
9873 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
9875 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
9878 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
9879 proc_formal && old_formal;
9880 proc_formal = proc_formal->next, old_formal = old_formal->next)
9882 if (proc->n.tb->pass_arg
9883 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
9884 proc_pass_arg = argpos;
9885 if (old->n.tb->pass_arg
9886 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
9887 old_pass_arg = argpos;
9889 /* Check that the names correspond. */
9890 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
9892 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
9893 " to match the corresponding argument of the overridden"
9894 " procedure", proc_formal->sym->name, proc->name, &where,
9895 old_formal->sym->name);
9899 /* Check that the types correspond if neither is the passed-object
9901 /* FIXME: Do more comprehensive testing here. */
9902 if (proc_pass_arg != argpos && old_pass_arg != argpos
9903 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
9905 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
9906 "in respect to the overridden procedure",
9907 proc_formal->sym->name, proc->name, &where);
9913 if (proc_formal || old_formal)
9915 gfc_error ("'%s' at %L must have the same number of formal arguments as"
9916 " the overridden procedure", proc->name, &where);
9920 /* If the overridden binding is NOPASS, the overriding one must also be
9922 if (old->n.tb->nopass && !proc->n.tb->nopass)
9924 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
9925 " NOPASS", proc->name, &where);
9929 /* If the overridden binding is PASS(x), the overriding one must also be
9930 PASS and the passed-object dummy arguments must correspond. */
9931 if (!old->n.tb->nopass)
9933 if (proc->n.tb->nopass)
9935 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
9936 " PASS", proc->name, &where);
9940 if (proc_pass_arg != old_pass_arg)
9942 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
9943 " the same position as the passed-object dummy argument of"
9944 " the overridden procedure", proc->name, &where);
9953 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
9956 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
9957 const char* generic_name, locus where)
9962 gcc_assert (t1->specific && t2->specific);
9963 gcc_assert (!t1->specific->is_generic);
9964 gcc_assert (!t2->specific->is_generic);
9966 sym1 = t1->specific->u.specific->n.sym;
9967 sym2 = t2->specific->u.specific->n.sym;
9972 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
9973 if (sym1->attr.subroutine != sym2->attr.subroutine
9974 || sym1->attr.function != sym2->attr.function)
9976 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
9977 " GENERIC '%s' at %L",
9978 sym1->name, sym2->name, generic_name, &where);
9982 /* Compare the interfaces. */
9983 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
9985 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
9986 sym1->name, sym2->name, generic_name, &where);
9994 /* Worker function for resolving a generic procedure binding; this is used to
9995 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
9997 The difference between those cases is finding possible inherited bindings
9998 that are overridden, as one has to look for them in tb_sym_root,
9999 tb_uop_root or tb_op, respectively. Thus the caller must already find
10000 the super-type and set p->overridden correctly. */
10003 resolve_tb_generic_targets (gfc_symbol* super_type,
10004 gfc_typebound_proc* p, const char* name)
10006 gfc_tbp_generic* target;
10007 gfc_symtree* first_target;
10008 gfc_symtree* inherited;
10010 gcc_assert (p && p->is_generic);
10012 /* Try to find the specific bindings for the symtrees in our target-list. */
10013 gcc_assert (p->u.generic);
10014 for (target = p->u.generic; target; target = target->next)
10015 if (!target->specific)
10017 gfc_typebound_proc* overridden_tbp;
10018 gfc_tbp_generic* g;
10019 const char* target_name;
10021 target_name = target->specific_st->name;
10023 /* Defined for this type directly. */
10024 if (target->specific_st->n.tb)
10026 target->specific = target->specific_st->n.tb;
10027 goto specific_found;
10030 /* Look for an inherited specific binding. */
10033 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10038 gcc_assert (inherited->n.tb);
10039 target->specific = inherited->n.tb;
10040 goto specific_found;
10044 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10045 " at %L", target_name, name, &p->where);
10048 /* Once we've found the specific binding, check it is not ambiguous with
10049 other specifics already found or inherited for the same GENERIC. */
10051 gcc_assert (target->specific);
10053 /* This must really be a specific binding! */
10054 if (target->specific->is_generic)
10056 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10057 " '%s' is GENERIC, too", name, &p->where, target_name);
10061 /* Check those already resolved on this type directly. */
10062 for (g = p->u.generic; g; g = g->next)
10063 if (g != target && g->specific
10064 && check_generic_tbp_ambiguity (target, g, name, p->where)
10068 /* Check for ambiguity with inherited specific targets. */
10069 for (overridden_tbp = p->overridden; overridden_tbp;
10070 overridden_tbp = overridden_tbp->overridden)
10071 if (overridden_tbp->is_generic)
10073 for (g = overridden_tbp->u.generic; g; g = g->next)
10075 gcc_assert (g->specific);
10076 if (check_generic_tbp_ambiguity (target, g,
10077 name, p->where) == FAILURE)
10083 /* If we attempt to "overwrite" a specific binding, this is an error. */
10084 if (p->overridden && !p->overridden->is_generic)
10086 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10087 " the same name", name, &p->where);
10091 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10092 all must have the same attributes here. */
10093 first_target = p->u.generic->specific->u.specific;
10094 gcc_assert (first_target);
10095 p->subroutine = first_target->n.sym->attr.subroutine;
10096 p->function = first_target->n.sym->attr.function;
10102 /* Resolve a GENERIC procedure binding for a derived type. */
10105 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10107 gfc_symbol* super_type;
10109 /* Find the overridden binding if any. */
10110 st->n.tb->overridden = NULL;
10111 super_type = gfc_get_derived_super_type (derived);
10114 gfc_symtree* overridden;
10115 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10118 if (overridden && overridden->n.tb)
10119 st->n.tb->overridden = overridden->n.tb;
10122 /* Resolve using worker function. */
10123 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10127 /* Retrieve the target-procedure of an operator binding and do some checks in
10128 common for intrinsic and user-defined type-bound operators. */
10131 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10133 gfc_symbol* target_proc;
10135 gcc_assert (target->specific && !target->specific->is_generic);
10136 target_proc = target->specific->u.specific->n.sym;
10137 gcc_assert (target_proc);
10139 /* All operator bindings must have a passed-object dummy argument. */
10140 if (target->specific->nopass)
10142 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10146 return target_proc;
10150 /* Resolve a type-bound intrinsic operator. */
10153 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10154 gfc_typebound_proc* p)
10156 gfc_symbol* super_type;
10157 gfc_tbp_generic* target;
10159 /* If there's already an error here, do nothing (but don't fail again). */
10163 /* Operators should always be GENERIC bindings. */
10164 gcc_assert (p->is_generic);
10166 /* Look for an overridden binding. */
10167 super_type = gfc_get_derived_super_type (derived);
10168 if (super_type && super_type->f2k_derived)
10169 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10172 p->overridden = NULL;
10174 /* Resolve general GENERIC properties using worker function. */
10175 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10178 /* Check the targets to be procedures of correct interface. */
10179 for (target = p->u.generic; target; target = target->next)
10181 gfc_symbol* target_proc;
10183 target_proc = get_checked_tb_operator_target (target, p->where);
10187 if (!gfc_check_operator_interface (target_proc, op, p->where))
10199 /* Resolve a type-bound user operator (tree-walker callback). */
10201 static gfc_symbol* resolve_bindings_derived;
10202 static gfc_try resolve_bindings_result;
10204 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10207 resolve_typebound_user_op (gfc_symtree* stree)
10209 gfc_symbol* super_type;
10210 gfc_tbp_generic* target;
10212 gcc_assert (stree && stree->n.tb);
10214 if (stree->n.tb->error)
10217 /* Operators should always be GENERIC bindings. */
10218 gcc_assert (stree->n.tb->is_generic);
10220 /* Find overridden procedure, if any. */
10221 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10222 if (super_type && super_type->f2k_derived)
10224 gfc_symtree* overridden;
10225 overridden = gfc_find_typebound_user_op (super_type, NULL,
10226 stree->name, true, NULL);
10228 if (overridden && overridden->n.tb)
10229 stree->n.tb->overridden = overridden->n.tb;
10232 stree->n.tb->overridden = NULL;
10234 /* Resolve basically using worker function. */
10235 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10239 /* Check the targets to be functions of correct interface. */
10240 for (target = stree->n.tb->u.generic; target; target = target->next)
10242 gfc_symbol* target_proc;
10244 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10248 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10255 resolve_bindings_result = FAILURE;
10256 stree->n.tb->error = 1;
10260 /* Resolve the type-bound procedures for a derived type. */
10263 resolve_typebound_procedure (gfc_symtree* stree)
10267 gfc_symbol* me_arg;
10268 gfc_symbol* super_type;
10269 gfc_component* comp;
10271 gcc_assert (stree);
10273 /* Undefined specific symbol from GENERIC target definition. */
10277 if (stree->n.tb->error)
10280 /* If this is a GENERIC binding, use that routine. */
10281 if (stree->n.tb->is_generic)
10283 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10289 /* Get the target-procedure to check it. */
10290 gcc_assert (!stree->n.tb->is_generic);
10291 gcc_assert (stree->n.tb->u.specific);
10292 proc = stree->n.tb->u.specific->n.sym;
10293 where = stree->n.tb->where;
10295 /* Default access should already be resolved from the parser. */
10296 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10298 /* It should be a module procedure or an external procedure with explicit
10299 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10300 if ((!proc->attr.subroutine && !proc->attr.function)
10301 || (proc->attr.proc != PROC_MODULE
10302 && proc->attr.if_source != IFSRC_IFBODY)
10303 || (proc->attr.abstract && !stree->n.tb->deferred))
10305 gfc_error ("'%s' must be a module procedure or an external procedure with"
10306 " an explicit interface at %L", proc->name, &where);
10309 stree->n.tb->subroutine = proc->attr.subroutine;
10310 stree->n.tb->function = proc->attr.function;
10312 /* Find the super-type of the current derived type. We could do this once and
10313 store in a global if speed is needed, but as long as not I believe this is
10314 more readable and clearer. */
10315 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10317 /* If PASS, resolve and check arguments if not already resolved / loaded
10318 from a .mod file. */
10319 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10321 if (stree->n.tb->pass_arg)
10323 gfc_formal_arglist* i;
10325 /* If an explicit passing argument name is given, walk the arg-list
10326 and look for it. */
10329 stree->n.tb->pass_arg_num = 1;
10330 for (i = proc->formal; i; i = i->next)
10332 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10337 ++stree->n.tb->pass_arg_num;
10342 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10344 proc->name, stree->n.tb->pass_arg, &where,
10345 stree->n.tb->pass_arg);
10351 /* Otherwise, take the first one; there should in fact be at least
10353 stree->n.tb->pass_arg_num = 1;
10356 gfc_error ("Procedure '%s' with PASS at %L must have at"
10357 " least one argument", proc->name, &where);
10360 me_arg = proc->formal->sym;
10363 /* Now check that the argument-type matches and the passed-object
10364 dummy argument is generally fine. */
10366 gcc_assert (me_arg);
10368 if (me_arg->ts.type != BT_CLASS)
10370 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10371 " at %L", proc->name, &where);
10375 if (me_arg->ts.u.derived->components->ts.u.derived
10376 != resolve_bindings_derived)
10378 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10379 " the derived-type '%s'", me_arg->name, proc->name,
10380 me_arg->name, &where, resolve_bindings_derived->name);
10384 gcc_assert (me_arg->ts.type == BT_CLASS);
10385 if (me_arg->ts.u.derived->components->as
10386 && me_arg->ts.u.derived->components->as->rank > 0)
10388 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
10389 " scalar", proc->name, &where);
10392 if (me_arg->ts.u.derived->components->attr.allocatable)
10394 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10395 " be ALLOCATABLE", proc->name, &where);
10398 if (me_arg->ts.u.derived->components->attr.class_pointer)
10400 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10401 " be POINTER", proc->name, &where);
10406 /* If we are extending some type, check that we don't override a procedure
10407 flagged NON_OVERRIDABLE. */
10408 stree->n.tb->overridden = NULL;
10411 gfc_symtree* overridden;
10412 overridden = gfc_find_typebound_proc (super_type, NULL,
10413 stree->name, true, NULL);
10415 if (overridden && overridden->n.tb)
10416 stree->n.tb->overridden = overridden->n.tb;
10418 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
10422 /* See if there's a name collision with a component directly in this type. */
10423 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
10424 if (!strcmp (comp->name, stree->name))
10426 gfc_error ("Procedure '%s' at %L has the same name as a component of"
10428 stree->name, &where, resolve_bindings_derived->name);
10432 /* Try to find a name collision with an inherited component. */
10433 if (super_type && gfc_find_component (super_type, stree->name, true, true))
10435 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
10436 " component of '%s'",
10437 stree->name, &where, resolve_bindings_derived->name);
10441 stree->n.tb->error = 0;
10445 resolve_bindings_result = FAILURE;
10446 stree->n.tb->error = 1;
10450 resolve_typebound_procedures (gfc_symbol* derived)
10454 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
10457 resolve_bindings_derived = derived;
10458 resolve_bindings_result = SUCCESS;
10460 if (derived->f2k_derived->tb_sym_root)
10461 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
10462 &resolve_typebound_procedure);
10464 if (derived->f2k_derived->tb_uop_root)
10465 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
10466 &resolve_typebound_user_op);
10468 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
10470 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
10471 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
10473 resolve_bindings_result = FAILURE;
10476 return resolve_bindings_result;
10480 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
10481 to give all identical derived types the same backend_decl. */
10483 add_dt_to_dt_list (gfc_symbol *derived)
10485 gfc_dt_list *dt_list;
10487 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
10488 if (derived == dt_list->derived)
10491 if (dt_list == NULL)
10493 dt_list = gfc_get_dt_list ();
10494 dt_list->next = gfc_derived_types;
10495 dt_list->derived = derived;
10496 gfc_derived_types = dt_list;
10501 /* Ensure that a derived-type is really not abstract, meaning that every
10502 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
10505 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
10510 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
10512 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
10515 if (st->n.tb && st->n.tb->deferred)
10517 gfc_symtree* overriding;
10518 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
10521 gcc_assert (overriding->n.tb);
10522 if (overriding->n.tb->deferred)
10524 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
10525 " '%s' is DEFERRED and not overridden",
10526 sub->name, &sub->declared_at, st->name);
10535 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
10537 /* The algorithm used here is to recursively travel up the ancestry of sub
10538 and for each ancestor-type, check all bindings. If any of them is
10539 DEFERRED, look it up starting from sub and see if the found (overriding)
10540 binding is not DEFERRED.
10541 This is not the most efficient way to do this, but it should be ok and is
10542 clearer than something sophisticated. */
10544 gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
10546 /* Walk bindings of this ancestor. */
10547 if (ancestor->f2k_derived)
10550 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
10555 /* Find next ancestor type and recurse on it. */
10556 ancestor = gfc_get_derived_super_type (ancestor);
10558 return ensure_not_abstract (sub, ancestor);
10564 static void resolve_symbol (gfc_symbol *sym);
10567 /* Resolve the components of a derived type. */
10570 resolve_fl_derived (gfc_symbol *sym)
10572 gfc_symbol* super_type;
10576 super_type = gfc_get_derived_super_type (sym);
10579 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
10581 gfc_error ("As extending type '%s' at %L has a coarray component, "
10582 "parent type '%s' shall also have one", sym->name,
10583 &sym->declared_at, super_type->name);
10587 /* Ensure the extended type gets resolved before we do. */
10588 if (super_type && resolve_fl_derived (super_type) == FAILURE)
10591 /* An ABSTRACT type must be extensible. */
10592 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
10594 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
10595 sym->name, &sym->declared_at);
10599 for (c = sym->components; c != NULL; c = c->next)
10602 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
10603 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
10605 gfc_error ("Coarray component '%s' at %L must be allocatable with "
10606 "deferred shape", c->name, &c->loc);
10611 if (c->attr.codimension && c->ts.type == BT_DERIVED
10612 && c->ts.u.derived->ts.is_iso_c)
10614 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
10615 "shall not be a coarray", c->name, &c->loc);
10620 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
10621 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
10622 || c->attr.allocatable))
10624 gfc_error ("Component '%s' at %L with coarray component "
10625 "shall be a nonpointer, nonallocatable scalar",
10630 if (c->attr.proc_pointer && c->ts.interface)
10632 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
10633 gfc_error ("Interface '%s', used by procedure pointer component "
10634 "'%s' at %L, is declared in a later PROCEDURE statement",
10635 c->ts.interface->name, c->name, &c->loc);
10637 /* Get the attributes from the interface (now resolved). */
10638 if (c->ts.interface->attr.if_source
10639 || c->ts.interface->attr.intrinsic)
10641 gfc_symbol *ifc = c->ts.interface;
10643 if (ifc->formal && !ifc->formal_ns)
10644 resolve_symbol (ifc);
10646 if (ifc->attr.intrinsic)
10647 resolve_intrinsic (ifc, &ifc->declared_at);
10651 c->ts = ifc->result->ts;
10652 c->attr.allocatable = ifc->result->attr.allocatable;
10653 c->attr.pointer = ifc->result->attr.pointer;
10654 c->attr.dimension = ifc->result->attr.dimension;
10655 c->as = gfc_copy_array_spec (ifc->result->as);
10660 c->attr.allocatable = ifc->attr.allocatable;
10661 c->attr.pointer = ifc->attr.pointer;
10662 c->attr.dimension = ifc->attr.dimension;
10663 c->as = gfc_copy_array_spec (ifc->as);
10665 c->ts.interface = ifc;
10666 c->attr.function = ifc->attr.function;
10667 c->attr.subroutine = ifc->attr.subroutine;
10668 gfc_copy_formal_args_ppc (c, ifc);
10670 c->attr.pure = ifc->attr.pure;
10671 c->attr.elemental = ifc->attr.elemental;
10672 c->attr.recursive = ifc->attr.recursive;
10673 c->attr.always_explicit = ifc->attr.always_explicit;
10674 c->attr.ext_attr |= ifc->attr.ext_attr;
10675 /* Replace symbols in array spec. */
10679 for (i = 0; i < c->as->rank; i++)
10681 gfc_expr_replace_comp (c->as->lower[i], c);
10682 gfc_expr_replace_comp (c->as->upper[i], c);
10685 /* Copy char length. */
10686 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
10688 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
10689 gfc_expr_replace_comp (cl->length, c);
10690 if (cl->length && !cl->resolved
10691 && gfc_resolve_expr (cl->length) == FAILURE)
10696 else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype)
10698 gfc_error ("Interface '%s' of procedure pointer component "
10699 "'%s' at %L must be explicit", c->ts.interface->name,
10704 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
10706 /* Since PPCs are not implicitly typed, a PPC without an explicit
10707 interface must be a subroutine. */
10708 gfc_add_subroutine (&c->attr, c->name, &c->loc);
10711 /* Procedure pointer components: Check PASS arg. */
10712 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
10713 && !sym->attr.vtype)
10715 gfc_symbol* me_arg;
10717 if (c->tb->pass_arg)
10719 gfc_formal_arglist* i;
10721 /* If an explicit passing argument name is given, walk the arg-list
10722 and look for it. */
10725 c->tb->pass_arg_num = 1;
10726 for (i = c->formal; i; i = i->next)
10728 if (!strcmp (i->sym->name, c->tb->pass_arg))
10733 c->tb->pass_arg_num++;
10738 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
10739 "at %L has no argument '%s'", c->name,
10740 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
10747 /* Otherwise, take the first one; there should in fact be at least
10749 c->tb->pass_arg_num = 1;
10752 gfc_error ("Procedure pointer component '%s' with PASS at %L "
10753 "must have at least one argument",
10758 me_arg = c->formal->sym;
10761 /* Now check that the argument-type matches. */
10762 gcc_assert (me_arg);
10763 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
10764 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
10765 || (me_arg->ts.type == BT_CLASS
10766 && me_arg->ts.u.derived->components->ts.u.derived != sym))
10768 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10769 " the derived type '%s'", me_arg->name, c->name,
10770 me_arg->name, &c->loc, sym->name);
10775 /* Check for C453. */
10776 if (me_arg->attr.dimension)
10778 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10779 "must be scalar", me_arg->name, c->name, me_arg->name,
10785 if (me_arg->attr.pointer)
10787 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10788 "may not have the POINTER attribute", me_arg->name,
10789 c->name, me_arg->name, &c->loc);
10794 if (me_arg->attr.allocatable)
10796 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10797 "may not be ALLOCATABLE", me_arg->name, c->name,
10798 me_arg->name, &c->loc);
10803 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
10804 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10805 " at %L", c->name, &c->loc);
10809 /* Check type-spec if this is not the parent-type component. */
10810 if ((!sym->attr.extension || c != sym->components)
10811 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
10814 /* If this type is an extension, set the accessibility of the parent
10816 if (super_type && c == sym->components
10817 && strcmp (super_type->name, c->name) == 0)
10818 c->attr.access = super_type->attr.access;
10820 /* If this type is an extension, see if this component has the same name
10821 as an inherited type-bound procedure. */
10822 if (super_type && !sym->attr.is_class
10823 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
10825 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
10826 " inherited type-bound procedure",
10827 c->name, sym->name, &c->loc);
10831 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
10833 if (c->ts.u.cl->length == NULL
10834 || (resolve_charlen (c->ts.u.cl) == FAILURE)
10835 || !gfc_is_constant_expr (c->ts.u.cl->length))
10837 gfc_error ("Character length of component '%s' needs to "
10838 "be a constant specification expression at %L",
10840 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
10845 if (c->ts.type == BT_DERIVED
10846 && sym->component_access != ACCESS_PRIVATE
10847 && gfc_check_access (sym->attr.access, sym->ns->default_access)
10848 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
10849 && !c->ts.u.derived->attr.use_assoc
10850 && !gfc_check_access (c->ts.u.derived->attr.access,
10851 c->ts.u.derived->ns->default_access)
10852 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
10853 "is a PRIVATE type and cannot be a component of "
10854 "'%s', which is PUBLIC at %L", c->name,
10855 sym->name, &sym->declared_at) == FAILURE)
10858 if (sym->attr.sequence)
10860 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
10862 gfc_error ("Component %s of SEQUENCE type declared at %L does "
10863 "not have the SEQUENCE attribute",
10864 c->ts.u.derived->name, &sym->declared_at);
10869 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
10870 && c->ts.u.derived->components == NULL
10871 && !c->ts.u.derived->attr.zero_comp)
10873 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10874 "that has not been declared", c->name, sym->name,
10879 if (c->ts.type == BT_CLASS && c->ts.u.derived->components->attr.pointer
10880 && c->ts.u.derived->components->ts.u.derived->components == NULL
10881 && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp)
10883 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10884 "that has not been declared", c->name, sym->name,
10890 if (c->ts.type == BT_CLASS
10891 && !(c->ts.u.derived->components->attr.pointer
10892 || c->ts.u.derived->components->attr.allocatable))
10894 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
10895 "or pointer", c->name, &c->loc);
10899 /* Ensure that all the derived type components are put on the
10900 derived type list; even in formal namespaces, where derived type
10901 pointer components might not have been declared. */
10902 if (c->ts.type == BT_DERIVED
10904 && c->ts.u.derived->components
10906 && sym != c->ts.u.derived)
10907 add_dt_to_dt_list (c->ts.u.derived);
10909 if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
10913 for (i = 0; i < c->as->rank; i++)
10915 if (c->as->lower[i] == NULL
10916 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
10917 || !gfc_is_constant_expr (c->as->lower[i])
10918 || c->as->upper[i] == NULL
10919 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
10920 || !gfc_is_constant_expr (c->as->upper[i]))
10922 gfc_error ("Component '%s' of '%s' at %L must have "
10923 "constant array bounds",
10924 c->name, sym->name, &c->loc);
10930 /* Resolve the type-bound procedures. */
10931 if (resolve_typebound_procedures (sym) == FAILURE)
10934 /* Resolve the finalizer procedures. */
10935 if (gfc_resolve_finalizers (sym) == FAILURE)
10938 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
10939 all DEFERRED bindings are overridden. */
10940 if (super_type && super_type->attr.abstract && !sym->attr.abstract
10941 && ensure_not_abstract (sym, super_type) == FAILURE)
10944 /* Add derived type to the derived type list. */
10945 add_dt_to_dt_list (sym);
10952 resolve_fl_namelist (gfc_symbol *sym)
10957 /* Reject PRIVATE objects in a PUBLIC namelist. */
10958 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
10960 for (nl = sym->namelist; nl; nl = nl->next)
10962 if (!nl->sym->attr.use_assoc
10963 && !is_sym_host_assoc (nl->sym, sym->ns)
10964 && !gfc_check_access(nl->sym->attr.access,
10965 nl->sym->ns->default_access))
10967 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
10968 "cannot be member of PUBLIC namelist '%s' at %L",
10969 nl->sym->name, sym->name, &sym->declared_at);
10973 /* Types with private components that came here by USE-association. */
10974 if (nl->sym->ts.type == BT_DERIVED
10975 && derived_inaccessible (nl->sym->ts.u.derived))
10977 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
10978 "components and cannot be member of namelist '%s' at %L",
10979 nl->sym->name, sym->name, &sym->declared_at);
10983 /* Types with private components that are defined in the same module. */
10984 if (nl->sym->ts.type == BT_DERIVED
10985 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
10986 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
10987 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
10988 nl->sym->ns->default_access))
10990 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
10991 "cannot be a member of PUBLIC namelist '%s' at %L",
10992 nl->sym->name, sym->name, &sym->declared_at);
10998 for (nl = sym->namelist; nl; nl = nl->next)
11000 /* Reject namelist arrays of assumed shape. */
11001 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11002 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11003 "must not have assumed shape in namelist "
11004 "'%s' at %L", nl->sym->name, sym->name,
11005 &sym->declared_at) == FAILURE)
11008 /* Reject namelist arrays that are not constant shape. */
11009 if (is_non_constant_shape_array (nl->sym))
11011 gfc_error ("NAMELIST array object '%s' must have constant "
11012 "shape in namelist '%s' at %L", nl->sym->name,
11013 sym->name, &sym->declared_at);
11017 /* Namelist objects cannot have allocatable or pointer components. */
11018 if (nl->sym->ts.type != BT_DERIVED)
11021 if (nl->sym->ts.u.derived->attr.alloc_comp)
11023 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11024 "have ALLOCATABLE components",
11025 nl->sym->name, sym->name, &sym->declared_at);
11029 if (nl->sym->ts.u.derived->attr.pointer_comp)
11031 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11032 "have POINTER components",
11033 nl->sym->name, sym->name, &sym->declared_at);
11039 /* 14.1.2 A module or internal procedure represent local entities
11040 of the same type as a namelist member and so are not allowed. */
11041 for (nl = sym->namelist; nl; nl = nl->next)
11043 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11046 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11047 if ((nl->sym == sym->ns->proc_name)
11049 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11053 if (nl->sym && nl->sym->name)
11054 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11055 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11057 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11058 "attribute in '%s' at %L", nlsym->name,
11059 &sym->declared_at);
11069 resolve_fl_parameter (gfc_symbol *sym)
11071 /* A parameter array's shape needs to be constant. */
11072 if (sym->as != NULL
11073 && (sym->as->type == AS_DEFERRED
11074 || is_non_constant_shape_array (sym)))
11076 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11077 "or of deferred shape", sym->name, &sym->declared_at);
11081 /* Make sure a parameter that has been implicitly typed still
11082 matches the implicit type, since PARAMETER statements can precede
11083 IMPLICIT statements. */
11084 if (sym->attr.implicit_type
11085 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11088 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11089 "later IMPLICIT type", sym->name, &sym->declared_at);
11093 /* Make sure the types of derived parameters are consistent. This
11094 type checking is deferred until resolution because the type may
11095 refer to a derived type from the host. */
11096 if (sym->ts.type == BT_DERIVED
11097 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11099 gfc_error ("Incompatible derived type in PARAMETER at %L",
11100 &sym->value->where);
11107 /* Do anything necessary to resolve a symbol. Right now, we just
11108 assume that an otherwise unknown symbol is a variable. This sort
11109 of thing commonly happens for symbols in module. */
11112 resolve_symbol (gfc_symbol *sym)
11114 int check_constant, mp_flag;
11115 gfc_symtree *symtree;
11116 gfc_symtree *this_symtree;
11120 /* Avoid double resolution of function result symbols. */
11121 if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns))
11124 if (sym->attr.flavor == FL_UNKNOWN)
11127 /* If we find that a flavorless symbol is an interface in one of the
11128 parent namespaces, find its symtree in this namespace, free the
11129 symbol and set the symtree to point to the interface symbol. */
11130 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11132 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11133 if (symtree && symtree->n.sym->generic)
11135 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11139 gfc_free_symbol (sym);
11140 symtree->n.sym->refs++;
11141 this_symtree->n.sym = symtree->n.sym;
11146 /* Otherwise give it a flavor according to such attributes as
11148 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11149 sym->attr.flavor = FL_VARIABLE;
11152 sym->attr.flavor = FL_PROCEDURE;
11153 if (sym->attr.dimension)
11154 sym->attr.function = 1;
11158 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11159 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11161 if (sym->attr.procedure && sym->ts.interface
11162 && sym->attr.if_source != IFSRC_DECL)
11164 if (sym->ts.interface == sym)
11166 gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
11167 "interface", sym->name, &sym->declared_at);
11170 if (sym->ts.interface->attr.procedure)
11172 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
11173 " in a later PROCEDURE statement", sym->ts.interface->name,
11174 sym->name,&sym->declared_at);
11178 /* Get the attributes from the interface (now resolved). */
11179 if (sym->ts.interface->attr.if_source
11180 || sym->ts.interface->attr.intrinsic)
11182 gfc_symbol *ifc = sym->ts.interface;
11183 resolve_symbol (ifc);
11185 if (ifc->attr.intrinsic)
11186 resolve_intrinsic (ifc, &ifc->declared_at);
11189 sym->ts = ifc->result->ts;
11192 sym->ts.interface = ifc;
11193 sym->attr.function = ifc->attr.function;
11194 sym->attr.subroutine = ifc->attr.subroutine;
11195 gfc_copy_formal_args (sym, ifc);
11197 sym->attr.allocatable = ifc->attr.allocatable;
11198 sym->attr.pointer = ifc->attr.pointer;
11199 sym->attr.pure = ifc->attr.pure;
11200 sym->attr.elemental = ifc->attr.elemental;
11201 sym->attr.dimension = ifc->attr.dimension;
11202 sym->attr.recursive = ifc->attr.recursive;
11203 sym->attr.always_explicit = ifc->attr.always_explicit;
11204 sym->attr.ext_attr |= ifc->attr.ext_attr;
11205 /* Copy array spec. */
11206 sym->as = gfc_copy_array_spec (ifc->as);
11210 for (i = 0; i < sym->as->rank; i++)
11212 gfc_expr_replace_symbols (sym->as->lower[i], sym);
11213 gfc_expr_replace_symbols (sym->as->upper[i], sym);
11216 /* Copy char length. */
11217 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11219 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11220 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
11221 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
11222 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
11226 else if (sym->ts.interface->name[0] != '\0')
11228 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
11229 sym->ts.interface->name, sym->name, &sym->declared_at);
11234 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11237 /* Symbols that are module procedures with results (functions) have
11238 the types and array specification copied for type checking in
11239 procedures that call them, as well as for saving to a module
11240 file. These symbols can't stand the scrutiny that their results
11242 mp_flag = (sym->result != NULL && sym->result != sym);
11245 /* Make sure that the intrinsic is consistent with its internal
11246 representation. This needs to be done before assigning a default
11247 type to avoid spurious warnings. */
11248 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11249 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11252 /* Assign default type to symbols that need one and don't have one. */
11253 if (sym->ts.type == BT_UNKNOWN)
11255 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11256 gfc_set_default_type (sym, 1, NULL);
11258 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11259 && !sym->attr.function && !sym->attr.subroutine
11260 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11261 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11263 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11265 /* The specific case of an external procedure should emit an error
11266 in the case that there is no implicit type. */
11268 gfc_set_default_type (sym, sym->attr.external, NULL);
11271 /* Result may be in another namespace. */
11272 resolve_symbol (sym->result);
11274 if (!sym->result->attr.proc_pointer)
11276 sym->ts = sym->result->ts;
11277 sym->as = gfc_copy_array_spec (sym->result->as);
11278 sym->attr.dimension = sym->result->attr.dimension;
11279 sym->attr.pointer = sym->result->attr.pointer;
11280 sym->attr.allocatable = sym->result->attr.allocatable;
11286 /* Assumed size arrays and assumed shape arrays must be dummy
11289 if (sym->as != NULL
11290 && ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11291 || sym->as->type == AS_ASSUMED_SHAPE)
11292 && sym->attr.dummy == 0)
11294 if (sym->as->type == AS_ASSUMED_SIZE)
11295 gfc_error ("Assumed size array at %L must be a dummy argument",
11296 &sym->declared_at);
11298 gfc_error ("Assumed shape array at %L must be a dummy argument",
11299 &sym->declared_at);
11303 /* Make sure symbols with known intent or optional are really dummy
11304 variable. Because of ENTRY statement, this has to be deferred
11305 until resolution time. */
11307 if (!sym->attr.dummy
11308 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11310 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11314 if (sym->attr.value && !sym->attr.dummy)
11316 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11317 "it is not a dummy argument", sym->name, &sym->declared_at);
11321 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11323 gfc_charlen *cl = sym->ts.u.cl;
11324 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11326 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11327 "attribute must have constant length",
11328 sym->name, &sym->declared_at);
11332 if (sym->ts.is_c_interop
11333 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11335 gfc_error ("C interoperable character dummy variable '%s' at %L "
11336 "with VALUE attribute must have length one",
11337 sym->name, &sym->declared_at);
11342 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11343 do this for something that was implicitly typed because that is handled
11344 in gfc_set_default_type. Handle dummy arguments and procedure
11345 definitions separately. Also, anything that is use associated is not
11346 handled here but instead is handled in the module it is declared in.
11347 Finally, derived type definitions are allowed to be BIND(C) since that
11348 only implies that they're interoperable, and they are checked fully for
11349 interoperability when a variable is declared of that type. */
11350 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11351 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11352 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11354 gfc_try t = SUCCESS;
11356 /* First, make sure the variable is declared at the
11357 module-level scope (J3/04-007, Section 15.3). */
11358 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11359 sym->attr.in_common == 0)
11361 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11362 "is neither a COMMON block nor declared at the "
11363 "module level scope", sym->name, &(sym->declared_at));
11366 else if (sym->common_head != NULL)
11368 t = verify_com_block_vars_c_interop (sym->common_head);
11372 /* If type() declaration, we need to verify that the components
11373 of the given type are all C interoperable, etc. */
11374 if (sym->ts.type == BT_DERIVED &&
11375 sym->ts.u.derived->attr.is_c_interop != 1)
11377 /* Make sure the user marked the derived type as BIND(C). If
11378 not, call the verify routine. This could print an error
11379 for the derived type more than once if multiple variables
11380 of that type are declared. */
11381 if (sym->ts.u.derived->attr.is_bind_c != 1)
11382 verify_bind_c_derived_type (sym->ts.u.derived);
11386 /* Verify the variable itself as C interoperable if it
11387 is BIND(C). It is not possible for this to succeed if
11388 the verify_bind_c_derived_type failed, so don't have to handle
11389 any error returned by verify_bind_c_derived_type. */
11390 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11391 sym->common_block);
11396 /* clear the is_bind_c flag to prevent reporting errors more than
11397 once if something failed. */
11398 sym->attr.is_bind_c = 0;
11403 /* If a derived type symbol has reached this point, without its
11404 type being declared, we have an error. Notice that most
11405 conditions that produce undefined derived types have already
11406 been dealt with. However, the likes of:
11407 implicit type(t) (t) ..... call foo (t) will get us here if
11408 the type is not declared in the scope of the implicit
11409 statement. Change the type to BT_UNKNOWN, both because it is so
11410 and to prevent an ICE. */
11411 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
11412 && !sym->ts.u.derived->attr.zero_comp)
11414 gfc_error ("The derived type '%s' at %L is of type '%s', "
11415 "which has not been defined", sym->name,
11416 &sym->declared_at, sym->ts.u.derived->name);
11417 sym->ts.type = BT_UNKNOWN;
11421 /* Make sure that the derived type has been resolved and that the
11422 derived type is visible in the symbol's namespace, if it is a
11423 module function and is not PRIVATE. */
11424 if (sym->ts.type == BT_DERIVED
11425 && sym->ts.u.derived->attr.use_assoc
11426 && sym->ns->proc_name
11427 && sym->ns->proc_name->attr.flavor == FL_MODULE)
11431 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
11434 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
11435 if (!ds && sym->attr.function
11436 && gfc_check_access (sym->attr.access, sym->ns->default_access))
11438 symtree = gfc_new_symtree (&sym->ns->sym_root,
11439 sym->ts.u.derived->name);
11440 symtree->n.sym = sym->ts.u.derived;
11441 sym->ts.u.derived->refs++;
11445 /* Unless the derived-type declaration is use associated, Fortran 95
11446 does not allow public entries of private derived types.
11447 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
11448 161 in 95-006r3. */
11449 if (sym->ts.type == BT_DERIVED
11450 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
11451 && !sym->ts.u.derived->attr.use_assoc
11452 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11453 && !gfc_check_access (sym->ts.u.derived->attr.access,
11454 sym->ts.u.derived->ns->default_access)
11455 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
11456 "of PRIVATE derived type '%s'",
11457 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
11458 : "variable", sym->name, &sym->declared_at,
11459 sym->ts.u.derived->name) == FAILURE)
11462 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
11463 default initialization is defined (5.1.2.4.4). */
11464 if (sym->ts.type == BT_DERIVED
11466 && sym->attr.intent == INTENT_OUT
11468 && sym->as->type == AS_ASSUMED_SIZE)
11470 for (c = sym->ts.u.derived->components; c; c = c->next)
11472 if (c->initializer)
11474 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
11475 "ASSUMED SIZE and so cannot have a default initializer",
11476 sym->name, &sym->declared_at);
11483 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
11484 || sym->attr.codimension)
11485 && sym->attr.result)
11486 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
11487 "a coarray component", sym->name, &sym->declared_at);
11490 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
11491 && sym->ts.u.derived->ts.is_iso_c)
11492 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11493 "shall not be a coarray", sym->name, &sym->declared_at);
11496 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
11497 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
11498 || sym->attr.allocatable))
11499 gfc_error ("Variable '%s' at %L with coarray component "
11500 "shall be a nonpointer, nonallocatable scalar",
11501 sym->name, &sym->declared_at);
11503 /* F2008, C526. The function-result case was handled above. */
11504 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
11505 || sym->attr.codimension)
11506 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
11507 || sym->ns->proc_name->attr.flavor == FL_MODULE
11508 || sym->ns->proc_name->attr.is_main_program
11509 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
11510 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
11511 "component and is not ALLOCATABLE, SAVE nor a "
11512 "dummy argument", sym->name, &sym->declared_at);
11513 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
11514 else if (sym->attr.codimension && !sym->attr.allocatable
11515 && sym->as && sym->as->cotype == AS_DEFERRED)
11516 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
11517 "deferred shape", sym->name, &sym->declared_at);
11518 else if (sym->attr.codimension && sym->attr.allocatable
11519 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
11520 gfc_error ("Allocatable coarray variable '%s' at %L must have "
11521 "deferred shape", sym->name, &sym->declared_at);
11525 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
11526 || (sym->attr.codimension && sym->attr.allocatable))
11527 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
11528 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
11529 "allocatable coarray or have coarray components",
11530 sym->name, &sym->declared_at);
11532 if (sym->attr.codimension && sym->attr.dummy
11533 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
11534 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
11535 "procedure '%s'", sym->name, &sym->declared_at,
11536 sym->ns->proc_name->name);
11538 switch (sym->attr.flavor)
11541 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
11546 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
11551 if (resolve_fl_namelist (sym) == FAILURE)
11556 if (resolve_fl_parameter (sym) == FAILURE)
11564 /* Resolve array specifier. Check as well some constraints
11565 on COMMON blocks. */
11567 check_constant = sym->attr.in_common && !sym->attr.pointer;
11569 /* Set the formal_arg_flag so that check_conflict will not throw
11570 an error for host associated variables in the specification
11571 expression for an array_valued function. */
11572 if (sym->attr.function && sym->as)
11573 formal_arg_flag = 1;
11575 gfc_resolve_array_spec (sym->as, check_constant);
11577 formal_arg_flag = 0;
11579 /* Resolve formal namespaces. */
11580 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
11581 && !sym->attr.contained && !sym->attr.intrinsic)
11582 gfc_resolve (sym->formal_ns);
11584 /* Make sure the formal namespace is present. */
11585 if (sym->formal && !sym->formal_ns)
11587 gfc_formal_arglist *formal = sym->formal;
11588 while (formal && !formal->sym)
11589 formal = formal->next;
11593 sym->formal_ns = formal->sym->ns;
11594 sym->formal_ns->refs++;
11598 /* Check threadprivate restrictions. */
11599 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
11600 && (!sym->attr.in_common
11601 && sym->module == NULL
11602 && (sym->ns->proc_name == NULL
11603 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
11604 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
11606 /* If we have come this far we can apply default-initializers, as
11607 described in 14.7.5, to those variables that have not already
11608 been assigned one. */
11609 if (sym->ts.type == BT_DERIVED
11610 && sym->attr.referenced
11611 && sym->ns == gfc_current_ns
11613 && !sym->attr.allocatable
11614 && !sym->attr.alloc_comp)
11616 symbol_attribute *a = &sym->attr;
11618 if ((!a->save && !a->dummy && !a->pointer
11619 && !a->in_common && !a->use_assoc
11620 && !(a->function && sym != sym->result))
11621 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
11622 apply_default_init (sym);
11625 /* If this symbol has a type-spec, check it. */
11626 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
11627 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
11628 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
11634 /************* Resolve DATA statements *************/
11638 gfc_data_value *vnode;
11644 /* Advance the values structure to point to the next value in the data list. */
11647 next_data_value (void)
11649 while (mpz_cmp_ui (values.left, 0) == 0)
11652 if (values.vnode->next == NULL)
11655 values.vnode = values.vnode->next;
11656 mpz_set (values.left, values.vnode->repeat);
11664 check_data_variable (gfc_data_variable *var, locus *where)
11670 ar_type mark = AR_UNKNOWN;
11672 mpz_t section_index[GFC_MAX_DIMENSIONS];
11678 if (gfc_resolve_expr (var->expr) == FAILURE)
11682 mpz_init_set_si (offset, 0);
11685 if (e->expr_type != EXPR_VARIABLE)
11686 gfc_internal_error ("check_data_variable(): Bad expression");
11688 sym = e->symtree->n.sym;
11690 if (sym->ns->is_block_data && !sym->attr.in_common)
11692 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
11693 sym->name, &sym->declared_at);
11696 if (e->ref == NULL && sym->as)
11698 gfc_error ("DATA array '%s' at %L must be specified in a previous"
11699 " declaration", sym->name, where);
11703 has_pointer = sym->attr.pointer;
11705 for (ref = e->ref; ref; ref = ref->next)
11707 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
11710 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
11712 gfc_error ("DATA element '%s' at %L cannot have a coindex",
11718 && ref->type == REF_ARRAY
11719 && ref->u.ar.type != AR_FULL)
11721 gfc_error ("DATA element '%s' at %L is a pointer and so must "
11722 "be a full array", sym->name, where);
11727 if (e->rank == 0 || has_pointer)
11729 mpz_init_set_ui (size, 1);
11736 /* Find the array section reference. */
11737 for (ref = e->ref; ref; ref = ref->next)
11739 if (ref->type != REF_ARRAY)
11741 if (ref->u.ar.type == AR_ELEMENT)
11747 /* Set marks according to the reference pattern. */
11748 switch (ref->u.ar.type)
11756 /* Get the start position of array section. */
11757 gfc_get_section_index (ar, section_index, &offset);
11762 gcc_unreachable ();
11765 if (gfc_array_size (e, &size) == FAILURE)
11767 gfc_error ("Nonconstant array section at %L in DATA statement",
11769 mpz_clear (offset);
11776 while (mpz_cmp_ui (size, 0) > 0)
11778 if (next_data_value () == FAILURE)
11780 gfc_error ("DATA statement at %L has more variables than values",
11786 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
11790 /* If we have more than one element left in the repeat count,
11791 and we have more than one element left in the target variable,
11792 then create a range assignment. */
11793 /* FIXME: Only done for full arrays for now, since array sections
11795 if (mark == AR_FULL && ref && ref->next == NULL
11796 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
11800 if (mpz_cmp (size, values.left) >= 0)
11802 mpz_init_set (range, values.left);
11803 mpz_sub (size, size, values.left);
11804 mpz_set_ui (values.left, 0);
11808 mpz_init_set (range, size);
11809 mpz_sub (values.left, values.left, size);
11810 mpz_set_ui (size, 0);
11813 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
11816 mpz_add (offset, offset, range);
11823 /* Assign initial value to symbol. */
11826 mpz_sub_ui (values.left, values.left, 1);
11827 mpz_sub_ui (size, size, 1);
11829 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
11833 if (mark == AR_FULL)
11834 mpz_add_ui (offset, offset, 1);
11836 /* Modify the array section indexes and recalculate the offset
11837 for next element. */
11838 else if (mark == AR_SECTION)
11839 gfc_advance_section (section_index, ar, &offset);
11843 if (mark == AR_SECTION)
11845 for (i = 0; i < ar->dimen; i++)
11846 mpz_clear (section_index[i]);
11850 mpz_clear (offset);
11856 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
11858 /* Iterate over a list of elements in a DATA statement. */
11861 traverse_data_list (gfc_data_variable *var, locus *where)
11864 iterator_stack frame;
11865 gfc_expr *e, *start, *end, *step;
11866 gfc_try retval = SUCCESS;
11868 mpz_init (frame.value);
11871 start = gfc_copy_expr (var->iter.start);
11872 end = gfc_copy_expr (var->iter.end);
11873 step = gfc_copy_expr (var->iter.step);
11875 if (gfc_simplify_expr (start, 1) == FAILURE
11876 || start->expr_type != EXPR_CONSTANT)
11878 gfc_error ("start of implied-do loop at %L could not be "
11879 "simplified to a constant value", &start->where);
11883 if (gfc_simplify_expr (end, 1) == FAILURE
11884 || end->expr_type != EXPR_CONSTANT)
11886 gfc_error ("end of implied-do loop at %L could not be "
11887 "simplified to a constant value", &start->where);
11891 if (gfc_simplify_expr (step, 1) == FAILURE
11892 || step->expr_type != EXPR_CONSTANT)
11894 gfc_error ("step of implied-do loop at %L could not be "
11895 "simplified to a constant value", &start->where);
11900 mpz_set (trip, end->value.integer);
11901 mpz_sub (trip, trip, start->value.integer);
11902 mpz_add (trip, trip, step->value.integer);
11904 mpz_div (trip, trip, step->value.integer);
11906 mpz_set (frame.value, start->value.integer);
11908 frame.prev = iter_stack;
11909 frame.variable = var->iter.var->symtree;
11910 iter_stack = &frame;
11912 while (mpz_cmp_ui (trip, 0) > 0)
11914 if (traverse_data_var (var->list, where) == FAILURE)
11920 e = gfc_copy_expr (var->expr);
11921 if (gfc_simplify_expr (e, 1) == FAILURE)
11928 mpz_add (frame.value, frame.value, step->value.integer);
11930 mpz_sub_ui (trip, trip, 1);
11934 mpz_clear (frame.value);
11937 gfc_free_expr (start);
11938 gfc_free_expr (end);
11939 gfc_free_expr (step);
11941 iter_stack = frame.prev;
11946 /* Type resolve variables in the variable list of a DATA statement. */
11949 traverse_data_var (gfc_data_variable *var, locus *where)
11953 for (; var; var = var->next)
11955 if (var->expr == NULL)
11956 t = traverse_data_list (var, where);
11958 t = check_data_variable (var, where);
11968 /* Resolve the expressions and iterators associated with a data statement.
11969 This is separate from the assignment checking because data lists should
11970 only be resolved once. */
11973 resolve_data_variables (gfc_data_variable *d)
11975 for (; d; d = d->next)
11977 if (d->list == NULL)
11979 if (gfc_resolve_expr (d->expr) == FAILURE)
11984 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
11987 if (resolve_data_variables (d->list) == FAILURE)
11996 /* Resolve a single DATA statement. We implement this by storing a pointer to
11997 the value list into static variables, and then recursively traversing the
11998 variables list, expanding iterators and such. */
12001 resolve_data (gfc_data *d)
12004 if (resolve_data_variables (d->var) == FAILURE)
12007 values.vnode = d->value;
12008 if (d->value == NULL)
12009 mpz_set_ui (values.left, 0);
12011 mpz_set (values.left, d->value->repeat);
12013 if (traverse_data_var (d->var, &d->where) == FAILURE)
12016 /* At this point, we better not have any values left. */
12018 if (next_data_value () == SUCCESS)
12019 gfc_error ("DATA statement at %L has more values than variables",
12024 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12025 accessed by host or use association, is a dummy argument to a pure function,
12026 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12027 is storage associated with any such variable, shall not be used in the
12028 following contexts: (clients of this function). */
12030 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12031 procedure. Returns zero if assignment is OK, nonzero if there is a
12034 gfc_impure_variable (gfc_symbol *sym)
12039 if (sym->attr.use_assoc || sym->attr.in_common)
12042 /* Check if the symbol's ns is inside the pure procedure. */
12043 for (ns = gfc_current_ns; ns; ns = ns->parent)
12047 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12051 proc = sym->ns->proc_name;
12052 if (sym->attr.dummy && gfc_pure (proc)
12053 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12055 proc->attr.function))
12058 /* TODO: Sort out what can be storage associated, if anything, and include
12059 it here. In principle equivalences should be scanned but it does not
12060 seem to be possible to storage associate an impure variable this way. */
12065 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12066 current namespace is inside a pure procedure. */
12069 gfc_pure (gfc_symbol *sym)
12071 symbol_attribute attr;
12076 /* Check if the current namespace or one of its parents
12077 belongs to a pure procedure. */
12078 for (ns = gfc_current_ns; ns; ns = ns->parent)
12080 sym = ns->proc_name;
12084 if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
12092 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
12096 /* Test whether the current procedure is elemental or not. */
12099 gfc_elemental (gfc_symbol *sym)
12101 symbol_attribute attr;
12104 sym = gfc_current_ns->proc_name;
12109 return attr.flavor == FL_PROCEDURE && attr.elemental;
12113 /* Warn about unused labels. */
12116 warn_unused_fortran_label (gfc_st_label *label)
12121 warn_unused_fortran_label (label->left);
12123 if (label->defined == ST_LABEL_UNKNOWN)
12126 switch (label->referenced)
12128 case ST_LABEL_UNKNOWN:
12129 gfc_warning ("Label %d at %L defined but not used", label->value,
12133 case ST_LABEL_BAD_TARGET:
12134 gfc_warning ("Label %d at %L defined but cannot be used",
12135 label->value, &label->where);
12142 warn_unused_fortran_label (label->right);
12146 /* Returns the sequence type of a symbol or sequence. */
12149 sequence_type (gfc_typespec ts)
12158 if (ts.u.derived->components == NULL)
12159 return SEQ_NONDEFAULT;
12161 result = sequence_type (ts.u.derived->components->ts);
12162 for (c = ts.u.derived->components->next; c; c = c->next)
12163 if (sequence_type (c->ts) != result)
12169 if (ts.kind != gfc_default_character_kind)
12170 return SEQ_NONDEFAULT;
12172 return SEQ_CHARACTER;
12175 if (ts.kind != gfc_default_integer_kind)
12176 return SEQ_NONDEFAULT;
12178 return SEQ_NUMERIC;
12181 if (!(ts.kind == gfc_default_real_kind
12182 || ts.kind == gfc_default_double_kind))
12183 return SEQ_NONDEFAULT;
12185 return SEQ_NUMERIC;
12188 if (ts.kind != gfc_default_complex_kind)
12189 return SEQ_NONDEFAULT;
12191 return SEQ_NUMERIC;
12194 if (ts.kind != gfc_default_logical_kind)
12195 return SEQ_NONDEFAULT;
12197 return SEQ_NUMERIC;
12200 return SEQ_NONDEFAULT;
12205 /* Resolve derived type EQUIVALENCE object. */
12208 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12210 gfc_component *c = derived->components;
12215 /* Shall not be an object of nonsequence derived type. */
12216 if (!derived->attr.sequence)
12218 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12219 "attribute to be an EQUIVALENCE object", sym->name,
12224 /* Shall not have allocatable components. */
12225 if (derived->attr.alloc_comp)
12227 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12228 "components to be an EQUIVALENCE object",sym->name,
12233 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12235 gfc_error ("Derived type variable '%s' at %L with default "
12236 "initialization cannot be in EQUIVALENCE with a variable "
12237 "in COMMON", sym->name, &e->where);
12241 for (; c ; c = c->next)
12243 if (c->ts.type == BT_DERIVED
12244 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12247 /* Shall not be an object of sequence derived type containing a pointer
12248 in the structure. */
12249 if (c->attr.pointer)
12251 gfc_error ("Derived type variable '%s' at %L with pointer "
12252 "component(s) cannot be an EQUIVALENCE object",
12253 sym->name, &e->where);
12261 /* Resolve equivalence object.
12262 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12263 an allocatable array, an object of nonsequence derived type, an object of
12264 sequence derived type containing a pointer at any level of component
12265 selection, an automatic object, a function name, an entry name, a result
12266 name, a named constant, a structure component, or a subobject of any of
12267 the preceding objects. A substring shall not have length zero. A
12268 derived type shall not have components with default initialization nor
12269 shall two objects of an equivalence group be initialized.
12270 Either all or none of the objects shall have an protected attribute.
12271 The simple constraints are done in symbol.c(check_conflict) and the rest
12272 are implemented here. */
12275 resolve_equivalence (gfc_equiv *eq)
12278 gfc_symbol *first_sym;
12281 locus *last_where = NULL;
12282 seq_type eq_type, last_eq_type;
12283 gfc_typespec *last_ts;
12284 int object, cnt_protected;
12287 last_ts = &eq->expr->symtree->n.sym->ts;
12289 first_sym = eq->expr->symtree->n.sym;
12293 for (object = 1; eq; eq = eq->eq, object++)
12297 e->ts = e->symtree->n.sym->ts;
12298 /* match_varspec might not know yet if it is seeing
12299 array reference or substring reference, as it doesn't
12301 if (e->ref && e->ref->type == REF_ARRAY)
12303 gfc_ref *ref = e->ref;
12304 sym = e->symtree->n.sym;
12306 if (sym->attr.dimension)
12308 ref->u.ar.as = sym->as;
12312 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12313 if (e->ts.type == BT_CHARACTER
12315 && ref->type == REF_ARRAY
12316 && ref->u.ar.dimen == 1
12317 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12318 && ref->u.ar.stride[0] == NULL)
12320 gfc_expr *start = ref->u.ar.start[0];
12321 gfc_expr *end = ref->u.ar.end[0];
12324 /* Optimize away the (:) reference. */
12325 if (start == NULL && end == NULL)
12328 e->ref = ref->next;
12330 e->ref->next = ref->next;
12335 ref->type = REF_SUBSTRING;
12337 start = gfc_get_int_expr (gfc_default_integer_kind,
12339 ref->u.ss.start = start;
12340 if (end == NULL && e->ts.u.cl)
12341 end = gfc_copy_expr (e->ts.u.cl->length);
12342 ref->u.ss.end = end;
12343 ref->u.ss.length = e->ts.u.cl;
12350 /* Any further ref is an error. */
12353 gcc_assert (ref->type == REF_ARRAY);
12354 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12360 if (gfc_resolve_expr (e) == FAILURE)
12363 sym = e->symtree->n.sym;
12365 if (sym->attr.is_protected)
12367 if (cnt_protected > 0 && cnt_protected != object)
12369 gfc_error ("Either all or none of the objects in the "
12370 "EQUIVALENCE set at %L shall have the "
12371 "PROTECTED attribute",
12376 /* Shall not equivalence common block variables in a PURE procedure. */
12377 if (sym->ns->proc_name
12378 && sym->ns->proc_name->attr.pure
12379 && sym->attr.in_common)
12381 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
12382 "object in the pure procedure '%s'",
12383 sym->name, &e->where, sym->ns->proc_name->name);
12387 /* Shall not be a named constant. */
12388 if (e->expr_type == EXPR_CONSTANT)
12390 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
12391 "object", sym->name, &e->where);
12395 if (e->ts.type == BT_DERIVED
12396 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
12399 /* Check that the types correspond correctly:
12401 A numeric sequence structure may be equivalenced to another sequence
12402 structure, an object of default integer type, default real type, double
12403 precision real type, default logical type such that components of the
12404 structure ultimately only become associated to objects of the same
12405 kind. A character sequence structure may be equivalenced to an object
12406 of default character kind or another character sequence structure.
12407 Other objects may be equivalenced only to objects of the same type and
12408 kind parameters. */
12410 /* Identical types are unconditionally OK. */
12411 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
12412 goto identical_types;
12414 last_eq_type = sequence_type (*last_ts);
12415 eq_type = sequence_type (sym->ts);
12417 /* Since the pair of objects is not of the same type, mixed or
12418 non-default sequences can be rejected. */
12420 msg = "Sequence %s with mixed components in EQUIVALENCE "
12421 "statement at %L with different type objects";
12423 && last_eq_type == SEQ_MIXED
12424 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
12426 || (eq_type == SEQ_MIXED
12427 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12428 &e->where) == FAILURE))
12431 msg = "Non-default type object or sequence %s in EQUIVALENCE "
12432 "statement at %L with objects of different type";
12434 && last_eq_type == SEQ_NONDEFAULT
12435 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
12436 last_where) == FAILURE)
12437 || (eq_type == SEQ_NONDEFAULT
12438 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12439 &e->where) == FAILURE))
12442 msg ="Non-CHARACTER object '%s' in default CHARACTER "
12443 "EQUIVALENCE statement at %L";
12444 if (last_eq_type == SEQ_CHARACTER
12445 && eq_type != SEQ_CHARACTER
12446 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12447 &e->where) == FAILURE)
12450 msg ="Non-NUMERIC object '%s' in default NUMERIC "
12451 "EQUIVALENCE statement at %L";
12452 if (last_eq_type == SEQ_NUMERIC
12453 && eq_type != SEQ_NUMERIC
12454 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12455 &e->where) == FAILURE)
12460 last_where = &e->where;
12465 /* Shall not be an automatic array. */
12466 if (e->ref->type == REF_ARRAY
12467 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
12469 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
12470 "an EQUIVALENCE object", sym->name, &e->where);
12477 /* Shall not be a structure component. */
12478 if (r->type == REF_COMPONENT)
12480 gfc_error ("Structure component '%s' at %L cannot be an "
12481 "EQUIVALENCE object",
12482 r->u.c.component->name, &e->where);
12486 /* A substring shall not have length zero. */
12487 if (r->type == REF_SUBSTRING)
12489 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
12491 gfc_error ("Substring at %L has length zero",
12492 &r->u.ss.start->where);
12502 /* Resolve function and ENTRY types, issue diagnostics if needed. */
12505 resolve_fntype (gfc_namespace *ns)
12507 gfc_entry_list *el;
12510 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
12513 /* If there are any entries, ns->proc_name is the entry master
12514 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
12516 sym = ns->entries->sym;
12518 sym = ns->proc_name;
12519 if (sym->result == sym
12520 && sym->ts.type == BT_UNKNOWN
12521 && gfc_set_default_type (sym, 0, NULL) == FAILURE
12522 && !sym->attr.untyped)
12524 gfc_error ("Function '%s' at %L has no IMPLICIT type",
12525 sym->name, &sym->declared_at);
12526 sym->attr.untyped = 1;
12529 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
12530 && !sym->attr.contained
12531 && !gfc_check_access (sym->ts.u.derived->attr.access,
12532 sym->ts.u.derived->ns->default_access)
12533 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12535 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
12536 "%L of PRIVATE type '%s'", sym->name,
12537 &sym->declared_at, sym->ts.u.derived->name);
12541 for (el = ns->entries->next; el; el = el->next)
12543 if (el->sym->result == el->sym
12544 && el->sym->ts.type == BT_UNKNOWN
12545 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
12546 && !el->sym->attr.untyped)
12548 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
12549 el->sym->name, &el->sym->declared_at);
12550 el->sym->attr.untyped = 1;
12556 /* 12.3.2.1.1 Defined operators. */
12559 check_uop_procedure (gfc_symbol *sym, locus where)
12561 gfc_formal_arglist *formal;
12563 if (!sym->attr.function)
12565 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
12566 sym->name, &where);
12570 if (sym->ts.type == BT_CHARACTER
12571 && !(sym->ts.u.cl && sym->ts.u.cl->length)
12572 && !(sym->result && sym->result->ts.u.cl
12573 && sym->result->ts.u.cl->length))
12575 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
12576 "character length", sym->name, &where);
12580 formal = sym->formal;
12581 if (!formal || !formal->sym)
12583 gfc_error ("User operator procedure '%s' at %L must have at least "
12584 "one argument", sym->name, &where);
12588 if (formal->sym->attr.intent != INTENT_IN)
12590 gfc_error ("First argument of operator interface at %L must be "
12591 "INTENT(IN)", &where);
12595 if (formal->sym->attr.optional)
12597 gfc_error ("First argument of operator interface at %L cannot be "
12598 "optional", &where);
12602 formal = formal->next;
12603 if (!formal || !formal->sym)
12606 if (formal->sym->attr.intent != INTENT_IN)
12608 gfc_error ("Second argument of operator interface at %L must be "
12609 "INTENT(IN)", &where);
12613 if (formal->sym->attr.optional)
12615 gfc_error ("Second argument of operator interface at %L cannot be "
12616 "optional", &where);
12622 gfc_error ("Operator interface at %L must have, at most, two "
12623 "arguments", &where);
12631 gfc_resolve_uops (gfc_symtree *symtree)
12633 gfc_interface *itr;
12635 if (symtree == NULL)
12638 gfc_resolve_uops (symtree->left);
12639 gfc_resolve_uops (symtree->right);
12641 for (itr = symtree->n.uop->op; itr; itr = itr->next)
12642 check_uop_procedure (itr->sym, itr->sym->declared_at);
12646 /* Examine all of the expressions associated with a program unit,
12647 assign types to all intermediate expressions, make sure that all
12648 assignments are to compatible types and figure out which names
12649 refer to which functions or subroutines. It doesn't check code
12650 block, which is handled by resolve_code. */
12653 resolve_types (gfc_namespace *ns)
12659 gfc_namespace* old_ns = gfc_current_ns;
12661 /* Check that all IMPLICIT types are ok. */
12662 if (!ns->seen_implicit_none)
12665 for (letter = 0; letter != GFC_LETTERS; ++letter)
12666 if (ns->set_flag[letter]
12667 && resolve_typespec_used (&ns->default_type[letter],
12668 &ns->implicit_loc[letter],
12673 gfc_current_ns = ns;
12675 resolve_entries (ns);
12677 resolve_common_vars (ns->blank_common.head, false);
12678 resolve_common_blocks (ns->common_root);
12680 resolve_contained_functions (ns);
12682 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
12684 for (cl = ns->cl_list; cl; cl = cl->next)
12685 resolve_charlen (cl);
12687 gfc_traverse_ns (ns, resolve_symbol);
12689 resolve_fntype (ns);
12691 for (n = ns->contained; n; n = n->sibling)
12693 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
12694 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
12695 "also be PURE", n->proc_name->name,
12696 &n->proc_name->declared_at);
12702 gfc_check_interfaces (ns);
12704 gfc_traverse_ns (ns, resolve_values);
12710 for (d = ns->data; d; d = d->next)
12714 gfc_traverse_ns (ns, gfc_formalize_init_value);
12716 gfc_traverse_ns (ns, gfc_verify_binding_labels);
12718 if (ns->common_root != NULL)
12719 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
12721 for (eq = ns->equiv; eq; eq = eq->next)
12722 resolve_equivalence (eq);
12724 /* Warn about unused labels. */
12725 if (warn_unused_label)
12726 warn_unused_fortran_label (ns->st_labels);
12728 gfc_resolve_uops (ns->uop_root);
12730 gfc_current_ns = old_ns;
12734 /* Call resolve_code recursively. */
12737 resolve_codes (gfc_namespace *ns)
12740 bitmap_obstack old_obstack;
12742 for (n = ns->contained; n; n = n->sibling)
12745 gfc_current_ns = ns;
12747 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
12748 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
12751 /* Set to an out of range value. */
12752 current_entry_id = -1;
12754 old_obstack = labels_obstack;
12755 bitmap_obstack_initialize (&labels_obstack);
12757 resolve_code (ns->code, ns);
12759 bitmap_obstack_release (&labels_obstack);
12760 labels_obstack = old_obstack;
12764 /* This function is called after a complete program unit has been compiled.
12765 Its purpose is to examine all of the expressions associated with a program
12766 unit, assign types to all intermediate expressions, make sure that all
12767 assignments are to compatible types and figure out which names refer to
12768 which functions or subroutines. */
12771 gfc_resolve (gfc_namespace *ns)
12773 gfc_namespace *old_ns;
12774 code_stack *old_cs_base;
12780 old_ns = gfc_current_ns;
12781 old_cs_base = cs_base;
12783 resolve_types (ns);
12784 resolve_codes (ns);
12786 gfc_current_ns = old_ns;
12787 cs_base = old_cs_base;