1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
29 #include "arith.h" /* For gfc_compare_expr(). */
30 #include "dependency.h"
32 #include "target-memory.h" /* for gfc_simplify_transfer */
33 #include "constructor.h"
35 /* Types used in equivalence statements. */
39 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
43 /* Stack to keep track of the nesting of blocks as we move through the
44 code. See resolve_branch() and resolve_code(). */
46 typedef struct code_stack
48 struct gfc_code *head, *current;
49 struct code_stack *prev;
51 /* This bitmap keeps track of the targets valid for a branch from
52 inside this block except for END {IF|SELECT}s of enclosing
54 bitmap reachable_labels;
58 static code_stack *cs_base = NULL;
61 /* Nonzero if we're inside a FORALL block. */
63 static int forall_flag;
65 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
67 static int omp_workshare_flag;
69 /* Nonzero if we are processing a formal arglist. The corresponding function
70 resets the flag each time that it is read. */
71 static int formal_arg_flag = 0;
73 /* True if we are resolving a specification expression. */
74 static int specification_expr = 0;
76 /* The id of the last entry seen. */
77 static int current_entry_id;
79 /* We use bitmaps to determine if a branch target is valid. */
80 static bitmap_obstack labels_obstack;
82 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
83 static bool inquiry_argument = false;
86 gfc_is_formal_arg (void)
88 return formal_arg_flag;
91 /* Is the symbol host associated? */
93 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
95 for (ns = ns->parent; ns; ns = ns->parent)
104 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
105 an ABSTRACT derived-type. If where is not NULL, an error message with that
106 locus is printed, optionally using name. */
109 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
111 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
116 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
117 name, where, ts->u.derived->name);
119 gfc_error ("ABSTRACT type '%s' used at %L",
120 ts->u.derived->name, where);
130 static void resolve_symbol (gfc_symbol *sym);
131 static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
134 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
137 resolve_procedure_interface (gfc_symbol *sym)
139 if (sym->ts.interface == sym)
141 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
142 sym->name, &sym->declared_at);
145 if (sym->ts.interface->attr.procedure)
147 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
148 "in a later PROCEDURE statement", sym->ts.interface->name,
149 sym->name, &sym->declared_at);
153 /* Get the attributes from the interface (now resolved). */
154 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
156 gfc_symbol *ifc = sym->ts.interface;
157 resolve_symbol (ifc);
159 if (ifc->attr.intrinsic)
160 resolve_intrinsic (ifc, &ifc->declared_at);
163 sym->ts = ifc->result->ts;
166 sym->ts.interface = ifc;
167 sym->attr.function = ifc->attr.function;
168 sym->attr.subroutine = ifc->attr.subroutine;
169 gfc_copy_formal_args (sym, ifc);
171 sym->attr.allocatable = ifc->attr.allocatable;
172 sym->attr.pointer = ifc->attr.pointer;
173 sym->attr.pure = ifc->attr.pure;
174 sym->attr.elemental = ifc->attr.elemental;
175 sym->attr.dimension = ifc->attr.dimension;
176 sym->attr.contiguous = ifc->attr.contiguous;
177 sym->attr.recursive = ifc->attr.recursive;
178 sym->attr.always_explicit = ifc->attr.always_explicit;
179 sym->attr.ext_attr |= ifc->attr.ext_attr;
180 sym->attr.is_bind_c = ifc->attr.is_bind_c;
181 /* Copy array spec. */
182 sym->as = gfc_copy_array_spec (ifc->as);
186 for (i = 0; i < sym->as->rank; i++)
188 gfc_expr_replace_symbols (sym->as->lower[i], sym);
189 gfc_expr_replace_symbols (sym->as->upper[i], sym);
192 /* Copy char length. */
193 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
195 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
196 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
197 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
198 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
202 else if (sym->ts.interface->name[0] != '\0')
204 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
205 sym->ts.interface->name, sym->name, &sym->declared_at);
213 /* Resolve types of formal argument lists. These have to be done early so that
214 the formal argument lists of module procedures can be copied to the
215 containing module before the individual procedures are resolved
216 individually. We also resolve argument lists of procedures in interface
217 blocks because they are self-contained scoping units.
219 Since a dummy argument cannot be a non-dummy procedure, the only
220 resort left for untyped names are the IMPLICIT types. */
223 resolve_formal_arglist (gfc_symbol *proc)
225 gfc_formal_arglist *f;
229 if (proc->result != NULL)
234 if (gfc_elemental (proc)
235 || sym->attr.pointer || sym->attr.allocatable
236 || (sym->as && sym->as->rank > 0))
238 proc->attr.always_explicit = 1;
239 sym->attr.always_explicit = 1;
244 for (f = proc->formal; f; f = f->next)
250 /* Alternate return placeholder. */
251 if (gfc_elemental (proc))
252 gfc_error ("Alternate return specifier in elemental subroutine "
253 "'%s' at %L is not allowed", proc->name,
255 if (proc->attr.function)
256 gfc_error ("Alternate return specifier in function "
257 "'%s' at %L is not allowed", proc->name,
261 else if (sym->attr.procedure && sym->ts.interface
262 && sym->attr.if_source != IFSRC_DECL)
263 resolve_procedure_interface (sym);
265 if (sym->attr.if_source != IFSRC_UNKNOWN)
266 resolve_formal_arglist (sym);
268 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
270 if (gfc_pure (proc) && !gfc_pure (sym))
272 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
273 "also be PURE", sym->name, &sym->declared_at);
277 if (proc->attr.implicit_pure && !gfc_pure(sym))
278 proc->attr.implicit_pure = 0;
280 if (gfc_elemental (proc))
282 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
283 "procedure", &sym->declared_at);
287 if (sym->attr.function
288 && sym->ts.type == BT_UNKNOWN
289 && sym->attr.intrinsic)
291 gfc_intrinsic_sym *isym;
292 isym = gfc_find_function (sym->name);
293 if (isym == NULL || !isym->specific)
295 gfc_error ("Unable to find a specific INTRINSIC procedure "
296 "for the reference '%s' at %L", sym->name,
305 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
306 && (!sym->attr.function || sym->result == sym))
307 gfc_set_default_type (sym, 1, sym->ns);
309 gfc_resolve_array_spec (sym->as, 0);
311 /* We can't tell if an array with dimension (:) is assumed or deferred
312 shape until we know if it has the pointer or allocatable attributes.
314 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
315 && !(sym->attr.pointer || sym->attr.allocatable))
317 sym->as->type = AS_ASSUMED_SHAPE;
318 for (i = 0; i < sym->as->rank; i++)
319 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
323 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
324 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
325 || sym->attr.optional)
327 proc->attr.always_explicit = 1;
329 proc->result->attr.always_explicit = 1;
332 /* If the flavor is unknown at this point, it has to be a variable.
333 A procedure specification would have already set the type. */
335 if (sym->attr.flavor == FL_UNKNOWN)
336 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
338 if (gfc_pure (proc) && !sym->attr.pointer
339 && sym->attr.flavor != FL_PROCEDURE)
341 if (proc->attr.function && sym->attr.intent != INTENT_IN
343 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
344 "INTENT(IN) or VALUE", sym->name, proc->name,
347 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
349 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
350 "have its INTENT specified or have the VALUE "
351 "attribute", sym->name, proc->name, &sym->declared_at);
354 if (proc->attr.implicit_pure && !sym->attr.pointer
355 && sym->attr.flavor != FL_PROCEDURE)
357 if (proc->attr.function && sym->attr.intent != INTENT_IN)
358 proc->attr.implicit_pure = 0;
360 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
361 proc->attr.implicit_pure = 0;
364 if (gfc_elemental (proc))
367 if (sym->attr.codimension)
369 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
370 "procedure", sym->name, &sym->declared_at);
376 gfc_error ("Argument '%s' of elemental procedure at %L must "
377 "be scalar", sym->name, &sym->declared_at);
381 if (sym->attr.allocatable)
383 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
384 "have the ALLOCATABLE attribute", sym->name,
389 if (sym->attr.pointer)
391 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
392 "have the POINTER attribute", sym->name,
397 if (sym->attr.flavor == FL_PROCEDURE)
399 gfc_error ("Dummy procedure '%s' not allowed in elemental "
400 "procedure '%s' at %L", sym->name, proc->name,
405 if (sym->attr.intent == INTENT_UNKNOWN)
407 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
408 "have its INTENT specified", sym->name, proc->name,
414 /* Each dummy shall be specified to be scalar. */
415 if (proc->attr.proc == PROC_ST_FUNCTION)
419 gfc_error ("Argument '%s' of statement function at %L must "
420 "be scalar", sym->name, &sym->declared_at);
424 if (sym->ts.type == BT_CHARACTER)
426 gfc_charlen *cl = sym->ts.u.cl;
427 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
429 gfc_error ("Character-valued argument '%s' of statement "
430 "function at %L must have constant length",
431 sym->name, &sym->declared_at);
441 /* Work function called when searching for symbols that have argument lists
442 associated with them. */
445 find_arglists (gfc_symbol *sym)
447 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
450 resolve_formal_arglist (sym);
454 /* Given a namespace, resolve all formal argument lists within the namespace.
458 resolve_formal_arglists (gfc_namespace *ns)
463 gfc_traverse_ns (ns, find_arglists);
468 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
472 /* If this namespace is not a function or an entry master function,
474 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
475 || sym->attr.entry_master)
478 /* Try to find out of what the return type is. */
479 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
481 t = gfc_set_default_type (sym->result, 0, ns);
483 if (t == FAILURE && !sym->result->attr.untyped)
485 if (sym->result == sym)
486 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
487 sym->name, &sym->declared_at);
488 else if (!sym->result->attr.proc_pointer)
489 gfc_error ("Result '%s' of contained function '%s' at %L has "
490 "no IMPLICIT type", sym->result->name, sym->name,
491 &sym->result->declared_at);
492 sym->result->attr.untyped = 1;
496 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
497 type, lists the only ways a character length value of * can be used:
498 dummy arguments of procedures, named constants, and function results
499 in external functions. Internal function results and results of module
500 procedures are not on this list, ergo, not permitted. */
502 if (sym->result->ts.type == BT_CHARACTER)
504 gfc_charlen *cl = sym->result->ts.u.cl;
505 if ((!cl || !cl->length) && !sym->result->ts.deferred)
507 /* See if this is a module-procedure and adapt error message
510 gcc_assert (ns->parent && ns->parent->proc_name);
511 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
513 gfc_error ("Character-valued %s '%s' at %L must not be"
515 module_proc ? _("module procedure")
516 : _("internal function"),
517 sym->name, &sym->declared_at);
523 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
524 introduce duplicates. */
527 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
529 gfc_formal_arglist *f, *new_arglist;
532 for (; new_args != NULL; new_args = new_args->next)
534 new_sym = new_args->sym;
535 /* See if this arg is already in the formal argument list. */
536 for (f = proc->formal; f; f = f->next)
538 if (new_sym == f->sym)
545 /* Add a new argument. Argument order is not important. */
546 new_arglist = gfc_get_formal_arglist ();
547 new_arglist->sym = new_sym;
548 new_arglist->next = proc->formal;
549 proc->formal = new_arglist;
554 /* Flag the arguments that are not present in all entries. */
557 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
559 gfc_formal_arglist *f, *head;
562 for (f = proc->formal; f; f = f->next)
567 for (new_args = head; new_args; new_args = new_args->next)
569 if (new_args->sym == f->sym)
576 f->sym->attr.not_always_present = 1;
581 /* Resolve alternate entry points. If a symbol has multiple entry points we
582 create a new master symbol for the main routine, and turn the existing
583 symbol into an entry point. */
586 resolve_entries (gfc_namespace *ns)
588 gfc_namespace *old_ns;
592 char name[GFC_MAX_SYMBOL_LEN + 1];
593 static int master_count = 0;
595 if (ns->proc_name == NULL)
598 /* No need to do anything if this procedure doesn't have alternate entry
603 /* We may already have resolved alternate entry points. */
604 if (ns->proc_name->attr.entry_master)
607 /* If this isn't a procedure something has gone horribly wrong. */
608 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
610 /* Remember the current namespace. */
611 old_ns = gfc_current_ns;
615 /* Add the main entry point to the list of entry points. */
616 el = gfc_get_entry_list ();
617 el->sym = ns->proc_name;
619 el->next = ns->entries;
621 ns->proc_name->attr.entry = 1;
623 /* If it is a module function, it needs to be in the right namespace
624 so that gfc_get_fake_result_decl can gather up the results. The
625 need for this arose in get_proc_name, where these beasts were
626 left in their own namespace, to keep prior references linked to
627 the entry declaration.*/
628 if (ns->proc_name->attr.function
629 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
632 /* Do the same for entries where the master is not a module
633 procedure. These are retained in the module namespace because
634 of the module procedure declaration. */
635 for (el = el->next; el; el = el->next)
636 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
637 && el->sym->attr.mod_proc)
641 /* Add an entry statement for it. */
648 /* Create a new symbol for the master function. */
649 /* Give the internal function a unique name (within this file).
650 Also include the function name so the user has some hope of figuring
651 out what is going on. */
652 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
653 master_count++, ns->proc_name->name);
654 gfc_get_ha_symbol (name, &proc);
655 gcc_assert (proc != NULL);
657 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
658 if (ns->proc_name->attr.subroutine)
659 gfc_add_subroutine (&proc->attr, proc->name, NULL);
663 gfc_typespec *ts, *fts;
664 gfc_array_spec *as, *fas;
665 gfc_add_function (&proc->attr, proc->name, NULL);
667 fas = ns->entries->sym->as;
668 fas = fas ? fas : ns->entries->sym->result->as;
669 fts = &ns->entries->sym->result->ts;
670 if (fts->type == BT_UNKNOWN)
671 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
672 for (el = ns->entries->next; el; el = el->next)
674 ts = &el->sym->result->ts;
676 as = as ? as : el->sym->result->as;
677 if (ts->type == BT_UNKNOWN)
678 ts = gfc_get_default_type (el->sym->result->name, NULL);
680 if (! gfc_compare_types (ts, fts)
681 || (el->sym->result->attr.dimension
682 != ns->entries->sym->result->attr.dimension)
683 || (el->sym->result->attr.pointer
684 != ns->entries->sym->result->attr.pointer))
686 else if (as && fas && ns->entries->sym->result != el->sym->result
687 && gfc_compare_array_spec (as, fas) == 0)
688 gfc_error ("Function %s at %L has entries with mismatched "
689 "array specifications", ns->entries->sym->name,
690 &ns->entries->sym->declared_at);
691 /* The characteristics need to match and thus both need to have
692 the same string length, i.e. both len=*, or both len=4.
693 Having both len=<variable> is also possible, but difficult to
694 check at compile time. */
695 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
696 && (((ts->u.cl->length && !fts->u.cl->length)
697 ||(!ts->u.cl->length && fts->u.cl->length))
699 && ts->u.cl->length->expr_type
700 != fts->u.cl->length->expr_type)
702 && ts->u.cl->length->expr_type == EXPR_CONSTANT
703 && mpz_cmp (ts->u.cl->length->value.integer,
704 fts->u.cl->length->value.integer) != 0)))
705 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
706 "entries returning variables of different "
707 "string lengths", ns->entries->sym->name,
708 &ns->entries->sym->declared_at);
713 sym = ns->entries->sym->result;
714 /* All result types the same. */
716 if (sym->attr.dimension)
717 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
718 if (sym->attr.pointer)
719 gfc_add_pointer (&proc->attr, NULL);
723 /* Otherwise the result will be passed through a union by
725 proc->attr.mixed_entry_master = 1;
726 for (el = ns->entries; el; el = el->next)
728 sym = el->sym->result;
729 if (sym->attr.dimension)
731 if (el == ns->entries)
732 gfc_error ("FUNCTION result %s can't be an array in "
733 "FUNCTION %s at %L", sym->name,
734 ns->entries->sym->name, &sym->declared_at);
736 gfc_error ("ENTRY result %s can't be an array in "
737 "FUNCTION %s at %L", sym->name,
738 ns->entries->sym->name, &sym->declared_at);
740 else if (sym->attr.pointer)
742 if (el == ns->entries)
743 gfc_error ("FUNCTION result %s can't be a POINTER in "
744 "FUNCTION %s at %L", sym->name,
745 ns->entries->sym->name, &sym->declared_at);
747 gfc_error ("ENTRY result %s can't be a POINTER in "
748 "FUNCTION %s at %L", sym->name,
749 ns->entries->sym->name, &sym->declared_at);
754 if (ts->type == BT_UNKNOWN)
755 ts = gfc_get_default_type (sym->name, NULL);
759 if (ts->kind == gfc_default_integer_kind)
763 if (ts->kind == gfc_default_real_kind
764 || ts->kind == gfc_default_double_kind)
768 if (ts->kind == gfc_default_complex_kind)
772 if (ts->kind == gfc_default_logical_kind)
776 /* We will issue error elsewhere. */
784 if (el == ns->entries)
785 gfc_error ("FUNCTION result %s can't be of type %s "
786 "in FUNCTION %s at %L", sym->name,
787 gfc_typename (ts), ns->entries->sym->name,
790 gfc_error ("ENTRY result %s can't be of type %s "
791 "in FUNCTION %s at %L", sym->name,
792 gfc_typename (ts), ns->entries->sym->name,
799 proc->attr.access = ACCESS_PRIVATE;
800 proc->attr.entry_master = 1;
802 /* Merge all the entry point arguments. */
803 for (el = ns->entries; el; el = el->next)
804 merge_argument_lists (proc, el->sym->formal);
806 /* Check the master formal arguments for any that are not
807 present in all entry points. */
808 for (el = ns->entries; el; el = el->next)
809 check_argument_lists (proc, el->sym->formal);
811 /* Use the master function for the function body. */
812 ns->proc_name = proc;
814 /* Finalize the new symbols. */
815 gfc_commit_symbols ();
817 /* Restore the original namespace. */
818 gfc_current_ns = old_ns;
822 /* Resolve common variables. */
824 resolve_common_vars (gfc_symbol *sym, bool named_common)
826 gfc_symbol *csym = sym;
828 for (; csym; csym = csym->common_next)
830 if (csym->value || csym->attr.data)
832 if (!csym->ns->is_block_data)
833 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
834 "but only in BLOCK DATA initialization is "
835 "allowed", csym->name, &csym->declared_at);
836 else if (!named_common)
837 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
838 "in a blank COMMON but initialization is only "
839 "allowed in named common blocks", csym->name,
843 if (csym->ts.type != BT_DERIVED)
846 if (!(csym->ts.u.derived->attr.sequence
847 || csym->ts.u.derived->attr.is_bind_c))
848 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
849 "has neither the SEQUENCE nor the BIND(C) "
850 "attribute", csym->name, &csym->declared_at);
851 if (csym->ts.u.derived->attr.alloc_comp)
852 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
853 "has an ultimate component that is "
854 "allocatable", csym->name, &csym->declared_at);
855 if (gfc_has_default_initializer (csym->ts.u.derived))
856 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
857 "may not have default initializer", csym->name,
860 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
861 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
865 /* Resolve common blocks. */
867 resolve_common_blocks (gfc_symtree *common_root)
871 if (common_root == NULL)
874 if (common_root->left)
875 resolve_common_blocks (common_root->left);
876 if (common_root->right)
877 resolve_common_blocks (common_root->right);
879 resolve_common_vars (common_root->n.common->head, true);
881 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
885 if (sym->attr.flavor == FL_PARAMETER)
886 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
887 sym->name, &common_root->n.common->where, &sym->declared_at);
889 if (sym->attr.intrinsic)
890 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
891 sym->name, &common_root->n.common->where);
892 else if (sym->attr.result
893 || gfc_is_function_return_value (sym, gfc_current_ns))
894 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
895 "that is also a function result", sym->name,
896 &common_root->n.common->where);
897 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
898 && sym->attr.proc != PROC_ST_FUNCTION)
899 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
900 "that is also a global procedure", sym->name,
901 &common_root->n.common->where);
905 /* Resolve contained function types. Because contained functions can call one
906 another, they have to be worked out before any of the contained procedures
909 The good news is that if a function doesn't already have a type, the only
910 way it can get one is through an IMPLICIT type or a RESULT variable, because
911 by definition contained functions are contained namespace they're contained
912 in, not in a sibling or parent namespace. */
915 resolve_contained_functions (gfc_namespace *ns)
917 gfc_namespace *child;
920 resolve_formal_arglists (ns);
922 for (child = ns->contained; child; child = child->sibling)
924 /* Resolve alternate entry points first. */
925 resolve_entries (child);
927 /* Then check function return types. */
928 resolve_contained_fntype (child->proc_name, child);
929 for (el = child->entries; el; el = el->next)
930 resolve_contained_fntype (el->sym, child);
935 /* Resolve all of the elements of a structure constructor and make sure that
936 the types are correct. The 'init' flag indicates that the given
937 constructor is an initializer. */
940 resolve_structure_cons (gfc_expr *expr, int init)
942 gfc_constructor *cons;
949 if (expr->ts.type == BT_DERIVED)
950 resolve_symbol (expr->ts.u.derived);
952 cons = gfc_constructor_first (expr->value.constructor);
953 /* A constructor may have references if it is the result of substituting a
954 parameter variable. In this case we just pull out the component we
957 comp = expr->ref->u.c.sym->components;
959 comp = expr->ts.u.derived->components;
961 /* See if the user is trying to invoke a structure constructor for one of
962 the iso_c_binding derived types. */
963 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
964 && expr->ts.u.derived->ts.is_iso_c && cons
965 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
967 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
968 expr->ts.u.derived->name, &(expr->where));
972 /* Return if structure constructor is c_null_(fun)prt. */
973 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
974 && expr->ts.u.derived->ts.is_iso_c && cons
975 && cons->expr && cons->expr->expr_type == EXPR_NULL)
978 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
985 if (gfc_resolve_expr (cons->expr) == FAILURE)
991 rank = comp->as ? comp->as->rank : 0;
992 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
993 && (comp->attr.allocatable || cons->expr->rank))
995 gfc_error ("The rank of the element in the derived type "
996 "constructor at %L does not match that of the "
997 "component (%d/%d)", &cons->expr->where,
998 cons->expr->rank, rank);
1002 /* If we don't have the right type, try to convert it. */
1004 if (!comp->attr.proc_pointer &&
1005 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1008 if (strcmp (comp->name, "_extends") == 0)
1010 /* Can afford to be brutal with the _extends initializer.
1011 The derived type can get lost because it is PRIVATE
1012 but it is not usage constrained by the standard. */
1013 cons->expr->ts = comp->ts;
1016 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1017 gfc_error ("The element in the derived type constructor at %L, "
1018 "for pointer component '%s', is %s but should be %s",
1019 &cons->expr->where, comp->name,
1020 gfc_basic_typename (cons->expr->ts.type),
1021 gfc_basic_typename (comp->ts.type));
1023 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1026 /* For strings, the length of the constructor should be the same as
1027 the one of the structure, ensure this if the lengths are known at
1028 compile time and when we are dealing with PARAMETER or structure
1030 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1031 && comp->ts.u.cl->length
1032 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1033 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1034 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1035 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1036 comp->ts.u.cl->length->value.integer) != 0)
1038 if (cons->expr->expr_type == EXPR_VARIABLE
1039 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1041 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1042 to make use of the gfc_resolve_character_array_constructor
1043 machinery. The expression is later simplified away to
1044 an array of string literals. */
1045 gfc_expr *para = cons->expr;
1046 cons->expr = gfc_get_expr ();
1047 cons->expr->ts = para->ts;
1048 cons->expr->where = para->where;
1049 cons->expr->expr_type = EXPR_ARRAY;
1050 cons->expr->rank = para->rank;
1051 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1052 gfc_constructor_append_expr (&cons->expr->value.constructor,
1053 para, &cons->expr->where);
1055 if (cons->expr->expr_type == EXPR_ARRAY)
1058 p = gfc_constructor_first (cons->expr->value.constructor);
1059 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1061 gfc_charlen *cl, *cl2;
1064 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1066 if (cl == cons->expr->ts.u.cl)
1074 cl2->next = cl->next;
1076 gfc_free_expr (cl->length);
1080 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1081 cons->expr->ts.u.cl->length_from_typespec = true;
1082 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1083 gfc_resolve_character_array_constructor (cons->expr);
1087 if (cons->expr->expr_type == EXPR_NULL
1088 && !(comp->attr.pointer || comp->attr.allocatable
1089 || comp->attr.proc_pointer
1090 || (comp->ts.type == BT_CLASS
1091 && (CLASS_DATA (comp)->attr.class_pointer
1092 || CLASS_DATA (comp)->attr.allocatable))))
1095 gfc_error ("The NULL in the derived type constructor at %L is "
1096 "being applied to component '%s', which is neither "
1097 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1101 if (!comp->attr.pointer || comp->attr.proc_pointer
1102 || cons->expr->expr_type == EXPR_NULL)
1105 a = gfc_expr_attr (cons->expr);
1107 if (!a.pointer && !a.target)
1110 gfc_error ("The element in the derived type constructor at %L, "
1111 "for pointer component '%s' should be a POINTER or "
1112 "a TARGET", &cons->expr->where, comp->name);
1117 /* F08:C461. Additional checks for pointer initialization. */
1121 gfc_error ("Pointer initialization target at %L "
1122 "must not be ALLOCATABLE ", &cons->expr->where);
1127 gfc_error ("Pointer initialization target at %L "
1128 "must have the SAVE attribute", &cons->expr->where);
1132 /* F2003, C1272 (3). */
1133 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1134 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1135 || gfc_is_coindexed (cons->expr)))
1138 gfc_error ("Invalid expression in the derived type constructor for "
1139 "pointer component '%s' at %L in PURE procedure",
1140 comp->name, &cons->expr->where);
1143 if (gfc_implicit_pure (NULL)
1144 && cons->expr->expr_type == EXPR_VARIABLE
1145 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1146 || gfc_is_coindexed (cons->expr)))
1147 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1155 /****************** Expression name resolution ******************/
1157 /* Returns 0 if a symbol was not declared with a type or
1158 attribute declaration statement, nonzero otherwise. */
1161 was_declared (gfc_symbol *sym)
1167 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1170 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1171 || a.optional || a.pointer || a.save || a.target || a.volatile_
1172 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1173 || a.asynchronous || a.codimension)
1180 /* Determine if a symbol is generic or not. */
1183 generic_sym (gfc_symbol *sym)
1187 if (sym->attr.generic ||
1188 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1191 if (was_declared (sym) || sym->ns->parent == NULL)
1194 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1201 return generic_sym (s);
1208 /* Determine if a symbol is specific or not. */
1211 specific_sym (gfc_symbol *sym)
1215 if (sym->attr.if_source == IFSRC_IFBODY
1216 || sym->attr.proc == PROC_MODULE
1217 || sym->attr.proc == PROC_INTERNAL
1218 || sym->attr.proc == PROC_ST_FUNCTION
1219 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1220 || sym->attr.external)
1223 if (was_declared (sym) || sym->ns->parent == NULL)
1226 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1228 return (s == NULL) ? 0 : specific_sym (s);
1232 /* Figure out if the procedure is specific, generic or unknown. */
1235 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1239 procedure_kind (gfc_symbol *sym)
1241 if (generic_sym (sym))
1242 return PTYPE_GENERIC;
1244 if (specific_sym (sym))
1245 return PTYPE_SPECIFIC;
1247 return PTYPE_UNKNOWN;
1250 /* Check references to assumed size arrays. The flag need_full_assumed_size
1251 is nonzero when matching actual arguments. */
1253 static int need_full_assumed_size = 0;
1256 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1258 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1261 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1262 What should it be? */
1263 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1264 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1265 && (e->ref->u.ar.type == AR_FULL))
1267 gfc_error ("The upper bound in the last dimension must "
1268 "appear in the reference to the assumed size "
1269 "array '%s' at %L", sym->name, &e->where);
1276 /* Look for bad assumed size array references in argument expressions
1277 of elemental and array valued intrinsic procedures. Since this is
1278 called from procedure resolution functions, it only recurses at
1282 resolve_assumed_size_actual (gfc_expr *e)
1287 switch (e->expr_type)
1290 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1295 if (resolve_assumed_size_actual (e->value.op.op1)
1296 || resolve_assumed_size_actual (e->value.op.op2))
1307 /* Check a generic procedure, passed as an actual argument, to see if
1308 there is a matching specific name. If none, it is an error, and if
1309 more than one, the reference is ambiguous. */
1311 count_specific_procs (gfc_expr *e)
1318 sym = e->symtree->n.sym;
1320 for (p = sym->generic; p; p = p->next)
1321 if (strcmp (sym->name, p->sym->name) == 0)
1323 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1329 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1333 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1334 "argument at %L", sym->name, &e->where);
1340 /* See if a call to sym could possibly be a not allowed RECURSION because of
1341 a missing RECURIVE declaration. This means that either sym is the current
1342 context itself, or sym is the parent of a contained procedure calling its
1343 non-RECURSIVE containing procedure.
1344 This also works if sym is an ENTRY. */
1347 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1349 gfc_symbol* proc_sym;
1350 gfc_symbol* context_proc;
1351 gfc_namespace* real_context;
1353 if (sym->attr.flavor == FL_PROGRAM)
1356 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1358 /* If we've got an ENTRY, find real procedure. */
1359 if (sym->attr.entry && sym->ns->entries)
1360 proc_sym = sym->ns->entries->sym;
1364 /* If sym is RECURSIVE, all is well of course. */
1365 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1368 /* Find the context procedure's "real" symbol if it has entries.
1369 We look for a procedure symbol, so recurse on the parents if we don't
1370 find one (like in case of a BLOCK construct). */
1371 for (real_context = context; ; real_context = real_context->parent)
1373 /* We should find something, eventually! */
1374 gcc_assert (real_context);
1376 context_proc = (real_context->entries ? real_context->entries->sym
1377 : real_context->proc_name);
1379 /* In some special cases, there may not be a proc_name, like for this
1381 real(bad_kind()) function foo () ...
1382 when checking the call to bad_kind ().
1383 In these cases, we simply return here and assume that the
1388 if (context_proc->attr.flavor != FL_LABEL)
1392 /* A call from sym's body to itself is recursion, of course. */
1393 if (context_proc == proc_sym)
1396 /* The same is true if context is a contained procedure and sym the
1398 if (context_proc->attr.contained)
1400 gfc_symbol* parent_proc;
1402 gcc_assert (context->parent);
1403 parent_proc = (context->parent->entries ? context->parent->entries->sym
1404 : context->parent->proc_name);
1406 if (parent_proc == proc_sym)
1414 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1415 its typespec and formal argument list. */
1418 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1420 gfc_intrinsic_sym* isym = NULL;
1426 /* We already know this one is an intrinsic, so we don't call
1427 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1428 gfc_find_subroutine directly to check whether it is a function or
1431 if (sym->intmod_sym_id)
1432 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1434 isym = gfc_find_function (sym->name);
1438 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1439 && !sym->attr.implicit_type)
1440 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1441 " ignored", sym->name, &sym->declared_at);
1443 if (!sym->attr.function &&
1444 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1449 else if ((isym = gfc_find_subroutine (sym->name)))
1451 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1453 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1454 " specifier", sym->name, &sym->declared_at);
1458 if (!sym->attr.subroutine &&
1459 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1464 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1469 gfc_copy_formal_args_intr (sym, isym);
1471 /* Check it is actually available in the standard settings. */
1472 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1475 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1476 " available in the current standard settings but %s. Use"
1477 " an appropriate -std=* option or enable -fall-intrinsics"
1478 " in order to use it.",
1479 sym->name, &sym->declared_at, symstd);
1487 /* Resolve a procedure expression, like passing it to a called procedure or as
1488 RHS for a procedure pointer assignment. */
1491 resolve_procedure_expression (gfc_expr* expr)
1495 if (expr->expr_type != EXPR_VARIABLE)
1497 gcc_assert (expr->symtree);
1499 sym = expr->symtree->n.sym;
1501 if (sym->attr.intrinsic)
1502 resolve_intrinsic (sym, &expr->where);
1504 if (sym->attr.flavor != FL_PROCEDURE
1505 || (sym->attr.function && sym->result == sym))
1508 /* A non-RECURSIVE procedure that is used as procedure expression within its
1509 own body is in danger of being called recursively. */
1510 if (is_illegal_recursion (sym, gfc_current_ns))
1511 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1512 " itself recursively. Declare it RECURSIVE or use"
1513 " -frecursive", sym->name, &expr->where);
1519 /* Resolve an actual argument list. Most of the time, this is just
1520 resolving the expressions in the list.
1521 The exception is that we sometimes have to decide whether arguments
1522 that look like procedure arguments are really simple variable
1526 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1527 bool no_formal_args)
1530 gfc_symtree *parent_st;
1532 int save_need_full_assumed_size;
1534 for (; arg; arg = arg->next)
1539 /* Check the label is a valid branching target. */
1542 if (arg->label->defined == ST_LABEL_UNKNOWN)
1544 gfc_error ("Label %d referenced at %L is never defined",
1545 arg->label->value, &arg->label->where);
1552 if (e->expr_type == EXPR_VARIABLE
1553 && e->symtree->n.sym->attr.generic
1555 && count_specific_procs (e) != 1)
1558 if (e->ts.type != BT_PROCEDURE)
1560 save_need_full_assumed_size = need_full_assumed_size;
1561 if (e->expr_type != EXPR_VARIABLE)
1562 need_full_assumed_size = 0;
1563 if (gfc_resolve_expr (e) != SUCCESS)
1565 need_full_assumed_size = save_need_full_assumed_size;
1569 /* See if the expression node should really be a variable reference. */
1571 sym = e->symtree->n.sym;
1573 if (sym->attr.flavor == FL_PROCEDURE
1574 || sym->attr.intrinsic
1575 || sym->attr.external)
1579 /* If a procedure is not already determined to be something else
1580 check if it is intrinsic. */
1581 if (!sym->attr.intrinsic
1582 && !(sym->attr.external || sym->attr.use_assoc
1583 || sym->attr.if_source == IFSRC_IFBODY)
1584 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1585 sym->attr.intrinsic = 1;
1587 if (sym->attr.proc == PROC_ST_FUNCTION)
1589 gfc_error ("Statement function '%s' at %L is not allowed as an "
1590 "actual argument", sym->name, &e->where);
1593 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1594 sym->attr.subroutine);
1595 if (sym->attr.intrinsic && actual_ok == 0)
1597 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1598 "actual argument", sym->name, &e->where);
1601 if (sym->attr.contained && !sym->attr.use_assoc
1602 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1604 if (gfc_notify_std (GFC_STD_F2008,
1605 "Fortran 2008: Internal procedure '%s' is"
1606 " used as actual argument at %L",
1607 sym->name, &e->where) == FAILURE)
1611 if (sym->attr.elemental && !sym->attr.intrinsic)
1613 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1614 "allowed as an actual argument at %L", sym->name,
1618 /* Check if a generic interface has a specific procedure
1619 with the same name before emitting an error. */
1620 if (sym->attr.generic && count_specific_procs (e) != 1)
1623 /* Just in case a specific was found for the expression. */
1624 sym = e->symtree->n.sym;
1626 /* If the symbol is the function that names the current (or
1627 parent) scope, then we really have a variable reference. */
1629 if (gfc_is_function_return_value (sym, sym->ns))
1632 /* If all else fails, see if we have a specific intrinsic. */
1633 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1635 gfc_intrinsic_sym *isym;
1637 isym = gfc_find_function (sym->name);
1638 if (isym == NULL || !isym->specific)
1640 gfc_error ("Unable to find a specific INTRINSIC procedure "
1641 "for the reference '%s' at %L", sym->name,
1646 sym->attr.intrinsic = 1;
1647 sym->attr.function = 1;
1650 if (gfc_resolve_expr (e) == FAILURE)
1655 /* See if the name is a module procedure in a parent unit. */
1657 if (was_declared (sym) || sym->ns->parent == NULL)
1660 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1662 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1666 if (parent_st == NULL)
1669 sym = parent_st->n.sym;
1670 e->symtree = parent_st; /* Point to the right thing. */
1672 if (sym->attr.flavor == FL_PROCEDURE
1673 || sym->attr.intrinsic
1674 || sym->attr.external)
1676 if (gfc_resolve_expr (e) == FAILURE)
1682 e->expr_type = EXPR_VARIABLE;
1684 if (sym->as != NULL)
1686 e->rank = sym->as->rank;
1687 e->ref = gfc_get_ref ();
1688 e->ref->type = REF_ARRAY;
1689 e->ref->u.ar.type = AR_FULL;
1690 e->ref->u.ar.as = sym->as;
1693 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1694 primary.c (match_actual_arg). If above code determines that it
1695 is a variable instead, it needs to be resolved as it was not
1696 done at the beginning of this function. */
1697 save_need_full_assumed_size = need_full_assumed_size;
1698 if (e->expr_type != EXPR_VARIABLE)
1699 need_full_assumed_size = 0;
1700 if (gfc_resolve_expr (e) != SUCCESS)
1702 need_full_assumed_size = save_need_full_assumed_size;
1705 /* Check argument list functions %VAL, %LOC and %REF. There is
1706 nothing to do for %REF. */
1707 if (arg->name && arg->name[0] == '%')
1709 if (strncmp ("%VAL", arg->name, 4) == 0)
1711 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1713 gfc_error ("By-value argument at %L is not of numeric "
1720 gfc_error ("By-value argument at %L cannot be an array or "
1721 "an array section", &e->where);
1725 /* Intrinsics are still PROC_UNKNOWN here. However,
1726 since same file external procedures are not resolvable
1727 in gfortran, it is a good deal easier to leave them to
1729 if (ptype != PROC_UNKNOWN
1730 && ptype != PROC_DUMMY
1731 && ptype != PROC_EXTERNAL
1732 && ptype != PROC_MODULE)
1734 gfc_error ("By-value argument at %L is not allowed "
1735 "in this context", &e->where);
1740 /* Statement functions have already been excluded above. */
1741 else if (strncmp ("%LOC", arg->name, 4) == 0
1742 && e->ts.type == BT_PROCEDURE)
1744 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1746 gfc_error ("Passing internal procedure at %L by location "
1747 "not allowed", &e->where);
1753 /* Fortran 2008, C1237. */
1754 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1755 && gfc_has_ultimate_pointer (e))
1757 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1758 "component", &e->where);
1767 /* Do the checks of the actual argument list that are specific to elemental
1768 procedures. If called with c == NULL, we have a function, otherwise if
1769 expr == NULL, we have a subroutine. */
1772 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1774 gfc_actual_arglist *arg0;
1775 gfc_actual_arglist *arg;
1776 gfc_symbol *esym = NULL;
1777 gfc_intrinsic_sym *isym = NULL;
1779 gfc_intrinsic_arg *iformal = NULL;
1780 gfc_formal_arglist *eformal = NULL;
1781 bool formal_optional = false;
1782 bool set_by_optional = false;
1786 /* Is this an elemental procedure? */
1787 if (expr && expr->value.function.actual != NULL)
1789 if (expr->value.function.esym != NULL
1790 && expr->value.function.esym->attr.elemental)
1792 arg0 = expr->value.function.actual;
1793 esym = expr->value.function.esym;
1795 else if (expr->value.function.isym != NULL
1796 && expr->value.function.isym->elemental)
1798 arg0 = expr->value.function.actual;
1799 isym = expr->value.function.isym;
1804 else if (c && c->ext.actual != NULL)
1806 arg0 = c->ext.actual;
1808 if (c->resolved_sym)
1809 esym = c->resolved_sym;
1811 esym = c->symtree->n.sym;
1814 if (!esym->attr.elemental)
1820 /* The rank of an elemental is the rank of its array argument(s). */
1821 for (arg = arg0; arg; arg = arg->next)
1823 if (arg->expr != NULL && arg->expr->rank > 0)
1825 rank = arg->expr->rank;
1826 if (arg->expr->expr_type == EXPR_VARIABLE
1827 && arg->expr->symtree->n.sym->attr.optional)
1828 set_by_optional = true;
1830 /* Function specific; set the result rank and shape. */
1834 if (!expr->shape && arg->expr->shape)
1836 expr->shape = gfc_get_shape (rank);
1837 for (i = 0; i < rank; i++)
1838 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1845 /* If it is an array, it shall not be supplied as an actual argument
1846 to an elemental procedure unless an array of the same rank is supplied
1847 as an actual argument corresponding to a nonoptional dummy argument of
1848 that elemental procedure(12.4.1.5). */
1849 formal_optional = false;
1851 iformal = isym->formal;
1853 eformal = esym->formal;
1855 for (arg = arg0; arg; arg = arg->next)
1859 if (eformal->sym && eformal->sym->attr.optional)
1860 formal_optional = true;
1861 eformal = eformal->next;
1863 else if (isym && iformal)
1865 if (iformal->optional)
1866 formal_optional = true;
1867 iformal = iformal->next;
1870 formal_optional = true;
1872 if (pedantic && arg->expr != NULL
1873 && arg->expr->expr_type == EXPR_VARIABLE
1874 && arg->expr->symtree->n.sym->attr.optional
1877 && (set_by_optional || arg->expr->rank != rank)
1878 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1880 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1881 "MISSING, it cannot be the actual argument of an "
1882 "ELEMENTAL procedure unless there is a non-optional "
1883 "argument with the same rank (12.4.1.5)",
1884 arg->expr->symtree->n.sym->name, &arg->expr->where);
1889 for (arg = arg0; arg; arg = arg->next)
1891 if (arg->expr == NULL || arg->expr->rank == 0)
1894 /* Being elemental, the last upper bound of an assumed size array
1895 argument must be present. */
1896 if (resolve_assumed_size_actual (arg->expr))
1899 /* Elemental procedure's array actual arguments must conform. */
1902 if (gfc_check_conformance (arg->expr, e,
1903 "elemental procedure") == FAILURE)
1910 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1911 is an array, the intent inout/out variable needs to be also an array. */
1912 if (rank > 0 && esym && expr == NULL)
1913 for (eformal = esym->formal, arg = arg0; arg && eformal;
1914 arg = arg->next, eformal = eformal->next)
1915 if ((eformal->sym->attr.intent == INTENT_OUT
1916 || eformal->sym->attr.intent == INTENT_INOUT)
1917 && arg->expr && arg->expr->rank == 0)
1919 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1920 "ELEMENTAL subroutine '%s' is a scalar, but another "
1921 "actual argument is an array", &arg->expr->where,
1922 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1923 : "INOUT", eformal->sym->name, esym->name);
1930 /* This function does the checking of references to global procedures
1931 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1932 77 and 95 standards. It checks for a gsymbol for the name, making
1933 one if it does not already exist. If it already exists, then the
1934 reference being resolved must correspond to the type of gsymbol.
1935 Otherwise, the new symbol is equipped with the attributes of the
1936 reference. The corresponding code that is called in creating
1937 global entities is parse.c.
1939 In addition, for all but -std=legacy, the gsymbols are used to
1940 check the interfaces of external procedures from the same file.
1941 The namespace of the gsymbol is resolved and then, once this is
1942 done the interface is checked. */
1946 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1948 if (!gsym_ns->proc_name->attr.recursive)
1951 if (sym->ns == gsym_ns)
1954 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1961 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1963 if (gsym_ns->entries)
1965 gfc_entry_list *entry = gsym_ns->entries;
1967 for (; entry; entry = entry->next)
1969 if (strcmp (sym->name, entry->sym->name) == 0)
1971 if (strcmp (gsym_ns->proc_name->name,
1972 sym->ns->proc_name->name) == 0)
1976 && strcmp (gsym_ns->proc_name->name,
1977 sym->ns->parent->proc_name->name) == 0)
1986 resolve_global_procedure (gfc_symbol *sym, locus *where,
1987 gfc_actual_arglist **actual, int sub)
1991 enum gfc_symbol_type type;
1993 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1995 gsym = gfc_get_gsymbol (sym->name);
1997 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1998 gfc_global_used (gsym, where);
2000 if (gfc_option.flag_whole_file
2001 && (sym->attr.if_source == IFSRC_UNKNOWN
2002 || sym->attr.if_source == IFSRC_IFBODY)
2003 && gsym->type != GSYM_UNKNOWN
2005 && gsym->ns->resolved != -1
2006 && gsym->ns->proc_name
2007 && not_in_recursive (sym, gsym->ns)
2008 && not_entry_self_reference (sym, gsym->ns))
2010 gfc_symbol *def_sym;
2012 /* Resolve the gsymbol namespace if needed. */
2013 if (!gsym->ns->resolved)
2015 gfc_dt_list *old_dt_list;
2016 struct gfc_omp_saved_state old_omp_state;
2018 /* Stash away derived types so that the backend_decls do not
2020 old_dt_list = gfc_derived_types;
2021 gfc_derived_types = NULL;
2022 /* And stash away openmp state. */
2023 gfc_omp_save_and_clear_state (&old_omp_state);
2025 gfc_resolve (gsym->ns);
2027 /* Store the new derived types with the global namespace. */
2028 if (gfc_derived_types)
2029 gsym->ns->derived_types = gfc_derived_types;
2031 /* Restore the derived types of this namespace. */
2032 gfc_derived_types = old_dt_list;
2033 /* And openmp state. */
2034 gfc_omp_restore_state (&old_omp_state);
2037 /* Make sure that translation for the gsymbol occurs before
2038 the procedure currently being resolved. */
2039 ns = gfc_global_ns_list;
2040 for (; ns && ns != gsym->ns; ns = ns->sibling)
2042 if (ns->sibling == gsym->ns)
2044 ns->sibling = gsym->ns->sibling;
2045 gsym->ns->sibling = gfc_global_ns_list;
2046 gfc_global_ns_list = gsym->ns;
2051 def_sym = gsym->ns->proc_name;
2052 if (def_sym->attr.entry_master)
2054 gfc_entry_list *entry;
2055 for (entry = gsym->ns->entries; entry; entry = entry->next)
2056 if (strcmp (entry->sym->name, sym->name) == 0)
2058 def_sym = entry->sym;
2063 /* Differences in constant character lengths. */
2064 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2066 long int l1 = 0, l2 = 0;
2067 gfc_charlen *cl1 = sym->ts.u.cl;
2068 gfc_charlen *cl2 = def_sym->ts.u.cl;
2071 && cl1->length != NULL
2072 && cl1->length->expr_type == EXPR_CONSTANT)
2073 l1 = mpz_get_si (cl1->length->value.integer);
2076 && cl2->length != NULL
2077 && cl2->length->expr_type == EXPR_CONSTANT)
2078 l2 = mpz_get_si (cl2->length->value.integer);
2080 if (l1 && l2 && l1 != l2)
2081 gfc_error ("Character length mismatch in return type of "
2082 "function '%s' at %L (%ld/%ld)", sym->name,
2083 &sym->declared_at, l1, l2);
2086 /* Type mismatch of function return type and expected type. */
2087 if (sym->attr.function
2088 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2089 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2090 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2091 gfc_typename (&def_sym->ts));
2093 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2095 gfc_formal_arglist *arg = def_sym->formal;
2096 for ( ; arg; arg = arg->next)
2099 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2100 else if (arg->sym->attr.allocatable
2101 || arg->sym->attr.asynchronous
2102 || arg->sym->attr.optional
2103 || arg->sym->attr.pointer
2104 || arg->sym->attr.target
2105 || arg->sym->attr.value
2106 || arg->sym->attr.volatile_)
2108 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2109 "has an attribute that requires an explicit "
2110 "interface for this procedure", arg->sym->name,
2111 sym->name, &sym->declared_at);
2114 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2115 else if (arg->sym && arg->sym->as
2116 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2118 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2119 "argument '%s' must have an explicit interface",
2120 sym->name, &sym->declared_at, arg->sym->name);
2123 /* F2008, 12.4.2.2 (2c) */
2124 else if (arg->sym->attr.codimension)
2126 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2127 "'%s' must have an explicit interface",
2128 sym->name, &sym->declared_at, arg->sym->name);
2131 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2132 else if (false) /* TODO: is a parametrized derived type */
2134 gfc_error ("Procedure '%s' at %L with parametrized derived "
2135 "type argument '%s' must have an explicit "
2136 "interface", sym->name, &sym->declared_at,
2140 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2141 else if (arg->sym->ts.type == BT_CLASS)
2143 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2144 "argument '%s' must have an explicit interface",
2145 sym->name, &sym->declared_at, arg->sym->name);
2150 if (def_sym->attr.function)
2152 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2153 if (def_sym->as && def_sym->as->rank
2154 && (!sym->as || sym->as->rank != def_sym->as->rank))
2155 gfc_error ("The reference to function '%s' at %L either needs an "
2156 "explicit INTERFACE or the rank is incorrect", sym->name,
2159 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2160 if ((def_sym->result->attr.pointer
2161 || def_sym->result->attr.allocatable)
2162 && (sym->attr.if_source != IFSRC_IFBODY
2163 || def_sym->result->attr.pointer
2164 != sym->result->attr.pointer
2165 || def_sym->result->attr.allocatable
2166 != sym->result->attr.allocatable))
2167 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2168 "result must have an explicit interface", sym->name,
2171 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2172 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2173 && def_sym->ts.u.cl->length != NULL)
2175 gfc_charlen *cl = sym->ts.u.cl;
2177 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2178 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2180 gfc_error ("Nonconstant character-length function '%s' at %L "
2181 "must have an explicit interface", sym->name,
2187 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2188 if (def_sym->attr.elemental && !sym->attr.elemental)
2190 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2191 "interface", sym->name, &sym->declared_at);
2194 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2195 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2197 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2198 "an explicit interface", sym->name, &sym->declared_at);
2201 if (gfc_option.flag_whole_file == 1
2202 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2203 && !(gfc_option.warn_std & GFC_STD_GNU)))
2204 gfc_errors_to_warnings (1);
2206 if (sym->attr.if_source != IFSRC_IFBODY)
2207 gfc_procedure_use (def_sym, actual, where);
2209 gfc_errors_to_warnings (0);
2212 if (gsym->type == GSYM_UNKNOWN)
2215 gsym->where = *where;
2222 /************* Function resolution *************/
2224 /* Resolve a function call known to be generic.
2225 Section 14.1.2.4.1. */
2228 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2232 if (sym->attr.generic)
2234 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2237 expr->value.function.name = s->name;
2238 expr->value.function.esym = s;
2240 if (s->ts.type != BT_UNKNOWN)
2242 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2243 expr->ts = s->result->ts;
2246 expr->rank = s->as->rank;
2247 else if (s->result != NULL && s->result->as != NULL)
2248 expr->rank = s->result->as->rank;
2250 gfc_set_sym_referenced (expr->value.function.esym);
2255 /* TODO: Need to search for elemental references in generic
2259 if (sym->attr.intrinsic)
2260 return gfc_intrinsic_func_interface (expr, 0);
2267 resolve_generic_f (gfc_expr *expr)
2272 sym = expr->symtree->n.sym;
2276 m = resolve_generic_f0 (expr, sym);
2279 else if (m == MATCH_ERROR)
2283 if (sym->ns->parent == NULL)
2285 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2289 if (!generic_sym (sym))
2293 /* Last ditch attempt. See if the reference is to an intrinsic
2294 that possesses a matching interface. 14.1.2.4 */
2295 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2297 gfc_error ("There is no specific function for the generic '%s' at %L",
2298 expr->symtree->n.sym->name, &expr->where);
2302 m = gfc_intrinsic_func_interface (expr, 0);
2306 gfc_error ("Generic function '%s' at %L is not consistent with a "
2307 "specific intrinsic interface", expr->symtree->n.sym->name,
2314 /* Resolve a function call known to be specific. */
2317 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2321 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2323 if (sym->attr.dummy)
2325 sym->attr.proc = PROC_DUMMY;
2329 sym->attr.proc = PROC_EXTERNAL;
2333 if (sym->attr.proc == PROC_MODULE
2334 || sym->attr.proc == PROC_ST_FUNCTION
2335 || sym->attr.proc == PROC_INTERNAL)
2338 if (sym->attr.intrinsic)
2340 m = gfc_intrinsic_func_interface (expr, 1);
2344 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2345 "with an intrinsic", sym->name, &expr->where);
2353 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2356 expr->ts = sym->result->ts;
2359 expr->value.function.name = sym->name;
2360 expr->value.function.esym = sym;
2361 if (sym->as != NULL)
2362 expr->rank = sym->as->rank;
2369 resolve_specific_f (gfc_expr *expr)
2374 sym = expr->symtree->n.sym;
2378 m = resolve_specific_f0 (sym, expr);
2381 if (m == MATCH_ERROR)
2384 if (sym->ns->parent == NULL)
2387 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2393 gfc_error ("Unable to resolve the specific function '%s' at %L",
2394 expr->symtree->n.sym->name, &expr->where);
2400 /* Resolve a procedure call not known to be generic nor specific. */
2403 resolve_unknown_f (gfc_expr *expr)
2408 sym = expr->symtree->n.sym;
2410 if (sym->attr.dummy)
2412 sym->attr.proc = PROC_DUMMY;
2413 expr->value.function.name = sym->name;
2417 /* See if we have an intrinsic function reference. */
2419 if (gfc_is_intrinsic (sym, 0, expr->where))
2421 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2426 /* The reference is to an external name. */
2428 sym->attr.proc = PROC_EXTERNAL;
2429 expr->value.function.name = sym->name;
2430 expr->value.function.esym = expr->symtree->n.sym;
2432 if (sym->as != NULL)
2433 expr->rank = sym->as->rank;
2435 /* Type of the expression is either the type of the symbol or the
2436 default type of the symbol. */
2439 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2441 if (sym->ts.type != BT_UNKNOWN)
2445 ts = gfc_get_default_type (sym->name, sym->ns);
2447 if (ts->type == BT_UNKNOWN)
2449 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2450 sym->name, &expr->where);
2461 /* Return true, if the symbol is an external procedure. */
2463 is_external_proc (gfc_symbol *sym)
2465 if (!sym->attr.dummy && !sym->attr.contained
2466 && !(sym->attr.intrinsic
2467 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2468 && sym->attr.proc != PROC_ST_FUNCTION
2469 && !sym->attr.proc_pointer
2470 && !sym->attr.use_assoc
2478 /* Figure out if a function reference is pure or not. Also set the name
2479 of the function for a potential error message. Return nonzero if the
2480 function is PURE, zero if not. */
2482 pure_stmt_function (gfc_expr *, gfc_symbol *);
2485 pure_function (gfc_expr *e, const char **name)
2491 if (e->symtree != NULL
2492 && e->symtree->n.sym != NULL
2493 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2494 return pure_stmt_function (e, e->symtree->n.sym);
2496 if (e->value.function.esym)
2498 pure = gfc_pure (e->value.function.esym);
2499 *name = e->value.function.esym->name;
2501 else if (e->value.function.isym)
2503 pure = e->value.function.isym->pure
2504 || e->value.function.isym->elemental;
2505 *name = e->value.function.isym->name;
2509 /* Implicit functions are not pure. */
2511 *name = e->value.function.name;
2519 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2520 int *f ATTRIBUTE_UNUSED)
2524 /* Don't bother recursing into other statement functions
2525 since they will be checked individually for purity. */
2526 if (e->expr_type != EXPR_FUNCTION
2528 || e->symtree->n.sym == sym
2529 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2532 return pure_function (e, &name) ? false : true;
2537 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2539 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2544 is_scalar_expr_ptr (gfc_expr *expr)
2546 gfc_try retval = SUCCESS;
2551 /* See if we have a gfc_ref, which means we have a substring, array
2552 reference, or a component. */
2553 if (expr->ref != NULL)
2556 while (ref->next != NULL)
2562 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2563 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2568 if (ref->u.ar.type == AR_ELEMENT)
2570 else if (ref->u.ar.type == AR_FULL)
2572 /* The user can give a full array if the array is of size 1. */
2573 if (ref->u.ar.as != NULL
2574 && ref->u.ar.as->rank == 1
2575 && ref->u.ar.as->type == AS_EXPLICIT
2576 && ref->u.ar.as->lower[0] != NULL
2577 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2578 && ref->u.ar.as->upper[0] != NULL
2579 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2581 /* If we have a character string, we need to check if
2582 its length is one. */
2583 if (expr->ts.type == BT_CHARACTER)
2585 if (expr->ts.u.cl == NULL
2586 || expr->ts.u.cl->length == NULL
2587 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2593 /* We have constant lower and upper bounds. If the
2594 difference between is 1, it can be considered a
2596 FIXME: Use gfc_dep_compare_expr instead. */
2597 start = (int) mpz_get_si
2598 (ref->u.ar.as->lower[0]->value.integer);
2599 end = (int) mpz_get_si
2600 (ref->u.ar.as->upper[0]->value.integer);
2601 if (end - start + 1 != 1)
2616 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2618 /* Character string. Make sure it's of length 1. */
2619 if (expr->ts.u.cl == NULL
2620 || expr->ts.u.cl->length == NULL
2621 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2624 else if (expr->rank != 0)
2631 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2632 and, in the case of c_associated, set the binding label based on
2636 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2637 gfc_symbol **new_sym)
2639 char name[GFC_MAX_SYMBOL_LEN + 1];
2640 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2641 int optional_arg = 0;
2642 gfc_try retval = SUCCESS;
2643 gfc_symbol *args_sym;
2644 gfc_typespec *arg_ts;
2645 symbol_attribute arg_attr;
2647 if (args->expr->expr_type == EXPR_CONSTANT
2648 || args->expr->expr_type == EXPR_OP
2649 || args->expr->expr_type == EXPR_NULL)
2651 gfc_error ("Argument to '%s' at %L is not a variable",
2652 sym->name, &(args->expr->where));
2656 args_sym = args->expr->symtree->n.sym;
2658 /* The typespec for the actual arg should be that stored in the expr
2659 and not necessarily that of the expr symbol (args_sym), because
2660 the actual expression could be a part-ref of the expr symbol. */
2661 arg_ts = &(args->expr->ts);
2662 arg_attr = gfc_expr_attr (args->expr);
2664 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2666 /* If the user gave two args then they are providing something for
2667 the optional arg (the second cptr). Therefore, set the name and
2668 binding label to the c_associated for two cptrs. Otherwise,
2669 set c_associated to expect one cptr. */
2673 sprintf (name, "%s_2", sym->name);
2674 sprintf (binding_label, "%s_2", sym->binding_label);
2680 sprintf (name, "%s_1", sym->name);
2681 sprintf (binding_label, "%s_1", sym->binding_label);
2685 /* Get a new symbol for the version of c_associated that
2687 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2689 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2690 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2692 sprintf (name, "%s", sym->name);
2693 sprintf (binding_label, "%s", sym->binding_label);
2695 /* Error check the call. */
2696 if (args->next != NULL)
2698 gfc_error_now ("More actual than formal arguments in '%s' "
2699 "call at %L", name, &(args->expr->where));
2702 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2707 /* Make sure we have either the target or pointer attribute. */
2708 if (!arg_attr.target && !arg_attr.pointer)
2710 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2711 "a TARGET or an associated pointer",
2713 sym->name, &(args->expr->where));
2717 if (gfc_is_coindexed (args->expr))
2719 gfc_error_now ("Coindexed argument not permitted"
2720 " in '%s' call at %L", name,
2721 &(args->expr->where));
2725 /* Follow references to make sure there are no array
2727 seen_section = false;
2729 for (ref=args->expr->ref; ref; ref = ref->next)
2731 if (ref->type == REF_ARRAY)
2733 if (ref->u.ar.type == AR_SECTION)
2734 seen_section = true;
2736 if (ref->u.ar.type != AR_ELEMENT)
2739 for (r = ref->next; r; r=r->next)
2740 if (r->type == REF_COMPONENT)
2742 gfc_error_now ("Array section not permitted"
2743 " in '%s' call at %L", name,
2744 &(args->expr->where));
2752 if (seen_section && retval == SUCCESS)
2753 gfc_warning ("Array section in '%s' call at %L", name,
2754 &(args->expr->where));
2756 /* See if we have interoperable type and type param. */
2757 if (verify_c_interop (arg_ts) == SUCCESS
2758 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2760 if (args_sym->attr.target == 1)
2762 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2763 has the target attribute and is interoperable. */
2764 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2765 allocatable variable that has the TARGET attribute and
2766 is not an array of zero size. */
2767 if (args_sym->attr.allocatable == 1)
2769 if (args_sym->attr.dimension != 0
2770 && (args_sym->as && args_sym->as->rank == 0))
2772 gfc_error_now ("Allocatable variable '%s' used as a "
2773 "parameter to '%s' at %L must not be "
2774 "an array of zero size",
2775 args_sym->name, sym->name,
2776 &(args->expr->where));
2782 /* A non-allocatable target variable with C
2783 interoperable type and type parameters must be
2785 if (args_sym && args_sym->attr.dimension)
2787 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2789 gfc_error ("Assumed-shape array '%s' at %L "
2790 "cannot be an argument to the "
2791 "procedure '%s' because "
2792 "it is not C interoperable",
2794 &(args->expr->where), sym->name);
2797 else if (args_sym->as->type == AS_DEFERRED)
2799 gfc_error ("Deferred-shape array '%s' at %L "
2800 "cannot be an argument to the "
2801 "procedure '%s' because "
2802 "it is not C interoperable",
2804 &(args->expr->where), sym->name);
2809 /* Make sure it's not a character string. Arrays of
2810 any type should be ok if the variable is of a C
2811 interoperable type. */
2812 if (arg_ts->type == BT_CHARACTER)
2813 if (arg_ts->u.cl != NULL
2814 && (arg_ts->u.cl->length == NULL
2815 || arg_ts->u.cl->length->expr_type
2818 (arg_ts->u.cl->length->value.integer, 1)
2820 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2822 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2823 "at %L must have a length of 1",
2824 args_sym->name, sym->name,
2825 &(args->expr->where));
2830 else if (arg_attr.pointer
2831 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2833 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2835 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2836 "associated scalar POINTER", args_sym->name,
2837 sym->name, &(args->expr->where));
2843 /* The parameter is not required to be C interoperable. If it
2844 is not C interoperable, it must be a nonpolymorphic scalar
2845 with no length type parameters. It still must have either
2846 the pointer or target attribute, and it can be
2847 allocatable (but must be allocated when c_loc is called). */
2848 if (args->expr->rank != 0
2849 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2851 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2852 "scalar", args_sym->name, sym->name,
2853 &(args->expr->where));
2856 else if (arg_ts->type == BT_CHARACTER
2857 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2859 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2860 "%L must have a length of 1",
2861 args_sym->name, sym->name,
2862 &(args->expr->where));
2865 else if (arg_ts->type == BT_CLASS)
2867 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2868 "polymorphic", args_sym->name, sym->name,
2869 &(args->expr->where));
2874 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2876 if (args_sym->attr.flavor != FL_PROCEDURE)
2878 /* TODO: Update this error message to allow for procedure
2879 pointers once they are implemented. */
2880 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2882 args_sym->name, sym->name,
2883 &(args->expr->where));
2886 else if (args_sym->attr.is_bind_c != 1)
2888 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2890 args_sym->name, sym->name,
2891 &(args->expr->where));
2896 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2901 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2902 "iso_c_binding function: '%s'!\n", sym->name);
2909 /* Resolve a function call, which means resolving the arguments, then figuring
2910 out which entity the name refers to. */
2913 resolve_function (gfc_expr *expr)
2915 gfc_actual_arglist *arg;
2920 procedure_type p = PROC_INTRINSIC;
2921 bool no_formal_args;
2925 sym = expr->symtree->n.sym;
2927 /* If this is a procedure pointer component, it has already been resolved. */
2928 if (gfc_is_proc_ptr_comp (expr, NULL))
2931 if (sym && sym->attr.intrinsic
2932 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2935 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2937 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2941 /* If this ia a deferred TBP with an abstract interface (which may
2942 of course be referenced), expr->value.function.esym will be set. */
2943 if (sym && sym->attr.abstract && !expr->value.function.esym)
2945 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2946 sym->name, &expr->where);
2950 /* Switch off assumed size checking and do this again for certain kinds
2951 of procedure, once the procedure itself is resolved. */
2952 need_full_assumed_size++;
2954 if (expr->symtree && expr->symtree->n.sym)
2955 p = expr->symtree->n.sym->attr.proc;
2957 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2958 inquiry_argument = true;
2959 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2961 if (resolve_actual_arglist (expr->value.function.actual,
2962 p, no_formal_args) == FAILURE)
2964 inquiry_argument = false;
2968 inquiry_argument = false;
2970 /* Need to setup the call to the correct c_associated, depending on
2971 the number of cptrs to user gives to compare. */
2972 if (sym && sym->attr.is_iso_c == 1)
2974 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2978 /* Get the symtree for the new symbol (resolved func).
2979 the old one will be freed later, when it's no longer used. */
2980 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2983 /* Resume assumed_size checking. */
2984 need_full_assumed_size--;
2986 /* If the procedure is external, check for usage. */
2987 if (sym && is_external_proc (sym))
2988 resolve_global_procedure (sym, &expr->where,
2989 &expr->value.function.actual, 0);
2991 if (sym && sym->ts.type == BT_CHARACTER
2993 && sym->ts.u.cl->length == NULL
2995 && !sym->ts.deferred
2996 && expr->value.function.esym == NULL
2997 && !sym->attr.contained)
2999 /* Internal procedures are taken care of in resolve_contained_fntype. */
3000 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3001 "be used at %L since it is not a dummy argument",
3002 sym->name, &expr->where);
3006 /* See if function is already resolved. */
3008 if (expr->value.function.name != NULL)
3010 if (expr->ts.type == BT_UNKNOWN)
3016 /* Apply the rules of section 14.1.2. */
3018 switch (procedure_kind (sym))
3021 t = resolve_generic_f (expr);
3024 case PTYPE_SPECIFIC:
3025 t = resolve_specific_f (expr);
3029 t = resolve_unknown_f (expr);
3033 gfc_internal_error ("resolve_function(): bad function type");
3037 /* If the expression is still a function (it might have simplified),
3038 then we check to see if we are calling an elemental function. */
3040 if (expr->expr_type != EXPR_FUNCTION)
3043 temp = need_full_assumed_size;
3044 need_full_assumed_size = 0;
3046 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3049 if (omp_workshare_flag
3050 && expr->value.function.esym
3051 && ! gfc_elemental (expr->value.function.esym))
3053 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3054 "in WORKSHARE construct", expr->value.function.esym->name,
3059 #define GENERIC_ID expr->value.function.isym->id
3060 else if (expr->value.function.actual != NULL
3061 && expr->value.function.isym != NULL
3062 && GENERIC_ID != GFC_ISYM_LBOUND
3063 && GENERIC_ID != GFC_ISYM_LEN
3064 && GENERIC_ID != GFC_ISYM_LOC
3065 && GENERIC_ID != GFC_ISYM_PRESENT)
3067 /* Array intrinsics must also have the last upper bound of an
3068 assumed size array argument. UBOUND and SIZE have to be
3069 excluded from the check if the second argument is anything
3072 for (arg = expr->value.function.actual; arg; arg = arg->next)
3074 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3075 && arg->next != NULL && arg->next->expr)
3077 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3080 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3083 if ((int)mpz_get_si (arg->next->expr->value.integer)
3088 if (arg->expr != NULL
3089 && arg->expr->rank > 0
3090 && resolve_assumed_size_actual (arg->expr))
3096 need_full_assumed_size = temp;
3099 if (!pure_function (expr, &name) && name)
3103 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3104 "FORALL %s", name, &expr->where,
3105 forall_flag == 2 ? "mask" : "block");
3108 else if (gfc_pure (NULL))
3110 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3111 "procedure within a PURE procedure", name, &expr->where);
3116 if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
3117 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3119 /* Functions without the RECURSIVE attribution are not allowed to
3120 * call themselves. */
3121 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3124 esym = expr->value.function.esym;
3126 if (is_illegal_recursion (esym, gfc_current_ns))
3128 if (esym->attr.entry && esym->ns->entries)
3129 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3130 " function '%s' is not RECURSIVE",
3131 esym->name, &expr->where, esym->ns->entries->sym->name);
3133 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3134 " is not RECURSIVE", esym->name, &expr->where);
3140 /* Character lengths of use associated functions may contains references to
3141 symbols not referenced from the current program unit otherwise. Make sure
3142 those symbols are marked as referenced. */
3144 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3145 && expr->value.function.esym->attr.use_assoc)
3147 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3150 /* Make sure that the expression has a typespec that works. */
3151 if (expr->ts.type == BT_UNKNOWN)
3153 if (expr->symtree->n.sym->result
3154 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3155 && !expr->symtree->n.sym->result->attr.proc_pointer)
3156 expr->ts = expr->symtree->n.sym->result->ts;
3163 /************* Subroutine resolution *************/
3166 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3172 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3173 sym->name, &c->loc);
3174 else if (gfc_pure (NULL))
3175 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3181 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3185 if (sym->attr.generic)
3187 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3190 c->resolved_sym = s;
3191 pure_subroutine (c, s);
3195 /* TODO: Need to search for elemental references in generic interface. */
3198 if (sym->attr.intrinsic)
3199 return gfc_intrinsic_sub_interface (c, 0);
3206 resolve_generic_s (gfc_code *c)
3211 sym = c->symtree->n.sym;
3215 m = resolve_generic_s0 (c, sym);
3218 else if (m == MATCH_ERROR)
3222 if (sym->ns->parent == NULL)
3224 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3228 if (!generic_sym (sym))
3232 /* Last ditch attempt. See if the reference is to an intrinsic
3233 that possesses a matching interface. 14.1.2.4 */
3234 sym = c->symtree->n.sym;
3236 if (!gfc_is_intrinsic (sym, 1, c->loc))
3238 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3239 sym->name, &c->loc);
3243 m = gfc_intrinsic_sub_interface (c, 0);
3247 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3248 "intrinsic subroutine interface", sym->name, &c->loc);
3254 /* Set the name and binding label of the subroutine symbol in the call
3255 expression represented by 'c' to include the type and kind of the
3256 second parameter. This function is for resolving the appropriate
3257 version of c_f_pointer() and c_f_procpointer(). For example, a
3258 call to c_f_pointer() for a default integer pointer could have a
3259 name of c_f_pointer_i4. If no second arg exists, which is an error
3260 for these two functions, it defaults to the generic symbol's name
3261 and binding label. */
3264 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3265 char *name, char *binding_label)
3267 gfc_expr *arg = NULL;
3271 /* The second arg of c_f_pointer and c_f_procpointer determines
3272 the type and kind for the procedure name. */
3273 arg = c->ext.actual->next->expr;
3277 /* Set up the name to have the given symbol's name,
3278 plus the type and kind. */
3279 /* a derived type is marked with the type letter 'u' */
3280 if (arg->ts.type == BT_DERIVED)
3283 kind = 0; /* set the kind as 0 for now */
3287 type = gfc_type_letter (arg->ts.type);
3288 kind = arg->ts.kind;
3291 if (arg->ts.type == BT_CHARACTER)
3292 /* Kind info for character strings not needed. */
3295 sprintf (name, "%s_%c%d", sym->name, type, kind);
3296 /* Set up the binding label as the given symbol's label plus
3297 the type and kind. */
3298 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3302 /* If the second arg is missing, set the name and label as
3303 was, cause it should at least be found, and the missing
3304 arg error will be caught by compare_parameters(). */
3305 sprintf (name, "%s", sym->name);
3306 sprintf (binding_label, "%s", sym->binding_label);
3313 /* Resolve a generic version of the iso_c_binding procedure given
3314 (sym) to the specific one based on the type and kind of the
3315 argument(s). Currently, this function resolves c_f_pointer() and
3316 c_f_procpointer based on the type and kind of the second argument
3317 (FPTR). Other iso_c_binding procedures aren't specially handled.
3318 Upon successfully exiting, c->resolved_sym will hold the resolved
3319 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3323 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3325 gfc_symbol *new_sym;
3326 /* this is fine, since we know the names won't use the max */
3327 char name[GFC_MAX_SYMBOL_LEN + 1];
3328 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3329 /* default to success; will override if find error */
3330 match m = MATCH_YES;
3332 /* Make sure the actual arguments are in the necessary order (based on the
3333 formal args) before resolving. */
3334 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3336 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3337 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3339 set_name_and_label (c, sym, name, binding_label);
3341 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3343 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3345 /* Make sure we got a third arg if the second arg has non-zero
3346 rank. We must also check that the type and rank are
3347 correct since we short-circuit this check in
3348 gfc_procedure_use() (called above to sort actual args). */
3349 if (c->ext.actual->next->expr->rank != 0)
3351 if(c->ext.actual->next->next == NULL
3352 || c->ext.actual->next->next->expr == NULL)
3355 gfc_error ("Missing SHAPE parameter for call to %s "
3356 "at %L", sym->name, &(c->loc));
3358 else if (c->ext.actual->next->next->expr->ts.type
3360 || c->ext.actual->next->next->expr->rank != 1)
3363 gfc_error ("SHAPE parameter for call to %s at %L must "
3364 "be a rank 1 INTEGER array", sym->name,
3371 if (m != MATCH_ERROR)
3373 /* the 1 means to add the optional arg to formal list */
3374 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3376 /* for error reporting, say it's declared where the original was */
3377 new_sym->declared_at = sym->declared_at;
3382 /* no differences for c_loc or c_funloc */
3386 /* set the resolved symbol */
3387 if (m != MATCH_ERROR)
3388 c->resolved_sym = new_sym;
3390 c->resolved_sym = sym;
3396 /* Resolve a subroutine call known to be specific. */
3399 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3403 if(sym->attr.is_iso_c)
3405 m = gfc_iso_c_sub_interface (c,sym);
3409 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3411 if (sym->attr.dummy)
3413 sym->attr.proc = PROC_DUMMY;
3417 sym->attr.proc = PROC_EXTERNAL;
3421 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3424 if (sym->attr.intrinsic)
3426 m = gfc_intrinsic_sub_interface (c, 1);
3430 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3431 "with an intrinsic", sym->name, &c->loc);
3439 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3441 c->resolved_sym = sym;
3442 pure_subroutine (c, sym);
3449 resolve_specific_s (gfc_code *c)
3454 sym = c->symtree->n.sym;
3458 m = resolve_specific_s0 (c, sym);
3461 if (m == MATCH_ERROR)
3464 if (sym->ns->parent == NULL)
3467 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3473 sym = c->symtree->n.sym;
3474 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3475 sym->name, &c->loc);
3481 /* Resolve a subroutine call not known to be generic nor specific. */
3484 resolve_unknown_s (gfc_code *c)
3488 sym = c->symtree->n.sym;
3490 if (sym->attr.dummy)
3492 sym->attr.proc = PROC_DUMMY;
3496 /* See if we have an intrinsic function reference. */
3498 if (gfc_is_intrinsic (sym, 1, c->loc))
3500 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3505 /* The reference is to an external name. */
3508 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3510 c->resolved_sym = sym;
3512 pure_subroutine (c, sym);
3518 /* Resolve a subroutine call. Although it was tempting to use the same code
3519 for functions, subroutines and functions are stored differently and this
3520 makes things awkward. */
3523 resolve_call (gfc_code *c)
3526 procedure_type ptype = PROC_INTRINSIC;
3527 gfc_symbol *csym, *sym;
3528 bool no_formal_args;
3530 csym = c->symtree ? c->symtree->n.sym : NULL;
3532 if (csym && csym->ts.type != BT_UNKNOWN)
3534 gfc_error ("'%s' at %L has a type, which is not consistent with "
3535 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3539 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3542 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3543 sym = st ? st->n.sym : NULL;
3544 if (sym && csym != sym
3545 && sym->ns == gfc_current_ns
3546 && sym->attr.flavor == FL_PROCEDURE
3547 && sym->attr.contained)
3550 if (csym->attr.generic)
3551 c->symtree->n.sym = sym;
3554 csym = c->symtree->n.sym;
3558 /* If this ia a deferred TBP with an abstract interface
3559 (which may of course be referenced), c->expr1 will be set. */
3560 if (csym && csym->attr.abstract && !c->expr1)
3562 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3563 csym->name, &c->loc);
3567 /* Subroutines without the RECURSIVE attribution are not allowed to
3568 * call themselves. */
3569 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3571 if (csym->attr.entry && csym->ns->entries)
3572 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3573 " subroutine '%s' is not RECURSIVE",
3574 csym->name, &c->loc, csym->ns->entries->sym->name);
3576 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3577 " is not RECURSIVE", csym->name, &c->loc);
3582 /* Switch off assumed size checking and do this again for certain kinds
3583 of procedure, once the procedure itself is resolved. */
3584 need_full_assumed_size++;
3587 ptype = csym->attr.proc;
3589 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3590 if (resolve_actual_arglist (c->ext.actual, ptype,
3591 no_formal_args) == FAILURE)
3594 /* Resume assumed_size checking. */
3595 need_full_assumed_size--;
3597 /* If external, check for usage. */
3598 if (csym && is_external_proc (csym))
3599 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3602 if (c->resolved_sym == NULL)
3604 c->resolved_isym = NULL;
3605 switch (procedure_kind (csym))
3608 t = resolve_generic_s (c);
3611 case PTYPE_SPECIFIC:
3612 t = resolve_specific_s (c);
3616 t = resolve_unknown_s (c);
3620 gfc_internal_error ("resolve_subroutine(): bad function type");
3624 /* Some checks of elemental subroutine actual arguments. */
3625 if (resolve_elemental_actual (NULL, c) == FAILURE)
3632 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3633 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3634 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3635 if their shapes do not match. If either op1->shape or op2->shape is
3636 NULL, return SUCCESS. */
3639 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3646 if (op1->shape != NULL && op2->shape != NULL)
3648 for (i = 0; i < op1->rank; i++)
3650 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3652 gfc_error ("Shapes for operands at %L and %L are not conformable",
3653 &op1->where, &op2->where);
3664 /* Resolve an operator expression node. This can involve replacing the
3665 operation with a user defined function call. */
3668 resolve_operator (gfc_expr *e)
3670 gfc_expr *op1, *op2;
3672 bool dual_locus_error;
3675 /* Resolve all subnodes-- give them types. */
3677 switch (e->value.op.op)
3680 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3683 /* Fall through... */
3686 case INTRINSIC_UPLUS:
3687 case INTRINSIC_UMINUS:
3688 case INTRINSIC_PARENTHESES:
3689 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3694 /* Typecheck the new node. */
3696 op1 = e->value.op.op1;
3697 op2 = e->value.op.op2;
3698 dual_locus_error = false;
3700 if ((op1 && op1->expr_type == EXPR_NULL)
3701 || (op2 && op2->expr_type == EXPR_NULL))
3703 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3707 switch (e->value.op.op)
3709 case INTRINSIC_UPLUS:
3710 case INTRINSIC_UMINUS:
3711 if (op1->ts.type == BT_INTEGER
3712 || op1->ts.type == BT_REAL
3713 || op1->ts.type == BT_COMPLEX)
3719 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3720 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3723 case INTRINSIC_PLUS:
3724 case INTRINSIC_MINUS:
3725 case INTRINSIC_TIMES:
3726 case INTRINSIC_DIVIDE:
3727 case INTRINSIC_POWER:
3728 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3730 gfc_type_convert_binary (e, 1);
3735 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3736 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3737 gfc_typename (&op2->ts));
3740 case INTRINSIC_CONCAT:
3741 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3742 && op1->ts.kind == op2->ts.kind)
3744 e->ts.type = BT_CHARACTER;
3745 e->ts.kind = op1->ts.kind;
3750 _("Operands of string concatenation operator at %%L are %s/%s"),
3751 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3757 case INTRINSIC_NEQV:
3758 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3760 e->ts.type = BT_LOGICAL;
3761 e->ts.kind = gfc_kind_max (op1, op2);
3762 if (op1->ts.kind < e->ts.kind)
3763 gfc_convert_type (op1, &e->ts, 2);
3764 else if (op2->ts.kind < e->ts.kind)
3765 gfc_convert_type (op2, &e->ts, 2);
3769 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3770 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3771 gfc_typename (&op2->ts));
3776 if (op1->ts.type == BT_LOGICAL)
3778 e->ts.type = BT_LOGICAL;
3779 e->ts.kind = op1->ts.kind;
3783 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3784 gfc_typename (&op1->ts));
3788 case INTRINSIC_GT_OS:
3790 case INTRINSIC_GE_OS:
3792 case INTRINSIC_LT_OS:
3794 case INTRINSIC_LE_OS:
3795 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3797 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3801 /* Fall through... */
3804 case INTRINSIC_EQ_OS:
3806 case INTRINSIC_NE_OS:
3807 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3808 && op1->ts.kind == op2->ts.kind)
3810 e->ts.type = BT_LOGICAL;
3811 e->ts.kind = gfc_default_logical_kind;
3815 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3817 gfc_type_convert_binary (e, 1);
3819 e->ts.type = BT_LOGICAL;
3820 e->ts.kind = gfc_default_logical_kind;
3824 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3826 _("Logicals at %%L must be compared with %s instead of %s"),
3827 (e->value.op.op == INTRINSIC_EQ
3828 || e->value.op.op == INTRINSIC_EQ_OS)
3829 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3832 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3833 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3834 gfc_typename (&op2->ts));
3838 case INTRINSIC_USER:
3839 if (e->value.op.uop->op == NULL)
3840 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3841 else if (op2 == NULL)
3842 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3843 e->value.op.uop->name, gfc_typename (&op1->ts));
3846 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3847 e->value.op.uop->name, gfc_typename (&op1->ts),
3848 gfc_typename (&op2->ts));
3849 e->value.op.uop->op->sym->attr.referenced = 1;
3854 case INTRINSIC_PARENTHESES:
3856 if (e->ts.type == BT_CHARACTER)
3857 e->ts.u.cl = op1->ts.u.cl;
3861 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3864 /* Deal with arrayness of an operand through an operator. */
3868 switch (e->value.op.op)
3870 case INTRINSIC_PLUS:
3871 case INTRINSIC_MINUS:
3872 case INTRINSIC_TIMES:
3873 case INTRINSIC_DIVIDE:
3874 case INTRINSIC_POWER:
3875 case INTRINSIC_CONCAT:
3879 case INTRINSIC_NEQV:
3881 case INTRINSIC_EQ_OS:
3883 case INTRINSIC_NE_OS:
3885 case INTRINSIC_GT_OS:
3887 case INTRINSIC_GE_OS:
3889 case INTRINSIC_LT_OS:
3891 case INTRINSIC_LE_OS:
3893 if (op1->rank == 0 && op2->rank == 0)
3896 if (op1->rank == 0 && op2->rank != 0)
3898 e->rank = op2->rank;
3900 if (e->shape == NULL)
3901 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3904 if (op1->rank != 0 && op2->rank == 0)
3906 e->rank = op1->rank;
3908 if (e->shape == NULL)
3909 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3912 if (op1->rank != 0 && op2->rank != 0)
3914 if (op1->rank == op2->rank)
3916 e->rank = op1->rank;
3917 if (e->shape == NULL)
3919 t = compare_shapes (op1, op2);
3923 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3928 /* Allow higher level expressions to work. */
3931 /* Try user-defined operators, and otherwise throw an error. */
3932 dual_locus_error = true;
3934 _("Inconsistent ranks for operator at %%L and %%L"));
3941 case INTRINSIC_PARENTHESES:
3943 case INTRINSIC_UPLUS:
3944 case INTRINSIC_UMINUS:
3945 /* Simply copy arrayness attribute */
3946 e->rank = op1->rank;
3948 if (e->shape == NULL)
3949 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3957 /* Attempt to simplify the expression. */
3960 t = gfc_simplify_expr (e, 0);
3961 /* Some calls do not succeed in simplification and return FAILURE
3962 even though there is no error; e.g. variable references to
3963 PARAMETER arrays. */
3964 if (!gfc_is_constant_expr (e))
3973 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3980 if (dual_locus_error)
3981 gfc_error (msg, &op1->where, &op2->where);
3983 gfc_error (msg, &e->where);
3989 /************** Array resolution subroutines **************/
3992 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3995 /* Compare two integer expressions. */
3998 compare_bound (gfc_expr *a, gfc_expr *b)
4002 if (a == NULL || a->expr_type != EXPR_CONSTANT
4003 || b == NULL || b->expr_type != EXPR_CONSTANT)
4006 /* If either of the types isn't INTEGER, we must have
4007 raised an error earlier. */
4009 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4012 i = mpz_cmp (a->value.integer, b->value.integer);
4022 /* Compare an integer expression with an integer. */
4025 compare_bound_int (gfc_expr *a, int b)
4029 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4032 if (a->ts.type != BT_INTEGER)
4033 gfc_internal_error ("compare_bound_int(): Bad expression");
4035 i = mpz_cmp_si (a->value.integer, b);
4045 /* Compare an integer expression with a mpz_t. */
4048 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4052 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4055 if (a->ts.type != BT_INTEGER)
4056 gfc_internal_error ("compare_bound_int(): Bad expression");
4058 i = mpz_cmp (a->value.integer, b);
4068 /* Compute the last value of a sequence given by a triplet.
4069 Return 0 if it wasn't able to compute the last value, or if the
4070 sequence if empty, and 1 otherwise. */
4073 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4074 gfc_expr *stride, mpz_t last)
4078 if (start == NULL || start->expr_type != EXPR_CONSTANT
4079 || end == NULL || end->expr_type != EXPR_CONSTANT
4080 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4083 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4084 || (stride != NULL && stride->ts.type != BT_INTEGER))
4087 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4089 if (compare_bound (start, end) == CMP_GT)
4091 mpz_set (last, end->value.integer);
4095 if (compare_bound_int (stride, 0) == CMP_GT)
4097 /* Stride is positive */
4098 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4103 /* Stride is negative */
4104 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4109 mpz_sub (rem, end->value.integer, start->value.integer);
4110 mpz_tdiv_r (rem, rem, stride->value.integer);
4111 mpz_sub (last, end->value.integer, rem);
4118 /* Compare a single dimension of an array reference to the array
4122 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4126 if (ar->dimen_type[i] == DIMEN_STAR)
4128 gcc_assert (ar->stride[i] == NULL);
4129 /* This implies [*] as [*:] and [*:3] are not possible. */
4130 if (ar->start[i] == NULL)
4132 gcc_assert (ar->end[i] == NULL);
4137 /* Given start, end and stride values, calculate the minimum and
4138 maximum referenced indexes. */
4140 switch (ar->dimen_type[i])
4147 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4150 gfc_warning ("Array reference at %L is out of bounds "
4151 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4152 mpz_get_si (ar->start[i]->value.integer),
4153 mpz_get_si (as->lower[i]->value.integer), i+1);
4155 gfc_warning ("Array reference at %L is out of bounds "
4156 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4157 mpz_get_si (ar->start[i]->value.integer),
4158 mpz_get_si (as->lower[i]->value.integer),
4162 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4165 gfc_warning ("Array reference at %L is out of bounds "
4166 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4167 mpz_get_si (ar->start[i]->value.integer),
4168 mpz_get_si (as->upper[i]->value.integer), i+1);
4170 gfc_warning ("Array reference at %L is out of bounds "
4171 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4172 mpz_get_si (ar->start[i]->value.integer),
4173 mpz_get_si (as->upper[i]->value.integer),
4182 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4183 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4185 comparison comp_start_end = compare_bound (AR_START, AR_END);
4187 /* Check for zero stride, which is not allowed. */
4188 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4190 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4194 /* if start == len || (stride > 0 && start < len)
4195 || (stride < 0 && start > len),
4196 then the array section contains at least one element. In this
4197 case, there is an out-of-bounds access if
4198 (start < lower || start > upper). */
4199 if (compare_bound (AR_START, AR_END) == CMP_EQ
4200 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4201 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4202 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4203 && comp_start_end == CMP_GT))
4205 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4207 gfc_warning ("Lower array reference at %L is out of bounds "
4208 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4209 mpz_get_si (AR_START->value.integer),
4210 mpz_get_si (as->lower[i]->value.integer), i+1);
4213 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4215 gfc_warning ("Lower array reference at %L is out of bounds "
4216 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4217 mpz_get_si (AR_START->value.integer),
4218 mpz_get_si (as->upper[i]->value.integer), i+1);
4223 /* If we can compute the highest index of the array section,
4224 then it also has to be between lower and upper. */
4225 mpz_init (last_value);
4226 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4229 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4231 gfc_warning ("Upper array reference at %L is out of bounds "
4232 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4233 mpz_get_si (last_value),
4234 mpz_get_si (as->lower[i]->value.integer), i+1);
4235 mpz_clear (last_value);
4238 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4240 gfc_warning ("Upper array reference at %L is out of bounds "
4241 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4242 mpz_get_si (last_value),
4243 mpz_get_si (as->upper[i]->value.integer), i+1);
4244 mpz_clear (last_value);
4248 mpz_clear (last_value);
4256 gfc_internal_error ("check_dimension(): Bad array reference");
4263 /* Compare an array reference with an array specification. */
4266 compare_spec_to_ref (gfc_array_ref *ar)
4273 /* TODO: Full array sections are only allowed as actual parameters. */
4274 if (as->type == AS_ASSUMED_SIZE
4275 && (/*ar->type == AR_FULL
4276 ||*/ (ar->type == AR_SECTION
4277 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4279 gfc_error ("Rightmost upper bound of assumed size array section "
4280 "not specified at %L", &ar->where);
4284 if (ar->type == AR_FULL)
4287 if (as->rank != ar->dimen)
4289 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4290 &ar->where, ar->dimen, as->rank);
4294 /* ar->codimen == 0 is a local array. */
4295 if (as->corank != ar->codimen && ar->codimen != 0)
4297 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4298 &ar->where, ar->codimen, as->corank);
4302 for (i = 0; i < as->rank; i++)
4303 if (check_dimension (i, ar, as) == FAILURE)
4306 /* Local access has no coarray spec. */
4307 if (ar->codimen != 0)
4308 for (i = as->rank; i < as->rank + as->corank; i++)
4310 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4312 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4313 i + 1 - as->rank, &ar->where);
4316 if (check_dimension (i, ar, as) == FAILURE)
4324 /* Resolve one part of an array index. */
4327 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4328 int force_index_integer_kind)
4335 if (gfc_resolve_expr (index) == FAILURE)
4338 if (check_scalar && index->rank != 0)
4340 gfc_error ("Array index at %L must be scalar", &index->where);
4344 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4346 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4347 &index->where, gfc_basic_typename (index->ts.type));
4351 if (index->ts.type == BT_REAL)
4352 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4353 &index->where) == FAILURE)
4356 if ((index->ts.kind != gfc_index_integer_kind
4357 && force_index_integer_kind)
4358 || index->ts.type != BT_INTEGER)
4361 ts.type = BT_INTEGER;
4362 ts.kind = gfc_index_integer_kind;
4364 gfc_convert_type_warn (index, &ts, 2, 0);
4370 /* Resolve one part of an array index. */
4373 gfc_resolve_index (gfc_expr *index, int check_scalar)
4375 return gfc_resolve_index_1 (index, check_scalar, 1);
4378 /* Resolve a dim argument to an intrinsic function. */
4381 gfc_resolve_dim_arg (gfc_expr *dim)
4386 if (gfc_resolve_expr (dim) == FAILURE)
4391 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4396 if (dim->ts.type != BT_INTEGER)
4398 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4402 if (dim->ts.kind != gfc_index_integer_kind)
4407 ts.type = BT_INTEGER;
4408 ts.kind = gfc_index_integer_kind;
4410 gfc_convert_type_warn (dim, &ts, 2, 0);
4416 /* Given an expression that contains array references, update those array
4417 references to point to the right array specifications. While this is
4418 filled in during matching, this information is difficult to save and load
4419 in a module, so we take care of it here.
4421 The idea here is that the original array reference comes from the
4422 base symbol. We traverse the list of reference structures, setting
4423 the stored reference to references. Component references can
4424 provide an additional array specification. */
4427 find_array_spec (gfc_expr *e)
4431 gfc_symbol *derived;
4434 if (e->symtree->n.sym->ts.type == BT_CLASS)
4435 as = CLASS_DATA (e->symtree->n.sym)->as;
4437 as = e->symtree->n.sym->as;
4440 for (ref = e->ref; ref; ref = ref->next)
4445 gfc_internal_error ("find_array_spec(): Missing spec");
4452 if (derived == NULL)
4453 derived = e->symtree->n.sym->ts.u.derived;
4455 if (derived->attr.is_class)
4456 derived = derived->components->ts.u.derived;
4458 c = derived->components;
4460 for (; c; c = c->next)
4461 if (c == ref->u.c.component)
4463 /* Track the sequence of component references. */
4464 if (c->ts.type == BT_DERIVED)
4465 derived = c->ts.u.derived;
4470 gfc_internal_error ("find_array_spec(): Component not found");
4472 if (c->attr.dimension)
4475 gfc_internal_error ("find_array_spec(): unused as(1)");
4486 gfc_internal_error ("find_array_spec(): unused as(2)");
4490 /* Resolve an array reference. */
4493 resolve_array_ref (gfc_array_ref *ar)
4495 int i, check_scalar;
4498 for (i = 0; i < ar->dimen + ar->codimen; i++)
4500 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4502 /* Do not force gfc_index_integer_kind for the start. We can
4503 do fine with any integer kind. This avoids temporary arrays
4504 created for indexing with a vector. */
4505 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4507 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4509 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4514 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4518 ar->dimen_type[i] = DIMEN_ELEMENT;
4522 ar->dimen_type[i] = DIMEN_VECTOR;
4523 if (e->expr_type == EXPR_VARIABLE
4524 && e->symtree->n.sym->ts.type == BT_DERIVED)
4525 ar->start[i] = gfc_get_parentheses (e);
4529 gfc_error ("Array index at %L is an array of rank %d",
4530 &ar->c_where[i], e->rank);
4534 /* Fill in the upper bound, which may be lower than the
4535 specified one for something like a(2:10:5), which is
4536 identical to a(2:7:5). Only relevant for strides not equal
4538 if (ar->dimen_type[i] == DIMEN_RANGE
4539 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4540 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4544 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4546 if (ar->end[i] == NULL)
4549 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4551 mpz_set (ar->end[i]->value.integer, end);
4553 else if (ar->end[i]->ts.type == BT_INTEGER
4554 && ar->end[i]->expr_type == EXPR_CONSTANT)
4556 mpz_set (ar->end[i]->value.integer, end);
4567 if (ar->type == AR_FULL && ar->as->rank == 0)
4568 ar->type = AR_ELEMENT;
4570 /* If the reference type is unknown, figure out what kind it is. */
4572 if (ar->type == AR_UNKNOWN)
4574 ar->type = AR_ELEMENT;
4575 for (i = 0; i < ar->dimen; i++)
4576 if (ar->dimen_type[i] == DIMEN_RANGE
4577 || ar->dimen_type[i] == DIMEN_VECTOR)
4579 ar->type = AR_SECTION;
4584 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4592 resolve_substring (gfc_ref *ref)
4594 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4596 if (ref->u.ss.start != NULL)
4598 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4601 if (ref->u.ss.start->ts.type != BT_INTEGER)
4603 gfc_error ("Substring start index at %L must be of type INTEGER",
4604 &ref->u.ss.start->where);
4608 if (ref->u.ss.start->rank != 0)
4610 gfc_error ("Substring start index at %L must be scalar",
4611 &ref->u.ss.start->where);
4615 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4616 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4617 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4619 gfc_error ("Substring start index at %L is less than one",
4620 &ref->u.ss.start->where);
4625 if (ref->u.ss.end != NULL)
4627 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4630 if (ref->u.ss.end->ts.type != BT_INTEGER)
4632 gfc_error ("Substring end index at %L must be of type INTEGER",
4633 &ref->u.ss.end->where);
4637 if (ref->u.ss.end->rank != 0)
4639 gfc_error ("Substring end index at %L must be scalar",
4640 &ref->u.ss.end->where);
4644 if (ref->u.ss.length != NULL
4645 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4646 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4647 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4649 gfc_error ("Substring end index at %L exceeds the string length",
4650 &ref->u.ss.start->where);
4654 if (compare_bound_mpz_t (ref->u.ss.end,
4655 gfc_integer_kinds[k].huge) == CMP_GT
4656 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4657 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4659 gfc_error ("Substring end index at %L is too large",
4660 &ref->u.ss.end->where);
4669 /* This function supplies missing substring charlens. */
4672 gfc_resolve_substring_charlen (gfc_expr *e)
4675 gfc_expr *start, *end;
4677 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4678 if (char_ref->type == REF_SUBSTRING)
4684 gcc_assert (char_ref->next == NULL);
4688 if (e->ts.u.cl->length)
4689 gfc_free_expr (e->ts.u.cl->length);
4690 else if (e->expr_type == EXPR_VARIABLE
4691 && e->symtree->n.sym->attr.dummy)
4695 e->ts.type = BT_CHARACTER;
4696 e->ts.kind = gfc_default_character_kind;
4699 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4701 if (char_ref->u.ss.start)
4702 start = gfc_copy_expr (char_ref->u.ss.start);
4704 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4706 if (char_ref->u.ss.end)
4707 end = gfc_copy_expr (char_ref->u.ss.end);
4708 else if (e->expr_type == EXPR_VARIABLE)
4709 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4716 /* Length = (end - start +1). */
4717 e->ts.u.cl->length = gfc_subtract (end, start);
4718 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4719 gfc_get_int_expr (gfc_default_integer_kind,
4722 e->ts.u.cl->length->ts.type = BT_INTEGER;
4723 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4725 /* Make sure that the length is simplified. */
4726 gfc_simplify_expr (e->ts.u.cl->length, 1);
4727 gfc_resolve_expr (e->ts.u.cl->length);
4731 /* Resolve subtype references. */
4734 resolve_ref (gfc_expr *expr)
4736 int current_part_dimension, n_components, seen_part_dimension;
4739 for (ref = expr->ref; ref; ref = ref->next)
4740 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4742 find_array_spec (expr);
4746 for (ref = expr->ref; ref; ref = ref->next)
4750 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4758 resolve_substring (ref);
4762 /* Check constraints on part references. */
4764 current_part_dimension = 0;
4765 seen_part_dimension = 0;
4768 for (ref = expr->ref; ref; ref = ref->next)
4773 switch (ref->u.ar.type)
4776 /* Coarray scalar. */
4777 if (ref->u.ar.as->rank == 0)
4779 current_part_dimension = 0;
4784 current_part_dimension = 1;
4788 current_part_dimension = 0;
4792 gfc_internal_error ("resolve_ref(): Bad array reference");
4798 if (current_part_dimension || seen_part_dimension)
4801 if (ref->u.c.component->attr.pointer
4802 || ref->u.c.component->attr.proc_pointer)
4804 gfc_error ("Component to the right of a part reference "
4805 "with nonzero rank must not have the POINTER "
4806 "attribute at %L", &expr->where);
4809 else if (ref->u.c.component->attr.allocatable)
4811 gfc_error ("Component to the right of a part reference "
4812 "with nonzero rank must not have the ALLOCATABLE "
4813 "attribute at %L", &expr->where);
4825 if (((ref->type == REF_COMPONENT && n_components > 1)
4826 || ref->next == NULL)
4827 && current_part_dimension
4828 && seen_part_dimension)
4830 gfc_error ("Two or more part references with nonzero rank must "
4831 "not be specified at %L", &expr->where);
4835 if (ref->type == REF_COMPONENT)
4837 if (current_part_dimension)
4838 seen_part_dimension = 1;
4840 /* reset to make sure */
4841 current_part_dimension = 0;
4849 /* Given an expression, determine its shape. This is easier than it sounds.
4850 Leaves the shape array NULL if it is not possible to determine the shape. */
4853 expression_shape (gfc_expr *e)
4855 mpz_t array[GFC_MAX_DIMENSIONS];
4858 if (e->rank == 0 || e->shape != NULL)
4861 for (i = 0; i < e->rank; i++)
4862 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4865 e->shape = gfc_get_shape (e->rank);
4867 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4872 for (i--; i >= 0; i--)
4873 mpz_clear (array[i]);
4877 /* Given a variable expression node, compute the rank of the expression by
4878 examining the base symbol and any reference structures it may have. */
4881 expression_rank (gfc_expr *e)
4886 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4887 could lead to serious confusion... */
4888 gcc_assert (e->expr_type != EXPR_COMPCALL);
4892 if (e->expr_type == EXPR_ARRAY)
4894 /* Constructors can have a rank different from one via RESHAPE(). */
4896 if (e->symtree == NULL)
4902 e->rank = (e->symtree->n.sym->as == NULL)
4903 ? 0 : e->symtree->n.sym->as->rank;
4909 for (ref = e->ref; ref; ref = ref->next)
4911 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
4912 && ref->u.c.component->attr.function && !ref->next)
4913 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
4915 if (ref->type != REF_ARRAY)
4918 if (ref->u.ar.type == AR_FULL)
4920 rank = ref->u.ar.as->rank;
4924 if (ref->u.ar.type == AR_SECTION)
4926 /* Figure out the rank of the section. */
4928 gfc_internal_error ("expression_rank(): Two array specs");
4930 for (i = 0; i < ref->u.ar.dimen; i++)
4931 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4932 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4942 expression_shape (e);
4946 /* Resolve a variable expression. */
4949 resolve_variable (gfc_expr *e)
4956 if (e->symtree == NULL)
4958 sym = e->symtree->n.sym;
4960 /* If this is an associate-name, it may be parsed with an array reference
4961 in error even though the target is scalar. Fail directly in this case. */
4962 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4965 /* On the other hand, the parser may not have known this is an array;
4966 in this case, we have to add a FULL reference. */
4967 if (sym->assoc && sym->attr.dimension && !e->ref)
4969 e->ref = gfc_get_ref ();
4970 e->ref->type = REF_ARRAY;
4971 e->ref->u.ar.type = AR_FULL;
4972 e->ref->u.ar.dimen = 0;
4975 if (e->ref && resolve_ref (e) == FAILURE)
4978 if (sym->attr.flavor == FL_PROCEDURE
4979 && (!sym->attr.function
4980 || (sym->attr.function && sym->result
4981 && sym->result->attr.proc_pointer
4982 && !sym->result->attr.function)))
4984 e->ts.type = BT_PROCEDURE;
4985 goto resolve_procedure;
4988 if (sym->ts.type != BT_UNKNOWN)
4989 gfc_variable_attr (e, &e->ts);
4992 /* Must be a simple variable reference. */
4993 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4998 if (check_assumed_size_reference (sym, e))
5001 /* Deal with forward references to entries during resolve_code, to
5002 satisfy, at least partially, 12.5.2.5. */
5003 if (gfc_current_ns->entries
5004 && current_entry_id == sym->entry_id
5007 && cs_base->current->op != EXEC_ENTRY)
5009 gfc_entry_list *entry;
5010 gfc_formal_arglist *formal;
5014 /* If the symbol is a dummy... */
5015 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5017 entry = gfc_current_ns->entries;
5020 /* ...test if the symbol is a parameter of previous entries. */
5021 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5022 for (formal = entry->sym->formal; formal; formal = formal->next)
5024 if (formal->sym && sym->name == formal->sym->name)
5028 /* If it has not been seen as a dummy, this is an error. */
5031 if (specification_expr)
5032 gfc_error ("Variable '%s', used in a specification expression"
5033 ", is referenced at %L before the ENTRY statement "
5034 "in which it is a parameter",
5035 sym->name, &cs_base->current->loc);
5037 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5038 "statement in which it is a parameter",
5039 sym->name, &cs_base->current->loc);
5044 /* Now do the same check on the specification expressions. */
5045 specification_expr = 1;
5046 if (sym->ts.type == BT_CHARACTER
5047 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5051 for (n = 0; n < sym->as->rank; n++)
5053 specification_expr = 1;
5054 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5056 specification_expr = 1;
5057 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5060 specification_expr = 0;
5063 /* Update the symbol's entry level. */
5064 sym->entry_id = current_entry_id + 1;
5067 /* If a symbol has been host_associated mark it. This is used latter,
5068 to identify if aliasing is possible via host association. */
5069 if (sym->attr.flavor == FL_VARIABLE
5070 && gfc_current_ns->parent
5071 && (gfc_current_ns->parent == sym->ns
5072 || (gfc_current_ns->parent->parent
5073 && gfc_current_ns->parent->parent == sym->ns)))
5074 sym->attr.host_assoc = 1;
5077 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5080 /* F2008, C617 and C1229. */
5081 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5082 && gfc_is_coindexed (e))
5084 gfc_ref *ref, *ref2 = NULL;
5086 for (ref = e->ref; ref; ref = ref->next)
5088 if (ref->type == REF_COMPONENT)
5090 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5094 for ( ; ref; ref = ref->next)
5095 if (ref->type == REF_COMPONENT)
5098 /* Expression itself is not coindexed object. */
5099 if (ref && e->ts.type == BT_CLASS)
5101 gfc_error ("Polymorphic subobject of coindexed object at %L",
5106 /* Expression itself is coindexed object. */
5110 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5111 for ( ; c; c = c->next)
5112 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5114 gfc_error ("Coindexed object with polymorphic allocatable "
5115 "subcomponent at %L", &e->where);
5126 /* Checks to see that the correct symbol has been host associated.
5127 The only situation where this arises is that in which a twice
5128 contained function is parsed after the host association is made.
5129 Therefore, on detecting this, change the symbol in the expression
5130 and convert the array reference into an actual arglist if the old
5131 symbol is a variable. */
5133 check_host_association (gfc_expr *e)
5135 gfc_symbol *sym, *old_sym;
5139 gfc_actual_arglist *arg, *tail = NULL;
5140 bool retval = e->expr_type == EXPR_FUNCTION;
5142 /* If the expression is the result of substitution in
5143 interface.c(gfc_extend_expr) because there is no way in
5144 which the host association can be wrong. */
5145 if (e->symtree == NULL
5146 || e->symtree->n.sym == NULL
5147 || e->user_operator)
5150 old_sym = e->symtree->n.sym;
5152 if (gfc_current_ns->parent
5153 && old_sym->ns != gfc_current_ns)
5155 /* Use the 'USE' name so that renamed module symbols are
5156 correctly handled. */
5157 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5159 if (sym && old_sym != sym
5160 && sym->ts.type == old_sym->ts.type
5161 && sym->attr.flavor == FL_PROCEDURE
5162 && sym->attr.contained)
5164 /* Clear the shape, since it might not be valid. */
5165 if (e->shape != NULL)
5167 for (n = 0; n < e->rank; n++)
5168 mpz_clear (e->shape[n]);
5170 gfc_free (e->shape);
5173 /* Give the expression the right symtree! */
5174 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5175 gcc_assert (st != NULL);
5177 if (old_sym->attr.flavor == FL_PROCEDURE
5178 || e->expr_type == EXPR_FUNCTION)
5180 /* Original was function so point to the new symbol, since
5181 the actual argument list is already attached to the
5183 e->value.function.esym = NULL;
5188 /* Original was variable so convert array references into
5189 an actual arglist. This does not need any checking now
5190 since gfc_resolve_function will take care of it. */
5191 e->value.function.actual = NULL;
5192 e->expr_type = EXPR_FUNCTION;
5195 /* Ambiguity will not arise if the array reference is not
5196 the last reference. */
5197 for (ref = e->ref; ref; ref = ref->next)
5198 if (ref->type == REF_ARRAY && ref->next == NULL)
5201 gcc_assert (ref->type == REF_ARRAY);
5203 /* Grab the start expressions from the array ref and
5204 copy them into actual arguments. */
5205 for (n = 0; n < ref->u.ar.dimen; n++)
5207 arg = gfc_get_actual_arglist ();
5208 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5209 if (e->value.function.actual == NULL)
5210 tail = e->value.function.actual = arg;
5218 /* Dump the reference list and set the rank. */
5219 gfc_free_ref_list (e->ref);
5221 e->rank = sym->as ? sym->as->rank : 0;
5224 gfc_resolve_expr (e);
5228 /* This might have changed! */
5229 return e->expr_type == EXPR_FUNCTION;
5234 gfc_resolve_character_operator (gfc_expr *e)
5236 gfc_expr *op1 = e->value.op.op1;
5237 gfc_expr *op2 = e->value.op.op2;
5238 gfc_expr *e1 = NULL;
5239 gfc_expr *e2 = NULL;
5241 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5243 if (op1->ts.u.cl && op1->ts.u.cl->length)
5244 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5245 else if (op1->expr_type == EXPR_CONSTANT)
5246 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5247 op1->value.character.length);
5249 if (op2->ts.u.cl && op2->ts.u.cl->length)
5250 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5251 else if (op2->expr_type == EXPR_CONSTANT)
5252 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5253 op2->value.character.length);
5255 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5260 e->ts.u.cl->length = gfc_add (e1, e2);
5261 e->ts.u.cl->length->ts.type = BT_INTEGER;
5262 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5263 gfc_simplify_expr (e->ts.u.cl->length, 0);
5264 gfc_resolve_expr (e->ts.u.cl->length);
5270 /* Ensure that an character expression has a charlen and, if possible, a
5271 length expression. */
5274 fixup_charlen (gfc_expr *e)
5276 /* The cases fall through so that changes in expression type and the need
5277 for multiple fixes are picked up. In all circumstances, a charlen should
5278 be available for the middle end to hang a backend_decl on. */
5279 switch (e->expr_type)
5282 gfc_resolve_character_operator (e);
5285 if (e->expr_type == EXPR_ARRAY)
5286 gfc_resolve_character_array_constructor (e);
5288 case EXPR_SUBSTRING:
5289 if (!e->ts.u.cl && e->ref)
5290 gfc_resolve_substring_charlen (e);
5294 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5301 /* Update an actual argument to include the passed-object for type-bound
5302 procedures at the right position. */
5304 static gfc_actual_arglist*
5305 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5308 gcc_assert (argpos > 0);
5312 gfc_actual_arglist* result;
5314 result = gfc_get_actual_arglist ();
5318 result->name = name;
5324 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5326 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5331 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5334 extract_compcall_passed_object (gfc_expr* e)
5338 gcc_assert (e->expr_type == EXPR_COMPCALL);
5340 if (e->value.compcall.base_object)
5341 po = gfc_copy_expr (e->value.compcall.base_object);
5344 po = gfc_get_expr ();
5345 po->expr_type = EXPR_VARIABLE;
5346 po->symtree = e->symtree;
5347 po->ref = gfc_copy_ref (e->ref);
5348 po->where = e->where;
5351 if (gfc_resolve_expr (po) == FAILURE)
5358 /* Update the arglist of an EXPR_COMPCALL expression to include the
5362 update_compcall_arglist (gfc_expr* e)
5365 gfc_typebound_proc* tbp;
5367 tbp = e->value.compcall.tbp;
5372 po = extract_compcall_passed_object (e);
5376 if (tbp->nopass || e->value.compcall.ignore_pass)
5382 gcc_assert (tbp->pass_arg_num > 0);
5383 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5391 /* Extract the passed object from a PPC call (a copy of it). */
5394 extract_ppc_passed_object (gfc_expr *e)
5399 po = gfc_get_expr ();
5400 po->expr_type = EXPR_VARIABLE;
5401 po->symtree = e->symtree;
5402 po->ref = gfc_copy_ref (e->ref);
5403 po->where = e->where;
5405 /* Remove PPC reference. */
5407 while ((*ref)->next)
5408 ref = &(*ref)->next;
5409 gfc_free_ref_list (*ref);
5412 if (gfc_resolve_expr (po) == FAILURE)
5419 /* Update the actual arglist of a procedure pointer component to include the
5423 update_ppc_arglist (gfc_expr* e)
5427 gfc_typebound_proc* tb;
5429 if (!gfc_is_proc_ptr_comp (e, &ppc))
5436 else if (tb->nopass)
5439 po = extract_ppc_passed_object (e);
5446 gfc_error ("Passed-object at %L must be scalar", &e->where);
5451 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5453 gfc_error ("Base object for procedure-pointer component call at %L is of"
5454 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5458 gcc_assert (tb->pass_arg_num > 0);
5459 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5467 /* Check that the object a TBP is called on is valid, i.e. it must not be
5468 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5471 check_typebound_baseobject (gfc_expr* e)
5474 gfc_try return_value = FAILURE;
5476 base = extract_compcall_passed_object (e);
5480 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5483 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5485 gfc_error ("Base object for type-bound procedure call at %L is of"
5486 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5490 /* F08:C1230. If the procedure called is NOPASS,
5491 the base object must be scalar. */
5492 if (e->value.compcall.tbp->nopass && base->rank > 0)
5494 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5495 " be scalar", &e->where);
5499 /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
5502 gfc_error ("Non-scalar base object at %L currently not implemented",
5507 return_value = SUCCESS;
5510 gfc_free_expr (base);
5511 return return_value;
5515 /* Resolve a call to a type-bound procedure, either function or subroutine,
5516 statically from the data in an EXPR_COMPCALL expression. The adapted
5517 arglist and the target-procedure symtree are returned. */
5520 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5521 gfc_actual_arglist** actual)
5523 gcc_assert (e->expr_type == EXPR_COMPCALL);
5524 gcc_assert (!e->value.compcall.tbp->is_generic);
5526 /* Update the actual arglist for PASS. */
5527 if (update_compcall_arglist (e) == FAILURE)
5530 *actual = e->value.compcall.actual;
5531 *target = e->value.compcall.tbp->u.specific;
5533 gfc_free_ref_list (e->ref);
5535 e->value.compcall.actual = NULL;
5541 /* Get the ultimate declared type from an expression. In addition,
5542 return the last class/derived type reference and the copy of the
5545 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5548 gfc_symbol *declared;
5555 *new_ref = gfc_copy_ref (e->ref);
5557 for (ref = e->ref; ref; ref = ref->next)
5559 if (ref->type != REF_COMPONENT)
5562 if (ref->u.c.component->ts.type == BT_CLASS
5563 || ref->u.c.component->ts.type == BT_DERIVED)
5565 declared = ref->u.c.component->ts.u.derived;
5571 if (declared == NULL)
5572 declared = e->symtree->n.sym->ts.u.derived;
5578 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5579 which of the specific bindings (if any) matches the arglist and transform
5580 the expression into a call of that binding. */
5583 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5585 gfc_typebound_proc* genproc;
5586 const char* genname;
5588 gfc_symbol *derived;
5590 gcc_assert (e->expr_type == EXPR_COMPCALL);
5591 genname = e->value.compcall.name;
5592 genproc = e->value.compcall.tbp;
5594 if (!genproc->is_generic)
5597 /* Try the bindings on this type and in the inheritance hierarchy. */
5598 for (; genproc; genproc = genproc->overridden)
5602 gcc_assert (genproc->is_generic);
5603 for (g = genproc->u.generic; g; g = g->next)
5606 gfc_actual_arglist* args;
5609 gcc_assert (g->specific);
5611 if (g->specific->error)
5614 target = g->specific->u.specific->n.sym;
5616 /* Get the right arglist by handling PASS/NOPASS. */
5617 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5618 if (!g->specific->nopass)
5621 po = extract_compcall_passed_object (e);
5625 gcc_assert (g->specific->pass_arg_num > 0);
5626 gcc_assert (!g->specific->error);
5627 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5628 g->specific->pass_arg);
5630 resolve_actual_arglist (args, target->attr.proc,
5631 is_external_proc (target) && !target->formal);
5633 /* Check if this arglist matches the formal. */
5634 matches = gfc_arglist_matches_symbol (&args, target);
5636 /* Clean up and break out of the loop if we've found it. */
5637 gfc_free_actual_arglist (args);
5640 e->value.compcall.tbp = g->specific;
5641 genname = g->specific_st->name;
5642 /* Pass along the name for CLASS methods, where the vtab
5643 procedure pointer component has to be referenced. */
5651 /* Nothing matching found! */
5652 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5653 " '%s' at %L", genname, &e->where);
5657 /* Make sure that we have the right specific instance for the name. */
5658 derived = get_declared_from_expr (NULL, NULL, e);
5660 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5662 e->value.compcall.tbp = st->n.tb;
5668 /* Resolve a call to a type-bound subroutine. */
5671 resolve_typebound_call (gfc_code* c, const char **name)
5673 gfc_actual_arglist* newactual;
5674 gfc_symtree* target;
5676 /* Check that's really a SUBROUTINE. */
5677 if (!c->expr1->value.compcall.tbp->subroutine)
5679 gfc_error ("'%s' at %L should be a SUBROUTINE",
5680 c->expr1->value.compcall.name, &c->loc);
5684 if (check_typebound_baseobject (c->expr1) == FAILURE)
5687 /* Pass along the name for CLASS methods, where the vtab
5688 procedure pointer component has to be referenced. */
5690 *name = c->expr1->value.compcall.name;
5692 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5695 /* Transform into an ordinary EXEC_CALL for now. */
5697 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5700 c->ext.actual = newactual;
5701 c->symtree = target;
5702 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5704 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5706 gfc_free_expr (c->expr1);
5707 c->expr1 = gfc_get_expr ();
5708 c->expr1->expr_type = EXPR_FUNCTION;
5709 c->expr1->symtree = target;
5710 c->expr1->where = c->loc;
5712 return resolve_call (c);
5716 /* Resolve a component-call expression. */
5718 resolve_compcall (gfc_expr* e, const char **name)
5720 gfc_actual_arglist* newactual;
5721 gfc_symtree* target;
5723 /* Check that's really a FUNCTION. */
5724 if (!e->value.compcall.tbp->function)
5726 gfc_error ("'%s' at %L should be a FUNCTION",
5727 e->value.compcall.name, &e->where);
5731 /* These must not be assign-calls! */
5732 gcc_assert (!e->value.compcall.assign);
5734 if (check_typebound_baseobject (e) == FAILURE)
5737 /* Pass along the name for CLASS methods, where the vtab
5738 procedure pointer component has to be referenced. */
5740 *name = e->value.compcall.name;
5742 if (resolve_typebound_generic_call (e, name) == FAILURE)
5744 gcc_assert (!e->value.compcall.tbp->is_generic);
5746 /* Take the rank from the function's symbol. */
5747 if (e->value.compcall.tbp->u.specific->n.sym->as)
5748 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5750 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5751 arglist to the TBP's binding target. */
5753 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5756 e->value.function.actual = newactual;
5757 e->value.function.name = NULL;
5758 e->value.function.esym = target->n.sym;
5759 e->value.function.isym = NULL;
5760 e->symtree = target;
5761 e->ts = target->n.sym->ts;
5762 e->expr_type = EXPR_FUNCTION;
5764 /* Resolution is not necessary if this is a class subroutine; this
5765 function only has to identify the specific proc. Resolution of
5766 the call will be done next in resolve_typebound_call. */
5767 return gfc_resolve_expr (e);
5772 /* Resolve a typebound function, or 'method'. First separate all
5773 the non-CLASS references by calling resolve_compcall directly. */
5776 resolve_typebound_function (gfc_expr* e)
5778 gfc_symbol *declared;
5789 /* Deal with typebound operators for CLASS objects. */
5790 expr = e->value.compcall.base_object;
5791 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5793 /* Since the typebound operators are generic, we have to ensure
5794 that any delays in resolution are corrected and that the vtab
5797 declared = ts.u.derived;
5798 c = gfc_find_component (declared, "_vptr", true, true);
5799 if (c->ts.u.derived == NULL)
5800 c->ts.u.derived = gfc_find_derived_vtab (declared);
5802 if (resolve_compcall (e, &name) == FAILURE)
5805 /* Use the generic name if it is there. */
5806 name = name ? name : e->value.function.esym->name;
5807 e->symtree = expr->symtree;
5808 e->ref = gfc_copy_ref (expr->ref);
5809 gfc_add_vptr_component (e);
5810 gfc_add_component_ref (e, name);
5811 e->value.function.esym = NULL;
5816 return resolve_compcall (e, NULL);
5818 if (resolve_ref (e) == FAILURE)
5821 /* Get the CLASS declared type. */
5822 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5824 /* Weed out cases of the ultimate component being a derived type. */
5825 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5826 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5828 gfc_free_ref_list (new_ref);
5829 return resolve_compcall (e, NULL);
5832 c = gfc_find_component (declared, "_data", true, true);
5833 declared = c->ts.u.derived;
5835 /* Treat the call as if it is a typebound procedure, in order to roll
5836 out the correct name for the specific function. */
5837 if (resolve_compcall (e, &name) == FAILURE)
5841 /* Then convert the expression to a procedure pointer component call. */
5842 e->value.function.esym = NULL;
5848 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5849 gfc_add_vptr_component (e);
5850 gfc_add_component_ref (e, name);
5852 /* Recover the typespec for the expression. This is really only
5853 necessary for generic procedures, where the additional call
5854 to gfc_add_component_ref seems to throw the collection of the
5855 correct typespec. */
5860 /* Resolve a typebound subroutine, or 'method'. First separate all
5861 the non-CLASS references by calling resolve_typebound_call
5865 resolve_typebound_subroutine (gfc_code *code)
5867 gfc_symbol *declared;
5876 st = code->expr1->symtree;
5878 /* Deal with typebound operators for CLASS objects. */
5879 expr = code->expr1->value.compcall.base_object;
5880 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
5882 /* Since the typebound operators are generic, we have to ensure
5883 that any delays in resolution are corrected and that the vtab
5885 declared = expr->ts.u.derived;
5886 c = gfc_find_component (declared, "_vptr", true, true);
5887 if (c->ts.u.derived == NULL)
5888 c->ts.u.derived = gfc_find_derived_vtab (declared);
5890 if (resolve_typebound_call (code, &name) == FAILURE)
5893 /* Use the generic name if it is there. */
5894 name = name ? name : code->expr1->value.function.esym->name;
5895 code->expr1->symtree = expr->symtree;
5896 code->expr1->ref = gfc_copy_ref (expr->ref);
5897 expr->symtree->n.sym->ts.u.derived = declared;
5898 gfc_add_vptr_component (code->expr1);
5899 gfc_add_component_ref (code->expr1, name);
5900 code->expr1->value.function.esym = NULL;
5905 return resolve_typebound_call (code, NULL);
5907 if (resolve_ref (code->expr1) == FAILURE)
5910 /* Get the CLASS declared type. */
5911 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5913 /* Weed out cases of the ultimate component being a derived type. */
5914 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5915 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5917 gfc_free_ref_list (new_ref);
5918 return resolve_typebound_call (code, NULL);
5921 if (resolve_typebound_call (code, &name) == FAILURE)
5923 ts = code->expr1->ts;
5925 /* Then convert the expression to a procedure pointer component call. */
5926 code->expr1->value.function.esym = NULL;
5927 code->expr1->symtree = st;
5930 code->expr1->ref = new_ref;
5932 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5933 gfc_add_vptr_component (code->expr1);
5934 gfc_add_component_ref (code->expr1, name);
5936 /* Recover the typespec for the expression. This is really only
5937 necessary for generic procedures, where the additional call
5938 to gfc_add_component_ref seems to throw the collection of the
5939 correct typespec. */
5940 code->expr1->ts = ts;
5945 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5948 resolve_ppc_call (gfc_code* c)
5950 gfc_component *comp;
5953 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5956 c->resolved_sym = c->expr1->symtree->n.sym;
5957 c->expr1->expr_type = EXPR_VARIABLE;
5959 if (!comp->attr.subroutine)
5960 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5962 if (resolve_ref (c->expr1) == FAILURE)
5965 if (update_ppc_arglist (c->expr1) == FAILURE)
5968 c->ext.actual = c->expr1->value.compcall.actual;
5970 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5971 comp->formal == NULL) == FAILURE)
5974 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5980 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5983 resolve_expr_ppc (gfc_expr* e)
5985 gfc_component *comp;
5988 b = gfc_is_proc_ptr_comp (e, &comp);
5991 /* Convert to EXPR_FUNCTION. */
5992 e->expr_type = EXPR_FUNCTION;
5993 e->value.function.isym = NULL;
5994 e->value.function.actual = e->value.compcall.actual;
5996 if (comp->as != NULL)
5997 e->rank = comp->as->rank;
5999 if (!comp->attr.function)
6000 gfc_add_function (&comp->attr, comp->name, &e->where);
6002 if (resolve_ref (e) == FAILURE)
6005 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6006 comp->formal == NULL) == FAILURE)
6009 if (update_ppc_arglist (e) == FAILURE)
6012 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6019 gfc_is_expandable_expr (gfc_expr *e)
6021 gfc_constructor *con;
6023 if (e->expr_type == EXPR_ARRAY)
6025 /* Traverse the constructor looking for variables that are flavor
6026 parameter. Parameters must be expanded since they are fully used at
6028 con = gfc_constructor_first (e->value.constructor);
6029 for (; con; con = gfc_constructor_next (con))
6031 if (con->expr->expr_type == EXPR_VARIABLE
6032 && con->expr->symtree
6033 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6034 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6036 if (con->expr->expr_type == EXPR_ARRAY
6037 && gfc_is_expandable_expr (con->expr))
6045 /* Resolve an expression. That is, make sure that types of operands agree
6046 with their operators, intrinsic operators are converted to function calls
6047 for overloaded types and unresolved function references are resolved. */
6050 gfc_resolve_expr (gfc_expr *e)
6058 /* inquiry_argument only applies to variables. */
6059 inquiry_save = inquiry_argument;
6060 if (e->expr_type != EXPR_VARIABLE)
6061 inquiry_argument = false;
6063 switch (e->expr_type)
6066 t = resolve_operator (e);
6072 if (check_host_association (e))
6073 t = resolve_function (e);
6076 t = resolve_variable (e);
6078 expression_rank (e);
6081 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6082 && e->ref->type != REF_SUBSTRING)
6083 gfc_resolve_substring_charlen (e);
6088 t = resolve_typebound_function (e);
6091 case EXPR_SUBSTRING:
6092 t = resolve_ref (e);
6101 t = resolve_expr_ppc (e);
6106 if (resolve_ref (e) == FAILURE)
6109 t = gfc_resolve_array_constructor (e);
6110 /* Also try to expand a constructor. */
6113 expression_rank (e);
6114 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6115 gfc_expand_constructor (e, false);
6118 /* This provides the opportunity for the length of constructors with
6119 character valued function elements to propagate the string length
6120 to the expression. */
6121 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6123 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6124 here rather then add a duplicate test for it above. */
6125 gfc_expand_constructor (e, false);
6126 t = gfc_resolve_character_array_constructor (e);
6131 case EXPR_STRUCTURE:
6132 t = resolve_ref (e);
6136 t = resolve_structure_cons (e, 0);
6140 t = gfc_simplify_expr (e, 0);
6144 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6147 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6150 inquiry_argument = inquiry_save;
6156 /* Resolve an expression from an iterator. They must be scalar and have
6157 INTEGER or (optionally) REAL type. */
6160 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6161 const char *name_msgid)
6163 if (gfc_resolve_expr (expr) == FAILURE)
6166 if (expr->rank != 0)
6168 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6172 if (expr->ts.type != BT_INTEGER)
6174 if (expr->ts.type == BT_REAL)
6177 return gfc_notify_std (GFC_STD_F95_DEL,
6178 "Deleted feature: %s at %L must be integer",
6179 _(name_msgid), &expr->where);
6182 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6189 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6197 /* Resolve the expressions in an iterator structure. If REAL_OK is
6198 false allow only INTEGER type iterators, otherwise allow REAL types. */
6201 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6203 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6207 if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
6211 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6212 "Start expression in DO loop") == FAILURE)
6215 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6216 "End expression in DO loop") == FAILURE)
6219 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6220 "Step expression in DO loop") == FAILURE)
6223 if (iter->step->expr_type == EXPR_CONSTANT)
6225 if ((iter->step->ts.type == BT_INTEGER
6226 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6227 || (iter->step->ts.type == BT_REAL
6228 && mpfr_sgn (iter->step->value.real) == 0))
6230 gfc_error ("Step expression in DO loop at %L cannot be zero",
6231 &iter->step->where);
6236 /* Convert start, end, and step to the same type as var. */
6237 if (iter->start->ts.kind != iter->var->ts.kind
6238 || iter->start->ts.type != iter->var->ts.type)
6239 gfc_convert_type (iter->start, &iter->var->ts, 2);
6241 if (iter->end->ts.kind != iter->var->ts.kind
6242 || iter->end->ts.type != iter->var->ts.type)
6243 gfc_convert_type (iter->end, &iter->var->ts, 2);
6245 if (iter->step->ts.kind != iter->var->ts.kind
6246 || iter->step->ts.type != iter->var->ts.type)
6247 gfc_convert_type (iter->step, &iter->var->ts, 2);
6249 if (iter->start->expr_type == EXPR_CONSTANT
6250 && iter->end->expr_type == EXPR_CONSTANT
6251 && iter->step->expr_type == EXPR_CONSTANT)
6254 if (iter->start->ts.type == BT_INTEGER)
6256 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6257 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6261 sgn = mpfr_sgn (iter->step->value.real);
6262 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6264 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6265 gfc_warning ("DO loop at %L will be executed zero times",
6266 &iter->step->where);
6273 /* Traversal function for find_forall_index. f == 2 signals that
6274 that variable itself is not to be checked - only the references. */
6277 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6279 if (expr->expr_type != EXPR_VARIABLE)
6282 /* A scalar assignment */
6283 if (!expr->ref || *f == 1)
6285 if (expr->symtree->n.sym == sym)
6297 /* Check whether the FORALL index appears in the expression or not.
6298 Returns SUCCESS if SYM is found in EXPR. */
6301 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6303 if (gfc_traverse_expr (expr, sym, forall_index, f))
6310 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6311 to be a scalar INTEGER variable. The subscripts and stride are scalar
6312 INTEGERs, and if stride is a constant it must be nonzero.
6313 Furthermore "A subscript or stride in a forall-triplet-spec shall
6314 not contain a reference to any index-name in the
6315 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6318 resolve_forall_iterators (gfc_forall_iterator *it)
6320 gfc_forall_iterator *iter, *iter2;
6322 for (iter = it; iter; iter = iter->next)
6324 if (gfc_resolve_expr (iter->var) == SUCCESS
6325 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6326 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6329 if (gfc_resolve_expr (iter->start) == SUCCESS
6330 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6331 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6332 &iter->start->where);
6333 if (iter->var->ts.kind != iter->start->ts.kind)
6334 gfc_convert_type (iter->start, &iter->var->ts, 2);
6336 if (gfc_resolve_expr (iter->end) == SUCCESS
6337 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6338 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6340 if (iter->var->ts.kind != iter->end->ts.kind)
6341 gfc_convert_type (iter->end, &iter->var->ts, 2);
6343 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6345 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6346 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6347 &iter->stride->where, "INTEGER");
6349 if (iter->stride->expr_type == EXPR_CONSTANT
6350 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6351 gfc_error ("FORALL stride expression at %L cannot be zero",
6352 &iter->stride->where);
6354 if (iter->var->ts.kind != iter->stride->ts.kind)
6355 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6358 for (iter = it; iter; iter = iter->next)
6359 for (iter2 = iter; iter2; iter2 = iter2->next)
6361 if (find_forall_index (iter2->start,
6362 iter->var->symtree->n.sym, 0) == SUCCESS
6363 || find_forall_index (iter2->end,
6364 iter->var->symtree->n.sym, 0) == SUCCESS
6365 || find_forall_index (iter2->stride,
6366 iter->var->symtree->n.sym, 0) == SUCCESS)
6367 gfc_error ("FORALL index '%s' may not appear in triplet "
6368 "specification at %L", iter->var->symtree->name,
6369 &iter2->start->where);
6374 /* Given a pointer to a symbol that is a derived type, see if it's
6375 inaccessible, i.e. if it's defined in another module and the components are
6376 PRIVATE. The search is recursive if necessary. Returns zero if no
6377 inaccessible components are found, nonzero otherwise. */
6380 derived_inaccessible (gfc_symbol *sym)
6384 if (sym->attr.use_assoc && sym->attr.private_comp)
6387 for (c = sym->components; c; c = c->next)
6389 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6397 /* Resolve the argument of a deallocate expression. The expression must be
6398 a pointer or a full array. */
6401 resolve_deallocate_expr (gfc_expr *e)
6403 symbol_attribute attr;
6404 int allocatable, pointer;
6409 if (gfc_resolve_expr (e) == FAILURE)
6412 if (e->expr_type != EXPR_VARIABLE)
6415 sym = e->symtree->n.sym;
6417 if (sym->ts.type == BT_CLASS)
6419 allocatable = CLASS_DATA (sym)->attr.allocatable;
6420 pointer = CLASS_DATA (sym)->attr.class_pointer;
6424 allocatable = sym->attr.allocatable;
6425 pointer = sym->attr.pointer;
6427 for (ref = e->ref; ref; ref = ref->next)
6432 if (ref->u.ar.type != AR_FULL)
6437 c = ref->u.c.component;
6438 if (c->ts.type == BT_CLASS)
6440 allocatable = CLASS_DATA (c)->attr.allocatable;
6441 pointer = CLASS_DATA (c)->attr.class_pointer;
6445 allocatable = c->attr.allocatable;
6446 pointer = c->attr.pointer;
6456 attr = gfc_expr_attr (e);
6458 if (allocatable == 0 && attr.pointer == 0)
6461 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6467 && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
6469 if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
6476 /* Returns true if the expression e contains a reference to the symbol sym. */
6478 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6480 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6487 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6489 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6493 /* Given the expression node e for an allocatable/pointer of derived type to be
6494 allocated, get the expression node to be initialized afterwards (needed for
6495 derived types with default initializers, and derived types with allocatable
6496 components that need nullification.) */
6499 gfc_expr_to_initialize (gfc_expr *e)
6505 result = gfc_copy_expr (e);
6507 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6508 for (ref = result->ref; ref; ref = ref->next)
6509 if (ref->type == REF_ARRAY && ref->next == NULL)
6511 ref->u.ar.type = AR_FULL;
6513 for (i = 0; i < ref->u.ar.dimen; i++)
6514 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6516 result->rank = ref->u.ar.dimen;
6524 /* If the last ref of an expression is an array ref, return a copy of the
6525 expression with that one removed. Otherwise, a copy of the original
6526 expression. This is used for allocate-expressions and pointer assignment
6527 LHS, where there may be an array specification that needs to be stripped
6528 off when using gfc_check_vardef_context. */
6531 remove_last_array_ref (gfc_expr* e)
6536 e2 = gfc_copy_expr (e);
6537 for (r = &e2->ref; *r; r = &(*r)->next)
6538 if ((*r)->type == REF_ARRAY && !(*r)->next)
6540 gfc_free_ref_list (*r);
6549 /* Used in resolve_allocate_expr to check that a allocation-object and
6550 a source-expr are conformable. This does not catch all possible
6551 cases; in particular a runtime checking is needed. */
6554 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6557 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6559 /* First compare rank. */
6560 if (tail && e1->rank != tail->u.ar.as->rank)
6562 gfc_error ("Source-expr at %L must be scalar or have the "
6563 "same rank as the allocate-object at %L",
6564 &e1->where, &e2->where);
6575 for (i = 0; i < e1->rank; i++)
6577 if (tail->u.ar.end[i])
6579 mpz_set (s, tail->u.ar.end[i]->value.integer);
6580 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6581 mpz_add_ui (s, s, 1);
6585 mpz_set (s, tail->u.ar.start[i]->value.integer);
6588 if (mpz_cmp (e1->shape[i], s) != 0)
6590 gfc_error ("Source-expr at %L and allocate-object at %L must "
6591 "have the same shape", &e1->where, &e2->where);
6604 /* Resolve the expression in an ALLOCATE statement, doing the additional
6605 checks to see whether the expression is OK or not. The expression must
6606 have a trailing array reference that gives the size of the array. */
6609 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6611 int i, pointer, allocatable, dimension, is_abstract;
6613 symbol_attribute attr;
6614 gfc_ref *ref, *ref2;
6617 gfc_symbol *sym = NULL;
6622 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6623 checking of coarrays. */
6624 for (ref = e->ref; ref; ref = ref->next)
6625 if (ref->next == NULL)
6628 if (ref && ref->type == REF_ARRAY)
6629 ref->u.ar.in_allocate = true;
6631 if (gfc_resolve_expr (e) == FAILURE)
6634 /* Make sure the expression is allocatable or a pointer. If it is
6635 pointer, the next-to-last reference must be a pointer. */
6639 sym = e->symtree->n.sym;
6641 /* Check whether ultimate component is abstract and CLASS. */
6644 if (e->expr_type != EXPR_VARIABLE)
6647 attr = gfc_expr_attr (e);
6648 pointer = attr.pointer;
6649 dimension = attr.dimension;
6650 codimension = attr.codimension;
6654 if (sym->ts.type == BT_CLASS)
6656 allocatable = CLASS_DATA (sym)->attr.allocatable;
6657 pointer = CLASS_DATA (sym)->attr.class_pointer;
6658 dimension = CLASS_DATA (sym)->attr.dimension;
6659 codimension = CLASS_DATA (sym)->attr.codimension;
6660 is_abstract = CLASS_DATA (sym)->attr.abstract;
6664 allocatable = sym->attr.allocatable;
6665 pointer = sym->attr.pointer;
6666 dimension = sym->attr.dimension;
6667 codimension = sym->attr.codimension;
6670 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6675 if (ref->next != NULL)
6681 if (gfc_is_coindexed (e))
6683 gfc_error ("Coindexed allocatable object at %L",
6688 c = ref->u.c.component;
6689 if (c->ts.type == BT_CLASS)
6691 allocatable = CLASS_DATA (c)->attr.allocatable;
6692 pointer = CLASS_DATA (c)->attr.class_pointer;
6693 dimension = CLASS_DATA (c)->attr.dimension;
6694 codimension = CLASS_DATA (c)->attr.codimension;
6695 is_abstract = CLASS_DATA (c)->attr.abstract;
6699 allocatable = c->attr.allocatable;
6700 pointer = c->attr.pointer;
6701 dimension = c->attr.dimension;
6702 codimension = c->attr.codimension;
6703 is_abstract = c->attr.abstract;
6715 if (allocatable == 0 && pointer == 0)
6717 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6722 /* Some checks for the SOURCE tag. */
6725 /* Check F03:C631. */
6726 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6728 gfc_error ("Type of entity at %L is type incompatible with "
6729 "source-expr at %L", &e->where, &code->expr3->where);
6733 /* Check F03:C632 and restriction following Note 6.18. */
6734 if (code->expr3->rank > 0
6735 && conformable_arrays (code->expr3, e) == FAILURE)
6738 /* Check F03:C633. */
6739 if (code->expr3->ts.kind != e->ts.kind)
6741 gfc_error ("The allocate-object at %L and the source-expr at %L "
6742 "shall have the same kind type parameter",
6743 &e->where, &code->expr3->where);
6748 /* Check F08:C629. */
6749 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6752 gcc_assert (e->ts.type == BT_CLASS);
6753 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6754 "type-spec or source-expr", sym->name, &e->where);
6758 /* In the variable definition context checks, gfc_expr_attr is used
6759 on the expression. This is fooled by the array specification
6760 present in e, thus we have to eliminate that one temporarily. */
6761 e2 = remove_last_array_ref (e);
6763 if (t == SUCCESS && pointer)
6764 t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
6766 t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
6773 /* Set up default initializer if needed. */
6777 if (code->ext.alloc.ts.type == BT_DERIVED)
6778 ts = code->ext.alloc.ts;
6782 if (ts.type == BT_CLASS)
6783 ts = ts.u.derived->components->ts;
6785 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6787 gfc_code *init_st = gfc_get_code ();
6788 init_st->loc = code->loc;
6789 init_st->op = EXEC_INIT_ASSIGN;
6790 init_st->expr1 = gfc_expr_to_initialize (e);
6791 init_st->expr2 = init_e;
6792 init_st->next = code->next;
6793 code->next = init_st;
6796 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6798 /* Default initialization via MOLD (non-polymorphic). */
6799 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6800 gfc_resolve_expr (rhs);
6801 gfc_free_expr (code->expr3);
6805 if (e->ts.type == BT_CLASS)
6807 /* Make sure the vtab symbol is present when
6808 the module variables are generated. */
6809 gfc_typespec ts = e->ts;
6811 ts = code->expr3->ts;
6812 else if (code->ext.alloc.ts.type == BT_DERIVED)
6813 ts = code->ext.alloc.ts;
6814 gfc_find_derived_vtab (ts.u.derived);
6817 if (pointer || (dimension == 0 && codimension == 0))
6820 /* Make sure the last reference node is an array specifiction. */
6822 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6823 || (dimension && ref2->u.ar.dimen == 0))
6825 gfc_error ("Array specification required in ALLOCATE statement "
6826 "at %L", &e->where);
6830 /* Make sure that the array section reference makes sense in the
6831 context of an ALLOCATE specification. */
6835 if (codimension && ar->codimen == 0)
6837 gfc_error ("Coarray specification required in ALLOCATE statement "
6838 "at %L", &e->where);
6842 for (i = 0; i < ar->dimen; i++)
6844 if (ref2->u.ar.type == AR_ELEMENT)
6847 switch (ar->dimen_type[i])
6853 if (ar->start[i] != NULL
6854 && ar->end[i] != NULL
6855 && ar->stride[i] == NULL)
6858 /* Fall Through... */
6863 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6869 for (a = code->ext.alloc.list; a; a = a->next)
6871 sym = a->expr->symtree->n.sym;
6873 /* TODO - check derived type components. */
6874 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6877 if ((ar->start[i] != NULL
6878 && gfc_find_sym_in_expr (sym, ar->start[i]))
6879 || (ar->end[i] != NULL
6880 && gfc_find_sym_in_expr (sym, ar->end[i])))
6882 gfc_error ("'%s' must not appear in the array specification at "
6883 "%L in the same ALLOCATE statement where it is "
6884 "itself allocated", sym->name, &ar->where);
6890 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6892 if (ar->dimen_type[i] == DIMEN_ELEMENT
6893 || ar->dimen_type[i] == DIMEN_RANGE)
6895 if (i == (ar->dimen + ar->codimen - 1))
6897 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6898 "statement at %L", &e->where);
6904 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6905 && ar->stride[i] == NULL)
6908 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6913 if (codimension && ar->as->rank == 0)
6915 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6916 "at %L", &e->where);
6928 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6930 gfc_expr *stat, *errmsg, *pe, *qe;
6931 gfc_alloc *a, *p, *q;
6934 errmsg = code->expr2;
6936 /* Check the stat variable. */
6939 gfc_check_vardef_context (stat, false, _("STAT variable"));
6941 if ((stat->ts.type != BT_INTEGER
6942 && !(stat->ref && (stat->ref->type == REF_ARRAY
6943 || stat->ref->type == REF_COMPONENT)))
6945 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6946 "variable", &stat->where);
6948 for (p = code->ext.alloc.list; p; p = p->next)
6949 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6951 gfc_ref *ref1, *ref2;
6954 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6955 ref1 = ref1->next, ref2 = ref2->next)
6957 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6959 if (ref1->u.c.component->name != ref2->u.c.component->name)
6968 gfc_error ("Stat-variable at %L shall not be %sd within "
6969 "the same %s statement", &stat->where, fcn, fcn);
6975 /* Check the errmsg variable. */
6979 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6982 gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
6984 if ((errmsg->ts.type != BT_CHARACTER
6986 && (errmsg->ref->type == REF_ARRAY
6987 || errmsg->ref->type == REF_COMPONENT)))
6988 || errmsg->rank > 0 )
6989 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6990 "variable", &errmsg->where);
6992 for (p = code->ext.alloc.list; p; p = p->next)
6993 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6995 gfc_ref *ref1, *ref2;
6998 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6999 ref1 = ref1->next, ref2 = ref2->next)
7001 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7003 if (ref1->u.c.component->name != ref2->u.c.component->name)
7012 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7013 "the same %s statement", &errmsg->where, fcn, fcn);
7019 /* Check that an allocate-object appears only once in the statement.
7020 FIXME: Checking derived types is disabled. */
7021 for (p = code->ext.alloc.list; p; p = p->next)
7024 for (q = p->next; q; q = q->next)
7027 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7029 /* This is a potential collision. */
7030 gfc_ref *pr = pe->ref;
7031 gfc_ref *qr = qe->ref;
7033 /* Follow the references until
7034 a) They start to differ, in which case there is no error;
7035 you can deallocate a%b and a%c in a single statement
7036 b) Both of them stop, which is an error
7037 c) One of them stops, which is also an error. */
7040 if (pr == NULL && qr == NULL)
7042 gfc_error ("Allocate-object at %L also appears at %L",
7043 &pe->where, &qe->where);
7046 else if (pr != NULL && qr == NULL)
7048 gfc_error ("Allocate-object at %L is subobject of"
7049 " object at %L", &pe->where, &qe->where);
7052 else if (pr == NULL && qr != NULL)
7054 gfc_error ("Allocate-object at %L is subobject of"
7055 " object at %L", &qe->where, &pe->where);
7058 /* Here, pr != NULL && qr != NULL */
7059 gcc_assert(pr->type == qr->type);
7060 if (pr->type == REF_ARRAY)
7062 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7064 gcc_assert (qr->type == REF_ARRAY);
7066 if (pr->next && qr->next)
7068 gfc_array_ref *par = &(pr->u.ar);
7069 gfc_array_ref *qar = &(qr->u.ar);
7070 if (gfc_dep_compare_expr (par->start[0],
7071 qar->start[0]) != 0)
7077 if (pr->u.c.component->name != qr->u.c.component->name)
7088 if (strcmp (fcn, "ALLOCATE") == 0)
7090 for (a = code->ext.alloc.list; a; a = a->next)
7091 resolve_allocate_expr (a->expr, code);
7095 for (a = code->ext.alloc.list; a; a = a->next)
7096 resolve_deallocate_expr (a->expr);
7101 /************ SELECT CASE resolution subroutines ************/
7103 /* Callback function for our mergesort variant. Determines interval
7104 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7105 op1 > op2. Assumes we're not dealing with the default case.
7106 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7107 There are nine situations to check. */
7110 compare_cases (const gfc_case *op1, const gfc_case *op2)
7114 if (op1->low == NULL) /* op1 = (:L) */
7116 /* op2 = (:N), so overlap. */
7118 /* op2 = (M:) or (M:N), L < M */
7119 if (op2->low != NULL
7120 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7123 else if (op1->high == NULL) /* op1 = (K:) */
7125 /* op2 = (M:), so overlap. */
7127 /* op2 = (:N) or (M:N), K > N */
7128 if (op2->high != NULL
7129 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7132 else /* op1 = (K:L) */
7134 if (op2->low == NULL) /* op2 = (:N), K > N */
7135 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7137 else if (op2->high == NULL) /* op2 = (M:), L < M */
7138 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7140 else /* op2 = (M:N) */
7144 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7147 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7156 /* Merge-sort a double linked case list, detecting overlap in the
7157 process. LIST is the head of the double linked case list before it
7158 is sorted. Returns the head of the sorted list if we don't see any
7159 overlap, or NULL otherwise. */
7162 check_case_overlap (gfc_case *list)
7164 gfc_case *p, *q, *e, *tail;
7165 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7167 /* If the passed list was empty, return immediately. */
7174 /* Loop unconditionally. The only exit from this loop is a return
7175 statement, when we've finished sorting the case list. */
7182 /* Count the number of merges we do in this pass. */
7185 /* Loop while there exists a merge to be done. */
7190 /* Count this merge. */
7193 /* Cut the list in two pieces by stepping INSIZE places
7194 forward in the list, starting from P. */
7197 for (i = 0; i < insize; i++)
7206 /* Now we have two lists. Merge them! */
7207 while (psize > 0 || (qsize > 0 && q != NULL))
7209 /* See from which the next case to merge comes from. */
7212 /* P is empty so the next case must come from Q. */
7217 else if (qsize == 0 || q == NULL)
7226 cmp = compare_cases (p, q);
7229 /* The whole case range for P is less than the
7237 /* The whole case range for Q is greater than
7238 the case range for P. */
7245 /* The cases overlap, or they are the same
7246 element in the list. Either way, we must
7247 issue an error and get the next case from P. */
7248 /* FIXME: Sort P and Q by line number. */
7249 gfc_error ("CASE label at %L overlaps with CASE "
7250 "label at %L", &p->where, &q->where);
7258 /* Add the next element to the merged list. */
7267 /* P has now stepped INSIZE places along, and so has Q. So
7268 they're the same. */
7273 /* If we have done only one merge or none at all, we've
7274 finished sorting the cases. */
7283 /* Otherwise repeat, merging lists twice the size. */
7289 /* Check to see if an expression is suitable for use in a CASE statement.
7290 Makes sure that all case expressions are scalar constants of the same
7291 type. Return FAILURE if anything is wrong. */
7294 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7296 if (e == NULL) return SUCCESS;
7298 if (e->ts.type != case_expr->ts.type)
7300 gfc_error ("Expression in CASE statement at %L must be of type %s",
7301 &e->where, gfc_basic_typename (case_expr->ts.type));
7305 /* C805 (R808) For a given case-construct, each case-value shall be of
7306 the same type as case-expr. For character type, length differences
7307 are allowed, but the kind type parameters shall be the same. */
7309 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7311 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7312 &e->where, case_expr->ts.kind);
7316 /* Convert the case value kind to that of case expression kind,
7319 if (e->ts.kind != case_expr->ts.kind)
7320 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7324 gfc_error ("Expression in CASE statement at %L must be scalar",
7333 /* Given a completely parsed select statement, we:
7335 - Validate all expressions and code within the SELECT.
7336 - Make sure that the selection expression is not of the wrong type.
7337 - Make sure that no case ranges overlap.
7338 - Eliminate unreachable cases and unreachable code resulting from
7339 removing case labels.
7341 The standard does allow unreachable cases, e.g. CASE (5:3). But
7342 they are a hassle for code generation, and to prevent that, we just
7343 cut them out here. This is not necessary for overlapping cases
7344 because they are illegal and we never even try to generate code.
7346 We have the additional caveat that a SELECT construct could have
7347 been a computed GOTO in the source code. Fortunately we can fairly
7348 easily work around that here: The case_expr for a "real" SELECT CASE
7349 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7350 we have to do is make sure that the case_expr is a scalar integer
7354 resolve_select (gfc_code *code)
7357 gfc_expr *case_expr;
7358 gfc_case *cp, *default_case, *tail, *head;
7359 int seen_unreachable;
7365 if (code->expr1 == NULL)
7367 /* This was actually a computed GOTO statement. */
7368 case_expr = code->expr2;
7369 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7370 gfc_error ("Selection expression in computed GOTO statement "
7371 "at %L must be a scalar integer expression",
7374 /* Further checking is not necessary because this SELECT was built
7375 by the compiler, so it should always be OK. Just move the
7376 case_expr from expr2 to expr so that we can handle computed
7377 GOTOs as normal SELECTs from here on. */
7378 code->expr1 = code->expr2;
7383 case_expr = code->expr1;
7385 type = case_expr->ts.type;
7386 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7388 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7389 &case_expr->where, gfc_typename (&case_expr->ts));
7391 /* Punt. Going on here just produce more garbage error messages. */
7395 if (case_expr->rank != 0)
7397 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7398 "expression", &case_expr->where);
7405 /* Raise a warning if an INTEGER case value exceeds the range of
7406 the case-expr. Later, all expressions will be promoted to the
7407 largest kind of all case-labels. */
7409 if (type == BT_INTEGER)
7410 for (body = code->block; body; body = body->block)
7411 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7414 && gfc_check_integer_range (cp->low->value.integer,
7415 case_expr->ts.kind) != ARITH_OK)
7416 gfc_warning ("Expression in CASE statement at %L is "
7417 "not in the range of %s", &cp->low->where,
7418 gfc_typename (&case_expr->ts));
7421 && cp->low != cp->high
7422 && gfc_check_integer_range (cp->high->value.integer,
7423 case_expr->ts.kind) != ARITH_OK)
7424 gfc_warning ("Expression in CASE statement at %L is "
7425 "not in the range of %s", &cp->high->where,
7426 gfc_typename (&case_expr->ts));
7429 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7430 of the SELECT CASE expression and its CASE values. Walk the lists
7431 of case values, and if we find a mismatch, promote case_expr to
7432 the appropriate kind. */
7434 if (type == BT_LOGICAL || type == BT_INTEGER)
7436 for (body = code->block; body; body = body->block)
7438 /* Walk the case label list. */
7439 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7441 /* Intercept the DEFAULT case. It does not have a kind. */
7442 if (cp->low == NULL && cp->high == NULL)
7445 /* Unreachable case ranges are discarded, so ignore. */
7446 if (cp->low != NULL && cp->high != NULL
7447 && cp->low != cp->high
7448 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7452 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7453 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7455 if (cp->high != NULL
7456 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7457 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7462 /* Assume there is no DEFAULT case. */
7463 default_case = NULL;
7468 for (body = code->block; body; body = body->block)
7470 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7472 seen_unreachable = 0;
7474 /* Walk the case label list, making sure that all case labels
7476 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7478 /* Count the number of cases in the whole construct. */
7481 /* Intercept the DEFAULT case. */
7482 if (cp->low == NULL && cp->high == NULL)
7484 if (default_case != NULL)
7486 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7487 "by a second DEFAULT CASE at %L",
7488 &default_case->where, &cp->where);
7499 /* Deal with single value cases and case ranges. Errors are
7500 issued from the validation function. */
7501 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7502 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7508 if (type == BT_LOGICAL
7509 && ((cp->low == NULL || cp->high == NULL)
7510 || cp->low != cp->high))
7512 gfc_error ("Logical range in CASE statement at %L is not "
7513 "allowed", &cp->low->where);
7518 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7521 value = cp->low->value.logical == 0 ? 2 : 1;
7522 if (value & seen_logical)
7524 gfc_error ("Constant logical value in CASE statement "
7525 "is repeated at %L",
7530 seen_logical |= value;
7533 if (cp->low != NULL && cp->high != NULL
7534 && cp->low != cp->high
7535 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7537 if (gfc_option.warn_surprising)
7538 gfc_warning ("Range specification at %L can never "
7539 "be matched", &cp->where);
7541 cp->unreachable = 1;
7542 seen_unreachable = 1;
7546 /* If the case range can be matched, it can also overlap with
7547 other cases. To make sure it does not, we put it in a
7548 double linked list here. We sort that with a merge sort
7549 later on to detect any overlapping cases. */
7553 head->right = head->left = NULL;
7558 tail->right->left = tail;
7565 /* It there was a failure in the previous case label, give up
7566 for this case label list. Continue with the next block. */
7570 /* See if any case labels that are unreachable have been seen.
7571 If so, we eliminate them. This is a bit of a kludge because
7572 the case lists for a single case statement (label) is a
7573 single forward linked lists. */
7574 if (seen_unreachable)
7576 /* Advance until the first case in the list is reachable. */
7577 while (body->ext.block.case_list != NULL
7578 && body->ext.block.case_list->unreachable)
7580 gfc_case *n = body->ext.block.case_list;
7581 body->ext.block.case_list = body->ext.block.case_list->next;
7583 gfc_free_case_list (n);
7586 /* Strip all other unreachable cases. */
7587 if (body->ext.block.case_list)
7589 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7591 if (cp->next->unreachable)
7593 gfc_case *n = cp->next;
7594 cp->next = cp->next->next;
7596 gfc_free_case_list (n);
7603 /* See if there were overlapping cases. If the check returns NULL,
7604 there was overlap. In that case we don't do anything. If head
7605 is non-NULL, we prepend the DEFAULT case. The sorted list can
7606 then used during code generation for SELECT CASE constructs with
7607 a case expression of a CHARACTER type. */
7610 head = check_case_overlap (head);
7612 /* Prepend the default_case if it is there. */
7613 if (head != NULL && default_case)
7615 default_case->left = NULL;
7616 default_case->right = head;
7617 head->left = default_case;
7621 /* Eliminate dead blocks that may be the result if we've seen
7622 unreachable case labels for a block. */
7623 for (body = code; body && body->block; body = body->block)
7625 if (body->block->ext.block.case_list == NULL)
7627 /* Cut the unreachable block from the code chain. */
7628 gfc_code *c = body->block;
7629 body->block = c->block;
7631 /* Kill the dead block, but not the blocks below it. */
7633 gfc_free_statements (c);
7637 /* More than two cases is legal but insane for logical selects.
7638 Issue a warning for it. */
7639 if (gfc_option.warn_surprising && type == BT_LOGICAL
7641 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7646 /* Check if a derived type is extensible. */
7649 gfc_type_is_extensible (gfc_symbol *sym)
7651 return !(sym->attr.is_bind_c || sym->attr.sequence);
7655 /* Resolve an associate name: Resolve target and ensure the type-spec is
7656 correct as well as possibly the array-spec. */
7659 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7663 gcc_assert (sym->assoc);
7664 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7666 /* If this is for SELECT TYPE, the target may not yet be set. In that
7667 case, return. Resolution will be called later manually again when
7669 target = sym->assoc->target;
7672 gcc_assert (!sym->assoc->dangling);
7674 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7677 /* For variable targets, we get some attributes from the target. */
7678 if (target->expr_type == EXPR_VARIABLE)
7682 gcc_assert (target->symtree);
7683 tsym = target->symtree->n.sym;
7685 sym->attr.asynchronous = tsym->attr.asynchronous;
7686 sym->attr.volatile_ = tsym->attr.volatile_;
7688 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7691 /* Get type if this was not already set. Note that it can be
7692 some other type than the target in case this is a SELECT TYPE
7693 selector! So we must not update when the type is already there. */
7694 if (sym->ts.type == BT_UNKNOWN)
7695 sym->ts = target->ts;
7696 gcc_assert (sym->ts.type != BT_UNKNOWN);
7698 /* See if this is a valid association-to-variable. */
7699 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7700 && !gfc_has_vector_subscript (target));
7702 /* Finally resolve if this is an array or not. */
7703 if (sym->attr.dimension && target->rank == 0)
7705 gfc_error ("Associate-name '%s' at %L is used as array",
7706 sym->name, &sym->declared_at);
7707 sym->attr.dimension = 0;
7710 if (target->rank > 0)
7711 sym->attr.dimension = 1;
7713 if (sym->attr.dimension)
7715 sym->as = gfc_get_array_spec ();
7716 sym->as->rank = target->rank;
7717 sym->as->type = AS_DEFERRED;
7719 /* Target must not be coindexed, thus the associate-variable
7721 sym->as->corank = 0;
7726 /* Resolve a SELECT TYPE statement. */
7729 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7731 gfc_symbol *selector_type;
7732 gfc_code *body, *new_st, *if_st, *tail;
7733 gfc_code *class_is = NULL, *default_case = NULL;
7736 char name[GFC_MAX_SYMBOL_LEN];
7740 ns = code->ext.block.ns;
7743 /* Check for F03:C813. */
7744 if (code->expr1->ts.type != BT_CLASS
7745 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7747 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7748 "at %L", &code->loc);
7754 if (code->expr1->symtree->n.sym->attr.untyped)
7755 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7756 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7759 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7761 /* Loop over TYPE IS / CLASS IS cases. */
7762 for (body = code->block; body; body = body->block)
7764 c = body->ext.block.case_list;
7766 /* Check F03:C815. */
7767 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7768 && !gfc_type_is_extensible (c->ts.u.derived))
7770 gfc_error ("Derived type '%s' at %L must be extensible",
7771 c->ts.u.derived->name, &c->where);
7776 /* Check F03:C816. */
7777 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7778 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7780 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7781 c->ts.u.derived->name, &c->where, selector_type->name);
7786 /* Intercept the DEFAULT case. */
7787 if (c->ts.type == BT_UNKNOWN)
7789 /* Check F03:C818. */
7792 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7793 "by a second DEFAULT CASE at %L",
7794 &default_case->ext.block.case_list->where, &c->where);
7799 default_case = body;
7806 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7807 target if present. If there are any EXIT statements referring to the
7808 SELECT TYPE construct, this is no problem because the gfc_code
7809 reference stays the same and EXIT is equally possible from the BLOCK
7810 it is changed to. */
7811 code->op = EXEC_BLOCK;
7814 gfc_association_list* assoc;
7816 assoc = gfc_get_association_list ();
7817 assoc->st = code->expr1->symtree;
7818 assoc->target = gfc_copy_expr (code->expr2);
7819 /* assoc->variable will be set by resolve_assoc_var. */
7821 code->ext.block.assoc = assoc;
7822 code->expr1->symtree->n.sym->assoc = assoc;
7824 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7827 code->ext.block.assoc = NULL;
7829 /* Add EXEC_SELECT to switch on type. */
7830 new_st = gfc_get_code ();
7831 new_st->op = code->op;
7832 new_st->expr1 = code->expr1;
7833 new_st->expr2 = code->expr2;
7834 new_st->block = code->block;
7835 code->expr1 = code->expr2 = NULL;
7840 ns->code->next = new_st;
7842 code->op = EXEC_SELECT;
7843 gfc_add_vptr_component (code->expr1);
7844 gfc_add_hash_component (code->expr1);
7846 /* Loop over TYPE IS / CLASS IS cases. */
7847 for (body = code->block; body; body = body->block)
7849 c = body->ext.block.case_list;
7851 if (c->ts.type == BT_DERIVED)
7852 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7853 c->ts.u.derived->hash_value);
7855 else if (c->ts.type == BT_UNKNOWN)
7858 /* Associate temporary to selector. This should only be done
7859 when this case is actually true, so build a new ASSOCIATE
7860 that does precisely this here (instead of using the
7863 if (c->ts.type == BT_CLASS)
7864 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
7866 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
7867 st = gfc_find_symtree (ns->sym_root, name);
7868 gcc_assert (st->n.sym->assoc);
7869 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7870 if (c->ts.type == BT_DERIVED)
7871 gfc_add_data_component (st->n.sym->assoc->target);
7873 new_st = gfc_get_code ();
7874 new_st->op = EXEC_BLOCK;
7875 new_st->ext.block.ns = gfc_build_block_ns (ns);
7876 new_st->ext.block.ns->code = body->next;
7877 body->next = new_st;
7879 /* Chain in the new list only if it is marked as dangling. Otherwise
7880 there is a CASE label overlap and this is already used. Just ignore,
7881 the error is diagonsed elsewhere. */
7882 if (st->n.sym->assoc->dangling)
7884 new_st->ext.block.assoc = st->n.sym->assoc;
7885 st->n.sym->assoc->dangling = 0;
7888 resolve_assoc_var (st->n.sym, false);
7891 /* Take out CLASS IS cases for separate treatment. */
7893 while (body && body->block)
7895 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
7897 /* Add to class_is list. */
7898 if (class_is == NULL)
7900 class_is = body->block;
7905 for (tail = class_is; tail->block; tail = tail->block) ;
7906 tail->block = body->block;
7909 /* Remove from EXEC_SELECT list. */
7910 body->block = body->block->block;
7923 /* Add a default case to hold the CLASS IS cases. */
7924 for (tail = code; tail->block; tail = tail->block) ;
7925 tail->block = gfc_get_code ();
7927 tail->op = EXEC_SELECT_TYPE;
7928 tail->ext.block.case_list = gfc_get_case ();
7929 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
7931 default_case = tail;
7934 /* More than one CLASS IS block? */
7935 if (class_is->block)
7939 /* Sort CLASS IS blocks by extension level. */
7943 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7946 /* F03:C817 (check for doubles). */
7947 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
7948 == c2->ext.block.case_list->ts.u.derived->hash_value)
7950 gfc_error ("Double CLASS IS block in SELECT TYPE "
7952 &c2->ext.block.case_list->where);
7955 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
7956 < c2->ext.block.case_list->ts.u.derived->attr.extension)
7959 (*c1)->block = c2->block;
7969 /* Generate IF chain. */
7970 if_st = gfc_get_code ();
7971 if_st->op = EXEC_IF;
7973 for (body = class_is; body; body = body->block)
7975 new_st->block = gfc_get_code ();
7976 new_st = new_st->block;
7977 new_st->op = EXEC_IF;
7978 /* Set up IF condition: Call _gfortran_is_extension_of. */
7979 new_st->expr1 = gfc_get_expr ();
7980 new_st->expr1->expr_type = EXPR_FUNCTION;
7981 new_st->expr1->ts.type = BT_LOGICAL;
7982 new_st->expr1->ts.kind = 4;
7983 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7984 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7985 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7986 /* Set up arguments. */
7987 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7988 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7989 new_st->expr1->value.function.actual->expr->where = code->loc;
7990 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
7991 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
7992 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7993 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7994 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7995 new_st->next = body->next;
7997 if (default_case->next)
7999 new_st->block = gfc_get_code ();
8000 new_st = new_st->block;
8001 new_st->op = EXEC_IF;
8002 new_st->next = default_case->next;
8005 /* Replace CLASS DEFAULT code by the IF chain. */
8006 default_case->next = if_st;
8009 /* Resolve the internal code. This can not be done earlier because
8010 it requires that the sym->assoc of selectors is set already. */
8011 gfc_current_ns = ns;
8012 gfc_resolve_blocks (code->block, gfc_current_ns);
8013 gfc_current_ns = old_ns;
8015 resolve_select (code);
8019 /* Resolve a transfer statement. This is making sure that:
8020 -- a derived type being transferred has only non-pointer components
8021 -- a derived type being transferred doesn't have private components, unless
8022 it's being transferred from the module where the type was defined
8023 -- we're not trying to transfer a whole assumed size array. */
8026 resolve_transfer (gfc_code *code)
8035 while (exp != NULL && exp->expr_type == EXPR_OP
8036 && exp->value.op.op == INTRINSIC_PARENTHESES)
8037 exp = exp->value.op.op1;
8039 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8040 && exp->expr_type != EXPR_FUNCTION))
8043 /* If we are reading, the variable will be changed. Note that
8044 code->ext.dt may be NULL if the TRANSFER is related to
8045 an INQUIRE statement -- but in this case, we are not reading, either. */
8046 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8047 && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
8050 sym = exp->symtree->n.sym;
8053 /* Go to actual component transferred. */
8054 for (ref = exp->ref; ref; ref = ref->next)
8055 if (ref->type == REF_COMPONENT)
8056 ts = &ref->u.c.component->ts;
8058 if (ts->type == BT_CLASS)
8060 /* FIXME: Test for defined input/output. */
8061 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8062 "it is processed by a defined input/output procedure",
8067 if (ts->type == BT_DERIVED)
8069 /* Check that transferred derived type doesn't contain POINTER
8071 if (ts->u.derived->attr.pointer_comp)
8073 gfc_error ("Data transfer element at %L cannot have "
8074 "POINTER components", &code->loc);
8078 if (ts->u.derived->attr.alloc_comp)
8080 gfc_error ("Data transfer element at %L cannot have "
8081 "ALLOCATABLE components", &code->loc);
8085 if (derived_inaccessible (ts->u.derived))
8087 gfc_error ("Data transfer element at %L cannot have "
8088 "PRIVATE components",&code->loc);
8093 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
8094 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8096 gfc_error ("Data transfer element at %L cannot be a full reference to "
8097 "an assumed-size array", &code->loc);
8103 /*********** Toplevel code resolution subroutines ***********/
8105 /* Find the set of labels that are reachable from this block. We also
8106 record the last statement in each block. */
8109 find_reachable_labels (gfc_code *block)
8116 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8118 /* Collect labels in this block. We don't keep those corresponding
8119 to END {IF|SELECT}, these are checked in resolve_branch by going
8120 up through the code_stack. */
8121 for (c = block; c; c = c->next)
8123 if (c->here && c->op != EXEC_END_BLOCK)
8124 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8127 /* Merge with labels from parent block. */
8130 gcc_assert (cs_base->prev->reachable_labels);
8131 bitmap_ior_into (cs_base->reachable_labels,
8132 cs_base->prev->reachable_labels);
8138 resolve_sync (gfc_code *code)
8140 /* Check imageset. The * case matches expr1 == NULL. */
8143 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8144 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8145 "INTEGER expression", &code->expr1->where);
8146 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8147 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8148 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8149 &code->expr1->where);
8150 else if (code->expr1->expr_type == EXPR_ARRAY
8151 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8153 gfc_constructor *cons;
8154 cons = gfc_constructor_first (code->expr1->value.constructor);
8155 for (; cons; cons = gfc_constructor_next (cons))
8156 if (cons->expr->expr_type == EXPR_CONSTANT
8157 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8158 gfc_error ("Imageset argument at %L must between 1 and "
8159 "num_images()", &cons->expr->where);
8165 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8166 || code->expr2->expr_type != EXPR_VARIABLE))
8167 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8168 &code->expr2->where);
8172 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8173 || code->expr3->expr_type != EXPR_VARIABLE))
8174 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8175 &code->expr3->where);
8179 /* Given a branch to a label, see if the branch is conforming.
8180 The code node describes where the branch is located. */
8183 resolve_branch (gfc_st_label *label, gfc_code *code)
8190 /* Step one: is this a valid branching target? */
8192 if (label->defined == ST_LABEL_UNKNOWN)
8194 gfc_error ("Label %d referenced at %L is never defined", label->value,
8199 if (label->defined != ST_LABEL_TARGET)
8201 gfc_error ("Statement at %L is not a valid branch target statement "
8202 "for the branch statement at %L", &label->where, &code->loc);
8206 /* Step two: make sure this branch is not a branch to itself ;-) */
8208 if (code->here == label)
8210 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8214 /* Step three: See if the label is in the same block as the
8215 branching statement. The hard work has been done by setting up
8216 the bitmap reachable_labels. */
8218 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8220 /* Check now whether there is a CRITICAL construct; if so, check
8221 whether the label is still visible outside of the CRITICAL block,
8222 which is invalid. */
8223 for (stack = cs_base; stack; stack = stack->prev)
8224 if (stack->current->op == EXEC_CRITICAL
8225 && bitmap_bit_p (stack->reachable_labels, label->value))
8226 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8227 " at %L", &code->loc, &label->where);
8232 /* Step four: If we haven't found the label in the bitmap, it may
8233 still be the label of the END of the enclosing block, in which
8234 case we find it by going up the code_stack. */
8236 for (stack = cs_base; stack; stack = stack->prev)
8238 if (stack->current->next && stack->current->next->here == label)
8240 if (stack->current->op == EXEC_CRITICAL)
8242 /* Note: A label at END CRITICAL does not leave the CRITICAL
8243 construct as END CRITICAL is still part of it. */
8244 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8245 " at %L", &code->loc, &label->where);
8252 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8256 /* The label is not in an enclosing block, so illegal. This was
8257 allowed in Fortran 66, so we allow it as extension. No
8258 further checks are necessary in this case. */
8259 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8260 "as the GOTO statement at %L", &label->where,
8266 /* Check whether EXPR1 has the same shape as EXPR2. */
8269 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8271 mpz_t shape[GFC_MAX_DIMENSIONS];
8272 mpz_t shape2[GFC_MAX_DIMENSIONS];
8273 gfc_try result = FAILURE;
8276 /* Compare the rank. */
8277 if (expr1->rank != expr2->rank)
8280 /* Compare the size of each dimension. */
8281 for (i=0; i<expr1->rank; i++)
8283 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8286 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8289 if (mpz_cmp (shape[i], shape2[i]))
8293 /* When either of the two expression is an assumed size array, we
8294 ignore the comparison of dimension sizes. */
8299 for (i--; i >= 0; i--)
8301 mpz_clear (shape[i]);
8302 mpz_clear (shape2[i]);
8308 /* Check whether a WHERE assignment target or a WHERE mask expression
8309 has the same shape as the outmost WHERE mask expression. */
8312 resolve_where (gfc_code *code, gfc_expr *mask)
8318 cblock = code->block;
8320 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8321 In case of nested WHERE, only the outmost one is stored. */
8322 if (mask == NULL) /* outmost WHERE */
8324 else /* inner WHERE */
8331 /* Check if the mask-expr has a consistent shape with the
8332 outmost WHERE mask-expr. */
8333 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8334 gfc_error ("WHERE mask at %L has inconsistent shape",
8335 &cblock->expr1->where);
8338 /* the assignment statement of a WHERE statement, or the first
8339 statement in where-body-construct of a WHERE construct */
8340 cnext = cblock->next;
8345 /* WHERE assignment statement */
8348 /* Check shape consistent for WHERE assignment target. */
8349 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8350 gfc_error ("WHERE assignment target at %L has "
8351 "inconsistent shape", &cnext->expr1->where);
8355 case EXEC_ASSIGN_CALL:
8356 resolve_call (cnext);
8357 if (!cnext->resolved_sym->attr.elemental)
8358 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8359 &cnext->ext.actual->expr->where);
8362 /* WHERE or WHERE construct is part of a where-body-construct */
8364 resolve_where (cnext, e);
8368 gfc_error ("Unsupported statement inside WHERE at %L",
8371 /* the next statement within the same where-body-construct */
8372 cnext = cnext->next;
8374 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8375 cblock = cblock->block;
8380 /* Resolve assignment in FORALL construct.
8381 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8382 FORALL index variables. */
8385 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8389 for (n = 0; n < nvar; n++)
8391 gfc_symbol *forall_index;
8393 forall_index = var_expr[n]->symtree->n.sym;
8395 /* Check whether the assignment target is one of the FORALL index
8397 if ((code->expr1->expr_type == EXPR_VARIABLE)
8398 && (code->expr1->symtree->n.sym == forall_index))
8399 gfc_error ("Assignment to a FORALL index variable at %L",
8400 &code->expr1->where);
8403 /* If one of the FORALL index variables doesn't appear in the
8404 assignment variable, then there could be a many-to-one
8405 assignment. Emit a warning rather than an error because the
8406 mask could be resolving this problem. */
8407 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8408 gfc_warning ("The FORALL with index '%s' is not used on the "
8409 "left side of the assignment at %L and so might "
8410 "cause multiple assignment to this object",
8411 var_expr[n]->symtree->name, &code->expr1->where);
8417 /* Resolve WHERE statement in FORALL construct. */
8420 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8421 gfc_expr **var_expr)
8426 cblock = code->block;
8429 /* the assignment statement of a WHERE statement, or the first
8430 statement in where-body-construct of a WHERE construct */
8431 cnext = cblock->next;
8436 /* WHERE assignment statement */
8438 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8441 /* WHERE operator assignment statement */
8442 case EXEC_ASSIGN_CALL:
8443 resolve_call (cnext);
8444 if (!cnext->resolved_sym->attr.elemental)
8445 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8446 &cnext->ext.actual->expr->where);
8449 /* WHERE or WHERE construct is part of a where-body-construct */
8451 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8455 gfc_error ("Unsupported statement inside WHERE at %L",
8458 /* the next statement within the same where-body-construct */
8459 cnext = cnext->next;
8461 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8462 cblock = cblock->block;
8467 /* Traverse the FORALL body to check whether the following errors exist:
8468 1. For assignment, check if a many-to-one assignment happens.
8469 2. For WHERE statement, check the WHERE body to see if there is any
8470 many-to-one assignment. */
8473 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8477 c = code->block->next;
8483 case EXEC_POINTER_ASSIGN:
8484 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8487 case EXEC_ASSIGN_CALL:
8491 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8492 there is no need to handle it here. */
8496 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8501 /* The next statement in the FORALL body. */
8507 /* Counts the number of iterators needed inside a forall construct, including
8508 nested forall constructs. This is used to allocate the needed memory
8509 in gfc_resolve_forall. */
8512 gfc_count_forall_iterators (gfc_code *code)
8514 int max_iters, sub_iters, current_iters;
8515 gfc_forall_iterator *fa;
8517 gcc_assert(code->op == EXEC_FORALL);
8521 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8524 code = code->block->next;
8528 if (code->op == EXEC_FORALL)
8530 sub_iters = gfc_count_forall_iterators (code);
8531 if (sub_iters > max_iters)
8532 max_iters = sub_iters;
8537 return current_iters + max_iters;
8541 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8542 gfc_resolve_forall_body to resolve the FORALL body. */
8545 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8547 static gfc_expr **var_expr;
8548 static int total_var = 0;
8549 static int nvar = 0;
8551 gfc_forall_iterator *fa;
8556 /* Start to resolve a FORALL construct */
8557 if (forall_save == 0)
8559 /* Count the total number of FORALL index in the nested FORALL
8560 construct in order to allocate the VAR_EXPR with proper size. */
8561 total_var = gfc_count_forall_iterators (code);
8563 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8564 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8567 /* The information about FORALL iterator, including FORALL index start, end
8568 and stride. The FORALL index can not appear in start, end or stride. */
8569 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8571 /* Check if any outer FORALL index name is the same as the current
8573 for (i = 0; i < nvar; i++)
8575 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8577 gfc_error ("An outer FORALL construct already has an index "
8578 "with this name %L", &fa->var->where);
8582 /* Record the current FORALL index. */
8583 var_expr[nvar] = gfc_copy_expr (fa->var);
8587 /* No memory leak. */
8588 gcc_assert (nvar <= total_var);
8591 /* Resolve the FORALL body. */
8592 gfc_resolve_forall_body (code, nvar, var_expr);
8594 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8595 gfc_resolve_blocks (code->block, ns);
8599 /* Free only the VAR_EXPRs allocated in this frame. */
8600 for (i = nvar; i < tmp; i++)
8601 gfc_free_expr (var_expr[i]);
8605 /* We are in the outermost FORALL construct. */
8606 gcc_assert (forall_save == 0);
8608 /* VAR_EXPR is not needed any more. */
8609 gfc_free (var_expr);
8615 /* Resolve a BLOCK construct statement. */
8618 resolve_block_construct (gfc_code* code)
8620 /* Resolve the BLOCK's namespace. */
8621 gfc_resolve (code->ext.block.ns);
8623 /* For an ASSOCIATE block, the associations (and their targets) are already
8624 resolved during resolve_symbol. */
8628 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8631 static void resolve_code (gfc_code *, gfc_namespace *);
8634 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8638 for (; b; b = b->block)
8640 t = gfc_resolve_expr (b->expr1);
8641 if (gfc_resolve_expr (b->expr2) == FAILURE)
8647 if (t == SUCCESS && b->expr1 != NULL
8648 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8649 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8656 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8657 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8662 resolve_branch (b->label1, b);
8666 resolve_block_construct (b);
8670 case EXEC_SELECT_TYPE:
8681 case EXEC_OMP_ATOMIC:
8682 case EXEC_OMP_CRITICAL:
8684 case EXEC_OMP_MASTER:
8685 case EXEC_OMP_ORDERED:
8686 case EXEC_OMP_PARALLEL:
8687 case EXEC_OMP_PARALLEL_DO:
8688 case EXEC_OMP_PARALLEL_SECTIONS:
8689 case EXEC_OMP_PARALLEL_WORKSHARE:
8690 case EXEC_OMP_SECTIONS:
8691 case EXEC_OMP_SINGLE:
8693 case EXEC_OMP_TASKWAIT:
8694 case EXEC_OMP_WORKSHARE:
8698 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8701 resolve_code (b->next, ns);
8706 /* Does everything to resolve an ordinary assignment. Returns true
8707 if this is an interface assignment. */
8709 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8719 if (gfc_extend_assign (code, ns) == SUCCESS)
8723 if (code->op == EXEC_ASSIGN_CALL)
8725 lhs = code->ext.actual->expr;
8726 rhsptr = &code->ext.actual->next->expr;
8730 gfc_actual_arglist* args;
8731 gfc_typebound_proc* tbp;
8733 gcc_assert (code->op == EXEC_COMPCALL);
8735 args = code->expr1->value.compcall.actual;
8737 rhsptr = &args->next->expr;
8739 tbp = code->expr1->value.compcall.tbp;
8740 gcc_assert (!tbp->is_generic);
8743 /* Make a temporary rhs when there is a default initializer
8744 and rhs is the same symbol as the lhs. */
8745 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8746 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8747 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8748 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8749 *rhsptr = gfc_get_parentheses (*rhsptr);
8758 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8759 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8760 &code->loc) == FAILURE)
8763 /* Handle the case of a BOZ literal on the RHS. */
8764 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8767 if (gfc_option.warn_surprising)
8768 gfc_warning ("BOZ literal at %L is bitwise transferred "
8769 "non-integer symbol '%s'", &code->loc,
8770 lhs->symtree->n.sym->name);
8772 if (!gfc_convert_boz (rhs, &lhs->ts))
8774 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8776 if (rc == ARITH_UNDERFLOW)
8777 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8778 ". This check can be disabled with the option "
8779 "-fno-range-check", &rhs->where);
8780 else if (rc == ARITH_OVERFLOW)
8781 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8782 ". This check can be disabled with the option "
8783 "-fno-range-check", &rhs->where);
8784 else if (rc == ARITH_NAN)
8785 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8786 ". This check can be disabled with the option "
8787 "-fno-range-check", &rhs->where);
8792 if (lhs->ts.type == BT_CHARACTER
8793 && gfc_option.warn_character_truncation)
8795 if (lhs->ts.u.cl != NULL
8796 && lhs->ts.u.cl->length != NULL
8797 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8798 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8800 if (rhs->expr_type == EXPR_CONSTANT)
8801 rlen = rhs->value.character.length;
8803 else if (rhs->ts.u.cl != NULL
8804 && rhs->ts.u.cl->length != NULL
8805 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8806 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8808 if (rlen && llen && rlen > llen)
8809 gfc_warning_now ("CHARACTER expression will be truncated "
8810 "in assignment (%d/%d) at %L",
8811 llen, rlen, &code->loc);
8814 /* Ensure that a vector index expression for the lvalue is evaluated
8815 to a temporary if the lvalue symbol is referenced in it. */
8818 for (ref = lhs->ref; ref; ref= ref->next)
8819 if (ref->type == REF_ARRAY)
8821 for (n = 0; n < ref->u.ar.dimen; n++)
8822 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8823 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8824 ref->u.ar.start[n]))
8826 = gfc_get_parentheses (ref->u.ar.start[n]);
8830 if (gfc_pure (NULL))
8832 if (lhs->ts.type == BT_DERIVED
8833 && lhs->expr_type == EXPR_VARIABLE
8834 && lhs->ts.u.derived->attr.pointer_comp
8835 && rhs->expr_type == EXPR_VARIABLE
8836 && (gfc_impure_variable (rhs->symtree->n.sym)
8837 || gfc_is_coindexed (rhs)))
8840 if (gfc_is_coindexed (rhs))
8841 gfc_error ("Coindexed expression at %L is assigned to "
8842 "a derived type variable with a POINTER "
8843 "component in a PURE procedure",
8846 gfc_error ("The impure variable at %L is assigned to "
8847 "a derived type variable with a POINTER "
8848 "component in a PURE procedure (12.6)",
8853 /* Fortran 2008, C1283. */
8854 if (gfc_is_coindexed (lhs))
8856 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8857 "procedure", &rhs->where);
8862 if (gfc_implicit_pure (NULL))
8864 if (lhs->expr_type == EXPR_VARIABLE
8865 && lhs->symtree->n.sym != gfc_current_ns->proc_name
8866 && lhs->symtree->n.sym->ns != gfc_current_ns)
8867 gfc_current_ns->proc_name->attr.implicit_pure = 0;
8869 if (lhs->ts.type == BT_DERIVED
8870 && lhs->expr_type == EXPR_VARIABLE
8871 && lhs->ts.u.derived->attr.pointer_comp
8872 && rhs->expr_type == EXPR_VARIABLE
8873 && (gfc_impure_variable (rhs->symtree->n.sym)
8874 || gfc_is_coindexed (rhs)))
8875 gfc_current_ns->proc_name->attr.implicit_pure = 0;
8877 /* Fortran 2008, C1283. */
8878 if (gfc_is_coindexed (lhs))
8879 gfc_current_ns->proc_name->attr.implicit_pure = 0;
8883 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8884 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8885 if (lhs->ts.type == BT_CLASS)
8887 gfc_error ("Variable must not be polymorphic in assignment at %L",
8892 /* F2008, Section 7.2.1.2. */
8893 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8895 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8896 "component in assignment at %L", &lhs->where);
8900 gfc_check_assign (lhs, rhs, 1);
8905 /* Given a block of code, recursively resolve everything pointed to by this
8909 resolve_code (gfc_code *code, gfc_namespace *ns)
8911 int omp_workshare_save;
8916 frame.prev = cs_base;
8920 find_reachable_labels (code);
8922 for (; code; code = code->next)
8924 frame.current = code;
8925 forall_save = forall_flag;
8927 if (code->op == EXEC_FORALL)
8930 gfc_resolve_forall (code, ns, forall_save);
8933 else if (code->block)
8935 omp_workshare_save = -1;
8938 case EXEC_OMP_PARALLEL_WORKSHARE:
8939 omp_workshare_save = omp_workshare_flag;
8940 omp_workshare_flag = 1;
8941 gfc_resolve_omp_parallel_blocks (code, ns);
8943 case EXEC_OMP_PARALLEL:
8944 case EXEC_OMP_PARALLEL_DO:
8945 case EXEC_OMP_PARALLEL_SECTIONS:
8947 omp_workshare_save = omp_workshare_flag;
8948 omp_workshare_flag = 0;
8949 gfc_resolve_omp_parallel_blocks (code, ns);
8952 gfc_resolve_omp_do_blocks (code, ns);
8954 case EXEC_SELECT_TYPE:
8955 /* Blocks are handled in resolve_select_type because we have
8956 to transform the SELECT TYPE into ASSOCIATE first. */
8958 case EXEC_OMP_WORKSHARE:
8959 omp_workshare_save = omp_workshare_flag;
8960 omp_workshare_flag = 1;
8963 gfc_resolve_blocks (code->block, ns);
8967 if (omp_workshare_save != -1)
8968 omp_workshare_flag = omp_workshare_save;
8972 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8973 t = gfc_resolve_expr (code->expr1);
8974 forall_flag = forall_save;
8976 if (gfc_resolve_expr (code->expr2) == FAILURE)
8979 if (code->op == EXEC_ALLOCATE
8980 && gfc_resolve_expr (code->expr3) == FAILURE)
8986 case EXEC_END_BLOCK:
8990 case EXEC_ERROR_STOP:
8994 case EXEC_ASSIGN_CALL:
8999 case EXEC_SYNC_IMAGES:
9000 case EXEC_SYNC_MEMORY:
9001 resolve_sync (code);
9005 /* Keep track of which entry we are up to. */
9006 current_entry_id = code->ext.entry->id;
9010 resolve_where (code, NULL);
9014 if (code->expr1 != NULL)
9016 if (code->expr1->ts.type != BT_INTEGER)
9017 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9018 "INTEGER variable", &code->expr1->where);
9019 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9020 gfc_error ("Variable '%s' has not been assigned a target "
9021 "label at %L", code->expr1->symtree->n.sym->name,
9022 &code->expr1->where);
9025 resolve_branch (code->label1, code);
9029 if (code->expr1 != NULL
9030 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9031 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9032 "INTEGER return specifier", &code->expr1->where);
9035 case EXEC_INIT_ASSIGN:
9036 case EXEC_END_PROCEDURE:
9043 if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
9047 if (resolve_ordinary_assign (code, ns))
9049 if (code->op == EXEC_COMPCALL)
9056 case EXEC_LABEL_ASSIGN:
9057 if (code->label1->defined == ST_LABEL_UNKNOWN)
9058 gfc_error ("Label %d referenced at %L is never defined",
9059 code->label1->value, &code->label1->where);
9061 && (code->expr1->expr_type != EXPR_VARIABLE
9062 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9063 || code->expr1->symtree->n.sym->ts.kind
9064 != gfc_default_integer_kind
9065 || code->expr1->symtree->n.sym->as != NULL))
9066 gfc_error ("ASSIGN statement at %L requires a scalar "
9067 "default INTEGER variable", &code->expr1->where);
9070 case EXEC_POINTER_ASSIGN:
9077 /* This is both a variable definition and pointer assignment
9078 context, so check both of them. For rank remapping, a final
9079 array ref may be present on the LHS and fool gfc_expr_attr
9080 used in gfc_check_vardef_context. Remove it. */
9081 e = remove_last_array_ref (code->expr1);
9082 t = gfc_check_vardef_context (e, true, _("pointer assignment"));
9084 t = gfc_check_vardef_context (e, false, _("pointer assignment"));
9089 gfc_check_pointer_assign (code->expr1, code->expr2);
9093 case EXEC_ARITHMETIC_IF:
9095 && code->expr1->ts.type != BT_INTEGER
9096 && code->expr1->ts.type != BT_REAL)
9097 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9098 "expression", &code->expr1->where);
9100 resolve_branch (code->label1, code);
9101 resolve_branch (code->label2, code);
9102 resolve_branch (code->label3, code);
9106 if (t == SUCCESS && code->expr1 != NULL
9107 && (code->expr1->ts.type != BT_LOGICAL
9108 || code->expr1->rank != 0))
9109 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9110 &code->expr1->where);
9115 resolve_call (code);
9120 resolve_typebound_subroutine (code);
9124 resolve_ppc_call (code);
9128 /* Select is complicated. Also, a SELECT construct could be
9129 a transformed computed GOTO. */
9130 resolve_select (code);
9133 case EXEC_SELECT_TYPE:
9134 resolve_select_type (code, ns);
9138 resolve_block_construct (code);
9142 if (code->ext.iterator != NULL)
9144 gfc_iterator *iter = code->ext.iterator;
9145 if (gfc_resolve_iterator (iter, true) != FAILURE)
9146 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9151 if (code->expr1 == NULL)
9152 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9154 && (code->expr1->rank != 0
9155 || code->expr1->ts.type != BT_LOGICAL))
9156 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9157 "a scalar LOGICAL expression", &code->expr1->where);
9162 resolve_allocate_deallocate (code, "ALLOCATE");
9166 case EXEC_DEALLOCATE:
9168 resolve_allocate_deallocate (code, "DEALLOCATE");
9173 if (gfc_resolve_open (code->ext.open) == FAILURE)
9176 resolve_branch (code->ext.open->err, code);
9180 if (gfc_resolve_close (code->ext.close) == FAILURE)
9183 resolve_branch (code->ext.close->err, code);
9186 case EXEC_BACKSPACE:
9190 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9193 resolve_branch (code->ext.filepos->err, code);
9197 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9200 resolve_branch (code->ext.inquire->err, code);
9204 gcc_assert (code->ext.inquire != NULL);
9205 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9208 resolve_branch (code->ext.inquire->err, code);
9212 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9215 resolve_branch (code->ext.wait->err, code);
9216 resolve_branch (code->ext.wait->end, code);
9217 resolve_branch (code->ext.wait->eor, code);
9222 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9225 resolve_branch (code->ext.dt->err, code);
9226 resolve_branch (code->ext.dt->end, code);
9227 resolve_branch (code->ext.dt->eor, code);
9231 resolve_transfer (code);
9235 resolve_forall_iterators (code->ext.forall_iterator);
9237 if (code->expr1 != NULL
9238 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9239 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9240 "expression", &code->expr1->where);
9243 case EXEC_OMP_ATOMIC:
9244 case EXEC_OMP_BARRIER:
9245 case EXEC_OMP_CRITICAL:
9246 case EXEC_OMP_FLUSH:
9248 case EXEC_OMP_MASTER:
9249 case EXEC_OMP_ORDERED:
9250 case EXEC_OMP_SECTIONS:
9251 case EXEC_OMP_SINGLE:
9252 case EXEC_OMP_TASKWAIT:
9253 case EXEC_OMP_WORKSHARE:
9254 gfc_resolve_omp_directive (code, ns);
9257 case EXEC_OMP_PARALLEL:
9258 case EXEC_OMP_PARALLEL_DO:
9259 case EXEC_OMP_PARALLEL_SECTIONS:
9260 case EXEC_OMP_PARALLEL_WORKSHARE:
9262 omp_workshare_save = omp_workshare_flag;
9263 omp_workshare_flag = 0;
9264 gfc_resolve_omp_directive (code, ns);
9265 omp_workshare_flag = omp_workshare_save;
9269 gfc_internal_error ("resolve_code(): Bad statement code");
9273 cs_base = frame.prev;
9277 /* Resolve initial values and make sure they are compatible with
9281 resolve_values (gfc_symbol *sym)
9285 if (sym->value == NULL)
9288 if (sym->value->expr_type == EXPR_STRUCTURE)
9289 t= resolve_structure_cons (sym->value, 1);
9291 t = gfc_resolve_expr (sym->value);
9296 gfc_check_assign_symbol (sym, sym->value);
9300 /* Verify the binding labels for common blocks that are BIND(C). The label
9301 for a BIND(C) common block must be identical in all scoping units in which
9302 the common block is declared. Further, the binding label can not collide
9303 with any other global entity in the program. */
9306 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9308 if (comm_block_tree->n.common->is_bind_c == 1)
9310 gfc_gsymbol *binding_label_gsym;
9311 gfc_gsymbol *comm_name_gsym;
9313 /* See if a global symbol exists by the common block's name. It may
9314 be NULL if the common block is use-associated. */
9315 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9316 comm_block_tree->n.common->name);
9317 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9318 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9319 "with the global entity '%s' at %L",
9320 comm_block_tree->n.common->binding_label,
9321 comm_block_tree->n.common->name,
9322 &(comm_block_tree->n.common->where),
9323 comm_name_gsym->name, &(comm_name_gsym->where));
9324 else if (comm_name_gsym != NULL
9325 && strcmp (comm_name_gsym->name,
9326 comm_block_tree->n.common->name) == 0)
9328 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9330 if (comm_name_gsym->binding_label == NULL)
9331 /* No binding label for common block stored yet; save this one. */
9332 comm_name_gsym->binding_label =
9333 comm_block_tree->n.common->binding_label;
9335 if (strcmp (comm_name_gsym->binding_label,
9336 comm_block_tree->n.common->binding_label) != 0)
9338 /* Common block names match but binding labels do not. */
9339 gfc_error ("Binding label '%s' for common block '%s' at %L "
9340 "does not match the binding label '%s' for common "
9342 comm_block_tree->n.common->binding_label,
9343 comm_block_tree->n.common->name,
9344 &(comm_block_tree->n.common->where),
9345 comm_name_gsym->binding_label,
9346 comm_name_gsym->name,
9347 &(comm_name_gsym->where));
9352 /* There is no binding label (NAME="") so we have nothing further to
9353 check and nothing to add as a global symbol for the label. */
9354 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9357 binding_label_gsym =
9358 gfc_find_gsymbol (gfc_gsym_root,
9359 comm_block_tree->n.common->binding_label);
9360 if (binding_label_gsym == NULL)
9362 /* Need to make a global symbol for the binding label to prevent
9363 it from colliding with another. */
9364 binding_label_gsym =
9365 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9366 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9367 binding_label_gsym->type = GSYM_COMMON;
9371 /* If comm_name_gsym is NULL, the name common block is use
9372 associated and the name could be colliding. */
9373 if (binding_label_gsym->type != GSYM_COMMON)
9374 gfc_error ("Binding label '%s' for common block '%s' at %L "
9375 "collides with the global entity '%s' at %L",
9376 comm_block_tree->n.common->binding_label,
9377 comm_block_tree->n.common->name,
9378 &(comm_block_tree->n.common->where),
9379 binding_label_gsym->name,
9380 &(binding_label_gsym->where));
9381 else if (comm_name_gsym != NULL
9382 && (strcmp (binding_label_gsym->name,
9383 comm_name_gsym->binding_label) != 0)
9384 && (strcmp (binding_label_gsym->sym_name,
9385 comm_name_gsym->name) != 0))
9386 gfc_error ("Binding label '%s' for common block '%s' at %L "
9387 "collides with global entity '%s' at %L",
9388 binding_label_gsym->name, binding_label_gsym->sym_name,
9389 &(comm_block_tree->n.common->where),
9390 comm_name_gsym->name, &(comm_name_gsym->where));
9398 /* Verify any BIND(C) derived types in the namespace so we can report errors
9399 for them once, rather than for each variable declared of that type. */
9402 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9404 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9405 && derived_sym->attr.is_bind_c == 1)
9406 verify_bind_c_derived_type (derived_sym);
9412 /* Verify that any binding labels used in a given namespace do not collide
9413 with the names or binding labels of any global symbols. */
9416 gfc_verify_binding_labels (gfc_symbol *sym)
9420 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9421 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9423 gfc_gsymbol *bind_c_sym;
9425 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9426 if (bind_c_sym != NULL
9427 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9429 if (sym->attr.if_source == IFSRC_DECL
9430 && (bind_c_sym->type != GSYM_SUBROUTINE
9431 && bind_c_sym->type != GSYM_FUNCTION)
9432 && ((sym->attr.contained == 1
9433 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9434 || (sym->attr.use_assoc == 1
9435 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9437 /* Make sure global procedures don't collide with anything. */
9438 gfc_error ("Binding label '%s' at %L collides with the global "
9439 "entity '%s' at %L", sym->binding_label,
9440 &(sym->declared_at), bind_c_sym->name,
9441 &(bind_c_sym->where));
9444 else if (sym->attr.contained == 0
9445 && (sym->attr.if_source == IFSRC_IFBODY
9446 && sym->attr.flavor == FL_PROCEDURE)
9447 && (bind_c_sym->sym_name != NULL
9448 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9450 /* Make sure procedures in interface bodies don't collide. */
9451 gfc_error ("Binding label '%s' in interface body at %L collides "
9452 "with the global entity '%s' at %L",
9454 &(sym->declared_at), bind_c_sym->name,
9455 &(bind_c_sym->where));
9458 else if (sym->attr.contained == 0
9459 && sym->attr.if_source == IFSRC_UNKNOWN)
9460 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9461 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9462 || sym->attr.use_assoc == 0)
9464 gfc_error ("Binding label '%s' at %L collides with global "
9465 "entity '%s' at %L", sym->binding_label,
9466 &(sym->declared_at), bind_c_sym->name,
9467 &(bind_c_sym->where));
9472 /* Clear the binding label to prevent checking multiple times. */
9473 sym->binding_label[0] = '\0';
9475 else if (bind_c_sym == NULL)
9477 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9478 bind_c_sym->where = sym->declared_at;
9479 bind_c_sym->sym_name = sym->name;
9481 if (sym->attr.use_assoc == 1)
9482 bind_c_sym->mod_name = sym->module;
9484 if (sym->ns->proc_name != NULL)
9485 bind_c_sym->mod_name = sym->ns->proc_name->name;
9487 if (sym->attr.contained == 0)
9489 if (sym->attr.subroutine)
9490 bind_c_sym->type = GSYM_SUBROUTINE;
9491 else if (sym->attr.function)
9492 bind_c_sym->type = GSYM_FUNCTION;
9500 /* Resolve an index expression. */
9503 resolve_index_expr (gfc_expr *e)
9505 if (gfc_resolve_expr (e) == FAILURE)
9508 if (gfc_simplify_expr (e, 0) == FAILURE)
9511 if (gfc_specification_expr (e) == FAILURE)
9518 /* Resolve a charlen structure. */
9521 resolve_charlen (gfc_charlen *cl)
9530 specification_expr = 1;
9532 if (resolve_index_expr (cl->length) == FAILURE)
9534 specification_expr = 0;
9538 /* "If the character length parameter value evaluates to a negative
9539 value, the length of character entities declared is zero." */
9540 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9542 if (gfc_option.warn_surprising)
9543 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9544 " the length has been set to zero",
9545 &cl->length->where, i);
9546 gfc_replace_expr (cl->length,
9547 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9550 /* Check that the character length is not too large. */
9551 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9552 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9553 && cl->length->ts.type == BT_INTEGER
9554 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9556 gfc_error ("String length at %L is too large", &cl->length->where);
9564 /* Test for non-constant shape arrays. */
9567 is_non_constant_shape_array (gfc_symbol *sym)
9573 not_constant = false;
9574 if (sym->as != NULL)
9576 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9577 has not been simplified; parameter array references. Do the
9578 simplification now. */
9579 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9581 e = sym->as->lower[i];
9582 if (e && (resolve_index_expr (e) == FAILURE
9583 || !gfc_is_constant_expr (e)))
9584 not_constant = true;
9585 e = sym->as->upper[i];
9586 if (e && (resolve_index_expr (e) == FAILURE
9587 || !gfc_is_constant_expr (e)))
9588 not_constant = true;
9591 return not_constant;
9594 /* Given a symbol and an initialization expression, add code to initialize
9595 the symbol to the function entry. */
9597 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9601 gfc_namespace *ns = sym->ns;
9603 /* Search for the function namespace if this is a contained
9604 function without an explicit result. */
9605 if (sym->attr.function && sym == sym->result
9606 && sym->name != sym->ns->proc_name->name)
9609 for (;ns; ns = ns->sibling)
9610 if (strcmp (ns->proc_name->name, sym->name) == 0)
9616 gfc_free_expr (init);
9620 /* Build an l-value expression for the result. */
9621 lval = gfc_lval_expr_from_sym (sym);
9623 /* Add the code at scope entry. */
9624 init_st = gfc_get_code ();
9625 init_st->next = ns->code;
9628 /* Assign the default initializer to the l-value. */
9629 init_st->loc = sym->declared_at;
9630 init_st->op = EXEC_INIT_ASSIGN;
9631 init_st->expr1 = lval;
9632 init_st->expr2 = init;
9635 /* Assign the default initializer to a derived type variable or result. */
9638 apply_default_init (gfc_symbol *sym)
9640 gfc_expr *init = NULL;
9642 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9645 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9646 init = gfc_default_initializer (&sym->ts);
9648 if (init == NULL && sym->ts.type != BT_CLASS)
9651 build_init_assign (sym, init);
9652 sym->attr.referenced = 1;
9655 /* Build an initializer for a local integer, real, complex, logical, or
9656 character variable, based on the command line flags finit-local-zero,
9657 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9658 null if the symbol should not have a default initialization. */
9660 build_default_init_expr (gfc_symbol *sym)
9663 gfc_expr *init_expr;
9666 /* These symbols should never have a default initialization. */
9667 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9668 || sym->attr.external
9670 || sym->attr.pointer
9671 || sym->attr.in_equivalence
9672 || sym->attr.in_common
9675 || sym->attr.cray_pointee
9676 || sym->attr.cray_pointer)
9679 /* Now we'll try to build an initializer expression. */
9680 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9683 /* We will only initialize integers, reals, complex, logicals, and
9684 characters, and only if the corresponding command-line flags
9685 were set. Otherwise, we free init_expr and return null. */
9686 switch (sym->ts.type)
9689 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9690 mpz_set_si (init_expr->value.integer,
9691 gfc_option.flag_init_integer_value);
9694 gfc_free_expr (init_expr);
9700 switch (gfc_option.flag_init_real)
9702 case GFC_INIT_REAL_SNAN:
9703 init_expr->is_snan = 1;
9705 case GFC_INIT_REAL_NAN:
9706 mpfr_set_nan (init_expr->value.real);
9709 case GFC_INIT_REAL_INF:
9710 mpfr_set_inf (init_expr->value.real, 1);
9713 case GFC_INIT_REAL_NEG_INF:
9714 mpfr_set_inf (init_expr->value.real, -1);
9717 case GFC_INIT_REAL_ZERO:
9718 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9722 gfc_free_expr (init_expr);
9729 switch (gfc_option.flag_init_real)
9731 case GFC_INIT_REAL_SNAN:
9732 init_expr->is_snan = 1;
9734 case GFC_INIT_REAL_NAN:
9735 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9736 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9739 case GFC_INIT_REAL_INF:
9740 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9741 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9744 case GFC_INIT_REAL_NEG_INF:
9745 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9746 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9749 case GFC_INIT_REAL_ZERO:
9750 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9754 gfc_free_expr (init_expr);
9761 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9762 init_expr->value.logical = 0;
9763 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9764 init_expr->value.logical = 1;
9767 gfc_free_expr (init_expr);
9773 /* For characters, the length must be constant in order to
9774 create a default initializer. */
9775 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9776 && sym->ts.u.cl->length
9777 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9779 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9780 init_expr->value.character.length = char_len;
9781 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9782 for (i = 0; i < char_len; i++)
9783 init_expr->value.character.string[i]
9784 = (unsigned char) gfc_option.flag_init_character_value;
9788 gfc_free_expr (init_expr);
9794 gfc_free_expr (init_expr);
9800 /* Add an initialization expression to a local variable. */
9802 apply_default_init_local (gfc_symbol *sym)
9804 gfc_expr *init = NULL;
9806 /* The symbol should be a variable or a function return value. */
9807 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9808 || (sym->attr.function && sym->result != sym))
9811 /* Try to build the initializer expression. If we can't initialize
9812 this symbol, then init will be NULL. */
9813 init = build_default_init_expr (sym);
9817 /* For saved variables, we don't want to add an initializer at
9818 function entry, so we just add a static initializer. */
9819 if (sym->attr.save || sym->ns->save_all
9820 || gfc_option.flag_max_stack_var_size == 0)
9822 /* Don't clobber an existing initializer! */
9823 gcc_assert (sym->value == NULL);
9828 build_init_assign (sym, init);
9832 /* Resolution of common features of flavors variable and procedure. */
9835 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9837 /* Constraints on deferred shape variable. */
9838 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9840 if (sym->attr.allocatable)
9842 if (sym->attr.dimension)
9844 gfc_error ("Allocatable array '%s' at %L must have "
9845 "a deferred shape", sym->name, &sym->declared_at);
9848 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9849 "may not be ALLOCATABLE", sym->name,
9850 &sym->declared_at) == FAILURE)
9854 if (sym->attr.pointer && sym->attr.dimension)
9856 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9857 sym->name, &sym->declared_at);
9863 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9864 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9866 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9867 sym->name, &sym->declared_at);
9872 /* Constraints on polymorphic variables. */
9873 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9876 if (sym->attr.class_ok
9877 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9879 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9880 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9886 /* Assume that use associated symbols were checked in the module ns.
9887 Class-variables that are associate-names are also something special
9888 and excepted from the test. */
9889 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9891 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9892 "or pointer", sym->name, &sym->declared_at);
9901 /* Additional checks for symbols with flavor variable and derived
9902 type. To be called from resolve_fl_variable. */
9905 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9907 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9909 /* Check to see if a derived type is blocked from being host
9910 associated by the presence of another class I symbol in the same
9911 namespace. 14.6.1.3 of the standard and the discussion on
9912 comp.lang.fortran. */
9913 if (sym->ns != sym->ts.u.derived->ns
9914 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9917 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9918 if (s && s->attr.flavor != FL_DERIVED)
9920 gfc_error ("The type '%s' cannot be host associated at %L "
9921 "because it is blocked by an incompatible object "
9922 "of the same name declared at %L",
9923 sym->ts.u.derived->name, &sym->declared_at,
9929 /* 4th constraint in section 11.3: "If an object of a type for which
9930 component-initialization is specified (R429) appears in the
9931 specification-part of a module and does not have the ALLOCATABLE
9932 or POINTER attribute, the object shall have the SAVE attribute."
9934 The check for initializers is performed with
9935 gfc_has_default_initializer because gfc_default_initializer generates
9936 a hidden default for allocatable components. */
9937 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9938 && sym->ns->proc_name->attr.flavor == FL_MODULE
9939 && !sym->ns->save_all && !sym->attr.save
9940 && !sym->attr.pointer && !sym->attr.allocatable
9941 && gfc_has_default_initializer (sym->ts.u.derived)
9942 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9943 "module variable '%s' at %L, needed due to "
9944 "the default initialization", sym->name,
9945 &sym->declared_at) == FAILURE)
9948 /* Assign default initializer. */
9949 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9950 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9952 sym->value = gfc_default_initializer (&sym->ts);
9959 /* Resolve symbols with flavor variable. */
9962 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9964 int no_init_flag, automatic_flag;
9966 const char *auto_save_msg;
9968 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9971 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9974 /* Set this flag to check that variables are parameters of all entries.
9975 This check is effected by the call to gfc_resolve_expr through
9976 is_non_constant_shape_array. */
9977 specification_expr = 1;
9979 if (sym->ns->proc_name
9980 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9981 || sym->ns->proc_name->attr.is_main_program)
9982 && !sym->attr.use_assoc
9983 && !sym->attr.allocatable
9984 && !sym->attr.pointer
9985 && is_non_constant_shape_array (sym))
9987 /* The shape of a main program or module array needs to be
9989 gfc_error ("The module or main program array '%s' at %L must "
9990 "have constant shape", sym->name, &sym->declared_at);
9991 specification_expr = 0;
9995 /* Constraints on deferred type parameter. */
9996 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
9998 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
9999 "requires either the pointer or allocatable attribute",
10000 sym->name, &sym->declared_at);
10004 if (sym->ts.type == BT_CHARACTER)
10006 /* Make sure that character string variables with assumed length are
10007 dummy arguments. */
10008 e = sym->ts.u.cl->length;
10009 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10010 && !sym->ts.deferred)
10012 gfc_error ("Entity with assumed character length at %L must be a "
10013 "dummy argument or a PARAMETER", &sym->declared_at);
10017 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10019 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10023 if (!gfc_is_constant_expr (e)
10024 && !(e->expr_type == EXPR_VARIABLE
10025 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
10026 && sym->ns->proc_name
10027 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10028 || sym->ns->proc_name->attr.is_main_program)
10029 && !sym->attr.use_assoc)
10031 gfc_error ("'%s' at %L must have constant character length "
10032 "in this context", sym->name, &sym->declared_at);
10037 if (sym->value == NULL && sym->attr.referenced)
10038 apply_default_init_local (sym); /* Try to apply a default initialization. */
10040 /* Determine if the symbol may not have an initializer. */
10041 no_init_flag = automatic_flag = 0;
10042 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10043 || sym->attr.intrinsic || sym->attr.result)
10045 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10046 && is_non_constant_shape_array (sym))
10048 no_init_flag = automatic_flag = 1;
10050 /* Also, they must not have the SAVE attribute.
10051 SAVE_IMPLICIT is checked below. */
10052 if (sym->attr.save == SAVE_EXPLICIT)
10054 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10059 /* Ensure that any initializer is simplified. */
10061 gfc_simplify_expr (sym->value, 1);
10063 /* Reject illegal initializers. */
10064 if (!sym->mark && sym->value)
10066 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10067 && CLASS_DATA (sym)->attr.allocatable))
10068 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10069 sym->name, &sym->declared_at);
10070 else if (sym->attr.external)
10071 gfc_error ("External '%s' at %L cannot have an initializer",
10072 sym->name, &sym->declared_at);
10073 else if (sym->attr.dummy
10074 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10075 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10076 sym->name, &sym->declared_at);
10077 else if (sym->attr.intrinsic)
10078 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10079 sym->name, &sym->declared_at);
10080 else if (sym->attr.result)
10081 gfc_error ("Function result '%s' at %L cannot have an initializer",
10082 sym->name, &sym->declared_at);
10083 else if (automatic_flag)
10084 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10085 sym->name, &sym->declared_at);
10087 goto no_init_error;
10092 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10093 return resolve_fl_variable_derived (sym, no_init_flag);
10099 /* Resolve a procedure. */
10102 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10104 gfc_formal_arglist *arg;
10106 if (sym->attr.function
10107 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10110 if (sym->ts.type == BT_CHARACTER)
10112 gfc_charlen *cl = sym->ts.u.cl;
10114 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10115 && resolve_charlen (cl) == FAILURE)
10118 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10119 && sym->attr.proc == PROC_ST_FUNCTION)
10121 gfc_error ("Character-valued statement function '%s' at %L must "
10122 "have constant length", sym->name, &sym->declared_at);
10127 /* Ensure that derived type for are not of a private type. Internal
10128 module procedures are excluded by 2.2.3.3 - i.e., they are not
10129 externally accessible and can access all the objects accessible in
10131 if (!(sym->ns->parent
10132 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10133 && gfc_check_access(sym->attr.access, sym->ns->default_access))
10135 gfc_interface *iface;
10137 for (arg = sym->formal; arg; arg = arg->next)
10140 && arg->sym->ts.type == BT_DERIVED
10141 && !arg->sym->ts.u.derived->attr.use_assoc
10142 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10143 arg->sym->ts.u.derived->ns->default_access)
10144 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10145 "PRIVATE type and cannot be a dummy argument"
10146 " of '%s', which is PUBLIC at %L",
10147 arg->sym->name, sym->name, &sym->declared_at)
10150 /* Stop this message from recurring. */
10151 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10156 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10157 PRIVATE to the containing module. */
10158 for (iface = sym->generic; iface; iface = iface->next)
10160 for (arg = iface->sym->formal; arg; arg = arg->next)
10163 && arg->sym->ts.type == BT_DERIVED
10164 && !arg->sym->ts.u.derived->attr.use_assoc
10165 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10166 arg->sym->ts.u.derived->ns->default_access)
10167 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10168 "'%s' in PUBLIC interface '%s' at %L "
10169 "takes dummy arguments of '%s' which is "
10170 "PRIVATE", iface->sym->name, sym->name,
10171 &iface->sym->declared_at,
10172 gfc_typename (&arg->sym->ts)) == FAILURE)
10174 /* Stop this message from recurring. */
10175 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10181 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10182 PRIVATE to the containing module. */
10183 for (iface = sym->generic; iface; iface = iface->next)
10185 for (arg = iface->sym->formal; arg; arg = arg->next)
10188 && arg->sym->ts.type == BT_DERIVED
10189 && !arg->sym->ts.u.derived->attr.use_assoc
10190 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10191 arg->sym->ts.u.derived->ns->default_access)
10192 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10193 "'%s' in PUBLIC interface '%s' at %L "
10194 "takes dummy arguments of '%s' which is "
10195 "PRIVATE", iface->sym->name, sym->name,
10196 &iface->sym->declared_at,
10197 gfc_typename (&arg->sym->ts)) == FAILURE)
10199 /* Stop this message from recurring. */
10200 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10207 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10208 && !sym->attr.proc_pointer)
10210 gfc_error ("Function '%s' at %L cannot have an initializer",
10211 sym->name, &sym->declared_at);
10215 /* An external symbol may not have an initializer because it is taken to be
10216 a procedure. Exception: Procedure Pointers. */
10217 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10219 gfc_error ("External object '%s' at %L may not have an initializer",
10220 sym->name, &sym->declared_at);
10224 /* An elemental function is required to return a scalar 12.7.1 */
10225 if (sym->attr.elemental && sym->attr.function && sym->as)
10227 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10228 "result", sym->name, &sym->declared_at);
10229 /* Reset so that the error only occurs once. */
10230 sym->attr.elemental = 0;
10234 if (sym->attr.proc == PROC_ST_FUNCTION
10235 && (sym->attr.allocatable || sym->attr.pointer))
10237 gfc_error ("Statement function '%s' at %L may not have pointer or "
10238 "allocatable attribute", sym->name, &sym->declared_at);
10242 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10243 char-len-param shall not be array-valued, pointer-valued, recursive
10244 or pure. ....snip... A character value of * may only be used in the
10245 following ways: (i) Dummy arg of procedure - dummy associates with
10246 actual length; (ii) To declare a named constant; or (iii) External
10247 function - but length must be declared in calling scoping unit. */
10248 if (sym->attr.function
10249 && sym->ts.type == BT_CHARACTER
10250 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10252 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10253 || (sym->attr.recursive) || (sym->attr.pure))
10255 if (sym->as && sym->as->rank)
10256 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10257 "array-valued", sym->name, &sym->declared_at);
10259 if (sym->attr.pointer)
10260 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10261 "pointer-valued", sym->name, &sym->declared_at);
10263 if (sym->attr.pure)
10264 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10265 "pure", sym->name, &sym->declared_at);
10267 if (sym->attr.recursive)
10268 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10269 "recursive", sym->name, &sym->declared_at);
10274 /* Appendix B.2 of the standard. Contained functions give an
10275 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10276 character length is an F2003 feature. */
10277 if (!sym->attr.contained
10278 && gfc_current_form != FORM_FIXED
10279 && !sym->ts.deferred)
10280 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10281 "CHARACTER(*) function '%s' at %L",
10282 sym->name, &sym->declared_at);
10285 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10287 gfc_formal_arglist *curr_arg;
10288 int has_non_interop_arg = 0;
10290 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10291 sym->common_block) == FAILURE)
10293 /* Clear these to prevent looking at them again if there was an
10295 sym->attr.is_bind_c = 0;
10296 sym->attr.is_c_interop = 0;
10297 sym->ts.is_c_interop = 0;
10301 /* So far, no errors have been found. */
10302 sym->attr.is_c_interop = 1;
10303 sym->ts.is_c_interop = 1;
10306 curr_arg = sym->formal;
10307 while (curr_arg != NULL)
10309 /* Skip implicitly typed dummy args here. */
10310 if (curr_arg->sym->attr.implicit_type == 0)
10311 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10312 /* If something is found to fail, record the fact so we
10313 can mark the symbol for the procedure as not being
10314 BIND(C) to try and prevent multiple errors being
10316 has_non_interop_arg = 1;
10318 curr_arg = curr_arg->next;
10321 /* See if any of the arguments were not interoperable and if so, clear
10322 the procedure symbol to prevent duplicate error messages. */
10323 if (has_non_interop_arg != 0)
10325 sym->attr.is_c_interop = 0;
10326 sym->ts.is_c_interop = 0;
10327 sym->attr.is_bind_c = 0;
10331 if (!sym->attr.proc_pointer)
10333 if (sym->attr.save == SAVE_EXPLICIT)
10335 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10336 "in '%s' at %L", sym->name, &sym->declared_at);
10339 if (sym->attr.intent)
10341 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10342 "in '%s' at %L", sym->name, &sym->declared_at);
10345 if (sym->attr.subroutine && sym->attr.result)
10347 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10348 "in '%s' at %L", sym->name, &sym->declared_at);
10351 if (sym->attr.external && sym->attr.function
10352 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10353 || sym->attr.contained))
10355 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10356 "in '%s' at %L", sym->name, &sym->declared_at);
10359 if (strcmp ("ppr@", sym->name) == 0)
10361 gfc_error ("Procedure pointer result '%s' at %L "
10362 "is missing the pointer attribute",
10363 sym->ns->proc_name->name, &sym->declared_at);
10372 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10373 been defined and we now know their defined arguments, check that they fulfill
10374 the requirements of the standard for procedures used as finalizers. */
10377 gfc_resolve_finalizers (gfc_symbol* derived)
10379 gfc_finalizer* list;
10380 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10381 gfc_try result = SUCCESS;
10382 bool seen_scalar = false;
10384 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10387 /* Walk over the list of finalizer-procedures, check them, and if any one
10388 does not fit in with the standard's definition, print an error and remove
10389 it from the list. */
10390 prev_link = &derived->f2k_derived->finalizers;
10391 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10397 /* Skip this finalizer if we already resolved it. */
10398 if (list->proc_tree)
10400 prev_link = &(list->next);
10404 /* Check this exists and is a SUBROUTINE. */
10405 if (!list->proc_sym->attr.subroutine)
10407 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10408 list->proc_sym->name, &list->where);
10412 /* We should have exactly one argument. */
10413 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10415 gfc_error ("FINAL procedure at %L must have exactly one argument",
10419 arg = list->proc_sym->formal->sym;
10421 /* This argument must be of our type. */
10422 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10424 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10425 &arg->declared_at, derived->name);
10429 /* It must neither be a pointer nor allocatable nor optional. */
10430 if (arg->attr.pointer)
10432 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10433 &arg->declared_at);
10436 if (arg->attr.allocatable)
10438 gfc_error ("Argument of FINAL procedure at %L must not be"
10439 " ALLOCATABLE", &arg->declared_at);
10442 if (arg->attr.optional)
10444 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10445 &arg->declared_at);
10449 /* It must not be INTENT(OUT). */
10450 if (arg->attr.intent == INTENT_OUT)
10452 gfc_error ("Argument of FINAL procedure at %L must not be"
10453 " INTENT(OUT)", &arg->declared_at);
10457 /* Warn if the procedure is non-scalar and not assumed shape. */
10458 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10459 && arg->as->type != AS_ASSUMED_SHAPE)
10460 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10461 " shape argument", &arg->declared_at);
10463 /* Check that it does not match in kind and rank with a FINAL procedure
10464 defined earlier. To really loop over the *earlier* declarations,
10465 we need to walk the tail of the list as new ones were pushed at the
10467 /* TODO: Handle kind parameters once they are implemented. */
10468 my_rank = (arg->as ? arg->as->rank : 0);
10469 for (i = list->next; i; i = i->next)
10471 /* Argument list might be empty; that is an error signalled earlier,
10472 but we nevertheless continued resolving. */
10473 if (i->proc_sym->formal)
10475 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10476 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10477 if (i_rank == my_rank)
10479 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10480 " rank (%d) as '%s'",
10481 list->proc_sym->name, &list->where, my_rank,
10482 i->proc_sym->name);
10488 /* Is this the/a scalar finalizer procedure? */
10489 if (!arg->as || arg->as->rank == 0)
10490 seen_scalar = true;
10492 /* Find the symtree for this procedure. */
10493 gcc_assert (!list->proc_tree);
10494 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10496 prev_link = &list->next;
10499 /* Remove wrong nodes immediately from the list so we don't risk any
10500 troubles in the future when they might fail later expectations. */
10504 *prev_link = list->next;
10505 gfc_free_finalizer (i);
10508 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10509 were nodes in the list, must have been for arrays. It is surely a good
10510 idea to have a scalar version there if there's something to finalize. */
10511 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10512 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10513 " defined at %L, suggest also scalar one",
10514 derived->name, &derived->declared_at);
10516 /* TODO: Remove this error when finalization is finished. */
10517 gfc_error ("Finalization at %L is not yet implemented",
10518 &derived->declared_at);
10524 /* Check that it is ok for the typebound procedure proc to override the
10528 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10531 const gfc_symbol* proc_target;
10532 const gfc_symbol* old_target;
10533 unsigned proc_pass_arg, old_pass_arg, argpos;
10534 gfc_formal_arglist* proc_formal;
10535 gfc_formal_arglist* old_formal;
10537 /* This procedure should only be called for non-GENERIC proc. */
10538 gcc_assert (!proc->n.tb->is_generic);
10540 /* If the overwritten procedure is GENERIC, this is an error. */
10541 if (old->n.tb->is_generic)
10543 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10544 old->name, &proc->n.tb->where);
10548 where = proc->n.tb->where;
10549 proc_target = proc->n.tb->u.specific->n.sym;
10550 old_target = old->n.tb->u.specific->n.sym;
10552 /* Check that overridden binding is not NON_OVERRIDABLE. */
10553 if (old->n.tb->non_overridable)
10555 gfc_error ("'%s' at %L overrides a procedure binding declared"
10556 " NON_OVERRIDABLE", proc->name, &where);
10560 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10561 if (!old->n.tb->deferred && proc->n.tb->deferred)
10563 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10564 " non-DEFERRED binding", proc->name, &where);
10568 /* If the overridden binding is PURE, the overriding must be, too. */
10569 if (old_target->attr.pure && !proc_target->attr.pure)
10571 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10572 proc->name, &where);
10576 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10577 is not, the overriding must not be either. */
10578 if (old_target->attr.elemental && !proc_target->attr.elemental)
10580 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10581 " ELEMENTAL", proc->name, &where);
10584 if (!old_target->attr.elemental && proc_target->attr.elemental)
10586 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10587 " be ELEMENTAL, either", proc->name, &where);
10591 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10593 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10595 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10596 " SUBROUTINE", proc->name, &where);
10600 /* If the overridden binding is a FUNCTION, the overriding must also be a
10601 FUNCTION and have the same characteristics. */
10602 if (old_target->attr.function)
10604 if (!proc_target->attr.function)
10606 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10607 " FUNCTION", proc->name, &where);
10611 /* FIXME: Do more comprehensive checking (including, for instance, the
10612 rank and array-shape). */
10613 gcc_assert (proc_target->result && old_target->result);
10614 if (!gfc_compare_types (&proc_target->result->ts,
10615 &old_target->result->ts))
10617 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10618 " matching result types", proc->name, &where);
10623 /* If the overridden binding is PUBLIC, the overriding one must not be
10625 if (old->n.tb->access == ACCESS_PUBLIC
10626 && proc->n.tb->access == ACCESS_PRIVATE)
10628 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10629 " PRIVATE", proc->name, &where);
10633 /* Compare the formal argument lists of both procedures. This is also abused
10634 to find the position of the passed-object dummy arguments of both
10635 bindings as at least the overridden one might not yet be resolved and we
10636 need those positions in the check below. */
10637 proc_pass_arg = old_pass_arg = 0;
10638 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10640 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10643 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10644 proc_formal && old_formal;
10645 proc_formal = proc_formal->next, old_formal = old_formal->next)
10647 if (proc->n.tb->pass_arg
10648 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10649 proc_pass_arg = argpos;
10650 if (old->n.tb->pass_arg
10651 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10652 old_pass_arg = argpos;
10654 /* Check that the names correspond. */
10655 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10657 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10658 " to match the corresponding argument of the overridden"
10659 " procedure", proc_formal->sym->name, proc->name, &where,
10660 old_formal->sym->name);
10664 /* Check that the types correspond if neither is the passed-object
10666 /* FIXME: Do more comprehensive testing here. */
10667 if (proc_pass_arg != argpos && old_pass_arg != argpos
10668 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10670 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10671 "in respect to the overridden procedure",
10672 proc_formal->sym->name, proc->name, &where);
10678 if (proc_formal || old_formal)
10680 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10681 " the overridden procedure", proc->name, &where);
10685 /* If the overridden binding is NOPASS, the overriding one must also be
10687 if (old->n.tb->nopass && !proc->n.tb->nopass)
10689 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10690 " NOPASS", proc->name, &where);
10694 /* If the overridden binding is PASS(x), the overriding one must also be
10695 PASS and the passed-object dummy arguments must correspond. */
10696 if (!old->n.tb->nopass)
10698 if (proc->n.tb->nopass)
10700 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10701 " PASS", proc->name, &where);
10705 if (proc_pass_arg != old_pass_arg)
10707 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10708 " the same position as the passed-object dummy argument of"
10709 " the overridden procedure", proc->name, &where);
10718 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10721 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10722 const char* generic_name, locus where)
10727 gcc_assert (t1->specific && t2->specific);
10728 gcc_assert (!t1->specific->is_generic);
10729 gcc_assert (!t2->specific->is_generic);
10731 sym1 = t1->specific->u.specific->n.sym;
10732 sym2 = t2->specific->u.specific->n.sym;
10737 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10738 if (sym1->attr.subroutine != sym2->attr.subroutine
10739 || sym1->attr.function != sym2->attr.function)
10741 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10742 " GENERIC '%s' at %L",
10743 sym1->name, sym2->name, generic_name, &where);
10747 /* Compare the interfaces. */
10748 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10750 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10751 sym1->name, sym2->name, generic_name, &where);
10759 /* Worker function for resolving a generic procedure binding; this is used to
10760 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10762 The difference between those cases is finding possible inherited bindings
10763 that are overridden, as one has to look for them in tb_sym_root,
10764 tb_uop_root or tb_op, respectively. Thus the caller must already find
10765 the super-type and set p->overridden correctly. */
10768 resolve_tb_generic_targets (gfc_symbol* super_type,
10769 gfc_typebound_proc* p, const char* name)
10771 gfc_tbp_generic* target;
10772 gfc_symtree* first_target;
10773 gfc_symtree* inherited;
10775 gcc_assert (p && p->is_generic);
10777 /* Try to find the specific bindings for the symtrees in our target-list. */
10778 gcc_assert (p->u.generic);
10779 for (target = p->u.generic; target; target = target->next)
10780 if (!target->specific)
10782 gfc_typebound_proc* overridden_tbp;
10783 gfc_tbp_generic* g;
10784 const char* target_name;
10786 target_name = target->specific_st->name;
10788 /* Defined for this type directly. */
10789 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10791 target->specific = target->specific_st->n.tb;
10792 goto specific_found;
10795 /* Look for an inherited specific binding. */
10798 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10803 gcc_assert (inherited->n.tb);
10804 target->specific = inherited->n.tb;
10805 goto specific_found;
10809 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10810 " at %L", target_name, name, &p->where);
10813 /* Once we've found the specific binding, check it is not ambiguous with
10814 other specifics already found or inherited for the same GENERIC. */
10816 gcc_assert (target->specific);
10818 /* This must really be a specific binding! */
10819 if (target->specific->is_generic)
10821 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10822 " '%s' is GENERIC, too", name, &p->where, target_name);
10826 /* Check those already resolved on this type directly. */
10827 for (g = p->u.generic; g; g = g->next)
10828 if (g != target && g->specific
10829 && check_generic_tbp_ambiguity (target, g, name, p->where)
10833 /* Check for ambiguity with inherited specific targets. */
10834 for (overridden_tbp = p->overridden; overridden_tbp;
10835 overridden_tbp = overridden_tbp->overridden)
10836 if (overridden_tbp->is_generic)
10838 for (g = overridden_tbp->u.generic; g; g = g->next)
10840 gcc_assert (g->specific);
10841 if (check_generic_tbp_ambiguity (target, g,
10842 name, p->where) == FAILURE)
10848 /* If we attempt to "overwrite" a specific binding, this is an error. */
10849 if (p->overridden && !p->overridden->is_generic)
10851 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10852 " the same name", name, &p->where);
10856 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10857 all must have the same attributes here. */
10858 first_target = p->u.generic->specific->u.specific;
10859 gcc_assert (first_target);
10860 p->subroutine = first_target->n.sym->attr.subroutine;
10861 p->function = first_target->n.sym->attr.function;
10867 /* Resolve a GENERIC procedure binding for a derived type. */
10870 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10872 gfc_symbol* super_type;
10874 /* Find the overridden binding if any. */
10875 st->n.tb->overridden = NULL;
10876 super_type = gfc_get_derived_super_type (derived);
10879 gfc_symtree* overridden;
10880 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10883 if (overridden && overridden->n.tb)
10884 st->n.tb->overridden = overridden->n.tb;
10887 /* Resolve using worker function. */
10888 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10892 /* Retrieve the target-procedure of an operator binding and do some checks in
10893 common for intrinsic and user-defined type-bound operators. */
10896 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10898 gfc_symbol* target_proc;
10900 gcc_assert (target->specific && !target->specific->is_generic);
10901 target_proc = target->specific->u.specific->n.sym;
10902 gcc_assert (target_proc);
10904 /* All operator bindings must have a passed-object dummy argument. */
10905 if (target->specific->nopass)
10907 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10911 return target_proc;
10915 /* Resolve a type-bound intrinsic operator. */
10918 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10919 gfc_typebound_proc* p)
10921 gfc_symbol* super_type;
10922 gfc_tbp_generic* target;
10924 /* If there's already an error here, do nothing (but don't fail again). */
10928 /* Operators should always be GENERIC bindings. */
10929 gcc_assert (p->is_generic);
10931 /* Look for an overridden binding. */
10932 super_type = gfc_get_derived_super_type (derived);
10933 if (super_type && super_type->f2k_derived)
10934 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10937 p->overridden = NULL;
10939 /* Resolve general GENERIC properties using worker function. */
10940 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10943 /* Check the targets to be procedures of correct interface. */
10944 for (target = p->u.generic; target; target = target->next)
10946 gfc_symbol* target_proc;
10948 target_proc = get_checked_tb_operator_target (target, p->where);
10952 if (!gfc_check_operator_interface (target_proc, op, p->where))
10964 /* Resolve a type-bound user operator (tree-walker callback). */
10966 static gfc_symbol* resolve_bindings_derived;
10967 static gfc_try resolve_bindings_result;
10969 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10972 resolve_typebound_user_op (gfc_symtree* stree)
10974 gfc_symbol* super_type;
10975 gfc_tbp_generic* target;
10977 gcc_assert (stree && stree->n.tb);
10979 if (stree->n.tb->error)
10982 /* Operators should always be GENERIC bindings. */
10983 gcc_assert (stree->n.tb->is_generic);
10985 /* Find overridden procedure, if any. */
10986 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10987 if (super_type && super_type->f2k_derived)
10989 gfc_symtree* overridden;
10990 overridden = gfc_find_typebound_user_op (super_type, NULL,
10991 stree->name, true, NULL);
10993 if (overridden && overridden->n.tb)
10994 stree->n.tb->overridden = overridden->n.tb;
10997 stree->n.tb->overridden = NULL;
10999 /* Resolve basically using worker function. */
11000 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11004 /* Check the targets to be functions of correct interface. */
11005 for (target = stree->n.tb->u.generic; target; target = target->next)
11007 gfc_symbol* target_proc;
11009 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11013 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11020 resolve_bindings_result = FAILURE;
11021 stree->n.tb->error = 1;
11025 /* Resolve the type-bound procedures for a derived type. */
11028 resolve_typebound_procedure (gfc_symtree* stree)
11032 gfc_symbol* me_arg;
11033 gfc_symbol* super_type;
11034 gfc_component* comp;
11036 gcc_assert (stree);
11038 /* Undefined specific symbol from GENERIC target definition. */
11042 if (stree->n.tb->error)
11045 /* If this is a GENERIC binding, use that routine. */
11046 if (stree->n.tb->is_generic)
11048 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11054 /* Get the target-procedure to check it. */
11055 gcc_assert (!stree->n.tb->is_generic);
11056 gcc_assert (stree->n.tb->u.specific);
11057 proc = stree->n.tb->u.specific->n.sym;
11058 where = stree->n.tb->where;
11060 /* Default access should already be resolved from the parser. */
11061 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11063 /* It should be a module procedure or an external procedure with explicit
11064 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11065 if ((!proc->attr.subroutine && !proc->attr.function)
11066 || (proc->attr.proc != PROC_MODULE
11067 && proc->attr.if_source != IFSRC_IFBODY)
11068 || (proc->attr.abstract && !stree->n.tb->deferred))
11070 gfc_error ("'%s' must be a module procedure or an external procedure with"
11071 " an explicit interface at %L", proc->name, &where);
11074 stree->n.tb->subroutine = proc->attr.subroutine;
11075 stree->n.tb->function = proc->attr.function;
11077 /* Find the super-type of the current derived type. We could do this once and
11078 store in a global if speed is needed, but as long as not I believe this is
11079 more readable and clearer. */
11080 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11082 /* If PASS, resolve and check arguments if not already resolved / loaded
11083 from a .mod file. */
11084 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11086 if (stree->n.tb->pass_arg)
11088 gfc_formal_arglist* i;
11090 /* If an explicit passing argument name is given, walk the arg-list
11091 and look for it. */
11094 stree->n.tb->pass_arg_num = 1;
11095 for (i = proc->formal; i; i = i->next)
11097 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11102 ++stree->n.tb->pass_arg_num;
11107 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11109 proc->name, stree->n.tb->pass_arg, &where,
11110 stree->n.tb->pass_arg);
11116 /* Otherwise, take the first one; there should in fact be at least
11118 stree->n.tb->pass_arg_num = 1;
11121 gfc_error ("Procedure '%s' with PASS at %L must have at"
11122 " least one argument", proc->name, &where);
11125 me_arg = proc->formal->sym;
11128 /* Now check that the argument-type matches and the passed-object
11129 dummy argument is generally fine. */
11131 gcc_assert (me_arg);
11133 if (me_arg->ts.type != BT_CLASS)
11135 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11136 " at %L", proc->name, &where);
11140 if (CLASS_DATA (me_arg)->ts.u.derived
11141 != resolve_bindings_derived)
11143 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11144 " the derived-type '%s'", me_arg->name, proc->name,
11145 me_arg->name, &where, resolve_bindings_derived->name);
11149 gcc_assert (me_arg->ts.type == BT_CLASS);
11150 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11152 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11153 " scalar", proc->name, &where);
11156 if (CLASS_DATA (me_arg)->attr.allocatable)
11158 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11159 " be ALLOCATABLE", proc->name, &where);
11162 if (CLASS_DATA (me_arg)->attr.class_pointer)
11164 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11165 " be POINTER", proc->name, &where);
11170 /* If we are extending some type, check that we don't override a procedure
11171 flagged NON_OVERRIDABLE. */
11172 stree->n.tb->overridden = NULL;
11175 gfc_symtree* overridden;
11176 overridden = gfc_find_typebound_proc (super_type, NULL,
11177 stree->name, true, NULL);
11179 if (overridden && overridden->n.tb)
11180 stree->n.tb->overridden = overridden->n.tb;
11182 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11186 /* See if there's a name collision with a component directly in this type. */
11187 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11188 if (!strcmp (comp->name, stree->name))
11190 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11192 stree->name, &where, resolve_bindings_derived->name);
11196 /* Try to find a name collision with an inherited component. */
11197 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11199 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11200 " component of '%s'",
11201 stree->name, &where, resolve_bindings_derived->name);
11205 stree->n.tb->error = 0;
11209 resolve_bindings_result = FAILURE;
11210 stree->n.tb->error = 1;
11215 resolve_typebound_procedures (gfc_symbol* derived)
11219 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11222 resolve_bindings_derived = derived;
11223 resolve_bindings_result = SUCCESS;
11225 /* Make sure the vtab has been generated. */
11226 gfc_find_derived_vtab (derived);
11228 if (derived->f2k_derived->tb_sym_root)
11229 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11230 &resolve_typebound_procedure);
11232 if (derived->f2k_derived->tb_uop_root)
11233 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11234 &resolve_typebound_user_op);
11236 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11238 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11239 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11241 resolve_bindings_result = FAILURE;
11244 return resolve_bindings_result;
11248 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11249 to give all identical derived types the same backend_decl. */
11251 add_dt_to_dt_list (gfc_symbol *derived)
11253 gfc_dt_list *dt_list;
11255 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11256 if (derived == dt_list->derived)
11259 dt_list = gfc_get_dt_list ();
11260 dt_list->next = gfc_derived_types;
11261 dt_list->derived = derived;
11262 gfc_derived_types = dt_list;
11266 /* Ensure that a derived-type is really not abstract, meaning that every
11267 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11270 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11275 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11277 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11280 if (st->n.tb && st->n.tb->deferred)
11282 gfc_symtree* overriding;
11283 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11286 gcc_assert (overriding->n.tb);
11287 if (overriding->n.tb->deferred)
11289 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11290 " '%s' is DEFERRED and not overridden",
11291 sub->name, &sub->declared_at, st->name);
11300 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11302 /* The algorithm used here is to recursively travel up the ancestry of sub
11303 and for each ancestor-type, check all bindings. If any of them is
11304 DEFERRED, look it up starting from sub and see if the found (overriding)
11305 binding is not DEFERRED.
11306 This is not the most efficient way to do this, but it should be ok and is
11307 clearer than something sophisticated. */
11309 gcc_assert (ancestor && !sub->attr.abstract);
11311 if (!ancestor->attr.abstract)
11314 /* Walk bindings of this ancestor. */
11315 if (ancestor->f2k_derived)
11318 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11323 /* Find next ancestor type and recurse on it. */
11324 ancestor = gfc_get_derived_super_type (ancestor);
11326 return ensure_not_abstract (sub, ancestor);
11332 /* Resolve the components of a derived type. */
11335 resolve_fl_derived (gfc_symbol *sym)
11337 gfc_symbol* super_type;
11340 super_type = gfc_get_derived_super_type (sym);
11342 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11344 /* Fix up incomplete CLASS symbols. */
11345 gfc_component *data = gfc_find_component (sym, "_data", true, true);
11346 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
11347 if (vptr->ts.u.derived == NULL)
11349 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11351 vptr->ts.u.derived = vtab->ts.u.derived;
11356 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11358 gfc_error ("As extending type '%s' at %L has a coarray component, "
11359 "parent type '%s' shall also have one", sym->name,
11360 &sym->declared_at, super_type->name);
11364 /* Ensure the extended type gets resolved before we do. */
11365 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11368 /* An ABSTRACT type must be extensible. */
11369 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11371 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11372 sym->name, &sym->declared_at);
11376 for (c = sym->components; c != NULL; c = c->next)
11379 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11380 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11382 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11383 "deferred shape", c->name, &c->loc);
11388 if (c->attr.codimension && c->ts.type == BT_DERIVED
11389 && c->ts.u.derived->ts.is_iso_c)
11391 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11392 "shall not be a coarray", c->name, &c->loc);
11397 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11398 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11399 || c->attr.allocatable))
11401 gfc_error ("Component '%s' at %L with coarray component "
11402 "shall be a nonpointer, nonallocatable scalar",
11408 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11410 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11411 "is not an array pointer", c->name, &c->loc);
11415 if (c->attr.proc_pointer && c->ts.interface)
11417 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11418 gfc_error ("Interface '%s', used by procedure pointer component "
11419 "'%s' at %L, is declared in a later PROCEDURE statement",
11420 c->ts.interface->name, c->name, &c->loc);
11422 /* Get the attributes from the interface (now resolved). */
11423 if (c->ts.interface->attr.if_source
11424 || c->ts.interface->attr.intrinsic)
11426 gfc_symbol *ifc = c->ts.interface;
11428 if (ifc->formal && !ifc->formal_ns)
11429 resolve_symbol (ifc);
11431 if (ifc->attr.intrinsic)
11432 resolve_intrinsic (ifc, &ifc->declared_at);
11436 c->ts = ifc->result->ts;
11437 c->attr.allocatable = ifc->result->attr.allocatable;
11438 c->attr.pointer = ifc->result->attr.pointer;
11439 c->attr.dimension = ifc->result->attr.dimension;
11440 c->as = gfc_copy_array_spec (ifc->result->as);
11445 c->attr.allocatable = ifc->attr.allocatable;
11446 c->attr.pointer = ifc->attr.pointer;
11447 c->attr.dimension = ifc->attr.dimension;
11448 c->as = gfc_copy_array_spec (ifc->as);
11450 c->ts.interface = ifc;
11451 c->attr.function = ifc->attr.function;
11452 c->attr.subroutine = ifc->attr.subroutine;
11453 gfc_copy_formal_args_ppc (c, ifc);
11455 c->attr.pure = ifc->attr.pure;
11456 c->attr.elemental = ifc->attr.elemental;
11457 c->attr.recursive = ifc->attr.recursive;
11458 c->attr.always_explicit = ifc->attr.always_explicit;
11459 c->attr.ext_attr |= ifc->attr.ext_attr;
11460 /* Replace symbols in array spec. */
11464 for (i = 0; i < c->as->rank; i++)
11466 gfc_expr_replace_comp (c->as->lower[i], c);
11467 gfc_expr_replace_comp (c->as->upper[i], c);
11470 /* Copy char length. */
11471 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11473 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11474 gfc_expr_replace_comp (cl->length, c);
11475 if (cl->length && !cl->resolved
11476 && gfc_resolve_expr (cl->length) == FAILURE)
11481 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11483 gfc_error ("Interface '%s' of procedure pointer component "
11484 "'%s' at %L must be explicit", c->ts.interface->name,
11489 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11491 /* Since PPCs are not implicitly typed, a PPC without an explicit
11492 interface must be a subroutine. */
11493 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11496 /* Procedure pointer components: Check PASS arg. */
11497 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11498 && !sym->attr.vtype)
11500 gfc_symbol* me_arg;
11502 if (c->tb->pass_arg)
11504 gfc_formal_arglist* i;
11506 /* If an explicit passing argument name is given, walk the arg-list
11507 and look for it. */
11510 c->tb->pass_arg_num = 1;
11511 for (i = c->formal; i; i = i->next)
11513 if (!strcmp (i->sym->name, c->tb->pass_arg))
11518 c->tb->pass_arg_num++;
11523 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11524 "at %L has no argument '%s'", c->name,
11525 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11532 /* Otherwise, take the first one; there should in fact be at least
11534 c->tb->pass_arg_num = 1;
11537 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11538 "must have at least one argument",
11543 me_arg = c->formal->sym;
11546 /* Now check that the argument-type matches. */
11547 gcc_assert (me_arg);
11548 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11549 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11550 || (me_arg->ts.type == BT_CLASS
11551 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11553 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11554 " the derived type '%s'", me_arg->name, c->name,
11555 me_arg->name, &c->loc, sym->name);
11560 /* Check for C453. */
11561 if (me_arg->attr.dimension)
11563 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11564 "must be scalar", me_arg->name, c->name, me_arg->name,
11570 if (me_arg->attr.pointer)
11572 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11573 "may not have the POINTER attribute", me_arg->name,
11574 c->name, me_arg->name, &c->loc);
11579 if (me_arg->attr.allocatable)
11581 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11582 "may not be ALLOCATABLE", me_arg->name, c->name,
11583 me_arg->name, &c->loc);
11588 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11589 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11590 " at %L", c->name, &c->loc);
11594 /* Check type-spec if this is not the parent-type component. */
11595 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11596 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11599 /* If this type is an extension, set the accessibility of the parent
11601 if (super_type && c == sym->components
11602 && strcmp (super_type->name, c->name) == 0)
11603 c->attr.access = super_type->attr.access;
11605 /* If this type is an extension, see if this component has the same name
11606 as an inherited type-bound procedure. */
11607 if (super_type && !sym->attr.is_class
11608 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11610 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11611 " inherited type-bound procedure",
11612 c->name, sym->name, &c->loc);
11616 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11617 && !c->ts.deferred)
11619 if (c->ts.u.cl->length == NULL
11620 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11621 || !gfc_is_constant_expr (c->ts.u.cl->length))
11623 gfc_error ("Character length of component '%s' needs to "
11624 "be a constant specification expression at %L",
11626 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11631 if (c->ts.type == BT_CHARACTER && c->ts.deferred
11632 && !c->attr.pointer && !c->attr.allocatable)
11634 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11635 "length must be a POINTER or ALLOCATABLE",
11636 c->name, sym->name, &c->loc);
11640 if (c->ts.type == BT_DERIVED
11641 && sym->component_access != ACCESS_PRIVATE
11642 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11643 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11644 && !c->ts.u.derived->attr.use_assoc
11645 && !gfc_check_access (c->ts.u.derived->attr.access,
11646 c->ts.u.derived->ns->default_access)
11647 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11648 "is a PRIVATE type and cannot be a component of "
11649 "'%s', which is PUBLIC at %L", c->name,
11650 sym->name, &sym->declared_at) == FAILURE)
11653 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11655 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11656 "type %s", c->name, &c->loc, sym->name);
11660 if (sym->attr.sequence)
11662 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11664 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11665 "not have the SEQUENCE attribute",
11666 c->ts.u.derived->name, &sym->declared_at);
11671 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11672 && c->attr.pointer && c->ts.u.derived->components == NULL
11673 && !c->ts.u.derived->attr.zero_comp)
11675 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11676 "that has not been declared", c->name, sym->name,
11681 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11682 && CLASS_DATA (c)->ts.u.derived->components == NULL
11683 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11685 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11686 "that has not been declared", c->name, sym->name,
11692 if (c->ts.type == BT_CLASS
11693 && !(CLASS_DATA (c)->attr.class_pointer
11694 || CLASS_DATA (c)->attr.allocatable))
11696 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11697 "or pointer", c->name, &c->loc);
11701 /* Ensure that all the derived type components are put on the
11702 derived type list; even in formal namespaces, where derived type
11703 pointer components might not have been declared. */
11704 if (c->ts.type == BT_DERIVED
11706 && c->ts.u.derived->components
11708 && sym != c->ts.u.derived)
11709 add_dt_to_dt_list (c->ts.u.derived);
11711 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11712 || c->attr.proc_pointer
11713 || c->attr.allocatable)) == FAILURE)
11717 /* Resolve the type-bound procedures. */
11718 if (resolve_typebound_procedures (sym) == FAILURE)
11721 /* Resolve the finalizer procedures. */
11722 if (gfc_resolve_finalizers (sym) == FAILURE)
11725 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11726 all DEFERRED bindings are overridden. */
11727 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11728 && !sym->attr.is_class
11729 && ensure_not_abstract (sym, super_type) == FAILURE)
11732 /* Add derived type to the derived type list. */
11733 add_dt_to_dt_list (sym);
11740 resolve_fl_namelist (gfc_symbol *sym)
11745 for (nl = sym->namelist; nl; nl = nl->next)
11747 /* Check again, the check in match only works if NAMELIST comes
11749 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
11751 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
11752 "allowed", nl->sym->name, sym->name, &sym->declared_at);
11756 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11757 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
11758 "object '%s' with assumed shape in namelist "
11759 "'%s' at %L", nl->sym->name, sym->name,
11760 &sym->declared_at) == FAILURE)
11763 if (is_non_constant_shape_array (nl->sym)
11764 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
11765 "object '%s' with nonconstant shape in namelist "
11766 "'%s' at %L", nl->sym->name, sym->name,
11767 &sym->declared_at) == FAILURE)
11770 if (nl->sym->ts.type == BT_CHARACTER
11771 && (nl->sym->ts.u.cl->length == NULL
11772 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
11773 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
11774 "'%s' with nonconstant character length in "
11775 "namelist '%s' at %L", nl->sym->name, sym->name,
11776 &sym->declared_at) == FAILURE)
11779 /* FIXME: Once UDDTIO is implemented, the following can be
11781 if (nl->sym->ts.type == BT_CLASS)
11783 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
11784 "polymorphic and requires a defined input/output "
11785 "procedure", nl->sym->name, sym->name, &sym->declared_at);
11789 if (nl->sym->ts.type == BT_DERIVED
11790 && (nl->sym->ts.u.derived->attr.alloc_comp
11791 || nl->sym->ts.u.derived->attr.pointer_comp))
11793 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
11794 "'%s' in namelist '%s' at %L with ALLOCATABLE "
11795 "or POINTER components", nl->sym->name,
11796 sym->name, &sym->declared_at) == FAILURE)
11799 /* FIXME: Once UDDTIO is implemented, the following can be
11801 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
11802 "ALLOCATABLE or POINTER components and thus requires "
11803 "a defined input/output procedure", nl->sym->name,
11804 sym->name, &sym->declared_at);
11809 /* Reject PRIVATE objects in a PUBLIC namelist. */
11810 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11812 for (nl = sym->namelist; nl; nl = nl->next)
11814 if (!nl->sym->attr.use_assoc
11815 && !is_sym_host_assoc (nl->sym, sym->ns)
11816 && !gfc_check_access(nl->sym->attr.access,
11817 nl->sym->ns->default_access))
11819 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11820 "cannot be member of PUBLIC namelist '%s' at %L",
11821 nl->sym->name, sym->name, &sym->declared_at);
11825 /* Types with private components that came here by USE-association. */
11826 if (nl->sym->ts.type == BT_DERIVED
11827 && derived_inaccessible (nl->sym->ts.u.derived))
11829 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11830 "components and cannot be member of namelist '%s' at %L",
11831 nl->sym->name, sym->name, &sym->declared_at);
11835 /* Types with private components that are defined in the same module. */
11836 if (nl->sym->ts.type == BT_DERIVED
11837 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11838 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11839 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11840 nl->sym->ns->default_access))
11842 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11843 "cannot be a member of PUBLIC namelist '%s' at %L",
11844 nl->sym->name, sym->name, &sym->declared_at);
11851 /* 14.1.2 A module or internal procedure represent local entities
11852 of the same type as a namelist member and so are not allowed. */
11853 for (nl = sym->namelist; nl; nl = nl->next)
11855 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11858 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11859 if ((nl->sym == sym->ns->proc_name)
11861 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11865 if (nl->sym && nl->sym->name)
11866 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11867 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11869 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11870 "attribute in '%s' at %L", nlsym->name,
11871 &sym->declared_at);
11881 resolve_fl_parameter (gfc_symbol *sym)
11883 /* A parameter array's shape needs to be constant. */
11884 if (sym->as != NULL
11885 && (sym->as->type == AS_DEFERRED
11886 || is_non_constant_shape_array (sym)))
11888 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11889 "or of deferred shape", sym->name, &sym->declared_at);
11893 /* Make sure a parameter that has been implicitly typed still
11894 matches the implicit type, since PARAMETER statements can precede
11895 IMPLICIT statements. */
11896 if (sym->attr.implicit_type
11897 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11900 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11901 "later IMPLICIT type", sym->name, &sym->declared_at);
11905 /* Make sure the types of derived parameters are consistent. This
11906 type checking is deferred until resolution because the type may
11907 refer to a derived type from the host. */
11908 if (sym->ts.type == BT_DERIVED
11909 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11911 gfc_error ("Incompatible derived type in PARAMETER at %L",
11912 &sym->value->where);
11919 /* Do anything necessary to resolve a symbol. Right now, we just
11920 assume that an otherwise unknown symbol is a variable. This sort
11921 of thing commonly happens for symbols in module. */
11924 resolve_symbol (gfc_symbol *sym)
11926 int check_constant, mp_flag;
11927 gfc_symtree *symtree;
11928 gfc_symtree *this_symtree;
11932 /* Avoid double resolution of function result symbols. */
11933 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11934 && (sym->ns != gfc_current_ns))
11937 if (sym->attr.flavor == FL_UNKNOWN)
11940 /* If we find that a flavorless symbol is an interface in one of the
11941 parent namespaces, find its symtree in this namespace, free the
11942 symbol and set the symtree to point to the interface symbol. */
11943 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11945 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11946 if (symtree && (symtree->n.sym->generic ||
11947 (symtree->n.sym->attr.flavor == FL_PROCEDURE
11948 && sym->ns->construct_entities)))
11950 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11952 gfc_release_symbol (sym);
11953 symtree->n.sym->refs++;
11954 this_symtree->n.sym = symtree->n.sym;
11959 /* Otherwise give it a flavor according to such attributes as
11961 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11962 sym->attr.flavor = FL_VARIABLE;
11965 sym->attr.flavor = FL_PROCEDURE;
11966 if (sym->attr.dimension)
11967 sym->attr.function = 1;
11971 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11972 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11974 if (sym->attr.procedure && sym->ts.interface
11975 && sym->attr.if_source != IFSRC_DECL
11976 && resolve_procedure_interface (sym) == FAILURE)
11979 if (sym->attr.is_protected && !sym->attr.proc_pointer
11980 && (sym->attr.procedure || sym->attr.external))
11982 if (sym->attr.external)
11983 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11984 "at %L", &sym->declared_at);
11986 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11987 "at %L", &sym->declared_at);
11994 if (sym->attr.contiguous
11995 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11996 && !sym->attr.pointer)))
11998 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11999 "array pointer or an assumed-shape array", sym->name,
12000 &sym->declared_at);
12004 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12007 /* Symbols that are module procedures with results (functions) have
12008 the types and array specification copied for type checking in
12009 procedures that call them, as well as for saving to a module
12010 file. These symbols can't stand the scrutiny that their results
12012 mp_flag = (sym->result != NULL && sym->result != sym);
12014 /* Make sure that the intrinsic is consistent with its internal
12015 representation. This needs to be done before assigning a default
12016 type to avoid spurious warnings. */
12017 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12018 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12021 /* Resolve associate names. */
12023 resolve_assoc_var (sym, true);
12025 /* Assign default type to symbols that need one and don't have one. */
12026 if (sym->ts.type == BT_UNKNOWN)
12028 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12029 gfc_set_default_type (sym, 1, NULL);
12031 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12032 && !sym->attr.function && !sym->attr.subroutine
12033 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12034 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12036 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12038 /* The specific case of an external procedure should emit an error
12039 in the case that there is no implicit type. */
12041 gfc_set_default_type (sym, sym->attr.external, NULL);
12044 /* Result may be in another namespace. */
12045 resolve_symbol (sym->result);
12047 if (!sym->result->attr.proc_pointer)
12049 sym->ts = sym->result->ts;
12050 sym->as = gfc_copy_array_spec (sym->result->as);
12051 sym->attr.dimension = sym->result->attr.dimension;
12052 sym->attr.pointer = sym->result->attr.pointer;
12053 sym->attr.allocatable = sym->result->attr.allocatable;
12054 sym->attr.contiguous = sym->result->attr.contiguous;
12060 /* Assumed size arrays and assumed shape arrays must be dummy
12061 arguments. Array-spec's of implied-shape should have been resolved to
12062 AS_EXPLICIT already. */
12066 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
12067 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
12068 || sym->as->type == AS_ASSUMED_SHAPE)
12069 && sym->attr.dummy == 0)
12071 if (sym->as->type == AS_ASSUMED_SIZE)
12072 gfc_error ("Assumed size array at %L must be a dummy argument",
12073 &sym->declared_at);
12075 gfc_error ("Assumed shape array at %L must be a dummy argument",
12076 &sym->declared_at);
12081 /* Make sure symbols with known intent or optional are really dummy
12082 variable. Because of ENTRY statement, this has to be deferred
12083 until resolution time. */
12085 if (!sym->attr.dummy
12086 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12088 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12092 if (sym->attr.value && !sym->attr.dummy)
12094 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12095 "it is not a dummy argument", sym->name, &sym->declared_at);
12099 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12101 gfc_charlen *cl = sym->ts.u.cl;
12102 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12104 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12105 "attribute must have constant length",
12106 sym->name, &sym->declared_at);
12110 if (sym->ts.is_c_interop
12111 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12113 gfc_error ("C interoperable character dummy variable '%s' at %L "
12114 "with VALUE attribute must have length one",
12115 sym->name, &sym->declared_at);
12120 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12121 do this for something that was implicitly typed because that is handled
12122 in gfc_set_default_type. Handle dummy arguments and procedure
12123 definitions separately. Also, anything that is use associated is not
12124 handled here but instead is handled in the module it is declared in.
12125 Finally, derived type definitions are allowed to be BIND(C) since that
12126 only implies that they're interoperable, and they are checked fully for
12127 interoperability when a variable is declared of that type. */
12128 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12129 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12130 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12132 gfc_try t = SUCCESS;
12134 /* First, make sure the variable is declared at the
12135 module-level scope (J3/04-007, Section 15.3). */
12136 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12137 sym->attr.in_common == 0)
12139 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12140 "is neither a COMMON block nor declared at the "
12141 "module level scope", sym->name, &(sym->declared_at));
12144 else if (sym->common_head != NULL)
12146 t = verify_com_block_vars_c_interop (sym->common_head);
12150 /* If type() declaration, we need to verify that the components
12151 of the given type are all C interoperable, etc. */
12152 if (sym->ts.type == BT_DERIVED &&
12153 sym->ts.u.derived->attr.is_c_interop != 1)
12155 /* Make sure the user marked the derived type as BIND(C). If
12156 not, call the verify routine. This could print an error
12157 for the derived type more than once if multiple variables
12158 of that type are declared. */
12159 if (sym->ts.u.derived->attr.is_bind_c != 1)
12160 verify_bind_c_derived_type (sym->ts.u.derived);
12164 /* Verify the variable itself as C interoperable if it
12165 is BIND(C). It is not possible for this to succeed if
12166 the verify_bind_c_derived_type failed, so don't have to handle
12167 any error returned by verify_bind_c_derived_type. */
12168 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12169 sym->common_block);
12174 /* clear the is_bind_c flag to prevent reporting errors more than
12175 once if something failed. */
12176 sym->attr.is_bind_c = 0;
12181 /* If a derived type symbol has reached this point, without its
12182 type being declared, we have an error. Notice that most
12183 conditions that produce undefined derived types have already
12184 been dealt with. However, the likes of:
12185 implicit type(t) (t) ..... call foo (t) will get us here if
12186 the type is not declared in the scope of the implicit
12187 statement. Change the type to BT_UNKNOWN, both because it is so
12188 and to prevent an ICE. */
12189 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
12190 && !sym->ts.u.derived->attr.zero_comp)
12192 gfc_error ("The derived type '%s' at %L is of type '%s', "
12193 "which has not been defined", sym->name,
12194 &sym->declared_at, sym->ts.u.derived->name);
12195 sym->ts.type = BT_UNKNOWN;
12199 /* Make sure that the derived type has been resolved and that the
12200 derived type is visible in the symbol's namespace, if it is a
12201 module function and is not PRIVATE. */
12202 if (sym->ts.type == BT_DERIVED
12203 && sym->ts.u.derived->attr.use_assoc
12204 && sym->ns->proc_name
12205 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12209 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12212 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12213 if (!ds && sym->attr.function
12214 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12216 symtree = gfc_new_symtree (&sym->ns->sym_root,
12217 sym->ts.u.derived->name);
12218 symtree->n.sym = sym->ts.u.derived;
12219 sym->ts.u.derived->refs++;
12223 /* Unless the derived-type declaration is use associated, Fortran 95
12224 does not allow public entries of private derived types.
12225 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12226 161 in 95-006r3. */
12227 if (sym->ts.type == BT_DERIVED
12228 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12229 && !sym->ts.u.derived->attr.use_assoc
12230 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12231 && !gfc_check_access (sym->ts.u.derived->attr.access,
12232 sym->ts.u.derived->ns->default_access)
12233 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12234 "of PRIVATE derived type '%s'",
12235 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12236 : "variable", sym->name, &sym->declared_at,
12237 sym->ts.u.derived->name) == FAILURE)
12240 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12241 default initialization is defined (5.1.2.4.4). */
12242 if (sym->ts.type == BT_DERIVED
12244 && sym->attr.intent == INTENT_OUT
12246 && sym->as->type == AS_ASSUMED_SIZE)
12248 for (c = sym->ts.u.derived->components; c; c = c->next)
12250 if (c->initializer)
12252 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12253 "ASSUMED SIZE and so cannot have a default initializer",
12254 sym->name, &sym->declared_at);
12261 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12262 || sym->attr.codimension)
12263 && sym->attr.result)
12264 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12265 "a coarray component", sym->name, &sym->declared_at);
12268 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12269 && sym->ts.u.derived->ts.is_iso_c)
12270 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12271 "shall not be a coarray", sym->name, &sym->declared_at);
12274 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12275 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12276 || sym->attr.allocatable))
12277 gfc_error ("Variable '%s' at %L with coarray component "
12278 "shall be a nonpointer, nonallocatable scalar",
12279 sym->name, &sym->declared_at);
12281 /* F2008, C526. The function-result case was handled above. */
12282 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12283 || sym->attr.codimension)
12284 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12285 || sym->ns->proc_name->attr.flavor == FL_MODULE
12286 || sym->ns->proc_name->attr.is_main_program
12287 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12288 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12289 "component and is not ALLOCATABLE, SAVE nor a "
12290 "dummy argument", sym->name, &sym->declared_at);
12291 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12292 else if (sym->attr.codimension && !sym->attr.allocatable
12293 && sym->as && sym->as->cotype == AS_DEFERRED)
12294 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12295 "deferred shape", sym->name, &sym->declared_at);
12296 else if (sym->attr.codimension && sym->attr.allocatable
12297 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12298 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12299 "deferred shape", sym->name, &sym->declared_at);
12303 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12304 || (sym->attr.codimension && sym->attr.allocatable))
12305 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12306 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12307 "allocatable coarray or have coarray components",
12308 sym->name, &sym->declared_at);
12310 if (sym->attr.codimension && sym->attr.dummy
12311 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12312 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12313 "procedure '%s'", sym->name, &sym->declared_at,
12314 sym->ns->proc_name->name);
12316 switch (sym->attr.flavor)
12319 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12324 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12329 if (resolve_fl_namelist (sym) == FAILURE)
12334 if (resolve_fl_parameter (sym) == FAILURE)
12342 /* Resolve array specifier. Check as well some constraints
12343 on COMMON blocks. */
12345 check_constant = sym->attr.in_common && !sym->attr.pointer;
12347 /* Set the formal_arg_flag so that check_conflict will not throw
12348 an error for host associated variables in the specification
12349 expression for an array_valued function. */
12350 if (sym->attr.function && sym->as)
12351 formal_arg_flag = 1;
12353 gfc_resolve_array_spec (sym->as, check_constant);
12355 formal_arg_flag = 0;
12357 /* Resolve formal namespaces. */
12358 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12359 && !sym->attr.contained && !sym->attr.intrinsic)
12360 gfc_resolve (sym->formal_ns);
12362 /* Make sure the formal namespace is present. */
12363 if (sym->formal && !sym->formal_ns)
12365 gfc_formal_arglist *formal = sym->formal;
12366 while (formal && !formal->sym)
12367 formal = formal->next;
12371 sym->formal_ns = formal->sym->ns;
12372 sym->formal_ns->refs++;
12376 /* Check threadprivate restrictions. */
12377 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12378 && (!sym->attr.in_common
12379 && sym->module == NULL
12380 && (sym->ns->proc_name == NULL
12381 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12382 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12384 /* If we have come this far we can apply default-initializers, as
12385 described in 14.7.5, to those variables that have not already
12386 been assigned one. */
12387 if (sym->ts.type == BT_DERIVED
12388 && sym->ns == gfc_current_ns
12390 && !sym->attr.allocatable
12391 && !sym->attr.alloc_comp)
12393 symbol_attribute *a = &sym->attr;
12395 if ((!a->save && !a->dummy && !a->pointer
12396 && !a->in_common && !a->use_assoc
12397 && (a->referenced || a->result)
12398 && !(a->function && sym != sym->result))
12399 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12400 apply_default_init (sym);
12403 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12404 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12405 && !CLASS_DATA (sym)->attr.class_pointer
12406 && !CLASS_DATA (sym)->attr.allocatable)
12407 apply_default_init (sym);
12409 /* If this symbol has a type-spec, check it. */
12410 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12411 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12412 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12418 /************* Resolve DATA statements *************/
12422 gfc_data_value *vnode;
12428 /* Advance the values structure to point to the next value in the data list. */
12431 next_data_value (void)
12433 while (mpz_cmp_ui (values.left, 0) == 0)
12436 if (values.vnode->next == NULL)
12439 values.vnode = values.vnode->next;
12440 mpz_set (values.left, values.vnode->repeat);
12448 check_data_variable (gfc_data_variable *var, locus *where)
12454 ar_type mark = AR_UNKNOWN;
12456 mpz_t section_index[GFC_MAX_DIMENSIONS];
12462 if (gfc_resolve_expr (var->expr) == FAILURE)
12466 mpz_init_set_si (offset, 0);
12469 if (e->expr_type != EXPR_VARIABLE)
12470 gfc_internal_error ("check_data_variable(): Bad expression");
12472 sym = e->symtree->n.sym;
12474 if (sym->ns->is_block_data && !sym->attr.in_common)
12476 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12477 sym->name, &sym->declared_at);
12480 if (e->ref == NULL && sym->as)
12482 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12483 " declaration", sym->name, where);
12487 has_pointer = sym->attr.pointer;
12489 for (ref = e->ref; ref; ref = ref->next)
12491 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12494 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12496 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12502 && ref->type == REF_ARRAY
12503 && ref->u.ar.type != AR_FULL)
12505 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12506 "be a full array", sym->name, where);
12511 if (e->rank == 0 || has_pointer)
12513 mpz_init_set_ui (size, 1);
12520 /* Find the array section reference. */
12521 for (ref = e->ref; ref; ref = ref->next)
12523 if (ref->type != REF_ARRAY)
12525 if (ref->u.ar.type == AR_ELEMENT)
12531 /* Set marks according to the reference pattern. */
12532 switch (ref->u.ar.type)
12540 /* Get the start position of array section. */
12541 gfc_get_section_index (ar, section_index, &offset);
12546 gcc_unreachable ();
12549 if (gfc_array_size (e, &size) == FAILURE)
12551 gfc_error ("Nonconstant array section at %L in DATA statement",
12553 mpz_clear (offset);
12560 while (mpz_cmp_ui (size, 0) > 0)
12562 if (next_data_value () == FAILURE)
12564 gfc_error ("DATA statement at %L has more variables than values",
12570 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12574 /* If we have more than one element left in the repeat count,
12575 and we have more than one element left in the target variable,
12576 then create a range assignment. */
12577 /* FIXME: Only done for full arrays for now, since array sections
12579 if (mark == AR_FULL && ref && ref->next == NULL
12580 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12584 if (mpz_cmp (size, values.left) >= 0)
12586 mpz_init_set (range, values.left);
12587 mpz_sub (size, size, values.left);
12588 mpz_set_ui (values.left, 0);
12592 mpz_init_set (range, size);
12593 mpz_sub (values.left, values.left, size);
12594 mpz_set_ui (size, 0);
12597 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12600 mpz_add (offset, offset, range);
12607 /* Assign initial value to symbol. */
12610 mpz_sub_ui (values.left, values.left, 1);
12611 mpz_sub_ui (size, size, 1);
12613 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12617 if (mark == AR_FULL)
12618 mpz_add_ui (offset, offset, 1);
12620 /* Modify the array section indexes and recalculate the offset
12621 for next element. */
12622 else if (mark == AR_SECTION)
12623 gfc_advance_section (section_index, ar, &offset);
12627 if (mark == AR_SECTION)
12629 for (i = 0; i < ar->dimen; i++)
12630 mpz_clear (section_index[i]);
12634 mpz_clear (offset);
12640 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12642 /* Iterate over a list of elements in a DATA statement. */
12645 traverse_data_list (gfc_data_variable *var, locus *where)
12648 iterator_stack frame;
12649 gfc_expr *e, *start, *end, *step;
12650 gfc_try retval = SUCCESS;
12652 mpz_init (frame.value);
12655 start = gfc_copy_expr (var->iter.start);
12656 end = gfc_copy_expr (var->iter.end);
12657 step = gfc_copy_expr (var->iter.step);
12659 if (gfc_simplify_expr (start, 1) == FAILURE
12660 || start->expr_type != EXPR_CONSTANT)
12662 gfc_error ("start of implied-do loop at %L could not be "
12663 "simplified to a constant value", &start->where);
12667 if (gfc_simplify_expr (end, 1) == FAILURE
12668 || end->expr_type != EXPR_CONSTANT)
12670 gfc_error ("end of implied-do loop at %L could not be "
12671 "simplified to a constant value", &start->where);
12675 if (gfc_simplify_expr (step, 1) == FAILURE
12676 || step->expr_type != EXPR_CONSTANT)
12678 gfc_error ("step of implied-do loop at %L could not be "
12679 "simplified to a constant value", &start->where);
12684 mpz_set (trip, end->value.integer);
12685 mpz_sub (trip, trip, start->value.integer);
12686 mpz_add (trip, trip, step->value.integer);
12688 mpz_div (trip, trip, step->value.integer);
12690 mpz_set (frame.value, start->value.integer);
12692 frame.prev = iter_stack;
12693 frame.variable = var->iter.var->symtree;
12694 iter_stack = &frame;
12696 while (mpz_cmp_ui (trip, 0) > 0)
12698 if (traverse_data_var (var->list, where) == FAILURE)
12704 e = gfc_copy_expr (var->expr);
12705 if (gfc_simplify_expr (e, 1) == FAILURE)
12712 mpz_add (frame.value, frame.value, step->value.integer);
12714 mpz_sub_ui (trip, trip, 1);
12718 mpz_clear (frame.value);
12721 gfc_free_expr (start);
12722 gfc_free_expr (end);
12723 gfc_free_expr (step);
12725 iter_stack = frame.prev;
12730 /* Type resolve variables in the variable list of a DATA statement. */
12733 traverse_data_var (gfc_data_variable *var, locus *where)
12737 for (; var; var = var->next)
12739 if (var->expr == NULL)
12740 t = traverse_data_list (var, where);
12742 t = check_data_variable (var, where);
12752 /* Resolve the expressions and iterators associated with a data statement.
12753 This is separate from the assignment checking because data lists should
12754 only be resolved once. */
12757 resolve_data_variables (gfc_data_variable *d)
12759 for (; d; d = d->next)
12761 if (d->list == NULL)
12763 if (gfc_resolve_expr (d->expr) == FAILURE)
12768 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12771 if (resolve_data_variables (d->list) == FAILURE)
12780 /* Resolve a single DATA statement. We implement this by storing a pointer to
12781 the value list into static variables, and then recursively traversing the
12782 variables list, expanding iterators and such. */
12785 resolve_data (gfc_data *d)
12788 if (resolve_data_variables (d->var) == FAILURE)
12791 values.vnode = d->value;
12792 if (d->value == NULL)
12793 mpz_set_ui (values.left, 0);
12795 mpz_set (values.left, d->value->repeat);
12797 if (traverse_data_var (d->var, &d->where) == FAILURE)
12800 /* At this point, we better not have any values left. */
12802 if (next_data_value () == SUCCESS)
12803 gfc_error ("DATA statement at %L has more values than variables",
12808 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12809 accessed by host or use association, is a dummy argument to a pure function,
12810 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12811 is storage associated with any such variable, shall not be used in the
12812 following contexts: (clients of this function). */
12814 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12815 procedure. Returns zero if assignment is OK, nonzero if there is a
12818 gfc_impure_variable (gfc_symbol *sym)
12823 if (sym->attr.use_assoc || sym->attr.in_common)
12826 /* Check if the symbol's ns is inside the pure procedure. */
12827 for (ns = gfc_current_ns; ns; ns = ns->parent)
12831 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12835 proc = sym->ns->proc_name;
12836 if (sym->attr.dummy && gfc_pure (proc)
12837 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12839 proc->attr.function))
12842 /* TODO: Sort out what can be storage associated, if anything, and include
12843 it here. In principle equivalences should be scanned but it does not
12844 seem to be possible to storage associate an impure variable this way. */
12849 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12850 current namespace is inside a pure procedure. */
12853 gfc_pure (gfc_symbol *sym)
12855 symbol_attribute attr;
12860 /* Check if the current namespace or one of its parents
12861 belongs to a pure procedure. */
12862 for (ns = gfc_current_ns; ns; ns = ns->parent)
12864 sym = ns->proc_name;
12868 if (attr.flavor == FL_PROCEDURE && attr.pure)
12876 return attr.flavor == FL_PROCEDURE && attr.pure;
12880 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
12881 checks if the current namespace is implicitly pure. Note that this
12882 function returns false for a PURE procedure. */
12885 gfc_implicit_pure (gfc_symbol *sym)
12887 symbol_attribute attr;
12891 /* Check if the current namespace is implicit_pure. */
12892 sym = gfc_current_ns->proc_name;
12896 if (attr.flavor == FL_PROCEDURE
12897 && attr.implicit_pure && !attr.pure)
12904 return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
12908 /* Test whether the current procedure is elemental or not. */
12911 gfc_elemental (gfc_symbol *sym)
12913 symbol_attribute attr;
12916 sym = gfc_current_ns->proc_name;
12921 return attr.flavor == FL_PROCEDURE && attr.elemental;
12925 /* Warn about unused labels. */
12928 warn_unused_fortran_label (gfc_st_label *label)
12933 warn_unused_fortran_label (label->left);
12935 if (label->defined == ST_LABEL_UNKNOWN)
12938 switch (label->referenced)
12940 case ST_LABEL_UNKNOWN:
12941 gfc_warning ("Label %d at %L defined but not used", label->value,
12945 case ST_LABEL_BAD_TARGET:
12946 gfc_warning ("Label %d at %L defined but cannot be used",
12947 label->value, &label->where);
12954 warn_unused_fortran_label (label->right);
12958 /* Returns the sequence type of a symbol or sequence. */
12961 sequence_type (gfc_typespec ts)
12970 if (ts.u.derived->components == NULL)
12971 return SEQ_NONDEFAULT;
12973 result = sequence_type (ts.u.derived->components->ts);
12974 for (c = ts.u.derived->components->next; c; c = c->next)
12975 if (sequence_type (c->ts) != result)
12981 if (ts.kind != gfc_default_character_kind)
12982 return SEQ_NONDEFAULT;
12984 return SEQ_CHARACTER;
12987 if (ts.kind != gfc_default_integer_kind)
12988 return SEQ_NONDEFAULT;
12990 return SEQ_NUMERIC;
12993 if (!(ts.kind == gfc_default_real_kind
12994 || ts.kind == gfc_default_double_kind))
12995 return SEQ_NONDEFAULT;
12997 return SEQ_NUMERIC;
13000 if (ts.kind != gfc_default_complex_kind)
13001 return SEQ_NONDEFAULT;
13003 return SEQ_NUMERIC;
13006 if (ts.kind != gfc_default_logical_kind)
13007 return SEQ_NONDEFAULT;
13009 return SEQ_NUMERIC;
13012 return SEQ_NONDEFAULT;
13017 /* Resolve derived type EQUIVALENCE object. */
13020 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13022 gfc_component *c = derived->components;
13027 /* Shall not be an object of nonsequence derived type. */
13028 if (!derived->attr.sequence)
13030 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13031 "attribute to be an EQUIVALENCE object", sym->name,
13036 /* Shall not have allocatable components. */
13037 if (derived->attr.alloc_comp)
13039 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13040 "components to be an EQUIVALENCE object",sym->name,
13045 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13047 gfc_error ("Derived type variable '%s' at %L with default "
13048 "initialization cannot be in EQUIVALENCE with a variable "
13049 "in COMMON", sym->name, &e->where);
13053 for (; c ; c = c->next)
13055 if (c->ts.type == BT_DERIVED
13056 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13059 /* Shall not be an object of sequence derived type containing a pointer
13060 in the structure. */
13061 if (c->attr.pointer)
13063 gfc_error ("Derived type variable '%s' at %L with pointer "
13064 "component(s) cannot be an EQUIVALENCE object",
13065 sym->name, &e->where);
13073 /* Resolve equivalence object.
13074 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13075 an allocatable array, an object of nonsequence derived type, an object of
13076 sequence derived type containing a pointer at any level of component
13077 selection, an automatic object, a function name, an entry name, a result
13078 name, a named constant, a structure component, or a subobject of any of
13079 the preceding objects. A substring shall not have length zero. A
13080 derived type shall not have components with default initialization nor
13081 shall two objects of an equivalence group be initialized.
13082 Either all or none of the objects shall have an protected attribute.
13083 The simple constraints are done in symbol.c(check_conflict) and the rest
13084 are implemented here. */
13087 resolve_equivalence (gfc_equiv *eq)
13090 gfc_symbol *first_sym;
13093 locus *last_where = NULL;
13094 seq_type eq_type, last_eq_type;
13095 gfc_typespec *last_ts;
13096 int object, cnt_protected;
13099 last_ts = &eq->expr->symtree->n.sym->ts;
13101 first_sym = eq->expr->symtree->n.sym;
13105 for (object = 1; eq; eq = eq->eq, object++)
13109 e->ts = e->symtree->n.sym->ts;
13110 /* match_varspec might not know yet if it is seeing
13111 array reference or substring reference, as it doesn't
13113 if (e->ref && e->ref->type == REF_ARRAY)
13115 gfc_ref *ref = e->ref;
13116 sym = e->symtree->n.sym;
13118 if (sym->attr.dimension)
13120 ref->u.ar.as = sym->as;
13124 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13125 if (e->ts.type == BT_CHARACTER
13127 && ref->type == REF_ARRAY
13128 && ref->u.ar.dimen == 1
13129 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13130 && ref->u.ar.stride[0] == NULL)
13132 gfc_expr *start = ref->u.ar.start[0];
13133 gfc_expr *end = ref->u.ar.end[0];
13136 /* Optimize away the (:) reference. */
13137 if (start == NULL && end == NULL)
13140 e->ref = ref->next;
13142 e->ref->next = ref->next;
13147 ref->type = REF_SUBSTRING;
13149 start = gfc_get_int_expr (gfc_default_integer_kind,
13151 ref->u.ss.start = start;
13152 if (end == NULL && e->ts.u.cl)
13153 end = gfc_copy_expr (e->ts.u.cl->length);
13154 ref->u.ss.end = end;
13155 ref->u.ss.length = e->ts.u.cl;
13162 /* Any further ref is an error. */
13165 gcc_assert (ref->type == REF_ARRAY);
13166 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13172 if (gfc_resolve_expr (e) == FAILURE)
13175 sym = e->symtree->n.sym;
13177 if (sym->attr.is_protected)
13179 if (cnt_protected > 0 && cnt_protected != object)
13181 gfc_error ("Either all or none of the objects in the "
13182 "EQUIVALENCE set at %L shall have the "
13183 "PROTECTED attribute",
13188 /* Shall not equivalence common block variables in a PURE procedure. */
13189 if (sym->ns->proc_name
13190 && sym->ns->proc_name->attr.pure
13191 && sym->attr.in_common)
13193 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13194 "object in the pure procedure '%s'",
13195 sym->name, &e->where, sym->ns->proc_name->name);
13199 /* Shall not be a named constant. */
13200 if (e->expr_type == EXPR_CONSTANT)
13202 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13203 "object", sym->name, &e->where);
13207 if (e->ts.type == BT_DERIVED
13208 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13211 /* Check that the types correspond correctly:
13213 A numeric sequence structure may be equivalenced to another sequence
13214 structure, an object of default integer type, default real type, double
13215 precision real type, default logical type such that components of the
13216 structure ultimately only become associated to objects of the same
13217 kind. A character sequence structure may be equivalenced to an object
13218 of default character kind or another character sequence structure.
13219 Other objects may be equivalenced only to objects of the same type and
13220 kind parameters. */
13222 /* Identical types are unconditionally OK. */
13223 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13224 goto identical_types;
13226 last_eq_type = sequence_type (*last_ts);
13227 eq_type = sequence_type (sym->ts);
13229 /* Since the pair of objects is not of the same type, mixed or
13230 non-default sequences can be rejected. */
13232 msg = "Sequence %s with mixed components in EQUIVALENCE "
13233 "statement at %L with different type objects";
13235 && last_eq_type == SEQ_MIXED
13236 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13238 || (eq_type == SEQ_MIXED
13239 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13240 &e->where) == FAILURE))
13243 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13244 "statement at %L with objects of different type";
13246 && last_eq_type == SEQ_NONDEFAULT
13247 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13248 last_where) == FAILURE)
13249 || (eq_type == SEQ_NONDEFAULT
13250 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13251 &e->where) == FAILURE))
13254 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13255 "EQUIVALENCE statement at %L";
13256 if (last_eq_type == SEQ_CHARACTER
13257 && eq_type != SEQ_CHARACTER
13258 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13259 &e->where) == FAILURE)
13262 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13263 "EQUIVALENCE statement at %L";
13264 if (last_eq_type == SEQ_NUMERIC
13265 && eq_type != SEQ_NUMERIC
13266 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13267 &e->where) == FAILURE)
13272 last_where = &e->where;
13277 /* Shall not be an automatic array. */
13278 if (e->ref->type == REF_ARRAY
13279 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13281 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13282 "an EQUIVALENCE object", sym->name, &e->where);
13289 /* Shall not be a structure component. */
13290 if (r->type == REF_COMPONENT)
13292 gfc_error ("Structure component '%s' at %L cannot be an "
13293 "EQUIVALENCE object",
13294 r->u.c.component->name, &e->where);
13298 /* A substring shall not have length zero. */
13299 if (r->type == REF_SUBSTRING)
13301 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13303 gfc_error ("Substring at %L has length zero",
13304 &r->u.ss.start->where);
13314 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13317 resolve_fntype (gfc_namespace *ns)
13319 gfc_entry_list *el;
13322 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13325 /* If there are any entries, ns->proc_name is the entry master
13326 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13328 sym = ns->entries->sym;
13330 sym = ns->proc_name;
13331 if (sym->result == sym
13332 && sym->ts.type == BT_UNKNOWN
13333 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13334 && !sym->attr.untyped)
13336 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13337 sym->name, &sym->declared_at);
13338 sym->attr.untyped = 1;
13341 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13342 && !sym->attr.contained
13343 && !gfc_check_access (sym->ts.u.derived->attr.access,
13344 sym->ts.u.derived->ns->default_access)
13345 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13347 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13348 "%L of PRIVATE type '%s'", sym->name,
13349 &sym->declared_at, sym->ts.u.derived->name);
13353 for (el = ns->entries->next; el; el = el->next)
13355 if (el->sym->result == el->sym
13356 && el->sym->ts.type == BT_UNKNOWN
13357 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13358 && !el->sym->attr.untyped)
13360 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13361 el->sym->name, &el->sym->declared_at);
13362 el->sym->attr.untyped = 1;
13368 /* 12.3.2.1.1 Defined operators. */
13371 check_uop_procedure (gfc_symbol *sym, locus where)
13373 gfc_formal_arglist *formal;
13375 if (!sym->attr.function)
13377 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13378 sym->name, &where);
13382 if (sym->ts.type == BT_CHARACTER
13383 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13384 && !(sym->result && sym->result->ts.u.cl
13385 && sym->result->ts.u.cl->length))
13387 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13388 "character length", sym->name, &where);
13392 formal = sym->formal;
13393 if (!formal || !formal->sym)
13395 gfc_error ("User operator procedure '%s' at %L must have at least "
13396 "one argument", sym->name, &where);
13400 if (formal->sym->attr.intent != INTENT_IN)
13402 gfc_error ("First argument of operator interface at %L must be "
13403 "INTENT(IN)", &where);
13407 if (formal->sym->attr.optional)
13409 gfc_error ("First argument of operator interface at %L cannot be "
13410 "optional", &where);
13414 formal = formal->next;
13415 if (!formal || !formal->sym)
13418 if (formal->sym->attr.intent != INTENT_IN)
13420 gfc_error ("Second argument of operator interface at %L must be "
13421 "INTENT(IN)", &where);
13425 if (formal->sym->attr.optional)
13427 gfc_error ("Second argument of operator interface at %L cannot be "
13428 "optional", &where);
13434 gfc_error ("Operator interface at %L must have, at most, two "
13435 "arguments", &where);
13443 gfc_resolve_uops (gfc_symtree *symtree)
13445 gfc_interface *itr;
13447 if (symtree == NULL)
13450 gfc_resolve_uops (symtree->left);
13451 gfc_resolve_uops (symtree->right);
13453 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13454 check_uop_procedure (itr->sym, itr->sym->declared_at);
13458 /* Examine all of the expressions associated with a program unit,
13459 assign types to all intermediate expressions, make sure that all
13460 assignments are to compatible types and figure out which names
13461 refer to which functions or subroutines. It doesn't check code
13462 block, which is handled by resolve_code. */
13465 resolve_types (gfc_namespace *ns)
13471 gfc_namespace* old_ns = gfc_current_ns;
13473 /* Check that all IMPLICIT types are ok. */
13474 if (!ns->seen_implicit_none)
13477 for (letter = 0; letter != GFC_LETTERS; ++letter)
13478 if (ns->set_flag[letter]
13479 && resolve_typespec_used (&ns->default_type[letter],
13480 &ns->implicit_loc[letter],
13485 gfc_current_ns = ns;
13487 resolve_entries (ns);
13489 resolve_common_vars (ns->blank_common.head, false);
13490 resolve_common_blocks (ns->common_root);
13492 resolve_contained_functions (ns);
13494 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13496 for (cl = ns->cl_list; cl; cl = cl->next)
13497 resolve_charlen (cl);
13499 gfc_traverse_ns (ns, resolve_symbol);
13501 resolve_fntype (ns);
13503 for (n = ns->contained; n; n = n->sibling)
13505 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13506 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13507 "also be PURE", n->proc_name->name,
13508 &n->proc_name->declared_at);
13514 gfc_check_interfaces (ns);
13516 gfc_traverse_ns (ns, resolve_values);
13522 for (d = ns->data; d; d = d->next)
13526 gfc_traverse_ns (ns, gfc_formalize_init_value);
13528 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13530 if (ns->common_root != NULL)
13531 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13533 for (eq = ns->equiv; eq; eq = eq->next)
13534 resolve_equivalence (eq);
13536 /* Warn about unused labels. */
13537 if (warn_unused_label)
13538 warn_unused_fortran_label (ns->st_labels);
13540 gfc_resolve_uops (ns->uop_root);
13542 gfc_current_ns = old_ns;
13546 /* Call resolve_code recursively. */
13549 resolve_codes (gfc_namespace *ns)
13552 bitmap_obstack old_obstack;
13554 if (ns->resolved == 1)
13557 for (n = ns->contained; n; n = n->sibling)
13560 gfc_current_ns = ns;
13562 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13563 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13566 /* Set to an out of range value. */
13567 current_entry_id = -1;
13569 old_obstack = labels_obstack;
13570 bitmap_obstack_initialize (&labels_obstack);
13572 resolve_code (ns->code, ns);
13574 bitmap_obstack_release (&labels_obstack);
13575 labels_obstack = old_obstack;
13579 /* This function is called after a complete program unit has been compiled.
13580 Its purpose is to examine all of the expressions associated with a program
13581 unit, assign types to all intermediate expressions, make sure that all
13582 assignments are to compatible types and figure out which names refer to
13583 which functions or subroutines. */
13586 gfc_resolve (gfc_namespace *ns)
13588 gfc_namespace *old_ns;
13589 code_stack *old_cs_base;
13595 old_ns = gfc_current_ns;
13596 old_cs_base = cs_base;
13598 resolve_types (ns);
13599 resolve_codes (ns);
13601 gfc_current_ns = old_ns;
13602 cs_base = old_cs_base;
13605 gfc_run_passes (ns);