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)
342 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
343 "INTENT(IN)", sym->name, proc->name,
346 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
347 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
348 "have its INTENT specified", sym->name, proc->name,
352 if (proc->attr.implicit_pure && !sym->attr.pointer
353 && sym->attr.flavor != FL_PROCEDURE)
355 if (proc->attr.function && sym->attr.intent != INTENT_IN)
356 proc->attr.implicit_pure = 0;
358 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
359 proc->attr.implicit_pure = 0;
362 if (gfc_elemental (proc))
365 if (sym->attr.codimension)
367 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
368 "procedure", sym->name, &sym->declared_at);
374 gfc_error ("Argument '%s' of elemental procedure at %L must "
375 "be scalar", sym->name, &sym->declared_at);
379 if (sym->attr.allocatable)
381 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
382 "have the ALLOCATABLE attribute", sym->name,
387 if (sym->attr.pointer)
389 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
390 "have the POINTER attribute", sym->name,
395 if (sym->attr.flavor == FL_PROCEDURE)
397 gfc_error ("Dummy procedure '%s' not allowed in elemental "
398 "procedure '%s' at %L", sym->name, proc->name,
403 if (sym->attr.intent == INTENT_UNKNOWN)
405 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
406 "have its INTENT specified", sym->name, proc->name,
412 /* Each dummy shall be specified to be scalar. */
413 if (proc->attr.proc == PROC_ST_FUNCTION)
417 gfc_error ("Argument '%s' of statement function at %L must "
418 "be scalar", sym->name, &sym->declared_at);
422 if (sym->ts.type == BT_CHARACTER)
424 gfc_charlen *cl = sym->ts.u.cl;
425 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
427 gfc_error ("Character-valued argument '%s' of statement "
428 "function at %L must have constant length",
429 sym->name, &sym->declared_at);
439 /* Work function called when searching for symbols that have argument lists
440 associated with them. */
443 find_arglists (gfc_symbol *sym)
445 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
448 resolve_formal_arglist (sym);
452 /* Given a namespace, resolve all formal argument lists within the namespace.
456 resolve_formal_arglists (gfc_namespace *ns)
461 gfc_traverse_ns (ns, find_arglists);
466 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
470 /* If this namespace is not a function or an entry master function,
472 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
473 || sym->attr.entry_master)
476 /* Try to find out of what the return type is. */
477 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
479 t = gfc_set_default_type (sym->result, 0, ns);
481 if (t == FAILURE && !sym->result->attr.untyped)
483 if (sym->result == sym)
484 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
485 sym->name, &sym->declared_at);
486 else if (!sym->result->attr.proc_pointer)
487 gfc_error ("Result '%s' of contained function '%s' at %L has "
488 "no IMPLICIT type", sym->result->name, sym->name,
489 &sym->result->declared_at);
490 sym->result->attr.untyped = 1;
494 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
495 type, lists the only ways a character length value of * can be used:
496 dummy arguments of procedures, named constants, and function results
497 in external functions. Internal function results and results of module
498 procedures are not on this list, ergo, not permitted. */
500 if (sym->result->ts.type == BT_CHARACTER)
502 gfc_charlen *cl = sym->result->ts.u.cl;
503 if (!cl || !cl->length)
505 /* See if this is a module-procedure and adapt error message
508 gcc_assert (ns->parent && ns->parent->proc_name);
509 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
511 gfc_error ("Character-valued %s '%s' at %L must not be"
513 module_proc ? _("module procedure")
514 : _("internal function"),
515 sym->name, &sym->declared_at);
521 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
522 introduce duplicates. */
525 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
527 gfc_formal_arglist *f, *new_arglist;
530 for (; new_args != NULL; new_args = new_args->next)
532 new_sym = new_args->sym;
533 /* See if this arg is already in the formal argument list. */
534 for (f = proc->formal; f; f = f->next)
536 if (new_sym == f->sym)
543 /* Add a new argument. Argument order is not important. */
544 new_arglist = gfc_get_formal_arglist ();
545 new_arglist->sym = new_sym;
546 new_arglist->next = proc->formal;
547 proc->formal = new_arglist;
552 /* Flag the arguments that are not present in all entries. */
555 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
557 gfc_formal_arglist *f, *head;
560 for (f = proc->formal; f; f = f->next)
565 for (new_args = head; new_args; new_args = new_args->next)
567 if (new_args->sym == f->sym)
574 f->sym->attr.not_always_present = 1;
579 /* Resolve alternate entry points. If a symbol has multiple entry points we
580 create a new master symbol for the main routine, and turn the existing
581 symbol into an entry point. */
584 resolve_entries (gfc_namespace *ns)
586 gfc_namespace *old_ns;
590 char name[GFC_MAX_SYMBOL_LEN + 1];
591 static int master_count = 0;
593 if (ns->proc_name == NULL)
596 /* No need to do anything if this procedure doesn't have alternate entry
601 /* We may already have resolved alternate entry points. */
602 if (ns->proc_name->attr.entry_master)
605 /* If this isn't a procedure something has gone horribly wrong. */
606 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
608 /* Remember the current namespace. */
609 old_ns = gfc_current_ns;
613 /* Add the main entry point to the list of entry points. */
614 el = gfc_get_entry_list ();
615 el->sym = ns->proc_name;
617 el->next = ns->entries;
619 ns->proc_name->attr.entry = 1;
621 /* If it is a module function, it needs to be in the right namespace
622 so that gfc_get_fake_result_decl can gather up the results. The
623 need for this arose in get_proc_name, where these beasts were
624 left in their own namespace, to keep prior references linked to
625 the entry declaration.*/
626 if (ns->proc_name->attr.function
627 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
630 /* Do the same for entries where the master is not a module
631 procedure. These are retained in the module namespace because
632 of the module procedure declaration. */
633 for (el = el->next; el; el = el->next)
634 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
635 && el->sym->attr.mod_proc)
639 /* Add an entry statement for it. */
646 /* Create a new symbol for the master function. */
647 /* Give the internal function a unique name (within this file).
648 Also include the function name so the user has some hope of figuring
649 out what is going on. */
650 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
651 master_count++, ns->proc_name->name);
652 gfc_get_ha_symbol (name, &proc);
653 gcc_assert (proc != NULL);
655 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
656 if (ns->proc_name->attr.subroutine)
657 gfc_add_subroutine (&proc->attr, proc->name, NULL);
661 gfc_typespec *ts, *fts;
662 gfc_array_spec *as, *fas;
663 gfc_add_function (&proc->attr, proc->name, NULL);
665 fas = ns->entries->sym->as;
666 fas = fas ? fas : ns->entries->sym->result->as;
667 fts = &ns->entries->sym->result->ts;
668 if (fts->type == BT_UNKNOWN)
669 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
670 for (el = ns->entries->next; el; el = el->next)
672 ts = &el->sym->result->ts;
674 as = as ? as : el->sym->result->as;
675 if (ts->type == BT_UNKNOWN)
676 ts = gfc_get_default_type (el->sym->result->name, NULL);
678 if (! gfc_compare_types (ts, fts)
679 || (el->sym->result->attr.dimension
680 != ns->entries->sym->result->attr.dimension)
681 || (el->sym->result->attr.pointer
682 != ns->entries->sym->result->attr.pointer))
684 else if (as && fas && ns->entries->sym->result != el->sym->result
685 && gfc_compare_array_spec (as, fas) == 0)
686 gfc_error ("Function %s at %L has entries with mismatched "
687 "array specifications", ns->entries->sym->name,
688 &ns->entries->sym->declared_at);
689 /* The characteristics need to match and thus both need to have
690 the same string length, i.e. both len=*, or both len=4.
691 Having both len=<variable> is also possible, but difficult to
692 check at compile time. */
693 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
694 && (((ts->u.cl->length && !fts->u.cl->length)
695 ||(!ts->u.cl->length && fts->u.cl->length))
697 && ts->u.cl->length->expr_type
698 != fts->u.cl->length->expr_type)
700 && ts->u.cl->length->expr_type == EXPR_CONSTANT
701 && mpz_cmp (ts->u.cl->length->value.integer,
702 fts->u.cl->length->value.integer) != 0)))
703 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
704 "entries returning variables of different "
705 "string lengths", ns->entries->sym->name,
706 &ns->entries->sym->declared_at);
711 sym = ns->entries->sym->result;
712 /* All result types the same. */
714 if (sym->attr.dimension)
715 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
716 if (sym->attr.pointer)
717 gfc_add_pointer (&proc->attr, NULL);
721 /* Otherwise the result will be passed through a union by
723 proc->attr.mixed_entry_master = 1;
724 for (el = ns->entries; el; el = el->next)
726 sym = el->sym->result;
727 if (sym->attr.dimension)
729 if (el == ns->entries)
730 gfc_error ("FUNCTION result %s can't be an array in "
731 "FUNCTION %s at %L", sym->name,
732 ns->entries->sym->name, &sym->declared_at);
734 gfc_error ("ENTRY result %s can't be an array in "
735 "FUNCTION %s at %L", sym->name,
736 ns->entries->sym->name, &sym->declared_at);
738 else if (sym->attr.pointer)
740 if (el == ns->entries)
741 gfc_error ("FUNCTION result %s can't be a POINTER in "
742 "FUNCTION %s at %L", sym->name,
743 ns->entries->sym->name, &sym->declared_at);
745 gfc_error ("ENTRY result %s can't be a POINTER in "
746 "FUNCTION %s at %L", sym->name,
747 ns->entries->sym->name, &sym->declared_at);
752 if (ts->type == BT_UNKNOWN)
753 ts = gfc_get_default_type (sym->name, NULL);
757 if (ts->kind == gfc_default_integer_kind)
761 if (ts->kind == gfc_default_real_kind
762 || ts->kind == gfc_default_double_kind)
766 if (ts->kind == gfc_default_complex_kind)
770 if (ts->kind == gfc_default_logical_kind)
774 /* We will issue error elsewhere. */
782 if (el == ns->entries)
783 gfc_error ("FUNCTION result %s can't be of type %s "
784 "in FUNCTION %s at %L", sym->name,
785 gfc_typename (ts), ns->entries->sym->name,
788 gfc_error ("ENTRY result %s can't be of type %s "
789 "in FUNCTION %s at %L", sym->name,
790 gfc_typename (ts), ns->entries->sym->name,
797 proc->attr.access = ACCESS_PRIVATE;
798 proc->attr.entry_master = 1;
800 /* Merge all the entry point arguments. */
801 for (el = ns->entries; el; el = el->next)
802 merge_argument_lists (proc, el->sym->formal);
804 /* Check the master formal arguments for any that are not
805 present in all entry points. */
806 for (el = ns->entries; el; el = el->next)
807 check_argument_lists (proc, el->sym->formal);
809 /* Use the master function for the function body. */
810 ns->proc_name = proc;
812 /* Finalize the new symbols. */
813 gfc_commit_symbols ();
815 /* Restore the original namespace. */
816 gfc_current_ns = old_ns;
820 /* Resolve common variables. */
822 resolve_common_vars (gfc_symbol *sym, bool named_common)
824 gfc_symbol *csym = sym;
826 for (; csym; csym = csym->common_next)
828 if (csym->value || csym->attr.data)
830 if (!csym->ns->is_block_data)
831 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
832 "but only in BLOCK DATA initialization is "
833 "allowed", csym->name, &csym->declared_at);
834 else if (!named_common)
835 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
836 "in a blank COMMON but initialization is only "
837 "allowed in named common blocks", csym->name,
841 if (csym->ts.type != BT_DERIVED)
844 if (!(csym->ts.u.derived->attr.sequence
845 || csym->ts.u.derived->attr.is_bind_c))
846 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
847 "has neither the SEQUENCE nor the BIND(C) "
848 "attribute", csym->name, &csym->declared_at);
849 if (csym->ts.u.derived->attr.alloc_comp)
850 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
851 "has an ultimate component that is "
852 "allocatable", csym->name, &csym->declared_at);
853 if (gfc_has_default_initializer (csym->ts.u.derived))
854 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
855 "may not have default initializer", csym->name,
858 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
859 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
863 /* Resolve common blocks. */
865 resolve_common_blocks (gfc_symtree *common_root)
869 if (common_root == NULL)
872 if (common_root->left)
873 resolve_common_blocks (common_root->left);
874 if (common_root->right)
875 resolve_common_blocks (common_root->right);
877 resolve_common_vars (common_root->n.common->head, true);
879 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
883 if (sym->attr.flavor == FL_PARAMETER)
884 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
885 sym->name, &common_root->n.common->where, &sym->declared_at);
887 if (sym->attr.intrinsic)
888 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
889 sym->name, &common_root->n.common->where);
890 else if (sym->attr.result
891 || gfc_is_function_return_value (sym, gfc_current_ns))
892 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
893 "that is also a function result", sym->name,
894 &common_root->n.common->where);
895 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
896 && sym->attr.proc != PROC_ST_FUNCTION)
897 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
898 "that is also a global procedure", sym->name,
899 &common_root->n.common->where);
903 /* Resolve contained function types. Because contained functions can call one
904 another, they have to be worked out before any of the contained procedures
907 The good news is that if a function doesn't already have a type, the only
908 way it can get one is through an IMPLICIT type or a RESULT variable, because
909 by definition contained functions are contained namespace they're contained
910 in, not in a sibling or parent namespace. */
913 resolve_contained_functions (gfc_namespace *ns)
915 gfc_namespace *child;
918 resolve_formal_arglists (ns);
920 for (child = ns->contained; child; child = child->sibling)
922 /* Resolve alternate entry points first. */
923 resolve_entries (child);
925 /* Then check function return types. */
926 resolve_contained_fntype (child->proc_name, child);
927 for (el = child->entries; el; el = el->next)
928 resolve_contained_fntype (el->sym, child);
933 /* Resolve all of the elements of a structure constructor and make sure that
934 the types are correct. The 'init' flag indicates that the given
935 constructor is an initializer. */
938 resolve_structure_cons (gfc_expr *expr, int init)
940 gfc_constructor *cons;
947 if (expr->ts.type == BT_DERIVED)
948 resolve_symbol (expr->ts.u.derived);
950 cons = gfc_constructor_first (expr->value.constructor);
951 /* A constructor may have references if it is the result of substituting a
952 parameter variable. In this case we just pull out the component we
955 comp = expr->ref->u.c.sym->components;
957 comp = expr->ts.u.derived->components;
959 /* See if the user is trying to invoke a structure constructor for one of
960 the iso_c_binding derived types. */
961 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
962 && expr->ts.u.derived->ts.is_iso_c && cons
963 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
965 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
966 expr->ts.u.derived->name, &(expr->where));
970 /* Return if structure constructor is c_null_(fun)prt. */
971 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
972 && expr->ts.u.derived->ts.is_iso_c && cons
973 && cons->expr && cons->expr->expr_type == EXPR_NULL)
976 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
983 if (gfc_resolve_expr (cons->expr) == FAILURE)
989 rank = comp->as ? comp->as->rank : 0;
990 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
991 && (comp->attr.allocatable || cons->expr->rank))
993 gfc_error ("The rank of the element in the derived type "
994 "constructor at %L does not match that of the "
995 "component (%d/%d)", &cons->expr->where,
996 cons->expr->rank, rank);
1000 /* If we don't have the right type, try to convert it. */
1002 if (!comp->attr.proc_pointer &&
1003 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1006 if (strcmp (comp->name, "_extends") == 0)
1008 /* Can afford to be brutal with the _extends initializer.
1009 The derived type can get lost because it is PRIVATE
1010 but it is not usage constrained by the standard. */
1011 cons->expr->ts = comp->ts;
1014 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1015 gfc_error ("The element in the derived type constructor at %L, "
1016 "for pointer component '%s', is %s but should be %s",
1017 &cons->expr->where, comp->name,
1018 gfc_basic_typename (cons->expr->ts.type),
1019 gfc_basic_typename (comp->ts.type));
1021 t = gfc_convert_type (cons->expr, &comp->ts, 1);
1024 /* For strings, the length of the constructor should be the same as
1025 the one of the structure, ensure this if the lengths are known at
1026 compile time and when we are dealing with PARAMETER or structure
1028 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1029 && comp->ts.u.cl->length
1030 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1031 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1032 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1033 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1034 comp->ts.u.cl->length->value.integer) != 0)
1036 if (cons->expr->expr_type == EXPR_VARIABLE
1037 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1039 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1040 to make use of the gfc_resolve_character_array_constructor
1041 machinery. The expression is later simplified away to
1042 an array of string literals. */
1043 gfc_expr *para = cons->expr;
1044 cons->expr = gfc_get_expr ();
1045 cons->expr->ts = para->ts;
1046 cons->expr->where = para->where;
1047 cons->expr->expr_type = EXPR_ARRAY;
1048 cons->expr->rank = para->rank;
1049 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1050 gfc_constructor_append_expr (&cons->expr->value.constructor,
1051 para, &cons->expr->where);
1053 if (cons->expr->expr_type == EXPR_ARRAY)
1056 p = gfc_constructor_first (cons->expr->value.constructor);
1057 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1059 gfc_charlen *cl, *cl2;
1062 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1064 if (cl == cons->expr->ts.u.cl)
1072 cl2->next = cl->next;
1074 gfc_free_expr (cl->length);
1078 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1079 cons->expr->ts.u.cl->length_from_typespec = true;
1080 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1081 gfc_resolve_character_array_constructor (cons->expr);
1085 if (cons->expr->expr_type == EXPR_NULL
1086 && !(comp->attr.pointer || comp->attr.allocatable
1087 || comp->attr.proc_pointer
1088 || (comp->ts.type == BT_CLASS
1089 && (CLASS_DATA (comp)->attr.class_pointer
1090 || CLASS_DATA (comp)->attr.allocatable))))
1093 gfc_error ("The NULL in the derived type constructor at %L is "
1094 "being applied to component '%s', which is neither "
1095 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1099 if (!comp->attr.pointer || comp->attr.proc_pointer
1100 || cons->expr->expr_type == EXPR_NULL)
1103 a = gfc_expr_attr (cons->expr);
1105 if (!a.pointer && !a.target)
1108 gfc_error ("The element in the derived type constructor at %L, "
1109 "for pointer component '%s' should be a POINTER or "
1110 "a TARGET", &cons->expr->where, comp->name);
1115 /* F08:C461. Additional checks for pointer initialization. */
1119 gfc_error ("Pointer initialization target at %L "
1120 "must not be ALLOCATABLE ", &cons->expr->where);
1125 gfc_error ("Pointer initialization target at %L "
1126 "must have the SAVE attribute", &cons->expr->where);
1130 /* F2003, C1272 (3). */
1131 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1132 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1133 || gfc_is_coindexed (cons->expr)))
1136 gfc_error ("Invalid expression in the derived type constructor for "
1137 "pointer component '%s' at %L in PURE procedure",
1138 comp->name, &cons->expr->where);
1141 if (gfc_implicit_pure (NULL)
1142 && cons->expr->expr_type == EXPR_VARIABLE
1143 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1144 || gfc_is_coindexed (cons->expr)))
1145 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1153 /****************** Expression name resolution ******************/
1155 /* Returns 0 if a symbol was not declared with a type or
1156 attribute declaration statement, nonzero otherwise. */
1159 was_declared (gfc_symbol *sym)
1165 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1168 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1169 || a.optional || a.pointer || a.save || a.target || a.volatile_
1170 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1171 || a.asynchronous || a.codimension)
1178 /* Determine if a symbol is generic or not. */
1181 generic_sym (gfc_symbol *sym)
1185 if (sym->attr.generic ||
1186 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1189 if (was_declared (sym) || sym->ns->parent == NULL)
1192 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1199 return generic_sym (s);
1206 /* Determine if a symbol is specific or not. */
1209 specific_sym (gfc_symbol *sym)
1213 if (sym->attr.if_source == IFSRC_IFBODY
1214 || sym->attr.proc == PROC_MODULE
1215 || sym->attr.proc == PROC_INTERNAL
1216 || sym->attr.proc == PROC_ST_FUNCTION
1217 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1218 || sym->attr.external)
1221 if (was_declared (sym) || sym->ns->parent == NULL)
1224 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1226 return (s == NULL) ? 0 : specific_sym (s);
1230 /* Figure out if the procedure is specific, generic or unknown. */
1233 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1237 procedure_kind (gfc_symbol *sym)
1239 if (generic_sym (sym))
1240 return PTYPE_GENERIC;
1242 if (specific_sym (sym))
1243 return PTYPE_SPECIFIC;
1245 return PTYPE_UNKNOWN;
1248 /* Check references to assumed size arrays. The flag need_full_assumed_size
1249 is nonzero when matching actual arguments. */
1251 static int need_full_assumed_size = 0;
1254 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1256 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1259 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1260 What should it be? */
1261 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1262 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1263 && (e->ref->u.ar.type == AR_FULL))
1265 gfc_error ("The upper bound in the last dimension must "
1266 "appear in the reference to the assumed size "
1267 "array '%s' at %L", sym->name, &e->where);
1274 /* Look for bad assumed size array references in argument expressions
1275 of elemental and array valued intrinsic procedures. Since this is
1276 called from procedure resolution functions, it only recurses at
1280 resolve_assumed_size_actual (gfc_expr *e)
1285 switch (e->expr_type)
1288 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1293 if (resolve_assumed_size_actual (e->value.op.op1)
1294 || resolve_assumed_size_actual (e->value.op.op2))
1305 /* Check a generic procedure, passed as an actual argument, to see if
1306 there is a matching specific name. If none, it is an error, and if
1307 more than one, the reference is ambiguous. */
1309 count_specific_procs (gfc_expr *e)
1316 sym = e->symtree->n.sym;
1318 for (p = sym->generic; p; p = p->next)
1319 if (strcmp (sym->name, p->sym->name) == 0)
1321 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1327 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1331 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1332 "argument at %L", sym->name, &e->where);
1338 /* See if a call to sym could possibly be a not allowed RECURSION because of
1339 a missing RECURIVE declaration. This means that either sym is the current
1340 context itself, or sym is the parent of a contained procedure calling its
1341 non-RECURSIVE containing procedure.
1342 This also works if sym is an ENTRY. */
1345 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1347 gfc_symbol* proc_sym;
1348 gfc_symbol* context_proc;
1349 gfc_namespace* real_context;
1351 if (sym->attr.flavor == FL_PROGRAM)
1354 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1356 /* If we've got an ENTRY, find real procedure. */
1357 if (sym->attr.entry && sym->ns->entries)
1358 proc_sym = sym->ns->entries->sym;
1362 /* If sym is RECURSIVE, all is well of course. */
1363 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1366 /* Find the context procedure's "real" symbol if it has entries.
1367 We look for a procedure symbol, so recurse on the parents if we don't
1368 find one (like in case of a BLOCK construct). */
1369 for (real_context = context; ; real_context = real_context->parent)
1371 /* We should find something, eventually! */
1372 gcc_assert (real_context);
1374 context_proc = (real_context->entries ? real_context->entries->sym
1375 : real_context->proc_name);
1377 /* In some special cases, there may not be a proc_name, like for this
1379 real(bad_kind()) function foo () ...
1380 when checking the call to bad_kind ().
1381 In these cases, we simply return here and assume that the
1386 if (context_proc->attr.flavor != FL_LABEL)
1390 /* A call from sym's body to itself is recursion, of course. */
1391 if (context_proc == proc_sym)
1394 /* The same is true if context is a contained procedure and sym the
1396 if (context_proc->attr.contained)
1398 gfc_symbol* parent_proc;
1400 gcc_assert (context->parent);
1401 parent_proc = (context->parent->entries ? context->parent->entries->sym
1402 : context->parent->proc_name);
1404 if (parent_proc == proc_sym)
1412 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1413 its typespec and formal argument list. */
1416 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1418 gfc_intrinsic_sym* isym = NULL;
1424 /* We already know this one is an intrinsic, so we don't call
1425 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1426 gfc_find_subroutine directly to check whether it is a function or
1429 if (sym->intmod_sym_id)
1430 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1432 isym = gfc_find_function (sym->name);
1436 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1437 && !sym->attr.implicit_type)
1438 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1439 " ignored", sym->name, &sym->declared_at);
1441 if (!sym->attr.function &&
1442 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1447 else if ((isym = gfc_find_subroutine (sym->name)))
1449 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1451 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1452 " specifier", sym->name, &sym->declared_at);
1456 if (!sym->attr.subroutine &&
1457 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1462 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1467 gfc_copy_formal_args_intr (sym, isym);
1469 /* Check it is actually available in the standard settings. */
1470 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1473 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1474 " available in the current standard settings but %s. Use"
1475 " an appropriate -std=* option or enable -fall-intrinsics"
1476 " in order to use it.",
1477 sym->name, &sym->declared_at, symstd);
1485 /* Resolve a procedure expression, like passing it to a called procedure or as
1486 RHS for a procedure pointer assignment. */
1489 resolve_procedure_expression (gfc_expr* expr)
1493 if (expr->expr_type != EXPR_VARIABLE)
1495 gcc_assert (expr->symtree);
1497 sym = expr->symtree->n.sym;
1499 if (sym->attr.intrinsic)
1500 resolve_intrinsic (sym, &expr->where);
1502 if (sym->attr.flavor != FL_PROCEDURE
1503 || (sym->attr.function && sym->result == sym))
1506 /* A non-RECURSIVE procedure that is used as procedure expression within its
1507 own body is in danger of being called recursively. */
1508 if (is_illegal_recursion (sym, gfc_current_ns))
1509 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1510 " itself recursively. Declare it RECURSIVE or use"
1511 " -frecursive", sym->name, &expr->where);
1517 /* Resolve an actual argument list. Most of the time, this is just
1518 resolving the expressions in the list.
1519 The exception is that we sometimes have to decide whether arguments
1520 that look like procedure arguments are really simple variable
1524 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1525 bool no_formal_args)
1528 gfc_symtree *parent_st;
1530 int save_need_full_assumed_size;
1532 for (; arg; arg = arg->next)
1537 /* Check the label is a valid branching target. */
1540 if (arg->label->defined == ST_LABEL_UNKNOWN)
1542 gfc_error ("Label %d referenced at %L is never defined",
1543 arg->label->value, &arg->label->where);
1550 if (e->expr_type == EXPR_VARIABLE
1551 && e->symtree->n.sym->attr.generic
1553 && count_specific_procs (e) != 1)
1556 if (e->ts.type != BT_PROCEDURE)
1558 save_need_full_assumed_size = need_full_assumed_size;
1559 if (e->expr_type != EXPR_VARIABLE)
1560 need_full_assumed_size = 0;
1561 if (gfc_resolve_expr (e) != SUCCESS)
1563 need_full_assumed_size = save_need_full_assumed_size;
1567 /* See if the expression node should really be a variable reference. */
1569 sym = e->symtree->n.sym;
1571 if (sym->attr.flavor == FL_PROCEDURE
1572 || sym->attr.intrinsic
1573 || sym->attr.external)
1577 /* If a procedure is not already determined to be something else
1578 check if it is intrinsic. */
1579 if (!sym->attr.intrinsic
1580 && !(sym->attr.external || sym->attr.use_assoc
1581 || sym->attr.if_source == IFSRC_IFBODY)
1582 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1583 sym->attr.intrinsic = 1;
1585 if (sym->attr.proc == PROC_ST_FUNCTION)
1587 gfc_error ("Statement function '%s' at %L is not allowed as an "
1588 "actual argument", sym->name, &e->where);
1591 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1592 sym->attr.subroutine);
1593 if (sym->attr.intrinsic && actual_ok == 0)
1595 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1596 "actual argument", sym->name, &e->where);
1599 if (sym->attr.contained && !sym->attr.use_assoc
1600 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1602 if (gfc_notify_std (GFC_STD_F2008,
1603 "Fortran 2008: Internal procedure '%s' is"
1604 " used as actual argument at %L",
1605 sym->name, &e->where) == FAILURE)
1609 if (sym->attr.elemental && !sym->attr.intrinsic)
1611 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1612 "allowed as an actual argument at %L", sym->name,
1616 /* Check if a generic interface has a specific procedure
1617 with the same name before emitting an error. */
1618 if (sym->attr.generic && count_specific_procs (e) != 1)
1621 /* Just in case a specific was found for the expression. */
1622 sym = e->symtree->n.sym;
1624 /* If the symbol is the function that names the current (or
1625 parent) scope, then we really have a variable reference. */
1627 if (gfc_is_function_return_value (sym, sym->ns))
1630 /* If all else fails, see if we have a specific intrinsic. */
1631 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1633 gfc_intrinsic_sym *isym;
1635 isym = gfc_find_function (sym->name);
1636 if (isym == NULL || !isym->specific)
1638 gfc_error ("Unable to find a specific INTRINSIC procedure "
1639 "for the reference '%s' at %L", sym->name,
1644 sym->attr.intrinsic = 1;
1645 sym->attr.function = 1;
1648 if (gfc_resolve_expr (e) == FAILURE)
1653 /* See if the name is a module procedure in a parent unit. */
1655 if (was_declared (sym) || sym->ns->parent == NULL)
1658 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1660 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1664 if (parent_st == NULL)
1667 sym = parent_st->n.sym;
1668 e->symtree = parent_st; /* Point to the right thing. */
1670 if (sym->attr.flavor == FL_PROCEDURE
1671 || sym->attr.intrinsic
1672 || sym->attr.external)
1674 if (gfc_resolve_expr (e) == FAILURE)
1680 e->expr_type = EXPR_VARIABLE;
1682 if (sym->as != NULL)
1684 e->rank = sym->as->rank;
1685 e->ref = gfc_get_ref ();
1686 e->ref->type = REF_ARRAY;
1687 e->ref->u.ar.type = AR_FULL;
1688 e->ref->u.ar.as = sym->as;
1691 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1692 primary.c (match_actual_arg). If above code determines that it
1693 is a variable instead, it needs to be resolved as it was not
1694 done at the beginning of this function. */
1695 save_need_full_assumed_size = need_full_assumed_size;
1696 if (e->expr_type != EXPR_VARIABLE)
1697 need_full_assumed_size = 0;
1698 if (gfc_resolve_expr (e) != SUCCESS)
1700 need_full_assumed_size = save_need_full_assumed_size;
1703 /* Check argument list functions %VAL, %LOC and %REF. There is
1704 nothing to do for %REF. */
1705 if (arg->name && arg->name[0] == '%')
1707 if (strncmp ("%VAL", arg->name, 4) == 0)
1709 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1711 gfc_error ("By-value argument at %L is not of numeric "
1718 gfc_error ("By-value argument at %L cannot be an array or "
1719 "an array section", &e->where);
1723 /* Intrinsics are still PROC_UNKNOWN here. However,
1724 since same file external procedures are not resolvable
1725 in gfortran, it is a good deal easier to leave them to
1727 if (ptype != PROC_UNKNOWN
1728 && ptype != PROC_DUMMY
1729 && ptype != PROC_EXTERNAL
1730 && ptype != PROC_MODULE)
1732 gfc_error ("By-value argument at %L is not allowed "
1733 "in this context", &e->where);
1738 /* Statement functions have already been excluded above. */
1739 else if (strncmp ("%LOC", arg->name, 4) == 0
1740 && e->ts.type == BT_PROCEDURE)
1742 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1744 gfc_error ("Passing internal procedure at %L by location "
1745 "not allowed", &e->where);
1751 /* Fortran 2008, C1237. */
1752 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1753 && gfc_has_ultimate_pointer (e))
1755 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1756 "component", &e->where);
1765 /* Do the checks of the actual argument list that are specific to elemental
1766 procedures. If called with c == NULL, we have a function, otherwise if
1767 expr == NULL, we have a subroutine. */
1770 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1772 gfc_actual_arglist *arg0;
1773 gfc_actual_arglist *arg;
1774 gfc_symbol *esym = NULL;
1775 gfc_intrinsic_sym *isym = NULL;
1777 gfc_intrinsic_arg *iformal = NULL;
1778 gfc_formal_arglist *eformal = NULL;
1779 bool formal_optional = false;
1780 bool set_by_optional = false;
1784 /* Is this an elemental procedure? */
1785 if (expr && expr->value.function.actual != NULL)
1787 if (expr->value.function.esym != NULL
1788 && expr->value.function.esym->attr.elemental)
1790 arg0 = expr->value.function.actual;
1791 esym = expr->value.function.esym;
1793 else if (expr->value.function.isym != NULL
1794 && expr->value.function.isym->elemental)
1796 arg0 = expr->value.function.actual;
1797 isym = expr->value.function.isym;
1802 else if (c && c->ext.actual != NULL)
1804 arg0 = c->ext.actual;
1806 if (c->resolved_sym)
1807 esym = c->resolved_sym;
1809 esym = c->symtree->n.sym;
1812 if (!esym->attr.elemental)
1818 /* The rank of an elemental is the rank of its array argument(s). */
1819 for (arg = arg0; arg; arg = arg->next)
1821 if (arg->expr != NULL && arg->expr->rank > 0)
1823 rank = arg->expr->rank;
1824 if (arg->expr->expr_type == EXPR_VARIABLE
1825 && arg->expr->symtree->n.sym->attr.optional)
1826 set_by_optional = true;
1828 /* Function specific; set the result rank and shape. */
1832 if (!expr->shape && arg->expr->shape)
1834 expr->shape = gfc_get_shape (rank);
1835 for (i = 0; i < rank; i++)
1836 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1843 /* If it is an array, it shall not be supplied as an actual argument
1844 to an elemental procedure unless an array of the same rank is supplied
1845 as an actual argument corresponding to a nonoptional dummy argument of
1846 that elemental procedure(12.4.1.5). */
1847 formal_optional = false;
1849 iformal = isym->formal;
1851 eformal = esym->formal;
1853 for (arg = arg0; arg; arg = arg->next)
1857 if (eformal->sym && eformal->sym->attr.optional)
1858 formal_optional = true;
1859 eformal = eformal->next;
1861 else if (isym && iformal)
1863 if (iformal->optional)
1864 formal_optional = true;
1865 iformal = iformal->next;
1868 formal_optional = true;
1870 if (pedantic && arg->expr != NULL
1871 && arg->expr->expr_type == EXPR_VARIABLE
1872 && arg->expr->symtree->n.sym->attr.optional
1875 && (set_by_optional || arg->expr->rank != rank)
1876 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1878 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1879 "MISSING, it cannot be the actual argument of an "
1880 "ELEMENTAL procedure unless there is a non-optional "
1881 "argument with the same rank (12.4.1.5)",
1882 arg->expr->symtree->n.sym->name, &arg->expr->where);
1887 for (arg = arg0; arg; arg = arg->next)
1889 if (arg->expr == NULL || arg->expr->rank == 0)
1892 /* Being elemental, the last upper bound of an assumed size array
1893 argument must be present. */
1894 if (resolve_assumed_size_actual (arg->expr))
1897 /* Elemental procedure's array actual arguments must conform. */
1900 if (gfc_check_conformance (arg->expr, e,
1901 "elemental procedure") == FAILURE)
1908 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1909 is an array, the intent inout/out variable needs to be also an array. */
1910 if (rank > 0 && esym && expr == NULL)
1911 for (eformal = esym->formal, arg = arg0; arg && eformal;
1912 arg = arg->next, eformal = eformal->next)
1913 if ((eformal->sym->attr.intent == INTENT_OUT
1914 || eformal->sym->attr.intent == INTENT_INOUT)
1915 && arg->expr && arg->expr->rank == 0)
1917 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1918 "ELEMENTAL subroutine '%s' is a scalar, but another "
1919 "actual argument is an array", &arg->expr->where,
1920 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1921 : "INOUT", eformal->sym->name, esym->name);
1928 /* This function does the checking of references to global procedures
1929 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1930 77 and 95 standards. It checks for a gsymbol for the name, making
1931 one if it does not already exist. If it already exists, then the
1932 reference being resolved must correspond to the type of gsymbol.
1933 Otherwise, the new symbol is equipped with the attributes of the
1934 reference. The corresponding code that is called in creating
1935 global entities is parse.c.
1937 In addition, for all but -std=legacy, the gsymbols are used to
1938 check the interfaces of external procedures from the same file.
1939 The namespace of the gsymbol is resolved and then, once this is
1940 done the interface is checked. */
1944 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1946 if (!gsym_ns->proc_name->attr.recursive)
1949 if (sym->ns == gsym_ns)
1952 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1959 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1961 if (gsym_ns->entries)
1963 gfc_entry_list *entry = gsym_ns->entries;
1965 for (; entry; entry = entry->next)
1967 if (strcmp (sym->name, entry->sym->name) == 0)
1969 if (strcmp (gsym_ns->proc_name->name,
1970 sym->ns->proc_name->name) == 0)
1974 && strcmp (gsym_ns->proc_name->name,
1975 sym->ns->parent->proc_name->name) == 0)
1984 resolve_global_procedure (gfc_symbol *sym, locus *where,
1985 gfc_actual_arglist **actual, int sub)
1989 enum gfc_symbol_type type;
1991 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1993 gsym = gfc_get_gsymbol (sym->name);
1995 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1996 gfc_global_used (gsym, where);
1998 if (gfc_option.flag_whole_file
1999 && (sym->attr.if_source == IFSRC_UNKNOWN
2000 || sym->attr.if_source == IFSRC_IFBODY)
2001 && gsym->type != GSYM_UNKNOWN
2003 && gsym->ns->resolved != -1
2004 && gsym->ns->proc_name
2005 && not_in_recursive (sym, gsym->ns)
2006 && not_entry_self_reference (sym, gsym->ns))
2008 gfc_symbol *def_sym;
2010 /* Resolve the gsymbol namespace if needed. */
2011 if (!gsym->ns->resolved)
2013 gfc_dt_list *old_dt_list;
2014 struct gfc_omp_saved_state old_omp_state;
2016 /* Stash away derived types so that the backend_decls do not
2018 old_dt_list = gfc_derived_types;
2019 gfc_derived_types = NULL;
2020 /* And stash away openmp state. */
2021 gfc_omp_save_and_clear_state (&old_omp_state);
2023 gfc_resolve (gsym->ns);
2025 /* Store the new derived types with the global namespace. */
2026 if (gfc_derived_types)
2027 gsym->ns->derived_types = gfc_derived_types;
2029 /* Restore the derived types of this namespace. */
2030 gfc_derived_types = old_dt_list;
2031 /* And openmp state. */
2032 gfc_omp_restore_state (&old_omp_state);
2035 /* Make sure that translation for the gsymbol occurs before
2036 the procedure currently being resolved. */
2037 ns = gfc_global_ns_list;
2038 for (; ns && ns != gsym->ns; ns = ns->sibling)
2040 if (ns->sibling == gsym->ns)
2042 ns->sibling = gsym->ns->sibling;
2043 gsym->ns->sibling = gfc_global_ns_list;
2044 gfc_global_ns_list = gsym->ns;
2049 def_sym = gsym->ns->proc_name;
2050 if (def_sym->attr.entry_master)
2052 gfc_entry_list *entry;
2053 for (entry = gsym->ns->entries; entry; entry = entry->next)
2054 if (strcmp (entry->sym->name, sym->name) == 0)
2056 def_sym = entry->sym;
2061 /* Differences in constant character lengths. */
2062 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2064 long int l1 = 0, l2 = 0;
2065 gfc_charlen *cl1 = sym->ts.u.cl;
2066 gfc_charlen *cl2 = def_sym->ts.u.cl;
2069 && cl1->length != NULL
2070 && cl1->length->expr_type == EXPR_CONSTANT)
2071 l1 = mpz_get_si (cl1->length->value.integer);
2074 && cl2->length != NULL
2075 && cl2->length->expr_type == EXPR_CONSTANT)
2076 l2 = mpz_get_si (cl2->length->value.integer);
2078 if (l1 && l2 && l1 != l2)
2079 gfc_error ("Character length mismatch in return type of "
2080 "function '%s' at %L (%ld/%ld)", sym->name,
2081 &sym->declared_at, l1, l2);
2084 /* Type mismatch of function return type and expected type. */
2085 if (sym->attr.function
2086 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2087 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2088 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2089 gfc_typename (&def_sym->ts));
2091 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2093 gfc_formal_arglist *arg = def_sym->formal;
2094 for ( ; arg; arg = arg->next)
2097 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2098 else if (arg->sym->attr.allocatable
2099 || arg->sym->attr.asynchronous
2100 || arg->sym->attr.optional
2101 || arg->sym->attr.pointer
2102 || arg->sym->attr.target
2103 || arg->sym->attr.value
2104 || arg->sym->attr.volatile_)
2106 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2107 "has an attribute that requires an explicit "
2108 "interface for this procedure", arg->sym->name,
2109 sym->name, &sym->declared_at);
2112 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2113 else if (arg->sym && arg->sym->as
2114 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2116 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2117 "argument '%s' must have an explicit interface",
2118 sym->name, &sym->declared_at, arg->sym->name);
2121 /* F2008, 12.4.2.2 (2c) */
2122 else if (arg->sym->attr.codimension)
2124 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2125 "'%s' must have an explicit interface",
2126 sym->name, &sym->declared_at, arg->sym->name);
2129 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2130 else if (false) /* TODO: is a parametrized derived type */
2132 gfc_error ("Procedure '%s' at %L with parametrized derived "
2133 "type argument '%s' must have an explicit "
2134 "interface", sym->name, &sym->declared_at,
2138 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2139 else if (arg->sym->ts.type == BT_CLASS)
2141 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2142 "argument '%s' must have an explicit interface",
2143 sym->name, &sym->declared_at, arg->sym->name);
2148 if (def_sym->attr.function)
2150 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2151 if (def_sym->as && def_sym->as->rank
2152 && (!sym->as || sym->as->rank != def_sym->as->rank))
2153 gfc_error ("The reference to function '%s' at %L either needs an "
2154 "explicit INTERFACE or the rank is incorrect", sym->name,
2157 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2158 if ((def_sym->result->attr.pointer
2159 || def_sym->result->attr.allocatable)
2160 && (sym->attr.if_source != IFSRC_IFBODY
2161 || def_sym->result->attr.pointer
2162 != sym->result->attr.pointer
2163 || def_sym->result->attr.allocatable
2164 != sym->result->attr.allocatable))
2165 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2166 "result must have an explicit interface", sym->name,
2169 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2170 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2171 && def_sym->ts.u.cl->length != NULL)
2173 gfc_charlen *cl = sym->ts.u.cl;
2175 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2176 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2178 gfc_error ("Nonconstant character-length function '%s' at %L "
2179 "must have an explicit interface", sym->name,
2185 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2186 if (def_sym->attr.elemental && !sym->attr.elemental)
2188 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2189 "interface", sym->name, &sym->declared_at);
2192 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2193 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2195 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2196 "an explicit interface", sym->name, &sym->declared_at);
2199 if (gfc_option.flag_whole_file == 1
2200 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2201 && !(gfc_option.warn_std & GFC_STD_GNU)))
2202 gfc_errors_to_warnings (1);
2204 if (sym->attr.if_source != IFSRC_IFBODY)
2205 gfc_procedure_use (def_sym, actual, where);
2207 gfc_errors_to_warnings (0);
2210 if (gsym->type == GSYM_UNKNOWN)
2213 gsym->where = *where;
2220 /************* Function resolution *************/
2222 /* Resolve a function call known to be generic.
2223 Section 14.1.2.4.1. */
2226 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2230 if (sym->attr.generic)
2232 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2235 expr->value.function.name = s->name;
2236 expr->value.function.esym = s;
2238 if (s->ts.type != BT_UNKNOWN)
2240 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2241 expr->ts = s->result->ts;
2244 expr->rank = s->as->rank;
2245 else if (s->result != NULL && s->result->as != NULL)
2246 expr->rank = s->result->as->rank;
2248 gfc_set_sym_referenced (expr->value.function.esym);
2253 /* TODO: Need to search for elemental references in generic
2257 if (sym->attr.intrinsic)
2258 return gfc_intrinsic_func_interface (expr, 0);
2265 resolve_generic_f (gfc_expr *expr)
2270 sym = expr->symtree->n.sym;
2274 m = resolve_generic_f0 (expr, sym);
2277 else if (m == MATCH_ERROR)
2281 if (sym->ns->parent == NULL)
2283 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2287 if (!generic_sym (sym))
2291 /* Last ditch attempt. See if the reference is to an intrinsic
2292 that possesses a matching interface. 14.1.2.4 */
2293 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2295 gfc_error ("There is no specific function for the generic '%s' at %L",
2296 expr->symtree->n.sym->name, &expr->where);
2300 m = gfc_intrinsic_func_interface (expr, 0);
2304 gfc_error ("Generic function '%s' at %L is not consistent with a "
2305 "specific intrinsic interface", expr->symtree->n.sym->name,
2312 /* Resolve a function call known to be specific. */
2315 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2319 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2321 if (sym->attr.dummy)
2323 sym->attr.proc = PROC_DUMMY;
2327 sym->attr.proc = PROC_EXTERNAL;
2331 if (sym->attr.proc == PROC_MODULE
2332 || sym->attr.proc == PROC_ST_FUNCTION
2333 || sym->attr.proc == PROC_INTERNAL)
2336 if (sym->attr.intrinsic)
2338 m = gfc_intrinsic_func_interface (expr, 1);
2342 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2343 "with an intrinsic", sym->name, &expr->where);
2351 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2354 expr->ts = sym->result->ts;
2357 expr->value.function.name = sym->name;
2358 expr->value.function.esym = sym;
2359 if (sym->as != NULL)
2360 expr->rank = sym->as->rank;
2367 resolve_specific_f (gfc_expr *expr)
2372 sym = expr->symtree->n.sym;
2376 m = resolve_specific_f0 (sym, expr);
2379 if (m == MATCH_ERROR)
2382 if (sym->ns->parent == NULL)
2385 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2391 gfc_error ("Unable to resolve the specific function '%s' at %L",
2392 expr->symtree->n.sym->name, &expr->where);
2398 /* Resolve a procedure call not known to be generic nor specific. */
2401 resolve_unknown_f (gfc_expr *expr)
2406 sym = expr->symtree->n.sym;
2408 if (sym->attr.dummy)
2410 sym->attr.proc = PROC_DUMMY;
2411 expr->value.function.name = sym->name;
2415 /* See if we have an intrinsic function reference. */
2417 if (gfc_is_intrinsic (sym, 0, expr->where))
2419 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2424 /* The reference is to an external name. */
2426 sym->attr.proc = PROC_EXTERNAL;
2427 expr->value.function.name = sym->name;
2428 expr->value.function.esym = expr->symtree->n.sym;
2430 if (sym->as != NULL)
2431 expr->rank = sym->as->rank;
2433 /* Type of the expression is either the type of the symbol or the
2434 default type of the symbol. */
2437 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2439 if (sym->ts.type != BT_UNKNOWN)
2443 ts = gfc_get_default_type (sym->name, sym->ns);
2445 if (ts->type == BT_UNKNOWN)
2447 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2448 sym->name, &expr->where);
2459 /* Return true, if the symbol is an external procedure. */
2461 is_external_proc (gfc_symbol *sym)
2463 if (!sym->attr.dummy && !sym->attr.contained
2464 && !(sym->attr.intrinsic
2465 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2466 && sym->attr.proc != PROC_ST_FUNCTION
2467 && !sym->attr.proc_pointer
2468 && !sym->attr.use_assoc
2476 /* Figure out if a function reference is pure or not. Also set the name
2477 of the function for a potential error message. Return nonzero if the
2478 function is PURE, zero if not. */
2480 pure_stmt_function (gfc_expr *, gfc_symbol *);
2483 pure_function (gfc_expr *e, const char **name)
2489 if (e->symtree != NULL
2490 && e->symtree->n.sym != NULL
2491 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2492 return pure_stmt_function (e, e->symtree->n.sym);
2494 if (e->value.function.esym)
2496 pure = gfc_pure (e->value.function.esym);
2497 *name = e->value.function.esym->name;
2499 else if (e->value.function.isym)
2501 pure = e->value.function.isym->pure
2502 || e->value.function.isym->elemental;
2503 *name = e->value.function.isym->name;
2507 /* Implicit functions are not pure. */
2509 *name = e->value.function.name;
2517 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2518 int *f ATTRIBUTE_UNUSED)
2522 /* Don't bother recursing into other statement functions
2523 since they will be checked individually for purity. */
2524 if (e->expr_type != EXPR_FUNCTION
2526 || e->symtree->n.sym == sym
2527 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2530 return pure_function (e, &name) ? false : true;
2535 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2537 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2542 is_scalar_expr_ptr (gfc_expr *expr)
2544 gfc_try retval = SUCCESS;
2549 /* See if we have a gfc_ref, which means we have a substring, array
2550 reference, or a component. */
2551 if (expr->ref != NULL)
2554 while (ref->next != NULL)
2560 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2561 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2566 if (ref->u.ar.type == AR_ELEMENT)
2568 else if (ref->u.ar.type == AR_FULL)
2570 /* The user can give a full array if the array is of size 1. */
2571 if (ref->u.ar.as != NULL
2572 && ref->u.ar.as->rank == 1
2573 && ref->u.ar.as->type == AS_EXPLICIT
2574 && ref->u.ar.as->lower[0] != NULL
2575 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2576 && ref->u.ar.as->upper[0] != NULL
2577 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2579 /* If we have a character string, we need to check if
2580 its length is one. */
2581 if (expr->ts.type == BT_CHARACTER)
2583 if (expr->ts.u.cl == NULL
2584 || expr->ts.u.cl->length == NULL
2585 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2591 /* We have constant lower and upper bounds. If the
2592 difference between is 1, it can be considered a
2594 FIXME: Use gfc_dep_compare_expr instead. */
2595 start = (int) mpz_get_si
2596 (ref->u.ar.as->lower[0]->value.integer);
2597 end = (int) mpz_get_si
2598 (ref->u.ar.as->upper[0]->value.integer);
2599 if (end - start + 1 != 1)
2614 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2616 /* Character string. Make sure it's of length 1. */
2617 if (expr->ts.u.cl == NULL
2618 || expr->ts.u.cl->length == NULL
2619 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2622 else if (expr->rank != 0)
2629 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2630 and, in the case of c_associated, set the binding label based on
2634 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2635 gfc_symbol **new_sym)
2637 char name[GFC_MAX_SYMBOL_LEN + 1];
2638 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2639 int optional_arg = 0;
2640 gfc_try retval = SUCCESS;
2641 gfc_symbol *args_sym;
2642 gfc_typespec *arg_ts;
2643 symbol_attribute arg_attr;
2645 if (args->expr->expr_type == EXPR_CONSTANT
2646 || args->expr->expr_type == EXPR_OP
2647 || args->expr->expr_type == EXPR_NULL)
2649 gfc_error ("Argument to '%s' at %L is not a variable",
2650 sym->name, &(args->expr->where));
2654 args_sym = args->expr->symtree->n.sym;
2656 /* The typespec for the actual arg should be that stored in the expr
2657 and not necessarily that of the expr symbol (args_sym), because
2658 the actual expression could be a part-ref of the expr symbol. */
2659 arg_ts = &(args->expr->ts);
2660 arg_attr = gfc_expr_attr (args->expr);
2662 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2664 /* If the user gave two args then they are providing something for
2665 the optional arg (the second cptr). Therefore, set the name and
2666 binding label to the c_associated for two cptrs. Otherwise,
2667 set c_associated to expect one cptr. */
2671 sprintf (name, "%s_2", sym->name);
2672 sprintf (binding_label, "%s_2", sym->binding_label);
2678 sprintf (name, "%s_1", sym->name);
2679 sprintf (binding_label, "%s_1", sym->binding_label);
2683 /* Get a new symbol for the version of c_associated that
2685 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2687 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2688 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2690 sprintf (name, "%s", sym->name);
2691 sprintf (binding_label, "%s", sym->binding_label);
2693 /* Error check the call. */
2694 if (args->next != NULL)
2696 gfc_error_now ("More actual than formal arguments in '%s' "
2697 "call at %L", name, &(args->expr->where));
2700 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2705 /* Make sure we have either the target or pointer attribute. */
2706 if (!arg_attr.target && !arg_attr.pointer)
2708 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2709 "a TARGET or an associated pointer",
2711 sym->name, &(args->expr->where));
2715 if (gfc_is_coindexed (args->expr))
2717 gfc_error_now ("Coindexed argument not permitted"
2718 " in '%s' call at %L", name,
2719 &(args->expr->where));
2723 /* Follow references to make sure there are no array
2725 seen_section = false;
2727 for (ref=args->expr->ref; ref; ref = ref->next)
2729 if (ref->type == REF_ARRAY)
2731 if (ref->u.ar.type == AR_SECTION)
2732 seen_section = true;
2734 if (ref->u.ar.type != AR_ELEMENT)
2737 for (r = ref->next; r; r=r->next)
2738 if (r->type == REF_COMPONENT)
2740 gfc_error_now ("Array section not permitted"
2741 " in '%s' call at %L", name,
2742 &(args->expr->where));
2750 if (seen_section && retval == SUCCESS)
2751 gfc_warning ("Array section in '%s' call at %L", name,
2752 &(args->expr->where));
2754 /* See if we have interoperable type and type param. */
2755 if (verify_c_interop (arg_ts) == SUCCESS
2756 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2758 if (args_sym->attr.target == 1)
2760 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2761 has the target attribute and is interoperable. */
2762 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2763 allocatable variable that has the TARGET attribute and
2764 is not an array of zero size. */
2765 if (args_sym->attr.allocatable == 1)
2767 if (args_sym->attr.dimension != 0
2768 && (args_sym->as && args_sym->as->rank == 0))
2770 gfc_error_now ("Allocatable variable '%s' used as a "
2771 "parameter to '%s' at %L must not be "
2772 "an array of zero size",
2773 args_sym->name, sym->name,
2774 &(args->expr->where));
2780 /* A non-allocatable target variable with C
2781 interoperable type and type parameters must be
2783 if (args_sym && args_sym->attr.dimension)
2785 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2787 gfc_error ("Assumed-shape array '%s' at %L "
2788 "cannot be an argument to the "
2789 "procedure '%s' because "
2790 "it is not C interoperable",
2792 &(args->expr->where), sym->name);
2795 else if (args_sym->as->type == AS_DEFERRED)
2797 gfc_error ("Deferred-shape array '%s' at %L "
2798 "cannot be an argument to the "
2799 "procedure '%s' because "
2800 "it is not C interoperable",
2802 &(args->expr->where), sym->name);
2807 /* Make sure it's not a character string. Arrays of
2808 any type should be ok if the variable is of a C
2809 interoperable type. */
2810 if (arg_ts->type == BT_CHARACTER)
2811 if (arg_ts->u.cl != NULL
2812 && (arg_ts->u.cl->length == NULL
2813 || arg_ts->u.cl->length->expr_type
2816 (arg_ts->u.cl->length->value.integer, 1)
2818 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2820 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2821 "at %L must have a length of 1",
2822 args_sym->name, sym->name,
2823 &(args->expr->where));
2828 else if (arg_attr.pointer
2829 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2831 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2833 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2834 "associated scalar POINTER", args_sym->name,
2835 sym->name, &(args->expr->where));
2841 /* The parameter is not required to be C interoperable. If it
2842 is not C interoperable, it must be a nonpolymorphic scalar
2843 with no length type parameters. It still must have either
2844 the pointer or target attribute, and it can be
2845 allocatable (but must be allocated when c_loc is called). */
2846 if (args->expr->rank != 0
2847 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2849 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2850 "scalar", args_sym->name, sym->name,
2851 &(args->expr->where));
2854 else if (arg_ts->type == BT_CHARACTER
2855 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2857 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2858 "%L must have a length of 1",
2859 args_sym->name, sym->name,
2860 &(args->expr->where));
2863 else if (arg_ts->type == BT_CLASS)
2865 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2866 "polymorphic", args_sym->name, sym->name,
2867 &(args->expr->where));
2872 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2874 if (args_sym->attr.flavor != FL_PROCEDURE)
2876 /* TODO: Update this error message to allow for procedure
2877 pointers once they are implemented. */
2878 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2880 args_sym->name, sym->name,
2881 &(args->expr->where));
2884 else if (args_sym->attr.is_bind_c != 1)
2886 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2888 args_sym->name, sym->name,
2889 &(args->expr->where));
2894 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2899 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2900 "iso_c_binding function: '%s'!\n", sym->name);
2907 /* Resolve a function call, which means resolving the arguments, then figuring
2908 out which entity the name refers to. */
2911 resolve_function (gfc_expr *expr)
2913 gfc_actual_arglist *arg;
2918 procedure_type p = PROC_INTRINSIC;
2919 bool no_formal_args;
2923 sym = expr->symtree->n.sym;
2925 /* If this is a procedure pointer component, it has already been resolved. */
2926 if (gfc_is_proc_ptr_comp (expr, NULL))
2929 if (sym && sym->attr.intrinsic
2930 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2933 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2935 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2939 /* If this ia a deferred TBP with an abstract interface (which may
2940 of course be referenced), expr->value.function.esym will be set. */
2941 if (sym && sym->attr.abstract && !expr->value.function.esym)
2943 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2944 sym->name, &expr->where);
2948 /* Switch off assumed size checking and do this again for certain kinds
2949 of procedure, once the procedure itself is resolved. */
2950 need_full_assumed_size++;
2952 if (expr->symtree && expr->symtree->n.sym)
2953 p = expr->symtree->n.sym->attr.proc;
2955 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2956 inquiry_argument = true;
2957 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2959 if (resolve_actual_arglist (expr->value.function.actual,
2960 p, no_formal_args) == FAILURE)
2962 inquiry_argument = false;
2966 inquiry_argument = false;
2968 /* Need to setup the call to the correct c_associated, depending on
2969 the number of cptrs to user gives to compare. */
2970 if (sym && sym->attr.is_iso_c == 1)
2972 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2976 /* Get the symtree for the new symbol (resolved func).
2977 the old one will be freed later, when it's no longer used. */
2978 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2981 /* Resume assumed_size checking. */
2982 need_full_assumed_size--;
2984 /* If the procedure is external, check for usage. */
2985 if (sym && is_external_proc (sym))
2986 resolve_global_procedure (sym, &expr->where,
2987 &expr->value.function.actual, 0);
2989 if (sym && sym->ts.type == BT_CHARACTER
2991 && sym->ts.u.cl->length == NULL
2993 && expr->value.function.esym == NULL
2994 && !sym->attr.contained)
2996 /* Internal procedures are taken care of in resolve_contained_fntype. */
2997 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2998 "be used at %L since it is not a dummy argument",
2999 sym->name, &expr->where);
3003 /* See if function is already resolved. */
3005 if (expr->value.function.name != NULL)
3007 if (expr->ts.type == BT_UNKNOWN)
3013 /* Apply the rules of section 14.1.2. */
3015 switch (procedure_kind (sym))
3018 t = resolve_generic_f (expr);
3021 case PTYPE_SPECIFIC:
3022 t = resolve_specific_f (expr);
3026 t = resolve_unknown_f (expr);
3030 gfc_internal_error ("resolve_function(): bad function type");
3034 /* If the expression is still a function (it might have simplified),
3035 then we check to see if we are calling an elemental function. */
3037 if (expr->expr_type != EXPR_FUNCTION)
3040 temp = need_full_assumed_size;
3041 need_full_assumed_size = 0;
3043 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3046 if (omp_workshare_flag
3047 && expr->value.function.esym
3048 && ! gfc_elemental (expr->value.function.esym))
3050 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3051 "in WORKSHARE construct", expr->value.function.esym->name,
3056 #define GENERIC_ID expr->value.function.isym->id
3057 else if (expr->value.function.actual != NULL
3058 && expr->value.function.isym != NULL
3059 && GENERIC_ID != GFC_ISYM_LBOUND
3060 && GENERIC_ID != GFC_ISYM_LEN
3061 && GENERIC_ID != GFC_ISYM_LOC
3062 && GENERIC_ID != GFC_ISYM_PRESENT)
3064 /* Array intrinsics must also have the last upper bound of an
3065 assumed size array argument. UBOUND and SIZE have to be
3066 excluded from the check if the second argument is anything
3069 for (arg = expr->value.function.actual; arg; arg = arg->next)
3071 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3072 && arg->next != NULL && arg->next->expr)
3074 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3077 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3080 if ((int)mpz_get_si (arg->next->expr->value.integer)
3085 if (arg->expr != NULL
3086 && arg->expr->rank > 0
3087 && resolve_assumed_size_actual (arg->expr))
3093 need_full_assumed_size = temp;
3096 if (!pure_function (expr, &name) && name)
3100 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3101 "FORALL %s", name, &expr->where,
3102 forall_flag == 2 ? "mask" : "block");
3105 else if (gfc_pure (NULL))
3107 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3108 "procedure within a PURE procedure", name, &expr->where);
3113 if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
3114 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3116 /* Functions without the RECURSIVE attribution are not allowed to
3117 * call themselves. */
3118 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3121 esym = expr->value.function.esym;
3123 if (is_illegal_recursion (esym, gfc_current_ns))
3125 if (esym->attr.entry && esym->ns->entries)
3126 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3127 " function '%s' is not RECURSIVE",
3128 esym->name, &expr->where, esym->ns->entries->sym->name);
3130 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3131 " is not RECURSIVE", esym->name, &expr->where);
3137 /* Character lengths of use associated functions may contains references to
3138 symbols not referenced from the current program unit otherwise. Make sure
3139 those symbols are marked as referenced. */
3141 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3142 && expr->value.function.esym->attr.use_assoc)
3144 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3147 /* Make sure that the expression has a typespec that works. */
3148 if (expr->ts.type == BT_UNKNOWN)
3150 if (expr->symtree->n.sym->result
3151 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3152 && !expr->symtree->n.sym->result->attr.proc_pointer)
3153 expr->ts = expr->symtree->n.sym->result->ts;
3160 /************* Subroutine resolution *************/
3163 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3169 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3170 sym->name, &c->loc);
3171 else if (gfc_pure (NULL))
3172 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3178 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3182 if (sym->attr.generic)
3184 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3187 c->resolved_sym = s;
3188 pure_subroutine (c, s);
3192 /* TODO: Need to search for elemental references in generic interface. */
3195 if (sym->attr.intrinsic)
3196 return gfc_intrinsic_sub_interface (c, 0);
3203 resolve_generic_s (gfc_code *c)
3208 sym = c->symtree->n.sym;
3212 m = resolve_generic_s0 (c, sym);
3215 else if (m == MATCH_ERROR)
3219 if (sym->ns->parent == NULL)
3221 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3225 if (!generic_sym (sym))
3229 /* Last ditch attempt. See if the reference is to an intrinsic
3230 that possesses a matching interface. 14.1.2.4 */
3231 sym = c->symtree->n.sym;
3233 if (!gfc_is_intrinsic (sym, 1, c->loc))
3235 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3236 sym->name, &c->loc);
3240 m = gfc_intrinsic_sub_interface (c, 0);
3244 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3245 "intrinsic subroutine interface", sym->name, &c->loc);
3251 /* Set the name and binding label of the subroutine symbol in the call
3252 expression represented by 'c' to include the type and kind of the
3253 second parameter. This function is for resolving the appropriate
3254 version of c_f_pointer() and c_f_procpointer(). For example, a
3255 call to c_f_pointer() for a default integer pointer could have a
3256 name of c_f_pointer_i4. If no second arg exists, which is an error
3257 for these two functions, it defaults to the generic symbol's name
3258 and binding label. */
3261 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3262 char *name, char *binding_label)
3264 gfc_expr *arg = NULL;
3268 /* The second arg of c_f_pointer and c_f_procpointer determines
3269 the type and kind for the procedure name. */
3270 arg = c->ext.actual->next->expr;
3274 /* Set up the name to have the given symbol's name,
3275 plus the type and kind. */
3276 /* a derived type is marked with the type letter 'u' */
3277 if (arg->ts.type == BT_DERIVED)
3280 kind = 0; /* set the kind as 0 for now */
3284 type = gfc_type_letter (arg->ts.type);
3285 kind = arg->ts.kind;
3288 if (arg->ts.type == BT_CHARACTER)
3289 /* Kind info for character strings not needed. */
3292 sprintf (name, "%s_%c%d", sym->name, type, kind);
3293 /* Set up the binding label as the given symbol's label plus
3294 the type and kind. */
3295 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3299 /* If the second arg is missing, set the name and label as
3300 was, cause it should at least be found, and the missing
3301 arg error will be caught by compare_parameters(). */
3302 sprintf (name, "%s", sym->name);
3303 sprintf (binding_label, "%s", sym->binding_label);
3310 /* Resolve a generic version of the iso_c_binding procedure given
3311 (sym) to the specific one based on the type and kind of the
3312 argument(s). Currently, this function resolves c_f_pointer() and
3313 c_f_procpointer based on the type and kind of the second argument
3314 (FPTR). Other iso_c_binding procedures aren't specially handled.
3315 Upon successfully exiting, c->resolved_sym will hold the resolved
3316 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3320 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3322 gfc_symbol *new_sym;
3323 /* this is fine, since we know the names won't use the max */
3324 char name[GFC_MAX_SYMBOL_LEN + 1];
3325 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3326 /* default to success; will override if find error */
3327 match m = MATCH_YES;
3329 /* Make sure the actual arguments are in the necessary order (based on the
3330 formal args) before resolving. */
3331 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3333 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3334 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3336 set_name_and_label (c, sym, name, binding_label);
3338 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3340 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3342 /* Make sure we got a third arg if the second arg has non-zero
3343 rank. We must also check that the type and rank are
3344 correct since we short-circuit this check in
3345 gfc_procedure_use() (called above to sort actual args). */
3346 if (c->ext.actual->next->expr->rank != 0)
3348 if(c->ext.actual->next->next == NULL
3349 || c->ext.actual->next->next->expr == NULL)
3352 gfc_error ("Missing SHAPE parameter for call to %s "
3353 "at %L", sym->name, &(c->loc));
3355 else if (c->ext.actual->next->next->expr->ts.type
3357 || c->ext.actual->next->next->expr->rank != 1)
3360 gfc_error ("SHAPE parameter for call to %s at %L must "
3361 "be a rank 1 INTEGER array", sym->name,
3368 if (m != MATCH_ERROR)
3370 /* the 1 means to add the optional arg to formal list */
3371 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3373 /* for error reporting, say it's declared where the original was */
3374 new_sym->declared_at = sym->declared_at;
3379 /* no differences for c_loc or c_funloc */
3383 /* set the resolved symbol */
3384 if (m != MATCH_ERROR)
3385 c->resolved_sym = new_sym;
3387 c->resolved_sym = sym;
3393 /* Resolve a subroutine call known to be specific. */
3396 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3400 if(sym->attr.is_iso_c)
3402 m = gfc_iso_c_sub_interface (c,sym);
3406 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3408 if (sym->attr.dummy)
3410 sym->attr.proc = PROC_DUMMY;
3414 sym->attr.proc = PROC_EXTERNAL;
3418 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3421 if (sym->attr.intrinsic)
3423 m = gfc_intrinsic_sub_interface (c, 1);
3427 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3428 "with an intrinsic", sym->name, &c->loc);
3436 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3438 c->resolved_sym = sym;
3439 pure_subroutine (c, sym);
3446 resolve_specific_s (gfc_code *c)
3451 sym = c->symtree->n.sym;
3455 m = resolve_specific_s0 (c, sym);
3458 if (m == MATCH_ERROR)
3461 if (sym->ns->parent == NULL)
3464 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3470 sym = c->symtree->n.sym;
3471 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3472 sym->name, &c->loc);
3478 /* Resolve a subroutine call not known to be generic nor specific. */
3481 resolve_unknown_s (gfc_code *c)
3485 sym = c->symtree->n.sym;
3487 if (sym->attr.dummy)
3489 sym->attr.proc = PROC_DUMMY;
3493 /* See if we have an intrinsic function reference. */
3495 if (gfc_is_intrinsic (sym, 1, c->loc))
3497 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3502 /* The reference is to an external name. */
3505 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3507 c->resolved_sym = sym;
3509 pure_subroutine (c, sym);
3515 /* Resolve a subroutine call. Although it was tempting to use the same code
3516 for functions, subroutines and functions are stored differently and this
3517 makes things awkward. */
3520 resolve_call (gfc_code *c)
3523 procedure_type ptype = PROC_INTRINSIC;
3524 gfc_symbol *csym, *sym;
3525 bool no_formal_args;
3527 csym = c->symtree ? c->symtree->n.sym : NULL;
3529 if (csym && csym->ts.type != BT_UNKNOWN)
3531 gfc_error ("'%s' at %L has a type, which is not consistent with "
3532 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3536 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3539 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3540 sym = st ? st->n.sym : NULL;
3541 if (sym && csym != sym
3542 && sym->ns == gfc_current_ns
3543 && sym->attr.flavor == FL_PROCEDURE
3544 && sym->attr.contained)
3547 if (csym->attr.generic)
3548 c->symtree->n.sym = sym;
3551 csym = c->symtree->n.sym;
3555 /* If this ia a deferred TBP with an abstract interface
3556 (which may of course be referenced), c->expr1 will be set. */
3557 if (csym && csym->attr.abstract && !c->expr1)
3559 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3560 csym->name, &c->loc);
3564 /* Subroutines without the RECURSIVE attribution are not allowed to
3565 * call themselves. */
3566 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3568 if (csym->attr.entry && csym->ns->entries)
3569 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3570 " subroutine '%s' is not RECURSIVE",
3571 csym->name, &c->loc, csym->ns->entries->sym->name);
3573 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3574 " is not RECURSIVE", csym->name, &c->loc);
3579 /* Switch off assumed size checking and do this again for certain kinds
3580 of procedure, once the procedure itself is resolved. */
3581 need_full_assumed_size++;
3584 ptype = csym->attr.proc;
3586 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3587 if (resolve_actual_arglist (c->ext.actual, ptype,
3588 no_formal_args) == FAILURE)
3591 /* Resume assumed_size checking. */
3592 need_full_assumed_size--;
3594 /* If external, check for usage. */
3595 if (csym && is_external_proc (csym))
3596 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3599 if (c->resolved_sym == NULL)
3601 c->resolved_isym = NULL;
3602 switch (procedure_kind (csym))
3605 t = resolve_generic_s (c);
3608 case PTYPE_SPECIFIC:
3609 t = resolve_specific_s (c);
3613 t = resolve_unknown_s (c);
3617 gfc_internal_error ("resolve_subroutine(): bad function type");
3621 /* Some checks of elemental subroutine actual arguments. */
3622 if (resolve_elemental_actual (NULL, c) == FAILURE)
3629 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3630 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3631 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3632 if their shapes do not match. If either op1->shape or op2->shape is
3633 NULL, return SUCCESS. */
3636 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3643 if (op1->shape != NULL && op2->shape != NULL)
3645 for (i = 0; i < op1->rank; i++)
3647 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3649 gfc_error ("Shapes for operands at %L and %L are not conformable",
3650 &op1->where, &op2->where);
3661 /* Resolve an operator expression node. This can involve replacing the
3662 operation with a user defined function call. */
3665 resolve_operator (gfc_expr *e)
3667 gfc_expr *op1, *op2;
3669 bool dual_locus_error;
3672 /* Resolve all subnodes-- give them types. */
3674 switch (e->value.op.op)
3677 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3680 /* Fall through... */
3683 case INTRINSIC_UPLUS:
3684 case INTRINSIC_UMINUS:
3685 case INTRINSIC_PARENTHESES:
3686 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3691 /* Typecheck the new node. */
3693 op1 = e->value.op.op1;
3694 op2 = e->value.op.op2;
3695 dual_locus_error = false;
3697 if ((op1 && op1->expr_type == EXPR_NULL)
3698 || (op2 && op2->expr_type == EXPR_NULL))
3700 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3704 switch (e->value.op.op)
3706 case INTRINSIC_UPLUS:
3707 case INTRINSIC_UMINUS:
3708 if (op1->ts.type == BT_INTEGER
3709 || op1->ts.type == BT_REAL
3710 || op1->ts.type == BT_COMPLEX)
3716 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3717 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3720 case INTRINSIC_PLUS:
3721 case INTRINSIC_MINUS:
3722 case INTRINSIC_TIMES:
3723 case INTRINSIC_DIVIDE:
3724 case INTRINSIC_POWER:
3725 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3727 gfc_type_convert_binary (e, 1);
3732 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3733 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3734 gfc_typename (&op2->ts));
3737 case INTRINSIC_CONCAT:
3738 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3739 && op1->ts.kind == op2->ts.kind)
3741 e->ts.type = BT_CHARACTER;
3742 e->ts.kind = op1->ts.kind;
3747 _("Operands of string concatenation operator at %%L are %s/%s"),
3748 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3754 case INTRINSIC_NEQV:
3755 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3757 e->ts.type = BT_LOGICAL;
3758 e->ts.kind = gfc_kind_max (op1, op2);
3759 if (op1->ts.kind < e->ts.kind)
3760 gfc_convert_type (op1, &e->ts, 2);
3761 else if (op2->ts.kind < e->ts.kind)
3762 gfc_convert_type (op2, &e->ts, 2);
3766 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3767 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3768 gfc_typename (&op2->ts));
3773 if (op1->ts.type == BT_LOGICAL)
3775 e->ts.type = BT_LOGICAL;
3776 e->ts.kind = op1->ts.kind;
3780 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3781 gfc_typename (&op1->ts));
3785 case INTRINSIC_GT_OS:
3787 case INTRINSIC_GE_OS:
3789 case INTRINSIC_LT_OS:
3791 case INTRINSIC_LE_OS:
3792 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3794 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3798 /* Fall through... */
3801 case INTRINSIC_EQ_OS:
3803 case INTRINSIC_NE_OS:
3804 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3805 && op1->ts.kind == op2->ts.kind)
3807 e->ts.type = BT_LOGICAL;
3808 e->ts.kind = gfc_default_logical_kind;
3812 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3814 gfc_type_convert_binary (e, 1);
3816 e->ts.type = BT_LOGICAL;
3817 e->ts.kind = gfc_default_logical_kind;
3821 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3823 _("Logicals at %%L must be compared with %s instead of %s"),
3824 (e->value.op.op == INTRINSIC_EQ
3825 || e->value.op.op == INTRINSIC_EQ_OS)
3826 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3829 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3830 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3831 gfc_typename (&op2->ts));
3835 case INTRINSIC_USER:
3836 if (e->value.op.uop->op == NULL)
3837 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3838 else if (op2 == NULL)
3839 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3840 e->value.op.uop->name, gfc_typename (&op1->ts));
3843 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3844 e->value.op.uop->name, gfc_typename (&op1->ts),
3845 gfc_typename (&op2->ts));
3846 e->value.op.uop->op->sym->attr.referenced = 1;
3851 case INTRINSIC_PARENTHESES:
3853 if (e->ts.type == BT_CHARACTER)
3854 e->ts.u.cl = op1->ts.u.cl;
3858 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3861 /* Deal with arrayness of an operand through an operator. */
3865 switch (e->value.op.op)
3867 case INTRINSIC_PLUS:
3868 case INTRINSIC_MINUS:
3869 case INTRINSIC_TIMES:
3870 case INTRINSIC_DIVIDE:
3871 case INTRINSIC_POWER:
3872 case INTRINSIC_CONCAT:
3876 case INTRINSIC_NEQV:
3878 case INTRINSIC_EQ_OS:
3880 case INTRINSIC_NE_OS:
3882 case INTRINSIC_GT_OS:
3884 case INTRINSIC_GE_OS:
3886 case INTRINSIC_LT_OS:
3888 case INTRINSIC_LE_OS:
3890 if (op1->rank == 0 && op2->rank == 0)
3893 if (op1->rank == 0 && op2->rank != 0)
3895 e->rank = op2->rank;
3897 if (e->shape == NULL)
3898 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3901 if (op1->rank != 0 && op2->rank == 0)
3903 e->rank = op1->rank;
3905 if (e->shape == NULL)
3906 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3909 if (op1->rank != 0 && op2->rank != 0)
3911 if (op1->rank == op2->rank)
3913 e->rank = op1->rank;
3914 if (e->shape == NULL)
3916 t = compare_shapes (op1, op2);
3920 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3925 /* Allow higher level expressions to work. */
3928 /* Try user-defined operators, and otherwise throw an error. */
3929 dual_locus_error = true;
3931 _("Inconsistent ranks for operator at %%L and %%L"));
3938 case INTRINSIC_PARENTHESES:
3940 case INTRINSIC_UPLUS:
3941 case INTRINSIC_UMINUS:
3942 /* Simply copy arrayness attribute */
3943 e->rank = op1->rank;
3945 if (e->shape == NULL)
3946 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3954 /* Attempt to simplify the expression. */
3957 t = gfc_simplify_expr (e, 0);
3958 /* Some calls do not succeed in simplification and return FAILURE
3959 even though there is no error; e.g. variable references to
3960 PARAMETER arrays. */
3961 if (!gfc_is_constant_expr (e))
3970 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3977 if (dual_locus_error)
3978 gfc_error (msg, &op1->where, &op2->where);
3980 gfc_error (msg, &e->where);
3986 /************** Array resolution subroutines **************/
3989 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3992 /* Compare two integer expressions. */
3995 compare_bound (gfc_expr *a, gfc_expr *b)
3999 if (a == NULL || a->expr_type != EXPR_CONSTANT
4000 || b == NULL || b->expr_type != EXPR_CONSTANT)
4003 /* If either of the types isn't INTEGER, we must have
4004 raised an error earlier. */
4006 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4009 i = mpz_cmp (a->value.integer, b->value.integer);
4019 /* Compare an integer expression with an integer. */
4022 compare_bound_int (gfc_expr *a, int b)
4026 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4029 if (a->ts.type != BT_INTEGER)
4030 gfc_internal_error ("compare_bound_int(): Bad expression");
4032 i = mpz_cmp_si (a->value.integer, b);
4042 /* Compare an integer expression with a mpz_t. */
4045 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4049 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4052 if (a->ts.type != BT_INTEGER)
4053 gfc_internal_error ("compare_bound_int(): Bad expression");
4055 i = mpz_cmp (a->value.integer, b);
4065 /* Compute the last value of a sequence given by a triplet.
4066 Return 0 if it wasn't able to compute the last value, or if the
4067 sequence if empty, and 1 otherwise. */
4070 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4071 gfc_expr *stride, mpz_t last)
4075 if (start == NULL || start->expr_type != EXPR_CONSTANT
4076 || end == NULL || end->expr_type != EXPR_CONSTANT
4077 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4080 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4081 || (stride != NULL && stride->ts.type != BT_INTEGER))
4084 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4086 if (compare_bound (start, end) == CMP_GT)
4088 mpz_set (last, end->value.integer);
4092 if (compare_bound_int (stride, 0) == CMP_GT)
4094 /* Stride is positive */
4095 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4100 /* Stride is negative */
4101 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4106 mpz_sub (rem, end->value.integer, start->value.integer);
4107 mpz_tdiv_r (rem, rem, stride->value.integer);
4108 mpz_sub (last, end->value.integer, rem);
4115 /* Compare a single dimension of an array reference to the array
4119 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4123 if (ar->dimen_type[i] == DIMEN_STAR)
4125 gcc_assert (ar->stride[i] == NULL);
4126 /* This implies [*] as [*:] and [*:3] are not possible. */
4127 if (ar->start[i] == NULL)
4129 gcc_assert (ar->end[i] == NULL);
4134 /* Given start, end and stride values, calculate the minimum and
4135 maximum referenced indexes. */
4137 switch (ar->dimen_type[i])
4144 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4147 gfc_warning ("Array reference at %L is out of bounds "
4148 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4149 mpz_get_si (ar->start[i]->value.integer),
4150 mpz_get_si (as->lower[i]->value.integer), i+1);
4152 gfc_warning ("Array reference at %L is out of bounds "
4153 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4154 mpz_get_si (ar->start[i]->value.integer),
4155 mpz_get_si (as->lower[i]->value.integer),
4159 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4162 gfc_warning ("Array reference at %L is out of bounds "
4163 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4164 mpz_get_si (ar->start[i]->value.integer),
4165 mpz_get_si (as->upper[i]->value.integer), i+1);
4167 gfc_warning ("Array reference at %L is out of bounds "
4168 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4169 mpz_get_si (ar->start[i]->value.integer),
4170 mpz_get_si (as->upper[i]->value.integer),
4179 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4180 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4182 comparison comp_start_end = compare_bound (AR_START, AR_END);
4184 /* Check for zero stride, which is not allowed. */
4185 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4187 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4191 /* if start == len || (stride > 0 && start < len)
4192 || (stride < 0 && start > len),
4193 then the array section contains at least one element. In this
4194 case, there is an out-of-bounds access if
4195 (start < lower || start > upper). */
4196 if (compare_bound (AR_START, AR_END) == CMP_EQ
4197 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4198 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4199 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4200 && comp_start_end == CMP_GT))
4202 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4204 gfc_warning ("Lower array reference at %L is out of bounds "
4205 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4206 mpz_get_si (AR_START->value.integer),
4207 mpz_get_si (as->lower[i]->value.integer), i+1);
4210 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4212 gfc_warning ("Lower array reference at %L is out of bounds "
4213 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4214 mpz_get_si (AR_START->value.integer),
4215 mpz_get_si (as->upper[i]->value.integer), i+1);
4220 /* If we can compute the highest index of the array section,
4221 then it also has to be between lower and upper. */
4222 mpz_init (last_value);
4223 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4226 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4228 gfc_warning ("Upper array reference at %L is out of bounds "
4229 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4230 mpz_get_si (last_value),
4231 mpz_get_si (as->lower[i]->value.integer), i+1);
4232 mpz_clear (last_value);
4235 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4237 gfc_warning ("Upper array reference at %L is out of bounds "
4238 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4239 mpz_get_si (last_value),
4240 mpz_get_si (as->upper[i]->value.integer), i+1);
4241 mpz_clear (last_value);
4245 mpz_clear (last_value);
4253 gfc_internal_error ("check_dimension(): Bad array reference");
4260 /* Compare an array reference with an array specification. */
4263 compare_spec_to_ref (gfc_array_ref *ar)
4270 /* TODO: Full array sections are only allowed as actual parameters. */
4271 if (as->type == AS_ASSUMED_SIZE
4272 && (/*ar->type == AR_FULL
4273 ||*/ (ar->type == AR_SECTION
4274 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4276 gfc_error ("Rightmost upper bound of assumed size array section "
4277 "not specified at %L", &ar->where);
4281 if (ar->type == AR_FULL)
4284 if (as->rank != ar->dimen)
4286 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4287 &ar->where, ar->dimen, as->rank);
4291 /* ar->codimen == 0 is a local array. */
4292 if (as->corank != ar->codimen && ar->codimen != 0)
4294 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4295 &ar->where, ar->codimen, as->corank);
4299 for (i = 0; i < as->rank; i++)
4300 if (check_dimension (i, ar, as) == FAILURE)
4303 /* Local access has no coarray spec. */
4304 if (ar->codimen != 0)
4305 for (i = as->rank; i < as->rank + as->corank; i++)
4307 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4309 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4310 i + 1 - as->rank, &ar->where);
4313 if (check_dimension (i, ar, as) == FAILURE)
4321 /* Resolve one part of an array index. */
4324 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4325 int force_index_integer_kind)
4332 if (gfc_resolve_expr (index) == FAILURE)
4335 if (check_scalar && index->rank != 0)
4337 gfc_error ("Array index at %L must be scalar", &index->where);
4341 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4343 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4344 &index->where, gfc_basic_typename (index->ts.type));
4348 if (index->ts.type == BT_REAL)
4349 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4350 &index->where) == FAILURE)
4353 if ((index->ts.kind != gfc_index_integer_kind
4354 && force_index_integer_kind)
4355 || index->ts.type != BT_INTEGER)
4358 ts.type = BT_INTEGER;
4359 ts.kind = gfc_index_integer_kind;
4361 gfc_convert_type_warn (index, &ts, 2, 0);
4367 /* Resolve one part of an array index. */
4370 gfc_resolve_index (gfc_expr *index, int check_scalar)
4372 return gfc_resolve_index_1 (index, check_scalar, 1);
4375 /* Resolve a dim argument to an intrinsic function. */
4378 gfc_resolve_dim_arg (gfc_expr *dim)
4383 if (gfc_resolve_expr (dim) == FAILURE)
4388 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4393 if (dim->ts.type != BT_INTEGER)
4395 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4399 if (dim->ts.kind != gfc_index_integer_kind)
4404 ts.type = BT_INTEGER;
4405 ts.kind = gfc_index_integer_kind;
4407 gfc_convert_type_warn (dim, &ts, 2, 0);
4413 /* Given an expression that contains array references, update those array
4414 references to point to the right array specifications. While this is
4415 filled in during matching, this information is difficult to save and load
4416 in a module, so we take care of it here.
4418 The idea here is that the original array reference comes from the
4419 base symbol. We traverse the list of reference structures, setting
4420 the stored reference to references. Component references can
4421 provide an additional array specification. */
4424 find_array_spec (gfc_expr *e)
4428 gfc_symbol *derived;
4431 if (e->symtree->n.sym->ts.type == BT_CLASS)
4432 as = CLASS_DATA (e->symtree->n.sym)->as;
4434 as = e->symtree->n.sym->as;
4437 for (ref = e->ref; ref; ref = ref->next)
4442 gfc_internal_error ("find_array_spec(): Missing spec");
4449 if (derived == NULL)
4450 derived = e->symtree->n.sym->ts.u.derived;
4452 if (derived->attr.is_class)
4453 derived = derived->components->ts.u.derived;
4455 c = derived->components;
4457 for (; c; c = c->next)
4458 if (c == ref->u.c.component)
4460 /* Track the sequence of component references. */
4461 if (c->ts.type == BT_DERIVED)
4462 derived = c->ts.u.derived;
4467 gfc_internal_error ("find_array_spec(): Component not found");
4469 if (c->attr.dimension)
4472 gfc_internal_error ("find_array_spec(): unused as(1)");
4483 gfc_internal_error ("find_array_spec(): unused as(2)");
4487 /* Resolve an array reference. */
4490 resolve_array_ref (gfc_array_ref *ar)
4492 int i, check_scalar;
4495 for (i = 0; i < ar->dimen + ar->codimen; i++)
4497 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4499 /* Do not force gfc_index_integer_kind for the start. We can
4500 do fine with any integer kind. This avoids temporary arrays
4501 created for indexing with a vector. */
4502 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4504 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4506 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4511 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4515 ar->dimen_type[i] = DIMEN_ELEMENT;
4519 ar->dimen_type[i] = DIMEN_VECTOR;
4520 if (e->expr_type == EXPR_VARIABLE
4521 && e->symtree->n.sym->ts.type == BT_DERIVED)
4522 ar->start[i] = gfc_get_parentheses (e);
4526 gfc_error ("Array index at %L is an array of rank %d",
4527 &ar->c_where[i], e->rank);
4531 /* Fill in the upper bound, which may be lower than the
4532 specified one for something like a(2:10:5), which is
4533 identical to a(2:7:5). Only relevant for strides not equal
4535 if (ar->dimen_type[i] == DIMEN_RANGE
4536 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4537 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4541 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4543 if (ar->end[i] == NULL)
4546 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4548 mpz_set (ar->end[i]->value.integer, end);
4550 else if (ar->end[i]->ts.type == BT_INTEGER
4551 && ar->end[i]->expr_type == EXPR_CONSTANT)
4553 mpz_set (ar->end[i]->value.integer, end);
4564 if (ar->type == AR_FULL && ar->as->rank == 0)
4565 ar->type = AR_ELEMENT;
4567 /* If the reference type is unknown, figure out what kind it is. */
4569 if (ar->type == AR_UNKNOWN)
4571 ar->type = AR_ELEMENT;
4572 for (i = 0; i < ar->dimen; i++)
4573 if (ar->dimen_type[i] == DIMEN_RANGE
4574 || ar->dimen_type[i] == DIMEN_VECTOR)
4576 ar->type = AR_SECTION;
4581 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4589 resolve_substring (gfc_ref *ref)
4591 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4593 if (ref->u.ss.start != NULL)
4595 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4598 if (ref->u.ss.start->ts.type != BT_INTEGER)
4600 gfc_error ("Substring start index at %L must be of type INTEGER",
4601 &ref->u.ss.start->where);
4605 if (ref->u.ss.start->rank != 0)
4607 gfc_error ("Substring start index at %L must be scalar",
4608 &ref->u.ss.start->where);
4612 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4613 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4614 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4616 gfc_error ("Substring start index at %L is less than one",
4617 &ref->u.ss.start->where);
4622 if (ref->u.ss.end != NULL)
4624 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4627 if (ref->u.ss.end->ts.type != BT_INTEGER)
4629 gfc_error ("Substring end index at %L must be of type INTEGER",
4630 &ref->u.ss.end->where);
4634 if (ref->u.ss.end->rank != 0)
4636 gfc_error ("Substring end index at %L must be scalar",
4637 &ref->u.ss.end->where);
4641 if (ref->u.ss.length != NULL
4642 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4643 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4644 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4646 gfc_error ("Substring end index at %L exceeds the string length",
4647 &ref->u.ss.start->where);
4651 if (compare_bound_mpz_t (ref->u.ss.end,
4652 gfc_integer_kinds[k].huge) == CMP_GT
4653 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4654 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4656 gfc_error ("Substring end index at %L is too large",
4657 &ref->u.ss.end->where);
4666 /* This function supplies missing substring charlens. */
4669 gfc_resolve_substring_charlen (gfc_expr *e)
4672 gfc_expr *start, *end;
4674 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4675 if (char_ref->type == REF_SUBSTRING)
4681 gcc_assert (char_ref->next == NULL);
4685 if (e->ts.u.cl->length)
4686 gfc_free_expr (e->ts.u.cl->length);
4687 else if (e->expr_type == EXPR_VARIABLE
4688 && e->symtree->n.sym->attr.dummy)
4692 e->ts.type = BT_CHARACTER;
4693 e->ts.kind = gfc_default_character_kind;
4696 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4698 if (char_ref->u.ss.start)
4699 start = gfc_copy_expr (char_ref->u.ss.start);
4701 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4703 if (char_ref->u.ss.end)
4704 end = gfc_copy_expr (char_ref->u.ss.end);
4705 else if (e->expr_type == EXPR_VARIABLE)
4706 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4713 /* Length = (end - start +1). */
4714 e->ts.u.cl->length = gfc_subtract (end, start);
4715 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4716 gfc_get_int_expr (gfc_default_integer_kind,
4719 e->ts.u.cl->length->ts.type = BT_INTEGER;
4720 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4722 /* Make sure that the length is simplified. */
4723 gfc_simplify_expr (e->ts.u.cl->length, 1);
4724 gfc_resolve_expr (e->ts.u.cl->length);
4728 /* Resolve subtype references. */
4731 resolve_ref (gfc_expr *expr)
4733 int current_part_dimension, n_components, seen_part_dimension;
4736 for (ref = expr->ref; ref; ref = ref->next)
4737 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4739 find_array_spec (expr);
4743 for (ref = expr->ref; ref; ref = ref->next)
4747 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4755 resolve_substring (ref);
4759 /* Check constraints on part references. */
4761 current_part_dimension = 0;
4762 seen_part_dimension = 0;
4765 for (ref = expr->ref; ref; ref = ref->next)
4770 switch (ref->u.ar.type)
4773 /* Coarray scalar. */
4774 if (ref->u.ar.as->rank == 0)
4776 current_part_dimension = 0;
4781 current_part_dimension = 1;
4785 current_part_dimension = 0;
4789 gfc_internal_error ("resolve_ref(): Bad array reference");
4795 if (current_part_dimension || seen_part_dimension)
4798 if (ref->u.c.component->attr.pointer
4799 || ref->u.c.component->attr.proc_pointer)
4801 gfc_error ("Component to the right of a part reference "
4802 "with nonzero rank must not have the POINTER "
4803 "attribute at %L", &expr->where);
4806 else if (ref->u.c.component->attr.allocatable)
4808 gfc_error ("Component to the right of a part reference "
4809 "with nonzero rank must not have the ALLOCATABLE "
4810 "attribute at %L", &expr->where);
4822 if (((ref->type == REF_COMPONENT && n_components > 1)
4823 || ref->next == NULL)
4824 && current_part_dimension
4825 && seen_part_dimension)
4827 gfc_error ("Two or more part references with nonzero rank must "
4828 "not be specified at %L", &expr->where);
4832 if (ref->type == REF_COMPONENT)
4834 if (current_part_dimension)
4835 seen_part_dimension = 1;
4837 /* reset to make sure */
4838 current_part_dimension = 0;
4846 /* Given an expression, determine its shape. This is easier than it sounds.
4847 Leaves the shape array NULL if it is not possible to determine the shape. */
4850 expression_shape (gfc_expr *e)
4852 mpz_t array[GFC_MAX_DIMENSIONS];
4855 if (e->rank == 0 || e->shape != NULL)
4858 for (i = 0; i < e->rank; i++)
4859 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4862 e->shape = gfc_get_shape (e->rank);
4864 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4869 for (i--; i >= 0; i--)
4870 mpz_clear (array[i]);
4874 /* Given a variable expression node, compute the rank of the expression by
4875 examining the base symbol and any reference structures it may have. */
4878 expression_rank (gfc_expr *e)
4883 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4884 could lead to serious confusion... */
4885 gcc_assert (e->expr_type != EXPR_COMPCALL);
4889 if (e->expr_type == EXPR_ARRAY)
4891 /* Constructors can have a rank different from one via RESHAPE(). */
4893 if (e->symtree == NULL)
4899 e->rank = (e->symtree->n.sym->as == NULL)
4900 ? 0 : e->symtree->n.sym->as->rank;
4906 for (ref = e->ref; ref; ref = ref->next)
4908 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
4909 && ref->u.c.component->attr.function && !ref->next)
4910 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
4912 if (ref->type != REF_ARRAY)
4915 if (ref->u.ar.type == AR_FULL)
4917 rank = ref->u.ar.as->rank;
4921 if (ref->u.ar.type == AR_SECTION)
4923 /* Figure out the rank of the section. */
4925 gfc_internal_error ("expression_rank(): Two array specs");
4927 for (i = 0; i < ref->u.ar.dimen; i++)
4928 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4929 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4939 expression_shape (e);
4943 /* Resolve a variable expression. */
4946 resolve_variable (gfc_expr *e)
4953 if (e->symtree == NULL)
4955 sym = e->symtree->n.sym;
4957 /* If this is an associate-name, it may be parsed with an array reference
4958 in error even though the target is scalar. Fail directly in this case. */
4959 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4962 /* On the other hand, the parser may not have known this is an array;
4963 in this case, we have to add a FULL reference. */
4964 if (sym->assoc && sym->attr.dimension && !e->ref)
4966 e->ref = gfc_get_ref ();
4967 e->ref->type = REF_ARRAY;
4968 e->ref->u.ar.type = AR_FULL;
4969 e->ref->u.ar.dimen = 0;
4972 if (e->ref && resolve_ref (e) == FAILURE)
4975 if (sym->attr.flavor == FL_PROCEDURE
4976 && (!sym->attr.function
4977 || (sym->attr.function && sym->result
4978 && sym->result->attr.proc_pointer
4979 && !sym->result->attr.function)))
4981 e->ts.type = BT_PROCEDURE;
4982 goto resolve_procedure;
4985 if (sym->ts.type != BT_UNKNOWN)
4986 gfc_variable_attr (e, &e->ts);
4989 /* Must be a simple variable reference. */
4990 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4995 if (check_assumed_size_reference (sym, e))
4998 /* Deal with forward references to entries during resolve_code, to
4999 satisfy, at least partially, 12.5.2.5. */
5000 if (gfc_current_ns->entries
5001 && current_entry_id == sym->entry_id
5004 && cs_base->current->op != EXEC_ENTRY)
5006 gfc_entry_list *entry;
5007 gfc_formal_arglist *formal;
5011 /* If the symbol is a dummy... */
5012 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5014 entry = gfc_current_ns->entries;
5017 /* ...test if the symbol is a parameter of previous entries. */
5018 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5019 for (formal = entry->sym->formal; formal; formal = formal->next)
5021 if (formal->sym && sym->name == formal->sym->name)
5025 /* If it has not been seen as a dummy, this is an error. */
5028 if (specification_expr)
5029 gfc_error ("Variable '%s', used in a specification expression"
5030 ", is referenced at %L before the ENTRY statement "
5031 "in which it is a parameter",
5032 sym->name, &cs_base->current->loc);
5034 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5035 "statement in which it is a parameter",
5036 sym->name, &cs_base->current->loc);
5041 /* Now do the same check on the specification expressions. */
5042 specification_expr = 1;
5043 if (sym->ts.type == BT_CHARACTER
5044 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5048 for (n = 0; n < sym->as->rank; n++)
5050 specification_expr = 1;
5051 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5053 specification_expr = 1;
5054 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5057 specification_expr = 0;
5060 /* Update the symbol's entry level. */
5061 sym->entry_id = current_entry_id + 1;
5064 /* If a symbol has been host_associated mark it. This is used latter,
5065 to identify if aliasing is possible via host association. */
5066 if (sym->attr.flavor == FL_VARIABLE
5067 && gfc_current_ns->parent
5068 && (gfc_current_ns->parent == sym->ns
5069 || (gfc_current_ns->parent->parent
5070 && gfc_current_ns->parent->parent == sym->ns)))
5071 sym->attr.host_assoc = 1;
5074 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5077 /* F2008, C617 and C1229. */
5078 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5079 && gfc_is_coindexed (e))
5081 gfc_ref *ref, *ref2 = NULL;
5083 for (ref = e->ref; ref; ref = ref->next)
5085 if (ref->type == REF_COMPONENT)
5087 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5091 for ( ; ref; ref = ref->next)
5092 if (ref->type == REF_COMPONENT)
5095 /* Expression itself is not coindexed object. */
5096 if (ref && e->ts.type == BT_CLASS)
5098 gfc_error ("Polymorphic subobject of coindexed object at %L",
5103 /* Expression itself is coindexed object. */
5107 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5108 for ( ; c; c = c->next)
5109 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5111 gfc_error ("Coindexed object with polymorphic allocatable "
5112 "subcomponent at %L", &e->where);
5123 /* Checks to see that the correct symbol has been host associated.
5124 The only situation where this arises is that in which a twice
5125 contained function is parsed after the host association is made.
5126 Therefore, on detecting this, change the symbol in the expression
5127 and convert the array reference into an actual arglist if the old
5128 symbol is a variable. */
5130 check_host_association (gfc_expr *e)
5132 gfc_symbol *sym, *old_sym;
5136 gfc_actual_arglist *arg, *tail = NULL;
5137 bool retval = e->expr_type == EXPR_FUNCTION;
5139 /* If the expression is the result of substitution in
5140 interface.c(gfc_extend_expr) because there is no way in
5141 which the host association can be wrong. */
5142 if (e->symtree == NULL
5143 || e->symtree->n.sym == NULL
5144 || e->user_operator)
5147 old_sym = e->symtree->n.sym;
5149 if (gfc_current_ns->parent
5150 && old_sym->ns != gfc_current_ns)
5152 /* Use the 'USE' name so that renamed module symbols are
5153 correctly handled. */
5154 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5156 if (sym && old_sym != sym
5157 && sym->ts.type == old_sym->ts.type
5158 && sym->attr.flavor == FL_PROCEDURE
5159 && sym->attr.contained)
5161 /* Clear the shape, since it might not be valid. */
5162 if (e->shape != NULL)
5164 for (n = 0; n < e->rank; n++)
5165 mpz_clear (e->shape[n]);
5167 gfc_free (e->shape);
5170 /* Give the expression the right symtree! */
5171 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5172 gcc_assert (st != NULL);
5174 if (old_sym->attr.flavor == FL_PROCEDURE
5175 || e->expr_type == EXPR_FUNCTION)
5177 /* Original was function so point to the new symbol, since
5178 the actual argument list is already attached to the
5180 e->value.function.esym = NULL;
5185 /* Original was variable so convert array references into
5186 an actual arglist. This does not need any checking now
5187 since gfc_resolve_function will take care of it. */
5188 e->value.function.actual = NULL;
5189 e->expr_type = EXPR_FUNCTION;
5192 /* Ambiguity will not arise if the array reference is not
5193 the last reference. */
5194 for (ref = e->ref; ref; ref = ref->next)
5195 if (ref->type == REF_ARRAY && ref->next == NULL)
5198 gcc_assert (ref->type == REF_ARRAY);
5200 /* Grab the start expressions from the array ref and
5201 copy them into actual arguments. */
5202 for (n = 0; n < ref->u.ar.dimen; n++)
5204 arg = gfc_get_actual_arglist ();
5205 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5206 if (e->value.function.actual == NULL)
5207 tail = e->value.function.actual = arg;
5215 /* Dump the reference list and set the rank. */
5216 gfc_free_ref_list (e->ref);
5218 e->rank = sym->as ? sym->as->rank : 0;
5221 gfc_resolve_expr (e);
5225 /* This might have changed! */
5226 return e->expr_type == EXPR_FUNCTION;
5231 gfc_resolve_character_operator (gfc_expr *e)
5233 gfc_expr *op1 = e->value.op.op1;
5234 gfc_expr *op2 = e->value.op.op2;
5235 gfc_expr *e1 = NULL;
5236 gfc_expr *e2 = NULL;
5238 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5240 if (op1->ts.u.cl && op1->ts.u.cl->length)
5241 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5242 else if (op1->expr_type == EXPR_CONSTANT)
5243 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5244 op1->value.character.length);
5246 if (op2->ts.u.cl && op2->ts.u.cl->length)
5247 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5248 else if (op2->expr_type == EXPR_CONSTANT)
5249 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5250 op2->value.character.length);
5252 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5257 e->ts.u.cl->length = gfc_add (e1, e2);
5258 e->ts.u.cl->length->ts.type = BT_INTEGER;
5259 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5260 gfc_simplify_expr (e->ts.u.cl->length, 0);
5261 gfc_resolve_expr (e->ts.u.cl->length);
5267 /* Ensure that an character expression has a charlen and, if possible, a
5268 length expression. */
5271 fixup_charlen (gfc_expr *e)
5273 /* The cases fall through so that changes in expression type and the need
5274 for multiple fixes are picked up. In all circumstances, a charlen should
5275 be available for the middle end to hang a backend_decl on. */
5276 switch (e->expr_type)
5279 gfc_resolve_character_operator (e);
5282 if (e->expr_type == EXPR_ARRAY)
5283 gfc_resolve_character_array_constructor (e);
5285 case EXPR_SUBSTRING:
5286 if (!e->ts.u.cl && e->ref)
5287 gfc_resolve_substring_charlen (e);
5291 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5298 /* Update an actual argument to include the passed-object for type-bound
5299 procedures at the right position. */
5301 static gfc_actual_arglist*
5302 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5305 gcc_assert (argpos > 0);
5309 gfc_actual_arglist* result;
5311 result = gfc_get_actual_arglist ();
5315 result->name = name;
5321 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5323 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5328 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5331 extract_compcall_passed_object (gfc_expr* e)
5335 gcc_assert (e->expr_type == EXPR_COMPCALL);
5337 if (e->value.compcall.base_object)
5338 po = gfc_copy_expr (e->value.compcall.base_object);
5341 po = gfc_get_expr ();
5342 po->expr_type = EXPR_VARIABLE;
5343 po->symtree = e->symtree;
5344 po->ref = gfc_copy_ref (e->ref);
5345 po->where = e->where;
5348 if (gfc_resolve_expr (po) == FAILURE)
5355 /* Update the arglist of an EXPR_COMPCALL expression to include the
5359 update_compcall_arglist (gfc_expr* e)
5362 gfc_typebound_proc* tbp;
5364 tbp = e->value.compcall.tbp;
5369 po = extract_compcall_passed_object (e);
5373 if (tbp->nopass || e->value.compcall.ignore_pass)
5379 gcc_assert (tbp->pass_arg_num > 0);
5380 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5388 /* Extract the passed object from a PPC call (a copy of it). */
5391 extract_ppc_passed_object (gfc_expr *e)
5396 po = gfc_get_expr ();
5397 po->expr_type = EXPR_VARIABLE;
5398 po->symtree = e->symtree;
5399 po->ref = gfc_copy_ref (e->ref);
5400 po->where = e->where;
5402 /* Remove PPC reference. */
5404 while ((*ref)->next)
5405 ref = &(*ref)->next;
5406 gfc_free_ref_list (*ref);
5409 if (gfc_resolve_expr (po) == FAILURE)
5416 /* Update the actual arglist of a procedure pointer component to include the
5420 update_ppc_arglist (gfc_expr* e)
5424 gfc_typebound_proc* tb;
5426 if (!gfc_is_proc_ptr_comp (e, &ppc))
5433 else if (tb->nopass)
5436 po = extract_ppc_passed_object (e);
5443 gfc_error ("Passed-object at %L must be scalar", &e->where);
5448 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5450 gfc_error ("Base object for procedure-pointer component call at %L is of"
5451 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5455 gcc_assert (tb->pass_arg_num > 0);
5456 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5464 /* Check that the object a TBP is called on is valid, i.e. it must not be
5465 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5468 check_typebound_baseobject (gfc_expr* e)
5471 gfc_try return_value = FAILURE;
5473 base = extract_compcall_passed_object (e);
5477 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5480 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5482 gfc_error ("Base object for type-bound procedure call at %L is of"
5483 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5487 /* F08:C1230. If the procedure called is NOPASS,
5488 the base object must be scalar. */
5489 if (e->value.compcall.tbp->nopass && base->rank > 0)
5491 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5492 " be scalar", &e->where);
5496 /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
5499 gfc_error ("Non-scalar base object at %L currently not implemented",
5504 return_value = SUCCESS;
5507 gfc_free_expr (base);
5508 return return_value;
5512 /* Resolve a call to a type-bound procedure, either function or subroutine,
5513 statically from the data in an EXPR_COMPCALL expression. The adapted
5514 arglist and the target-procedure symtree are returned. */
5517 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5518 gfc_actual_arglist** actual)
5520 gcc_assert (e->expr_type == EXPR_COMPCALL);
5521 gcc_assert (!e->value.compcall.tbp->is_generic);
5523 /* Update the actual arglist for PASS. */
5524 if (update_compcall_arglist (e) == FAILURE)
5527 *actual = e->value.compcall.actual;
5528 *target = e->value.compcall.tbp->u.specific;
5530 gfc_free_ref_list (e->ref);
5532 e->value.compcall.actual = NULL;
5538 /* Get the ultimate declared type from an expression. In addition,
5539 return the last class/derived type reference and the copy of the
5542 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5545 gfc_symbol *declared;
5552 *new_ref = gfc_copy_ref (e->ref);
5554 for (ref = e->ref; ref; ref = ref->next)
5556 if (ref->type != REF_COMPONENT)
5559 if (ref->u.c.component->ts.type == BT_CLASS
5560 || ref->u.c.component->ts.type == BT_DERIVED)
5562 declared = ref->u.c.component->ts.u.derived;
5568 if (declared == NULL)
5569 declared = e->symtree->n.sym->ts.u.derived;
5575 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5576 which of the specific bindings (if any) matches the arglist and transform
5577 the expression into a call of that binding. */
5580 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5582 gfc_typebound_proc* genproc;
5583 const char* genname;
5585 gfc_symbol *derived;
5587 gcc_assert (e->expr_type == EXPR_COMPCALL);
5588 genname = e->value.compcall.name;
5589 genproc = e->value.compcall.tbp;
5591 if (!genproc->is_generic)
5594 /* Try the bindings on this type and in the inheritance hierarchy. */
5595 for (; genproc; genproc = genproc->overridden)
5599 gcc_assert (genproc->is_generic);
5600 for (g = genproc->u.generic; g; g = g->next)
5603 gfc_actual_arglist* args;
5606 gcc_assert (g->specific);
5608 if (g->specific->error)
5611 target = g->specific->u.specific->n.sym;
5613 /* Get the right arglist by handling PASS/NOPASS. */
5614 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5615 if (!g->specific->nopass)
5618 po = extract_compcall_passed_object (e);
5622 gcc_assert (g->specific->pass_arg_num > 0);
5623 gcc_assert (!g->specific->error);
5624 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5625 g->specific->pass_arg);
5627 resolve_actual_arglist (args, target->attr.proc,
5628 is_external_proc (target) && !target->formal);
5630 /* Check if this arglist matches the formal. */
5631 matches = gfc_arglist_matches_symbol (&args, target);
5633 /* Clean up and break out of the loop if we've found it. */
5634 gfc_free_actual_arglist (args);
5637 e->value.compcall.tbp = g->specific;
5638 genname = g->specific_st->name;
5639 /* Pass along the name for CLASS methods, where the vtab
5640 procedure pointer component has to be referenced. */
5648 /* Nothing matching found! */
5649 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5650 " '%s' at %L", genname, &e->where);
5654 /* Make sure that we have the right specific instance for the name. */
5655 derived = get_declared_from_expr (NULL, NULL, e);
5657 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5659 e->value.compcall.tbp = st->n.tb;
5665 /* Resolve a call to a type-bound subroutine. */
5668 resolve_typebound_call (gfc_code* c, const char **name)
5670 gfc_actual_arglist* newactual;
5671 gfc_symtree* target;
5673 /* Check that's really a SUBROUTINE. */
5674 if (!c->expr1->value.compcall.tbp->subroutine)
5676 gfc_error ("'%s' at %L should be a SUBROUTINE",
5677 c->expr1->value.compcall.name, &c->loc);
5681 if (check_typebound_baseobject (c->expr1) == FAILURE)
5684 /* Pass along the name for CLASS methods, where the vtab
5685 procedure pointer component has to be referenced. */
5687 *name = c->expr1->value.compcall.name;
5689 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5692 /* Transform into an ordinary EXEC_CALL for now. */
5694 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5697 c->ext.actual = newactual;
5698 c->symtree = target;
5699 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5701 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5703 gfc_free_expr (c->expr1);
5704 c->expr1 = gfc_get_expr ();
5705 c->expr1->expr_type = EXPR_FUNCTION;
5706 c->expr1->symtree = target;
5707 c->expr1->where = c->loc;
5709 return resolve_call (c);
5713 /* Resolve a component-call expression. */
5715 resolve_compcall (gfc_expr* e, const char **name)
5717 gfc_actual_arglist* newactual;
5718 gfc_symtree* target;
5720 /* Check that's really a FUNCTION. */
5721 if (!e->value.compcall.tbp->function)
5723 gfc_error ("'%s' at %L should be a FUNCTION",
5724 e->value.compcall.name, &e->where);
5728 /* These must not be assign-calls! */
5729 gcc_assert (!e->value.compcall.assign);
5731 if (check_typebound_baseobject (e) == FAILURE)
5734 /* Pass along the name for CLASS methods, where the vtab
5735 procedure pointer component has to be referenced. */
5737 *name = e->value.compcall.name;
5739 if (resolve_typebound_generic_call (e, name) == FAILURE)
5741 gcc_assert (!e->value.compcall.tbp->is_generic);
5743 /* Take the rank from the function's symbol. */
5744 if (e->value.compcall.tbp->u.specific->n.sym->as)
5745 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5747 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5748 arglist to the TBP's binding target. */
5750 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5753 e->value.function.actual = newactual;
5754 e->value.function.name = NULL;
5755 e->value.function.esym = target->n.sym;
5756 e->value.function.isym = NULL;
5757 e->symtree = target;
5758 e->ts = target->n.sym->ts;
5759 e->expr_type = EXPR_FUNCTION;
5761 /* Resolution is not necessary if this is a class subroutine; this
5762 function only has to identify the specific proc. Resolution of
5763 the call will be done next in resolve_typebound_call. */
5764 return gfc_resolve_expr (e);
5769 /* Resolve a typebound function, or 'method'. First separate all
5770 the non-CLASS references by calling resolve_compcall directly. */
5773 resolve_typebound_function (gfc_expr* e)
5775 gfc_symbol *declared;
5786 /* Deal with typebound operators for CLASS objects. */
5787 expr = e->value.compcall.base_object;
5788 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5790 /* Since the typebound operators are generic, we have to ensure
5791 that any delays in resolution are corrected and that the vtab
5794 declared = ts.u.derived;
5795 c = gfc_find_component (declared, "_vptr", true, true);
5796 if (c->ts.u.derived == NULL)
5797 c->ts.u.derived = gfc_find_derived_vtab (declared);
5799 if (resolve_compcall (e, &name) == FAILURE)
5802 /* Use the generic name if it is there. */
5803 name = name ? name : e->value.function.esym->name;
5804 e->symtree = expr->symtree;
5805 e->ref = gfc_copy_ref (expr->ref);
5806 gfc_add_vptr_component (e);
5807 gfc_add_component_ref (e, name);
5808 e->value.function.esym = NULL;
5813 return resolve_compcall (e, NULL);
5815 if (resolve_ref (e) == FAILURE)
5818 /* Get the CLASS declared type. */
5819 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5821 /* Weed out cases of the ultimate component being a derived type. */
5822 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5823 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5825 gfc_free_ref_list (new_ref);
5826 return resolve_compcall (e, NULL);
5829 c = gfc_find_component (declared, "_data", true, true);
5830 declared = c->ts.u.derived;
5832 /* Treat the call as if it is a typebound procedure, in order to roll
5833 out the correct name for the specific function. */
5834 if (resolve_compcall (e, &name) == FAILURE)
5838 /* Then convert the expression to a procedure pointer component call. */
5839 e->value.function.esym = NULL;
5845 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5846 gfc_add_vptr_component (e);
5847 gfc_add_component_ref (e, name);
5849 /* Recover the typespec for the expression. This is really only
5850 necessary for generic procedures, where the additional call
5851 to gfc_add_component_ref seems to throw the collection of the
5852 correct typespec. */
5857 /* Resolve a typebound subroutine, or 'method'. First separate all
5858 the non-CLASS references by calling resolve_typebound_call
5862 resolve_typebound_subroutine (gfc_code *code)
5864 gfc_symbol *declared;
5873 st = code->expr1->symtree;
5875 /* Deal with typebound operators for CLASS objects. */
5876 expr = code->expr1->value.compcall.base_object;
5877 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5878 && code->expr1->value.compcall.name)
5880 /* Since the typebound operators are generic, we have to ensure
5881 that any delays in resolution are corrected and that the vtab
5883 ts = expr->symtree->n.sym->ts;
5884 declared = ts.u.derived;
5885 c = gfc_find_component (declared, "_vptr", true, true);
5886 if (c->ts.u.derived == NULL)
5887 c->ts.u.derived = gfc_find_derived_vtab (declared);
5889 if (resolve_typebound_call (code, &name) == FAILURE)
5892 /* Use the generic name if it is there. */
5893 name = name ? name : code->expr1->value.function.esym->name;
5894 code->expr1->symtree = expr->symtree;
5895 expr->symtree->n.sym->ts.u.derived = declared;
5896 gfc_add_vptr_component (code->expr1);
5897 gfc_add_component_ref (code->expr1, name);
5898 code->expr1->value.function.esym = NULL;
5903 return resolve_typebound_call (code, NULL);
5905 if (resolve_ref (code->expr1) == FAILURE)
5908 /* Get the CLASS declared type. */
5909 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5911 /* Weed out cases of the ultimate component being a derived type. */
5912 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5913 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5915 gfc_free_ref_list (new_ref);
5916 return resolve_typebound_call (code, NULL);
5919 if (resolve_typebound_call (code, &name) == FAILURE)
5921 ts = code->expr1->ts;
5923 /* Then convert the expression to a procedure pointer component call. */
5924 code->expr1->value.function.esym = NULL;
5925 code->expr1->symtree = st;
5928 code->expr1->ref = new_ref;
5930 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5931 gfc_add_vptr_component (code->expr1);
5932 gfc_add_component_ref (code->expr1, name);
5934 /* Recover the typespec for the expression. This is really only
5935 necessary for generic procedures, where the additional call
5936 to gfc_add_component_ref seems to throw the collection of the
5937 correct typespec. */
5938 code->expr1->ts = ts;
5943 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5946 resolve_ppc_call (gfc_code* c)
5948 gfc_component *comp;
5951 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5954 c->resolved_sym = c->expr1->symtree->n.sym;
5955 c->expr1->expr_type = EXPR_VARIABLE;
5957 if (!comp->attr.subroutine)
5958 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5960 if (resolve_ref (c->expr1) == FAILURE)
5963 if (update_ppc_arglist (c->expr1) == FAILURE)
5966 c->ext.actual = c->expr1->value.compcall.actual;
5968 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5969 comp->formal == NULL) == FAILURE)
5972 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5978 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5981 resolve_expr_ppc (gfc_expr* e)
5983 gfc_component *comp;
5986 b = gfc_is_proc_ptr_comp (e, &comp);
5989 /* Convert to EXPR_FUNCTION. */
5990 e->expr_type = EXPR_FUNCTION;
5991 e->value.function.isym = NULL;
5992 e->value.function.actual = e->value.compcall.actual;
5994 if (comp->as != NULL)
5995 e->rank = comp->as->rank;
5997 if (!comp->attr.function)
5998 gfc_add_function (&comp->attr, comp->name, &e->where);
6000 if (resolve_ref (e) == FAILURE)
6003 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6004 comp->formal == NULL) == FAILURE)
6007 if (update_ppc_arglist (e) == FAILURE)
6010 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6017 gfc_is_expandable_expr (gfc_expr *e)
6019 gfc_constructor *con;
6021 if (e->expr_type == EXPR_ARRAY)
6023 /* Traverse the constructor looking for variables that are flavor
6024 parameter. Parameters must be expanded since they are fully used at
6026 con = gfc_constructor_first (e->value.constructor);
6027 for (; con; con = gfc_constructor_next (con))
6029 if (con->expr->expr_type == EXPR_VARIABLE
6030 && con->expr->symtree
6031 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6032 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6034 if (con->expr->expr_type == EXPR_ARRAY
6035 && gfc_is_expandable_expr (con->expr))
6043 /* Resolve an expression. That is, make sure that types of operands agree
6044 with their operators, intrinsic operators are converted to function calls
6045 for overloaded types and unresolved function references are resolved. */
6048 gfc_resolve_expr (gfc_expr *e)
6056 /* inquiry_argument only applies to variables. */
6057 inquiry_save = inquiry_argument;
6058 if (e->expr_type != EXPR_VARIABLE)
6059 inquiry_argument = false;
6061 switch (e->expr_type)
6064 t = resolve_operator (e);
6070 if (check_host_association (e))
6071 t = resolve_function (e);
6074 t = resolve_variable (e);
6076 expression_rank (e);
6079 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6080 && e->ref->type != REF_SUBSTRING)
6081 gfc_resolve_substring_charlen (e);
6086 t = resolve_typebound_function (e);
6089 case EXPR_SUBSTRING:
6090 t = resolve_ref (e);
6099 t = resolve_expr_ppc (e);
6104 if (resolve_ref (e) == FAILURE)
6107 t = gfc_resolve_array_constructor (e);
6108 /* Also try to expand a constructor. */
6111 expression_rank (e);
6112 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6113 gfc_expand_constructor (e, false);
6116 /* This provides the opportunity for the length of constructors with
6117 character valued function elements to propagate the string length
6118 to the expression. */
6119 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6121 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6122 here rather then add a duplicate test for it above. */
6123 gfc_expand_constructor (e, false);
6124 t = gfc_resolve_character_array_constructor (e);
6129 case EXPR_STRUCTURE:
6130 t = resolve_ref (e);
6134 t = resolve_structure_cons (e, 0);
6138 t = gfc_simplify_expr (e, 0);
6142 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6145 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6148 inquiry_argument = inquiry_save;
6154 /* Resolve an expression from an iterator. They must be scalar and have
6155 INTEGER or (optionally) REAL type. */
6158 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6159 const char *name_msgid)
6161 if (gfc_resolve_expr (expr) == FAILURE)
6164 if (expr->rank != 0)
6166 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6170 if (expr->ts.type != BT_INTEGER)
6172 if (expr->ts.type == BT_REAL)
6175 return gfc_notify_std (GFC_STD_F95_DEL,
6176 "Deleted feature: %s at %L must be integer",
6177 _(name_msgid), &expr->where);
6180 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6187 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6195 /* Resolve the expressions in an iterator structure. If REAL_OK is
6196 false allow only INTEGER type iterators, otherwise allow REAL types. */
6199 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6201 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6205 if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
6209 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6210 "Start expression in DO loop") == FAILURE)
6213 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6214 "End expression in DO loop") == FAILURE)
6217 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6218 "Step expression in DO loop") == FAILURE)
6221 if (iter->step->expr_type == EXPR_CONSTANT)
6223 if ((iter->step->ts.type == BT_INTEGER
6224 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6225 || (iter->step->ts.type == BT_REAL
6226 && mpfr_sgn (iter->step->value.real) == 0))
6228 gfc_error ("Step expression in DO loop at %L cannot be zero",
6229 &iter->step->where);
6234 /* Convert start, end, and step to the same type as var. */
6235 if (iter->start->ts.kind != iter->var->ts.kind
6236 || iter->start->ts.type != iter->var->ts.type)
6237 gfc_convert_type (iter->start, &iter->var->ts, 2);
6239 if (iter->end->ts.kind != iter->var->ts.kind
6240 || iter->end->ts.type != iter->var->ts.type)
6241 gfc_convert_type (iter->end, &iter->var->ts, 2);
6243 if (iter->step->ts.kind != iter->var->ts.kind
6244 || iter->step->ts.type != iter->var->ts.type)
6245 gfc_convert_type (iter->step, &iter->var->ts, 2);
6247 if (iter->start->expr_type == EXPR_CONSTANT
6248 && iter->end->expr_type == EXPR_CONSTANT
6249 && iter->step->expr_type == EXPR_CONSTANT)
6252 if (iter->start->ts.type == BT_INTEGER)
6254 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6255 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6259 sgn = mpfr_sgn (iter->step->value.real);
6260 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6262 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6263 gfc_warning ("DO loop at %L will be executed zero times",
6264 &iter->step->where);
6271 /* Traversal function for find_forall_index. f == 2 signals that
6272 that variable itself is not to be checked - only the references. */
6275 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6277 if (expr->expr_type != EXPR_VARIABLE)
6280 /* A scalar assignment */
6281 if (!expr->ref || *f == 1)
6283 if (expr->symtree->n.sym == sym)
6295 /* Check whether the FORALL index appears in the expression or not.
6296 Returns SUCCESS if SYM is found in EXPR. */
6299 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6301 if (gfc_traverse_expr (expr, sym, forall_index, f))
6308 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6309 to be a scalar INTEGER variable. The subscripts and stride are scalar
6310 INTEGERs, and if stride is a constant it must be nonzero.
6311 Furthermore "A subscript or stride in a forall-triplet-spec shall
6312 not contain a reference to any index-name in the
6313 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6316 resolve_forall_iterators (gfc_forall_iterator *it)
6318 gfc_forall_iterator *iter, *iter2;
6320 for (iter = it; iter; iter = iter->next)
6322 if (gfc_resolve_expr (iter->var) == SUCCESS
6323 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6324 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6327 if (gfc_resolve_expr (iter->start) == SUCCESS
6328 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6329 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6330 &iter->start->where);
6331 if (iter->var->ts.kind != iter->start->ts.kind)
6332 gfc_convert_type (iter->start, &iter->var->ts, 2);
6334 if (gfc_resolve_expr (iter->end) == SUCCESS
6335 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6336 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6338 if (iter->var->ts.kind != iter->end->ts.kind)
6339 gfc_convert_type (iter->end, &iter->var->ts, 2);
6341 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6343 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6344 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6345 &iter->stride->where, "INTEGER");
6347 if (iter->stride->expr_type == EXPR_CONSTANT
6348 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6349 gfc_error ("FORALL stride expression at %L cannot be zero",
6350 &iter->stride->where);
6352 if (iter->var->ts.kind != iter->stride->ts.kind)
6353 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6356 for (iter = it; iter; iter = iter->next)
6357 for (iter2 = iter; iter2; iter2 = iter2->next)
6359 if (find_forall_index (iter2->start,
6360 iter->var->symtree->n.sym, 0) == SUCCESS
6361 || find_forall_index (iter2->end,
6362 iter->var->symtree->n.sym, 0) == SUCCESS
6363 || find_forall_index (iter2->stride,
6364 iter->var->symtree->n.sym, 0) == SUCCESS)
6365 gfc_error ("FORALL index '%s' may not appear in triplet "
6366 "specification at %L", iter->var->symtree->name,
6367 &iter2->start->where);
6372 /* Given a pointer to a symbol that is a derived type, see if it's
6373 inaccessible, i.e. if it's defined in another module and the components are
6374 PRIVATE. The search is recursive if necessary. Returns zero if no
6375 inaccessible components are found, nonzero otherwise. */
6378 derived_inaccessible (gfc_symbol *sym)
6382 if (sym->attr.use_assoc && sym->attr.private_comp)
6385 for (c = sym->components; c; c = c->next)
6387 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6395 /* Resolve the argument of a deallocate expression. The expression must be
6396 a pointer or a full array. */
6399 resolve_deallocate_expr (gfc_expr *e)
6401 symbol_attribute attr;
6402 int allocatable, pointer;
6407 if (gfc_resolve_expr (e) == FAILURE)
6410 if (e->expr_type != EXPR_VARIABLE)
6413 sym = e->symtree->n.sym;
6415 if (sym->ts.type == BT_CLASS)
6417 allocatable = CLASS_DATA (sym)->attr.allocatable;
6418 pointer = CLASS_DATA (sym)->attr.class_pointer;
6422 allocatable = sym->attr.allocatable;
6423 pointer = sym->attr.pointer;
6425 for (ref = e->ref; ref; ref = ref->next)
6430 if (ref->u.ar.type != AR_FULL)
6435 c = ref->u.c.component;
6436 if (c->ts.type == BT_CLASS)
6438 allocatable = CLASS_DATA (c)->attr.allocatable;
6439 pointer = CLASS_DATA (c)->attr.class_pointer;
6443 allocatable = c->attr.allocatable;
6444 pointer = c->attr.pointer;
6454 attr = gfc_expr_attr (e);
6456 if (allocatable == 0 && attr.pointer == 0)
6459 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6465 && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
6467 if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
6474 /* Returns true if the expression e contains a reference to the symbol sym. */
6476 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6478 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6485 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6487 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6491 /* Given the expression node e for an allocatable/pointer of derived type to be
6492 allocated, get the expression node to be initialized afterwards (needed for
6493 derived types with default initializers, and derived types with allocatable
6494 components that need nullification.) */
6497 gfc_expr_to_initialize (gfc_expr *e)
6503 result = gfc_copy_expr (e);
6505 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6506 for (ref = result->ref; ref; ref = ref->next)
6507 if (ref->type == REF_ARRAY && ref->next == NULL)
6509 ref->u.ar.type = AR_FULL;
6511 for (i = 0; i < ref->u.ar.dimen; i++)
6512 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6514 result->rank = ref->u.ar.dimen;
6522 /* If the last ref of an expression is an array ref, return a copy of the
6523 expression with that one removed. Otherwise, a copy of the original
6524 expression. This is used for allocate-expressions and pointer assignment
6525 LHS, where there may be an array specification that needs to be stripped
6526 off when using gfc_check_vardef_context. */
6529 remove_last_array_ref (gfc_expr* e)
6534 e2 = gfc_copy_expr (e);
6535 for (r = &e2->ref; *r; r = &(*r)->next)
6536 if ((*r)->type == REF_ARRAY && !(*r)->next)
6538 gfc_free_ref_list (*r);
6547 /* Used in resolve_allocate_expr to check that a allocation-object and
6548 a source-expr are conformable. This does not catch all possible
6549 cases; in particular a runtime checking is needed. */
6552 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6555 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6557 /* First compare rank. */
6558 if (tail && e1->rank != tail->u.ar.as->rank)
6560 gfc_error ("Source-expr at %L must be scalar or have the "
6561 "same rank as the allocate-object at %L",
6562 &e1->where, &e2->where);
6573 for (i = 0; i < e1->rank; i++)
6575 if (tail->u.ar.end[i])
6577 mpz_set (s, tail->u.ar.end[i]->value.integer);
6578 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6579 mpz_add_ui (s, s, 1);
6583 mpz_set (s, tail->u.ar.start[i]->value.integer);
6586 if (mpz_cmp (e1->shape[i], s) != 0)
6588 gfc_error ("Source-expr at %L and allocate-object at %L must "
6589 "have the same shape", &e1->where, &e2->where);
6602 /* Resolve the expression in an ALLOCATE statement, doing the additional
6603 checks to see whether the expression is OK or not. The expression must
6604 have a trailing array reference that gives the size of the array. */
6607 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6609 int i, pointer, allocatable, dimension, is_abstract;
6611 symbol_attribute attr;
6612 gfc_ref *ref, *ref2;
6615 gfc_symbol *sym = NULL;
6620 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6621 checking of coarrays. */
6622 for (ref = e->ref; ref; ref = ref->next)
6623 if (ref->next == NULL)
6626 if (ref && ref->type == REF_ARRAY)
6627 ref->u.ar.in_allocate = true;
6629 if (gfc_resolve_expr (e) == FAILURE)
6632 /* Make sure the expression is allocatable or a pointer. If it is
6633 pointer, the next-to-last reference must be a pointer. */
6637 sym = e->symtree->n.sym;
6639 /* Check whether ultimate component is abstract and CLASS. */
6642 if (e->expr_type != EXPR_VARIABLE)
6645 attr = gfc_expr_attr (e);
6646 pointer = attr.pointer;
6647 dimension = attr.dimension;
6648 codimension = attr.codimension;
6652 if (sym->ts.type == BT_CLASS)
6654 allocatable = CLASS_DATA (sym)->attr.allocatable;
6655 pointer = CLASS_DATA (sym)->attr.class_pointer;
6656 dimension = CLASS_DATA (sym)->attr.dimension;
6657 codimension = CLASS_DATA (sym)->attr.codimension;
6658 is_abstract = CLASS_DATA (sym)->attr.abstract;
6662 allocatable = sym->attr.allocatable;
6663 pointer = sym->attr.pointer;
6664 dimension = sym->attr.dimension;
6665 codimension = sym->attr.codimension;
6668 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6673 if (ref->next != NULL)
6679 if (gfc_is_coindexed (e))
6681 gfc_error ("Coindexed allocatable object at %L",
6686 c = ref->u.c.component;
6687 if (c->ts.type == BT_CLASS)
6689 allocatable = CLASS_DATA (c)->attr.allocatable;
6690 pointer = CLASS_DATA (c)->attr.class_pointer;
6691 dimension = CLASS_DATA (c)->attr.dimension;
6692 codimension = CLASS_DATA (c)->attr.codimension;
6693 is_abstract = CLASS_DATA (c)->attr.abstract;
6697 allocatable = c->attr.allocatable;
6698 pointer = c->attr.pointer;
6699 dimension = c->attr.dimension;
6700 codimension = c->attr.codimension;
6701 is_abstract = c->attr.abstract;
6713 if (allocatable == 0 && pointer == 0)
6715 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6720 /* Some checks for the SOURCE tag. */
6723 /* Check F03:C631. */
6724 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6726 gfc_error ("Type of entity at %L is type incompatible with "
6727 "source-expr at %L", &e->where, &code->expr3->where);
6731 /* Check F03:C632 and restriction following Note 6.18. */
6732 if (code->expr3->rank > 0
6733 && conformable_arrays (code->expr3, e) == FAILURE)
6736 /* Check F03:C633. */
6737 if (code->expr3->ts.kind != e->ts.kind)
6739 gfc_error ("The allocate-object at %L and the source-expr at %L "
6740 "shall have the same kind type parameter",
6741 &e->where, &code->expr3->where);
6746 /* Check F08:C629. */
6747 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6750 gcc_assert (e->ts.type == BT_CLASS);
6751 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6752 "type-spec or source-expr", sym->name, &e->where);
6756 /* In the variable definition context checks, gfc_expr_attr is used
6757 on the expression. This is fooled by the array specification
6758 present in e, thus we have to eliminate that one temporarily. */
6759 e2 = remove_last_array_ref (e);
6761 if (t == SUCCESS && pointer)
6762 t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
6764 t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
6771 /* Set up default initializer if needed. */
6775 if (code->ext.alloc.ts.type == BT_DERIVED)
6776 ts = code->ext.alloc.ts;
6780 if (ts.type == BT_CLASS)
6781 ts = ts.u.derived->components->ts;
6783 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6785 gfc_code *init_st = gfc_get_code ();
6786 init_st->loc = code->loc;
6787 init_st->op = EXEC_INIT_ASSIGN;
6788 init_st->expr1 = gfc_expr_to_initialize (e);
6789 init_st->expr2 = init_e;
6790 init_st->next = code->next;
6791 code->next = init_st;
6794 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6796 /* Default initialization via MOLD (non-polymorphic). */
6797 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6798 gfc_resolve_expr (rhs);
6799 gfc_free_expr (code->expr3);
6803 if (e->ts.type == BT_CLASS)
6805 /* Make sure the vtab symbol is present when
6806 the module variables are generated. */
6807 gfc_typespec ts = e->ts;
6809 ts = code->expr3->ts;
6810 else if (code->ext.alloc.ts.type == BT_DERIVED)
6811 ts = code->ext.alloc.ts;
6812 gfc_find_derived_vtab (ts.u.derived);
6815 if (pointer || (dimension == 0 && codimension == 0))
6818 /* Make sure the last reference node is an array specifiction. */
6820 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6821 || (dimension && ref2->u.ar.dimen == 0))
6823 gfc_error ("Array specification required in ALLOCATE statement "
6824 "at %L", &e->where);
6828 /* Make sure that the array section reference makes sense in the
6829 context of an ALLOCATE specification. */
6833 if (codimension && ar->codimen == 0)
6835 gfc_error ("Coarray specification required in ALLOCATE statement "
6836 "at %L", &e->where);
6840 for (i = 0; i < ar->dimen; i++)
6842 if (ref2->u.ar.type == AR_ELEMENT)
6845 switch (ar->dimen_type[i])
6851 if (ar->start[i] != NULL
6852 && ar->end[i] != NULL
6853 && ar->stride[i] == NULL)
6856 /* Fall Through... */
6861 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6867 for (a = code->ext.alloc.list; a; a = a->next)
6869 sym = a->expr->symtree->n.sym;
6871 /* TODO - check derived type components. */
6872 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6875 if ((ar->start[i] != NULL
6876 && gfc_find_sym_in_expr (sym, ar->start[i]))
6877 || (ar->end[i] != NULL
6878 && gfc_find_sym_in_expr (sym, ar->end[i])))
6880 gfc_error ("'%s' must not appear in the array specification at "
6881 "%L in the same ALLOCATE statement where it is "
6882 "itself allocated", sym->name, &ar->where);
6888 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6890 if (ar->dimen_type[i] == DIMEN_ELEMENT
6891 || ar->dimen_type[i] == DIMEN_RANGE)
6893 if (i == (ar->dimen + ar->codimen - 1))
6895 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6896 "statement at %L", &e->where);
6902 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6903 && ar->stride[i] == NULL)
6906 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6911 if (codimension && ar->as->rank == 0)
6913 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6914 "at %L", &e->where);
6921 gfc_error ("Support for entity at %L with deferred type parameter "
6922 "not yet implemented", &e->where);
6932 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6934 gfc_expr *stat, *errmsg, *pe, *qe;
6935 gfc_alloc *a, *p, *q;
6938 errmsg = code->expr2;
6940 /* Check the stat variable. */
6943 gfc_check_vardef_context (stat, false, _("STAT variable"));
6945 if ((stat->ts.type != BT_INTEGER
6946 && !(stat->ref && (stat->ref->type == REF_ARRAY
6947 || stat->ref->type == REF_COMPONENT)))
6949 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6950 "variable", &stat->where);
6952 for (p = code->ext.alloc.list; p; p = p->next)
6953 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6955 gfc_ref *ref1, *ref2;
6958 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6959 ref1 = ref1->next, ref2 = ref2->next)
6961 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6963 if (ref1->u.c.component->name != ref2->u.c.component->name)
6972 gfc_error ("Stat-variable at %L shall not be %sd within "
6973 "the same %s statement", &stat->where, fcn, fcn);
6979 /* Check the errmsg variable. */
6983 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6986 gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
6988 if ((errmsg->ts.type != BT_CHARACTER
6990 && (errmsg->ref->type == REF_ARRAY
6991 || errmsg->ref->type == REF_COMPONENT)))
6992 || errmsg->rank > 0 )
6993 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6994 "variable", &errmsg->where);
6996 for (p = code->ext.alloc.list; p; p = p->next)
6997 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6999 gfc_ref *ref1, *ref2;
7002 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7003 ref1 = ref1->next, ref2 = ref2->next)
7005 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7007 if (ref1->u.c.component->name != ref2->u.c.component->name)
7016 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7017 "the same %s statement", &errmsg->where, fcn, fcn);
7023 /* Check that an allocate-object appears only once in the statement.
7024 FIXME: Checking derived types is disabled. */
7025 for (p = code->ext.alloc.list; p; p = p->next)
7028 for (q = p->next; q; q = q->next)
7031 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7033 /* This is a potential collision. */
7034 gfc_ref *pr = pe->ref;
7035 gfc_ref *qr = qe->ref;
7037 /* Follow the references until
7038 a) They start to differ, in which case there is no error;
7039 you can deallocate a%b and a%c in a single statement
7040 b) Both of them stop, which is an error
7041 c) One of them stops, which is also an error. */
7044 if (pr == NULL && qr == NULL)
7046 gfc_error ("Allocate-object at %L also appears at %L",
7047 &pe->where, &qe->where);
7050 else if (pr != NULL && qr == NULL)
7052 gfc_error ("Allocate-object at %L is subobject of"
7053 " object at %L", &pe->where, &qe->where);
7056 else if (pr == NULL && qr != NULL)
7058 gfc_error ("Allocate-object at %L is subobject of"
7059 " object at %L", &qe->where, &pe->where);
7062 /* Here, pr != NULL && qr != NULL */
7063 gcc_assert(pr->type == qr->type);
7064 if (pr->type == REF_ARRAY)
7066 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7068 gcc_assert (qr->type == REF_ARRAY);
7070 if (pr->next && qr->next)
7072 gfc_array_ref *par = &(pr->u.ar);
7073 gfc_array_ref *qar = &(qr->u.ar);
7074 if (gfc_dep_compare_expr (par->start[0],
7075 qar->start[0]) != 0)
7081 if (pr->u.c.component->name != qr->u.c.component->name)
7092 if (strcmp (fcn, "ALLOCATE") == 0)
7094 for (a = code->ext.alloc.list; a; a = a->next)
7095 resolve_allocate_expr (a->expr, code);
7099 for (a = code->ext.alloc.list; a; a = a->next)
7100 resolve_deallocate_expr (a->expr);
7105 /************ SELECT CASE resolution subroutines ************/
7107 /* Callback function for our mergesort variant. Determines interval
7108 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7109 op1 > op2. Assumes we're not dealing with the default case.
7110 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7111 There are nine situations to check. */
7114 compare_cases (const gfc_case *op1, const gfc_case *op2)
7118 if (op1->low == NULL) /* op1 = (:L) */
7120 /* op2 = (:N), so overlap. */
7122 /* op2 = (M:) or (M:N), L < M */
7123 if (op2->low != NULL
7124 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7127 else if (op1->high == NULL) /* op1 = (K:) */
7129 /* op2 = (M:), so overlap. */
7131 /* op2 = (:N) or (M:N), K > N */
7132 if (op2->high != NULL
7133 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7136 else /* op1 = (K:L) */
7138 if (op2->low == NULL) /* op2 = (:N), K > N */
7139 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7141 else if (op2->high == NULL) /* op2 = (M:), L < M */
7142 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7144 else /* op2 = (M:N) */
7148 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7151 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7160 /* Merge-sort a double linked case list, detecting overlap in the
7161 process. LIST is the head of the double linked case list before it
7162 is sorted. Returns the head of the sorted list if we don't see any
7163 overlap, or NULL otherwise. */
7166 check_case_overlap (gfc_case *list)
7168 gfc_case *p, *q, *e, *tail;
7169 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7171 /* If the passed list was empty, return immediately. */
7178 /* Loop unconditionally. The only exit from this loop is a return
7179 statement, when we've finished sorting the case list. */
7186 /* Count the number of merges we do in this pass. */
7189 /* Loop while there exists a merge to be done. */
7194 /* Count this merge. */
7197 /* Cut the list in two pieces by stepping INSIZE places
7198 forward in the list, starting from P. */
7201 for (i = 0; i < insize; i++)
7210 /* Now we have two lists. Merge them! */
7211 while (psize > 0 || (qsize > 0 && q != NULL))
7213 /* See from which the next case to merge comes from. */
7216 /* P is empty so the next case must come from Q. */
7221 else if (qsize == 0 || q == NULL)
7230 cmp = compare_cases (p, q);
7233 /* The whole case range for P is less than the
7241 /* The whole case range for Q is greater than
7242 the case range for P. */
7249 /* The cases overlap, or they are the same
7250 element in the list. Either way, we must
7251 issue an error and get the next case from P. */
7252 /* FIXME: Sort P and Q by line number. */
7253 gfc_error ("CASE label at %L overlaps with CASE "
7254 "label at %L", &p->where, &q->where);
7262 /* Add the next element to the merged list. */
7271 /* P has now stepped INSIZE places along, and so has Q. So
7272 they're the same. */
7277 /* If we have done only one merge or none at all, we've
7278 finished sorting the cases. */
7287 /* Otherwise repeat, merging lists twice the size. */
7293 /* Check to see if an expression is suitable for use in a CASE statement.
7294 Makes sure that all case expressions are scalar constants of the same
7295 type. Return FAILURE if anything is wrong. */
7298 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7300 if (e == NULL) return SUCCESS;
7302 if (e->ts.type != case_expr->ts.type)
7304 gfc_error ("Expression in CASE statement at %L must be of type %s",
7305 &e->where, gfc_basic_typename (case_expr->ts.type));
7309 /* C805 (R808) For a given case-construct, each case-value shall be of
7310 the same type as case-expr. For character type, length differences
7311 are allowed, but the kind type parameters shall be the same. */
7313 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7315 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7316 &e->where, case_expr->ts.kind);
7320 /* Convert the case value kind to that of case expression kind,
7323 if (e->ts.kind != case_expr->ts.kind)
7324 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7328 gfc_error ("Expression in CASE statement at %L must be scalar",
7337 /* Given a completely parsed select statement, we:
7339 - Validate all expressions and code within the SELECT.
7340 - Make sure that the selection expression is not of the wrong type.
7341 - Make sure that no case ranges overlap.
7342 - Eliminate unreachable cases and unreachable code resulting from
7343 removing case labels.
7345 The standard does allow unreachable cases, e.g. CASE (5:3). But
7346 they are a hassle for code generation, and to prevent that, we just
7347 cut them out here. This is not necessary for overlapping cases
7348 because they are illegal and we never even try to generate code.
7350 We have the additional caveat that a SELECT construct could have
7351 been a computed GOTO in the source code. Fortunately we can fairly
7352 easily work around that here: The case_expr for a "real" SELECT CASE
7353 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7354 we have to do is make sure that the case_expr is a scalar integer
7358 resolve_select (gfc_code *code)
7361 gfc_expr *case_expr;
7362 gfc_case *cp, *default_case, *tail, *head;
7363 int seen_unreachable;
7369 if (code->expr1 == NULL)
7371 /* This was actually a computed GOTO statement. */
7372 case_expr = code->expr2;
7373 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7374 gfc_error ("Selection expression in computed GOTO statement "
7375 "at %L must be a scalar integer expression",
7378 /* Further checking is not necessary because this SELECT was built
7379 by the compiler, so it should always be OK. Just move the
7380 case_expr from expr2 to expr so that we can handle computed
7381 GOTOs as normal SELECTs from here on. */
7382 code->expr1 = code->expr2;
7387 case_expr = code->expr1;
7389 type = case_expr->ts.type;
7390 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7392 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7393 &case_expr->where, gfc_typename (&case_expr->ts));
7395 /* Punt. Going on here just produce more garbage error messages. */
7399 if (case_expr->rank != 0)
7401 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7402 "expression", &case_expr->where);
7409 /* Raise a warning if an INTEGER case value exceeds the range of
7410 the case-expr. Later, all expressions will be promoted to the
7411 largest kind of all case-labels. */
7413 if (type == BT_INTEGER)
7414 for (body = code->block; body; body = body->block)
7415 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7418 && gfc_check_integer_range (cp->low->value.integer,
7419 case_expr->ts.kind) != ARITH_OK)
7420 gfc_warning ("Expression in CASE statement at %L is "
7421 "not in the range of %s", &cp->low->where,
7422 gfc_typename (&case_expr->ts));
7425 && cp->low != cp->high
7426 && gfc_check_integer_range (cp->high->value.integer,
7427 case_expr->ts.kind) != ARITH_OK)
7428 gfc_warning ("Expression in CASE statement at %L is "
7429 "not in the range of %s", &cp->high->where,
7430 gfc_typename (&case_expr->ts));
7433 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7434 of the SELECT CASE expression and its CASE values. Walk the lists
7435 of case values, and if we find a mismatch, promote case_expr to
7436 the appropriate kind. */
7438 if (type == BT_LOGICAL || type == BT_INTEGER)
7440 for (body = code->block; body; body = body->block)
7442 /* Walk the case label list. */
7443 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7445 /* Intercept the DEFAULT case. It does not have a kind. */
7446 if (cp->low == NULL && cp->high == NULL)
7449 /* Unreachable case ranges are discarded, so ignore. */
7450 if (cp->low != NULL && cp->high != NULL
7451 && cp->low != cp->high
7452 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7456 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7457 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7459 if (cp->high != NULL
7460 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7461 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7466 /* Assume there is no DEFAULT case. */
7467 default_case = NULL;
7472 for (body = code->block; body; body = body->block)
7474 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7476 seen_unreachable = 0;
7478 /* Walk the case label list, making sure that all case labels
7480 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7482 /* Count the number of cases in the whole construct. */
7485 /* Intercept the DEFAULT case. */
7486 if (cp->low == NULL && cp->high == NULL)
7488 if (default_case != NULL)
7490 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7491 "by a second DEFAULT CASE at %L",
7492 &default_case->where, &cp->where);
7503 /* Deal with single value cases and case ranges. Errors are
7504 issued from the validation function. */
7505 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7506 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7512 if (type == BT_LOGICAL
7513 && ((cp->low == NULL || cp->high == NULL)
7514 || cp->low != cp->high))
7516 gfc_error ("Logical range in CASE statement at %L is not "
7517 "allowed", &cp->low->where);
7522 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7525 value = cp->low->value.logical == 0 ? 2 : 1;
7526 if (value & seen_logical)
7528 gfc_error ("Constant logical value in CASE statement "
7529 "is repeated at %L",
7534 seen_logical |= value;
7537 if (cp->low != NULL && cp->high != NULL
7538 && cp->low != cp->high
7539 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7541 if (gfc_option.warn_surprising)
7542 gfc_warning ("Range specification at %L can never "
7543 "be matched", &cp->where);
7545 cp->unreachable = 1;
7546 seen_unreachable = 1;
7550 /* If the case range can be matched, it can also overlap with
7551 other cases. To make sure it does not, we put it in a
7552 double linked list here. We sort that with a merge sort
7553 later on to detect any overlapping cases. */
7557 head->right = head->left = NULL;
7562 tail->right->left = tail;
7569 /* It there was a failure in the previous case label, give up
7570 for this case label list. Continue with the next block. */
7574 /* See if any case labels that are unreachable have been seen.
7575 If so, we eliminate them. This is a bit of a kludge because
7576 the case lists for a single case statement (label) is a
7577 single forward linked lists. */
7578 if (seen_unreachable)
7580 /* Advance until the first case in the list is reachable. */
7581 while (body->ext.block.case_list != NULL
7582 && body->ext.block.case_list->unreachable)
7584 gfc_case *n = body->ext.block.case_list;
7585 body->ext.block.case_list = body->ext.block.case_list->next;
7587 gfc_free_case_list (n);
7590 /* Strip all other unreachable cases. */
7591 if (body->ext.block.case_list)
7593 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7595 if (cp->next->unreachable)
7597 gfc_case *n = cp->next;
7598 cp->next = cp->next->next;
7600 gfc_free_case_list (n);
7607 /* See if there were overlapping cases. If the check returns NULL,
7608 there was overlap. In that case we don't do anything. If head
7609 is non-NULL, we prepend the DEFAULT case. The sorted list can
7610 then used during code generation for SELECT CASE constructs with
7611 a case expression of a CHARACTER type. */
7614 head = check_case_overlap (head);
7616 /* Prepend the default_case if it is there. */
7617 if (head != NULL && default_case)
7619 default_case->left = NULL;
7620 default_case->right = head;
7621 head->left = default_case;
7625 /* Eliminate dead blocks that may be the result if we've seen
7626 unreachable case labels for a block. */
7627 for (body = code; body && body->block; body = body->block)
7629 if (body->block->ext.block.case_list == NULL)
7631 /* Cut the unreachable block from the code chain. */
7632 gfc_code *c = body->block;
7633 body->block = c->block;
7635 /* Kill the dead block, but not the blocks below it. */
7637 gfc_free_statements (c);
7641 /* More than two cases is legal but insane for logical selects.
7642 Issue a warning for it. */
7643 if (gfc_option.warn_surprising && type == BT_LOGICAL
7645 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7650 /* Check if a derived type is extensible. */
7653 gfc_type_is_extensible (gfc_symbol *sym)
7655 return !(sym->attr.is_bind_c || sym->attr.sequence);
7659 /* Resolve an associate name: Resolve target and ensure the type-spec is
7660 correct as well as possibly the array-spec. */
7663 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7667 gcc_assert (sym->assoc);
7668 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7670 /* If this is for SELECT TYPE, the target may not yet be set. In that
7671 case, return. Resolution will be called later manually again when
7673 target = sym->assoc->target;
7676 gcc_assert (!sym->assoc->dangling);
7678 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7681 /* For variable targets, we get some attributes from the target. */
7682 if (target->expr_type == EXPR_VARIABLE)
7686 gcc_assert (target->symtree);
7687 tsym = target->symtree->n.sym;
7689 sym->attr.asynchronous = tsym->attr.asynchronous;
7690 sym->attr.volatile_ = tsym->attr.volatile_;
7692 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7695 /* Get type if this was not already set. Note that it can be
7696 some other type than the target in case this is a SELECT TYPE
7697 selector! So we must not update when the type is already there. */
7698 if (sym->ts.type == BT_UNKNOWN)
7699 sym->ts = target->ts;
7700 gcc_assert (sym->ts.type != BT_UNKNOWN);
7702 /* See if this is a valid association-to-variable. */
7703 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7704 && !gfc_has_vector_subscript (target));
7706 /* Finally resolve if this is an array or not. */
7707 if (sym->attr.dimension && target->rank == 0)
7709 gfc_error ("Associate-name '%s' at %L is used as array",
7710 sym->name, &sym->declared_at);
7711 sym->attr.dimension = 0;
7714 if (target->rank > 0)
7715 sym->attr.dimension = 1;
7717 if (sym->attr.dimension)
7719 sym->as = gfc_get_array_spec ();
7720 sym->as->rank = target->rank;
7721 sym->as->type = AS_DEFERRED;
7723 /* Target must not be coindexed, thus the associate-variable
7725 sym->as->corank = 0;
7730 /* Resolve a SELECT TYPE statement. */
7733 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7735 gfc_symbol *selector_type;
7736 gfc_code *body, *new_st, *if_st, *tail;
7737 gfc_code *class_is = NULL, *default_case = NULL;
7740 char name[GFC_MAX_SYMBOL_LEN];
7744 ns = code->ext.block.ns;
7747 /* Check for F03:C813. */
7748 if (code->expr1->ts.type != BT_CLASS
7749 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7751 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7752 "at %L", &code->loc);
7758 if (code->expr1->symtree->n.sym->attr.untyped)
7759 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7760 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7763 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7765 /* Loop over TYPE IS / CLASS IS cases. */
7766 for (body = code->block; body; body = body->block)
7768 c = body->ext.block.case_list;
7770 /* Check F03:C815. */
7771 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7772 && !gfc_type_is_extensible (c->ts.u.derived))
7774 gfc_error ("Derived type '%s' at %L must be extensible",
7775 c->ts.u.derived->name, &c->where);
7780 /* Check F03:C816. */
7781 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7782 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7784 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7785 c->ts.u.derived->name, &c->where, selector_type->name);
7790 /* Intercept the DEFAULT case. */
7791 if (c->ts.type == BT_UNKNOWN)
7793 /* Check F03:C818. */
7796 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7797 "by a second DEFAULT CASE at %L",
7798 &default_case->ext.block.case_list->where, &c->where);
7803 default_case = body;
7810 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7811 target if present. If there are any EXIT statements referring to the
7812 SELECT TYPE construct, this is no problem because the gfc_code
7813 reference stays the same and EXIT is equally possible from the BLOCK
7814 it is changed to. */
7815 code->op = EXEC_BLOCK;
7818 gfc_association_list* assoc;
7820 assoc = gfc_get_association_list ();
7821 assoc->st = code->expr1->symtree;
7822 assoc->target = gfc_copy_expr (code->expr2);
7823 /* assoc->variable will be set by resolve_assoc_var. */
7825 code->ext.block.assoc = assoc;
7826 code->expr1->symtree->n.sym->assoc = assoc;
7828 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7831 code->ext.block.assoc = NULL;
7833 /* Add EXEC_SELECT to switch on type. */
7834 new_st = gfc_get_code ();
7835 new_st->op = code->op;
7836 new_st->expr1 = code->expr1;
7837 new_st->expr2 = code->expr2;
7838 new_st->block = code->block;
7839 code->expr1 = code->expr2 = NULL;
7844 ns->code->next = new_st;
7846 code->op = EXEC_SELECT;
7847 gfc_add_vptr_component (code->expr1);
7848 gfc_add_hash_component (code->expr1);
7850 /* Loop over TYPE IS / CLASS IS cases. */
7851 for (body = code->block; body; body = body->block)
7853 c = body->ext.block.case_list;
7855 if (c->ts.type == BT_DERIVED)
7856 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7857 c->ts.u.derived->hash_value);
7859 else if (c->ts.type == BT_UNKNOWN)
7862 /* Associate temporary to selector. This should only be done
7863 when this case is actually true, so build a new ASSOCIATE
7864 that does precisely this here (instead of using the
7867 if (c->ts.type == BT_CLASS)
7868 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
7870 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
7871 st = gfc_find_symtree (ns->sym_root, name);
7872 gcc_assert (st->n.sym->assoc);
7873 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7874 if (c->ts.type == BT_DERIVED)
7875 gfc_add_data_component (st->n.sym->assoc->target);
7877 new_st = gfc_get_code ();
7878 new_st->op = EXEC_BLOCK;
7879 new_st->ext.block.ns = gfc_build_block_ns (ns);
7880 new_st->ext.block.ns->code = body->next;
7881 body->next = new_st;
7883 /* Chain in the new list only if it is marked as dangling. Otherwise
7884 there is a CASE label overlap and this is already used. Just ignore,
7885 the error is diagonsed elsewhere. */
7886 if (st->n.sym->assoc->dangling)
7888 new_st->ext.block.assoc = st->n.sym->assoc;
7889 st->n.sym->assoc->dangling = 0;
7892 resolve_assoc_var (st->n.sym, false);
7895 /* Take out CLASS IS cases for separate treatment. */
7897 while (body && body->block)
7899 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
7901 /* Add to class_is list. */
7902 if (class_is == NULL)
7904 class_is = body->block;
7909 for (tail = class_is; tail->block; tail = tail->block) ;
7910 tail->block = body->block;
7913 /* Remove from EXEC_SELECT list. */
7914 body->block = body->block->block;
7927 /* Add a default case to hold the CLASS IS cases. */
7928 for (tail = code; tail->block; tail = tail->block) ;
7929 tail->block = gfc_get_code ();
7931 tail->op = EXEC_SELECT_TYPE;
7932 tail->ext.block.case_list = gfc_get_case ();
7933 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
7935 default_case = tail;
7938 /* More than one CLASS IS block? */
7939 if (class_is->block)
7943 /* Sort CLASS IS blocks by extension level. */
7947 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7950 /* F03:C817 (check for doubles). */
7951 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
7952 == c2->ext.block.case_list->ts.u.derived->hash_value)
7954 gfc_error ("Double CLASS IS block in SELECT TYPE "
7956 &c2->ext.block.case_list->where);
7959 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
7960 < c2->ext.block.case_list->ts.u.derived->attr.extension)
7963 (*c1)->block = c2->block;
7973 /* Generate IF chain. */
7974 if_st = gfc_get_code ();
7975 if_st->op = EXEC_IF;
7977 for (body = class_is; body; body = body->block)
7979 new_st->block = gfc_get_code ();
7980 new_st = new_st->block;
7981 new_st->op = EXEC_IF;
7982 /* Set up IF condition: Call _gfortran_is_extension_of. */
7983 new_st->expr1 = gfc_get_expr ();
7984 new_st->expr1->expr_type = EXPR_FUNCTION;
7985 new_st->expr1->ts.type = BT_LOGICAL;
7986 new_st->expr1->ts.kind = 4;
7987 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7988 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7989 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7990 /* Set up arguments. */
7991 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7992 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7993 new_st->expr1->value.function.actual->expr->where = code->loc;
7994 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
7995 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
7996 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7997 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7998 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7999 new_st->next = body->next;
8001 if (default_case->next)
8003 new_st->block = gfc_get_code ();
8004 new_st = new_st->block;
8005 new_st->op = EXEC_IF;
8006 new_st->next = default_case->next;
8009 /* Replace CLASS DEFAULT code by the IF chain. */
8010 default_case->next = if_st;
8013 /* Resolve the internal code. This can not be done earlier because
8014 it requires that the sym->assoc of selectors is set already. */
8015 gfc_current_ns = ns;
8016 gfc_resolve_blocks (code->block, gfc_current_ns);
8017 gfc_current_ns = old_ns;
8019 resolve_select (code);
8023 /* Resolve a transfer statement. This is making sure that:
8024 -- a derived type being transferred has only non-pointer components
8025 -- a derived type being transferred doesn't have private components, unless
8026 it's being transferred from the module where the type was defined
8027 -- we're not trying to transfer a whole assumed size array. */
8030 resolve_transfer (gfc_code *code)
8039 while (exp != NULL && exp->expr_type == EXPR_OP
8040 && exp->value.op.op == INTRINSIC_PARENTHESES)
8041 exp = exp->value.op.op1;
8043 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8044 && exp->expr_type != EXPR_FUNCTION))
8047 /* If we are reading, the variable will be changed. Note that
8048 code->ext.dt may be NULL if the TRANSFER is related to
8049 an INQUIRE statement -- but in this case, we are not reading, either. */
8050 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8051 && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
8054 sym = exp->symtree->n.sym;
8057 /* Go to actual component transferred. */
8058 for (ref = exp->ref; ref; ref = ref->next)
8059 if (ref->type == REF_COMPONENT)
8060 ts = &ref->u.c.component->ts;
8062 if (ts->type == BT_CLASS)
8064 /* FIXME: Test for defined input/output. */
8065 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8066 "it is processed by a defined input/output procedure",
8071 if (ts->type == BT_DERIVED)
8073 /* Check that transferred derived type doesn't contain POINTER
8075 if (ts->u.derived->attr.pointer_comp)
8077 gfc_error ("Data transfer element at %L cannot have "
8078 "POINTER components", &code->loc);
8082 if (ts->u.derived->attr.alloc_comp)
8084 gfc_error ("Data transfer element at %L cannot have "
8085 "ALLOCATABLE components", &code->loc);
8089 if (derived_inaccessible (ts->u.derived))
8091 gfc_error ("Data transfer element at %L cannot have "
8092 "PRIVATE components",&code->loc);
8097 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
8098 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8100 gfc_error ("Data transfer element at %L cannot be a full reference to "
8101 "an assumed-size array", &code->loc);
8107 /*********** Toplevel code resolution subroutines ***********/
8109 /* Find the set of labels that are reachable from this block. We also
8110 record the last statement in each block. */
8113 find_reachable_labels (gfc_code *block)
8120 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8122 /* Collect labels in this block. We don't keep those corresponding
8123 to END {IF|SELECT}, these are checked in resolve_branch by going
8124 up through the code_stack. */
8125 for (c = block; c; c = c->next)
8127 if (c->here && c->op != EXEC_END_BLOCK)
8128 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8131 /* Merge with labels from parent block. */
8134 gcc_assert (cs_base->prev->reachable_labels);
8135 bitmap_ior_into (cs_base->reachable_labels,
8136 cs_base->prev->reachable_labels);
8142 resolve_sync (gfc_code *code)
8144 /* Check imageset. The * case matches expr1 == NULL. */
8147 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8148 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8149 "INTEGER expression", &code->expr1->where);
8150 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8151 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8152 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8153 &code->expr1->where);
8154 else if (code->expr1->expr_type == EXPR_ARRAY
8155 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8157 gfc_constructor *cons;
8158 cons = gfc_constructor_first (code->expr1->value.constructor);
8159 for (; cons; cons = gfc_constructor_next (cons))
8160 if (cons->expr->expr_type == EXPR_CONSTANT
8161 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8162 gfc_error ("Imageset argument at %L must between 1 and "
8163 "num_images()", &cons->expr->where);
8169 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8170 || code->expr2->expr_type != EXPR_VARIABLE))
8171 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8172 &code->expr2->where);
8176 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8177 || code->expr3->expr_type != EXPR_VARIABLE))
8178 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8179 &code->expr3->where);
8183 /* Given a branch to a label, see if the branch is conforming.
8184 The code node describes where the branch is located. */
8187 resolve_branch (gfc_st_label *label, gfc_code *code)
8194 /* Step one: is this a valid branching target? */
8196 if (label->defined == ST_LABEL_UNKNOWN)
8198 gfc_error ("Label %d referenced at %L is never defined", label->value,
8203 if (label->defined != ST_LABEL_TARGET)
8205 gfc_error ("Statement at %L is not a valid branch target statement "
8206 "for the branch statement at %L", &label->where, &code->loc);
8210 /* Step two: make sure this branch is not a branch to itself ;-) */
8212 if (code->here == label)
8214 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8218 /* Step three: See if the label is in the same block as the
8219 branching statement. The hard work has been done by setting up
8220 the bitmap reachable_labels. */
8222 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8224 /* Check now whether there is a CRITICAL construct; if so, check
8225 whether the label is still visible outside of the CRITICAL block,
8226 which is invalid. */
8227 for (stack = cs_base; stack; stack = stack->prev)
8228 if (stack->current->op == EXEC_CRITICAL
8229 && bitmap_bit_p (stack->reachable_labels, label->value))
8230 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8231 " at %L", &code->loc, &label->where);
8236 /* Step four: If we haven't found the label in the bitmap, it may
8237 still be the label of the END of the enclosing block, in which
8238 case we find it by going up the code_stack. */
8240 for (stack = cs_base; stack; stack = stack->prev)
8242 if (stack->current->next && stack->current->next->here == label)
8244 if (stack->current->op == EXEC_CRITICAL)
8246 /* Note: A label at END CRITICAL does not leave the CRITICAL
8247 construct as END CRITICAL is still part of it. */
8248 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8249 " at %L", &code->loc, &label->where);
8256 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8260 /* The label is not in an enclosing block, so illegal. This was
8261 allowed in Fortran 66, so we allow it as extension. No
8262 further checks are necessary in this case. */
8263 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8264 "as the GOTO statement at %L", &label->where,
8270 /* Check whether EXPR1 has the same shape as EXPR2. */
8273 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8275 mpz_t shape[GFC_MAX_DIMENSIONS];
8276 mpz_t shape2[GFC_MAX_DIMENSIONS];
8277 gfc_try result = FAILURE;
8280 /* Compare the rank. */
8281 if (expr1->rank != expr2->rank)
8284 /* Compare the size of each dimension. */
8285 for (i=0; i<expr1->rank; i++)
8287 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8290 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8293 if (mpz_cmp (shape[i], shape2[i]))
8297 /* When either of the two expression is an assumed size array, we
8298 ignore the comparison of dimension sizes. */
8303 for (i--; i >= 0; i--)
8305 mpz_clear (shape[i]);
8306 mpz_clear (shape2[i]);
8312 /* Check whether a WHERE assignment target or a WHERE mask expression
8313 has the same shape as the outmost WHERE mask expression. */
8316 resolve_where (gfc_code *code, gfc_expr *mask)
8322 cblock = code->block;
8324 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8325 In case of nested WHERE, only the outmost one is stored. */
8326 if (mask == NULL) /* outmost WHERE */
8328 else /* inner WHERE */
8335 /* Check if the mask-expr has a consistent shape with the
8336 outmost WHERE mask-expr. */
8337 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8338 gfc_error ("WHERE mask at %L has inconsistent shape",
8339 &cblock->expr1->where);
8342 /* the assignment statement of a WHERE statement, or the first
8343 statement in where-body-construct of a WHERE construct */
8344 cnext = cblock->next;
8349 /* WHERE assignment statement */
8352 /* Check shape consistent for WHERE assignment target. */
8353 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8354 gfc_error ("WHERE assignment target at %L has "
8355 "inconsistent shape", &cnext->expr1->where);
8359 case EXEC_ASSIGN_CALL:
8360 resolve_call (cnext);
8361 if (!cnext->resolved_sym->attr.elemental)
8362 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8363 &cnext->ext.actual->expr->where);
8366 /* WHERE or WHERE construct is part of a where-body-construct */
8368 resolve_where (cnext, e);
8372 gfc_error ("Unsupported statement inside WHERE at %L",
8375 /* the next statement within the same where-body-construct */
8376 cnext = cnext->next;
8378 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8379 cblock = cblock->block;
8384 /* Resolve assignment in FORALL construct.
8385 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8386 FORALL index variables. */
8389 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8393 for (n = 0; n < nvar; n++)
8395 gfc_symbol *forall_index;
8397 forall_index = var_expr[n]->symtree->n.sym;
8399 /* Check whether the assignment target is one of the FORALL index
8401 if ((code->expr1->expr_type == EXPR_VARIABLE)
8402 && (code->expr1->symtree->n.sym == forall_index))
8403 gfc_error ("Assignment to a FORALL index variable at %L",
8404 &code->expr1->where);
8407 /* If one of the FORALL index variables doesn't appear in the
8408 assignment variable, then there could be a many-to-one
8409 assignment. Emit a warning rather than an error because the
8410 mask could be resolving this problem. */
8411 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8412 gfc_warning ("The FORALL with index '%s' is not used on the "
8413 "left side of the assignment at %L and so might "
8414 "cause multiple assignment to this object",
8415 var_expr[n]->symtree->name, &code->expr1->where);
8421 /* Resolve WHERE statement in FORALL construct. */
8424 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8425 gfc_expr **var_expr)
8430 cblock = code->block;
8433 /* the assignment statement of a WHERE statement, or the first
8434 statement in where-body-construct of a WHERE construct */
8435 cnext = cblock->next;
8440 /* WHERE assignment statement */
8442 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8445 /* WHERE operator assignment statement */
8446 case EXEC_ASSIGN_CALL:
8447 resolve_call (cnext);
8448 if (!cnext->resolved_sym->attr.elemental)
8449 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8450 &cnext->ext.actual->expr->where);
8453 /* WHERE or WHERE construct is part of a where-body-construct */
8455 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8459 gfc_error ("Unsupported statement inside WHERE at %L",
8462 /* the next statement within the same where-body-construct */
8463 cnext = cnext->next;
8465 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8466 cblock = cblock->block;
8471 /* Traverse the FORALL body to check whether the following errors exist:
8472 1. For assignment, check if a many-to-one assignment happens.
8473 2. For WHERE statement, check the WHERE body to see if there is any
8474 many-to-one assignment. */
8477 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8481 c = code->block->next;
8487 case EXEC_POINTER_ASSIGN:
8488 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8491 case EXEC_ASSIGN_CALL:
8495 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8496 there is no need to handle it here. */
8500 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8505 /* The next statement in the FORALL body. */
8511 /* Counts the number of iterators needed inside a forall construct, including
8512 nested forall constructs. This is used to allocate the needed memory
8513 in gfc_resolve_forall. */
8516 gfc_count_forall_iterators (gfc_code *code)
8518 int max_iters, sub_iters, current_iters;
8519 gfc_forall_iterator *fa;
8521 gcc_assert(code->op == EXEC_FORALL);
8525 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8528 code = code->block->next;
8532 if (code->op == EXEC_FORALL)
8534 sub_iters = gfc_count_forall_iterators (code);
8535 if (sub_iters > max_iters)
8536 max_iters = sub_iters;
8541 return current_iters + max_iters;
8545 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8546 gfc_resolve_forall_body to resolve the FORALL body. */
8549 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8551 static gfc_expr **var_expr;
8552 static int total_var = 0;
8553 static int nvar = 0;
8555 gfc_forall_iterator *fa;
8560 /* Start to resolve a FORALL construct */
8561 if (forall_save == 0)
8563 /* Count the total number of FORALL index in the nested FORALL
8564 construct in order to allocate the VAR_EXPR with proper size. */
8565 total_var = gfc_count_forall_iterators (code);
8567 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8568 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8571 /* The information about FORALL iterator, including FORALL index start, end
8572 and stride. The FORALL index can not appear in start, end or stride. */
8573 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8575 /* Check if any outer FORALL index name is the same as the current
8577 for (i = 0; i < nvar; i++)
8579 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8581 gfc_error ("An outer FORALL construct already has an index "
8582 "with this name %L", &fa->var->where);
8586 /* Record the current FORALL index. */
8587 var_expr[nvar] = gfc_copy_expr (fa->var);
8591 /* No memory leak. */
8592 gcc_assert (nvar <= total_var);
8595 /* Resolve the FORALL body. */
8596 gfc_resolve_forall_body (code, nvar, var_expr);
8598 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8599 gfc_resolve_blocks (code->block, ns);
8603 /* Free only the VAR_EXPRs allocated in this frame. */
8604 for (i = nvar; i < tmp; i++)
8605 gfc_free_expr (var_expr[i]);
8609 /* We are in the outermost FORALL construct. */
8610 gcc_assert (forall_save == 0);
8612 /* VAR_EXPR is not needed any more. */
8613 gfc_free (var_expr);
8619 /* Resolve a BLOCK construct statement. */
8622 resolve_block_construct (gfc_code* code)
8624 /* Resolve the BLOCK's namespace. */
8625 gfc_resolve (code->ext.block.ns);
8627 /* For an ASSOCIATE block, the associations (and their targets) are already
8628 resolved during resolve_symbol. */
8632 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8635 static void resolve_code (gfc_code *, gfc_namespace *);
8638 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8642 for (; b; b = b->block)
8644 t = gfc_resolve_expr (b->expr1);
8645 if (gfc_resolve_expr (b->expr2) == FAILURE)
8651 if (t == SUCCESS && b->expr1 != NULL
8652 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8653 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8660 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8661 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8666 resolve_branch (b->label1, b);
8670 resolve_block_construct (b);
8674 case EXEC_SELECT_TYPE:
8685 case EXEC_OMP_ATOMIC:
8686 case EXEC_OMP_CRITICAL:
8688 case EXEC_OMP_MASTER:
8689 case EXEC_OMP_ORDERED:
8690 case EXEC_OMP_PARALLEL:
8691 case EXEC_OMP_PARALLEL_DO:
8692 case EXEC_OMP_PARALLEL_SECTIONS:
8693 case EXEC_OMP_PARALLEL_WORKSHARE:
8694 case EXEC_OMP_SECTIONS:
8695 case EXEC_OMP_SINGLE:
8697 case EXEC_OMP_TASKWAIT:
8698 case EXEC_OMP_WORKSHARE:
8702 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8705 resolve_code (b->next, ns);
8710 /* Does everything to resolve an ordinary assignment. Returns true
8711 if this is an interface assignment. */
8713 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8723 if (gfc_extend_assign (code, ns) == SUCCESS)
8727 if (code->op == EXEC_ASSIGN_CALL)
8729 lhs = code->ext.actual->expr;
8730 rhsptr = &code->ext.actual->next->expr;
8734 gfc_actual_arglist* args;
8735 gfc_typebound_proc* tbp;
8737 gcc_assert (code->op == EXEC_COMPCALL);
8739 args = code->expr1->value.compcall.actual;
8741 rhsptr = &args->next->expr;
8743 tbp = code->expr1->value.compcall.tbp;
8744 gcc_assert (!tbp->is_generic);
8747 /* Make a temporary rhs when there is a default initializer
8748 and rhs is the same symbol as the lhs. */
8749 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8750 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8751 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8752 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8753 *rhsptr = gfc_get_parentheses (*rhsptr);
8762 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8763 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8764 &code->loc) == FAILURE)
8767 /* Handle the case of a BOZ literal on the RHS. */
8768 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8771 if (gfc_option.warn_surprising)
8772 gfc_warning ("BOZ literal at %L is bitwise transferred "
8773 "non-integer symbol '%s'", &code->loc,
8774 lhs->symtree->n.sym->name);
8776 if (!gfc_convert_boz (rhs, &lhs->ts))
8778 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8780 if (rc == ARITH_UNDERFLOW)
8781 gfc_error ("Arithmetic underflow 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_OVERFLOW)
8785 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8786 ". This check can be disabled with the option "
8787 "-fno-range-check", &rhs->where);
8788 else if (rc == ARITH_NAN)
8789 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8790 ". This check can be disabled with the option "
8791 "-fno-range-check", &rhs->where);
8796 if (lhs->ts.type == BT_CHARACTER
8797 && gfc_option.warn_character_truncation)
8799 if (lhs->ts.u.cl != NULL
8800 && lhs->ts.u.cl->length != NULL
8801 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8802 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8804 if (rhs->expr_type == EXPR_CONSTANT)
8805 rlen = rhs->value.character.length;
8807 else if (rhs->ts.u.cl != NULL
8808 && rhs->ts.u.cl->length != NULL
8809 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8810 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8812 if (rlen && llen && rlen > llen)
8813 gfc_warning_now ("CHARACTER expression will be truncated "
8814 "in assignment (%d/%d) at %L",
8815 llen, rlen, &code->loc);
8818 /* Ensure that a vector index expression for the lvalue is evaluated
8819 to a temporary if the lvalue symbol is referenced in it. */
8822 for (ref = lhs->ref; ref; ref= ref->next)
8823 if (ref->type == REF_ARRAY)
8825 for (n = 0; n < ref->u.ar.dimen; n++)
8826 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8827 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8828 ref->u.ar.start[n]))
8830 = gfc_get_parentheses (ref->u.ar.start[n]);
8834 if (gfc_pure (NULL))
8836 if (lhs->ts.type == BT_DERIVED
8837 && lhs->expr_type == EXPR_VARIABLE
8838 && lhs->ts.u.derived->attr.pointer_comp
8839 && rhs->expr_type == EXPR_VARIABLE
8840 && (gfc_impure_variable (rhs->symtree->n.sym)
8841 || gfc_is_coindexed (rhs)))
8844 if (gfc_is_coindexed (rhs))
8845 gfc_error ("Coindexed expression at %L is assigned to "
8846 "a derived type variable with a POINTER "
8847 "component in a PURE procedure",
8850 gfc_error ("The impure variable at %L is assigned to "
8851 "a derived type variable with a POINTER "
8852 "component in a PURE procedure (12.6)",
8857 /* Fortran 2008, C1283. */
8858 if (gfc_is_coindexed (lhs))
8860 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8861 "procedure", &rhs->where);
8866 if (gfc_implicit_pure (NULL))
8868 if (lhs->expr_type == EXPR_VARIABLE
8869 && lhs->symtree->n.sym != gfc_current_ns->proc_name
8870 && lhs->symtree->n.sym->ns != gfc_current_ns)
8871 gfc_current_ns->proc_name->attr.implicit_pure = 0;
8873 if (lhs->ts.type == BT_DERIVED
8874 && lhs->expr_type == EXPR_VARIABLE
8875 && lhs->ts.u.derived->attr.pointer_comp
8876 && rhs->expr_type == EXPR_VARIABLE
8877 && (gfc_impure_variable (rhs->symtree->n.sym)
8878 || gfc_is_coindexed (rhs)))
8879 gfc_current_ns->proc_name->attr.implicit_pure = 0;
8881 /* Fortran 2008, C1283. */
8882 if (gfc_is_coindexed (lhs))
8883 gfc_current_ns->proc_name->attr.implicit_pure = 0;
8887 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8888 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8889 if (lhs->ts.type == BT_CLASS)
8891 gfc_error ("Variable must not be polymorphic in assignment at %L",
8896 /* F2008, Section 7.2.1.2. */
8897 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8899 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8900 "component in assignment at %L", &lhs->where);
8904 gfc_check_assign (lhs, rhs, 1);
8909 /* Given a block of code, recursively resolve everything pointed to by this
8913 resolve_code (gfc_code *code, gfc_namespace *ns)
8915 int omp_workshare_save;
8920 frame.prev = cs_base;
8924 find_reachable_labels (code);
8926 for (; code; code = code->next)
8928 frame.current = code;
8929 forall_save = forall_flag;
8931 if (code->op == EXEC_FORALL)
8934 gfc_resolve_forall (code, ns, forall_save);
8937 else if (code->block)
8939 omp_workshare_save = -1;
8942 case EXEC_OMP_PARALLEL_WORKSHARE:
8943 omp_workshare_save = omp_workshare_flag;
8944 omp_workshare_flag = 1;
8945 gfc_resolve_omp_parallel_blocks (code, ns);
8947 case EXEC_OMP_PARALLEL:
8948 case EXEC_OMP_PARALLEL_DO:
8949 case EXEC_OMP_PARALLEL_SECTIONS:
8951 omp_workshare_save = omp_workshare_flag;
8952 omp_workshare_flag = 0;
8953 gfc_resolve_omp_parallel_blocks (code, ns);
8956 gfc_resolve_omp_do_blocks (code, ns);
8958 case EXEC_SELECT_TYPE:
8959 /* Blocks are handled in resolve_select_type because we have
8960 to transform the SELECT TYPE into ASSOCIATE first. */
8962 case EXEC_OMP_WORKSHARE:
8963 omp_workshare_save = omp_workshare_flag;
8964 omp_workshare_flag = 1;
8967 gfc_resolve_blocks (code->block, ns);
8971 if (omp_workshare_save != -1)
8972 omp_workshare_flag = omp_workshare_save;
8976 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8977 t = gfc_resolve_expr (code->expr1);
8978 forall_flag = forall_save;
8980 if (gfc_resolve_expr (code->expr2) == FAILURE)
8983 if (code->op == EXEC_ALLOCATE
8984 && gfc_resolve_expr (code->expr3) == FAILURE)
8990 case EXEC_END_BLOCK:
8994 case EXEC_ERROR_STOP:
8998 case EXEC_ASSIGN_CALL:
9003 case EXEC_SYNC_IMAGES:
9004 case EXEC_SYNC_MEMORY:
9005 resolve_sync (code);
9009 /* Keep track of which entry we are up to. */
9010 current_entry_id = code->ext.entry->id;
9014 resolve_where (code, NULL);
9018 if (code->expr1 != NULL)
9020 if (code->expr1->ts.type != BT_INTEGER)
9021 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9022 "INTEGER variable", &code->expr1->where);
9023 else if (code->expr1->symtree->n.sym->attr.assign != 1)
9024 gfc_error ("Variable '%s' has not been assigned a target "
9025 "label at %L", code->expr1->symtree->n.sym->name,
9026 &code->expr1->where);
9029 resolve_branch (code->label1, code);
9033 if (code->expr1 != NULL
9034 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9035 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9036 "INTEGER return specifier", &code->expr1->where);
9039 case EXEC_INIT_ASSIGN:
9040 case EXEC_END_PROCEDURE:
9047 if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
9051 if (resolve_ordinary_assign (code, ns))
9053 if (code->op == EXEC_COMPCALL)
9060 case EXEC_LABEL_ASSIGN:
9061 if (code->label1->defined == ST_LABEL_UNKNOWN)
9062 gfc_error ("Label %d referenced at %L is never defined",
9063 code->label1->value, &code->label1->where);
9065 && (code->expr1->expr_type != EXPR_VARIABLE
9066 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9067 || code->expr1->symtree->n.sym->ts.kind
9068 != gfc_default_integer_kind
9069 || code->expr1->symtree->n.sym->as != NULL))
9070 gfc_error ("ASSIGN statement at %L requires a scalar "
9071 "default INTEGER variable", &code->expr1->where);
9074 case EXEC_POINTER_ASSIGN:
9081 /* This is both a variable definition and pointer assignment
9082 context, so check both of them. For rank remapping, a final
9083 array ref may be present on the LHS and fool gfc_expr_attr
9084 used in gfc_check_vardef_context. Remove it. */
9085 e = remove_last_array_ref (code->expr1);
9086 t = gfc_check_vardef_context (e, true, _("pointer assignment"));
9088 t = gfc_check_vardef_context (e, false, _("pointer assignment"));
9093 gfc_check_pointer_assign (code->expr1, code->expr2);
9097 case EXEC_ARITHMETIC_IF:
9099 && code->expr1->ts.type != BT_INTEGER
9100 && code->expr1->ts.type != BT_REAL)
9101 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9102 "expression", &code->expr1->where);
9104 resolve_branch (code->label1, code);
9105 resolve_branch (code->label2, code);
9106 resolve_branch (code->label3, code);
9110 if (t == SUCCESS && code->expr1 != NULL
9111 && (code->expr1->ts.type != BT_LOGICAL
9112 || code->expr1->rank != 0))
9113 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9114 &code->expr1->where);
9119 resolve_call (code);
9124 resolve_typebound_subroutine (code);
9128 resolve_ppc_call (code);
9132 /* Select is complicated. Also, a SELECT construct could be
9133 a transformed computed GOTO. */
9134 resolve_select (code);
9137 case EXEC_SELECT_TYPE:
9138 resolve_select_type (code, ns);
9142 resolve_block_construct (code);
9146 if (code->ext.iterator != NULL)
9148 gfc_iterator *iter = code->ext.iterator;
9149 if (gfc_resolve_iterator (iter, true) != FAILURE)
9150 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9155 if (code->expr1 == NULL)
9156 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9158 && (code->expr1->rank != 0
9159 || code->expr1->ts.type != BT_LOGICAL))
9160 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9161 "a scalar LOGICAL expression", &code->expr1->where);
9166 resolve_allocate_deallocate (code, "ALLOCATE");
9170 case EXEC_DEALLOCATE:
9172 resolve_allocate_deallocate (code, "DEALLOCATE");
9177 if (gfc_resolve_open (code->ext.open) == FAILURE)
9180 resolve_branch (code->ext.open->err, code);
9184 if (gfc_resolve_close (code->ext.close) == FAILURE)
9187 resolve_branch (code->ext.close->err, code);
9190 case EXEC_BACKSPACE:
9194 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9197 resolve_branch (code->ext.filepos->err, code);
9201 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9204 resolve_branch (code->ext.inquire->err, code);
9208 gcc_assert (code->ext.inquire != NULL);
9209 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9212 resolve_branch (code->ext.inquire->err, code);
9216 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9219 resolve_branch (code->ext.wait->err, code);
9220 resolve_branch (code->ext.wait->end, code);
9221 resolve_branch (code->ext.wait->eor, code);
9226 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9229 resolve_branch (code->ext.dt->err, code);
9230 resolve_branch (code->ext.dt->end, code);
9231 resolve_branch (code->ext.dt->eor, code);
9235 resolve_transfer (code);
9239 resolve_forall_iterators (code->ext.forall_iterator);
9241 if (code->expr1 != NULL
9242 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9243 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9244 "expression", &code->expr1->where);
9247 case EXEC_OMP_ATOMIC:
9248 case EXEC_OMP_BARRIER:
9249 case EXEC_OMP_CRITICAL:
9250 case EXEC_OMP_FLUSH:
9252 case EXEC_OMP_MASTER:
9253 case EXEC_OMP_ORDERED:
9254 case EXEC_OMP_SECTIONS:
9255 case EXEC_OMP_SINGLE:
9256 case EXEC_OMP_TASKWAIT:
9257 case EXEC_OMP_WORKSHARE:
9258 gfc_resolve_omp_directive (code, ns);
9261 case EXEC_OMP_PARALLEL:
9262 case EXEC_OMP_PARALLEL_DO:
9263 case EXEC_OMP_PARALLEL_SECTIONS:
9264 case EXEC_OMP_PARALLEL_WORKSHARE:
9266 omp_workshare_save = omp_workshare_flag;
9267 omp_workshare_flag = 0;
9268 gfc_resolve_omp_directive (code, ns);
9269 omp_workshare_flag = omp_workshare_save;
9273 gfc_internal_error ("resolve_code(): Bad statement code");
9277 cs_base = frame.prev;
9281 /* Resolve initial values and make sure they are compatible with
9285 resolve_values (gfc_symbol *sym)
9289 if (sym->value == NULL)
9292 if (sym->value->expr_type == EXPR_STRUCTURE)
9293 t= resolve_structure_cons (sym->value, 1);
9295 t = gfc_resolve_expr (sym->value);
9300 gfc_check_assign_symbol (sym, sym->value);
9304 /* Verify the binding labels for common blocks that are BIND(C). The label
9305 for a BIND(C) common block must be identical in all scoping units in which
9306 the common block is declared. Further, the binding label can not collide
9307 with any other global entity in the program. */
9310 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9312 if (comm_block_tree->n.common->is_bind_c == 1)
9314 gfc_gsymbol *binding_label_gsym;
9315 gfc_gsymbol *comm_name_gsym;
9317 /* See if a global symbol exists by the common block's name. It may
9318 be NULL if the common block is use-associated. */
9319 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9320 comm_block_tree->n.common->name);
9321 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9322 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9323 "with the global entity '%s' at %L",
9324 comm_block_tree->n.common->binding_label,
9325 comm_block_tree->n.common->name,
9326 &(comm_block_tree->n.common->where),
9327 comm_name_gsym->name, &(comm_name_gsym->where));
9328 else if (comm_name_gsym != NULL
9329 && strcmp (comm_name_gsym->name,
9330 comm_block_tree->n.common->name) == 0)
9332 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9334 if (comm_name_gsym->binding_label == NULL)
9335 /* No binding label for common block stored yet; save this one. */
9336 comm_name_gsym->binding_label =
9337 comm_block_tree->n.common->binding_label;
9339 if (strcmp (comm_name_gsym->binding_label,
9340 comm_block_tree->n.common->binding_label) != 0)
9342 /* Common block names match but binding labels do not. */
9343 gfc_error ("Binding label '%s' for common block '%s' at %L "
9344 "does not match the binding label '%s' for common "
9346 comm_block_tree->n.common->binding_label,
9347 comm_block_tree->n.common->name,
9348 &(comm_block_tree->n.common->where),
9349 comm_name_gsym->binding_label,
9350 comm_name_gsym->name,
9351 &(comm_name_gsym->where));
9356 /* There is no binding label (NAME="") so we have nothing further to
9357 check and nothing to add as a global symbol for the label. */
9358 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9361 binding_label_gsym =
9362 gfc_find_gsymbol (gfc_gsym_root,
9363 comm_block_tree->n.common->binding_label);
9364 if (binding_label_gsym == NULL)
9366 /* Need to make a global symbol for the binding label to prevent
9367 it from colliding with another. */
9368 binding_label_gsym =
9369 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9370 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9371 binding_label_gsym->type = GSYM_COMMON;
9375 /* If comm_name_gsym is NULL, the name common block is use
9376 associated and the name could be colliding. */
9377 if (binding_label_gsym->type != GSYM_COMMON)
9378 gfc_error ("Binding label '%s' for common block '%s' at %L "
9379 "collides with the global entity '%s' at %L",
9380 comm_block_tree->n.common->binding_label,
9381 comm_block_tree->n.common->name,
9382 &(comm_block_tree->n.common->where),
9383 binding_label_gsym->name,
9384 &(binding_label_gsym->where));
9385 else if (comm_name_gsym != NULL
9386 && (strcmp (binding_label_gsym->name,
9387 comm_name_gsym->binding_label) != 0)
9388 && (strcmp (binding_label_gsym->sym_name,
9389 comm_name_gsym->name) != 0))
9390 gfc_error ("Binding label '%s' for common block '%s' at %L "
9391 "collides with global entity '%s' at %L",
9392 binding_label_gsym->name, binding_label_gsym->sym_name,
9393 &(comm_block_tree->n.common->where),
9394 comm_name_gsym->name, &(comm_name_gsym->where));
9402 /* Verify any BIND(C) derived types in the namespace so we can report errors
9403 for them once, rather than for each variable declared of that type. */
9406 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9408 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9409 && derived_sym->attr.is_bind_c == 1)
9410 verify_bind_c_derived_type (derived_sym);
9416 /* Verify that any binding labels used in a given namespace do not collide
9417 with the names or binding labels of any global symbols. */
9420 gfc_verify_binding_labels (gfc_symbol *sym)
9424 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9425 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9427 gfc_gsymbol *bind_c_sym;
9429 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9430 if (bind_c_sym != NULL
9431 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9433 if (sym->attr.if_source == IFSRC_DECL
9434 && (bind_c_sym->type != GSYM_SUBROUTINE
9435 && bind_c_sym->type != GSYM_FUNCTION)
9436 && ((sym->attr.contained == 1
9437 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9438 || (sym->attr.use_assoc == 1
9439 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9441 /* Make sure global procedures don't collide with anything. */
9442 gfc_error ("Binding label '%s' at %L collides with the global "
9443 "entity '%s' at %L", sym->binding_label,
9444 &(sym->declared_at), bind_c_sym->name,
9445 &(bind_c_sym->where));
9448 else if (sym->attr.contained == 0
9449 && (sym->attr.if_source == IFSRC_IFBODY
9450 && sym->attr.flavor == FL_PROCEDURE)
9451 && (bind_c_sym->sym_name != NULL
9452 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9454 /* Make sure procedures in interface bodies don't collide. */
9455 gfc_error ("Binding label '%s' in interface body at %L collides "
9456 "with the global entity '%s' at %L",
9458 &(sym->declared_at), bind_c_sym->name,
9459 &(bind_c_sym->where));
9462 else if (sym->attr.contained == 0
9463 && sym->attr.if_source == IFSRC_UNKNOWN)
9464 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9465 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9466 || sym->attr.use_assoc == 0)
9468 gfc_error ("Binding label '%s' at %L collides with global "
9469 "entity '%s' at %L", sym->binding_label,
9470 &(sym->declared_at), bind_c_sym->name,
9471 &(bind_c_sym->where));
9476 /* Clear the binding label to prevent checking multiple times. */
9477 sym->binding_label[0] = '\0';
9479 else if (bind_c_sym == NULL)
9481 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9482 bind_c_sym->where = sym->declared_at;
9483 bind_c_sym->sym_name = sym->name;
9485 if (sym->attr.use_assoc == 1)
9486 bind_c_sym->mod_name = sym->module;
9488 if (sym->ns->proc_name != NULL)
9489 bind_c_sym->mod_name = sym->ns->proc_name->name;
9491 if (sym->attr.contained == 0)
9493 if (sym->attr.subroutine)
9494 bind_c_sym->type = GSYM_SUBROUTINE;
9495 else if (sym->attr.function)
9496 bind_c_sym->type = GSYM_FUNCTION;
9504 /* Resolve an index expression. */
9507 resolve_index_expr (gfc_expr *e)
9509 if (gfc_resolve_expr (e) == FAILURE)
9512 if (gfc_simplify_expr (e, 0) == FAILURE)
9515 if (gfc_specification_expr (e) == FAILURE)
9522 /* Resolve a charlen structure. */
9525 resolve_charlen (gfc_charlen *cl)
9534 specification_expr = 1;
9536 if (resolve_index_expr (cl->length) == FAILURE)
9538 specification_expr = 0;
9542 /* "If the character length parameter value evaluates to a negative
9543 value, the length of character entities declared is zero." */
9544 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9546 if (gfc_option.warn_surprising)
9547 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9548 " the length has been set to zero",
9549 &cl->length->where, i);
9550 gfc_replace_expr (cl->length,
9551 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9554 /* Check that the character length is not too large. */
9555 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9556 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9557 && cl->length->ts.type == BT_INTEGER
9558 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9560 gfc_error ("String length at %L is too large", &cl->length->where);
9568 /* Test for non-constant shape arrays. */
9571 is_non_constant_shape_array (gfc_symbol *sym)
9577 not_constant = false;
9578 if (sym->as != NULL)
9580 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9581 has not been simplified; parameter array references. Do the
9582 simplification now. */
9583 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9585 e = sym->as->lower[i];
9586 if (e && (resolve_index_expr (e) == FAILURE
9587 || !gfc_is_constant_expr (e)))
9588 not_constant = true;
9589 e = sym->as->upper[i];
9590 if (e && (resolve_index_expr (e) == FAILURE
9591 || !gfc_is_constant_expr (e)))
9592 not_constant = true;
9595 return not_constant;
9598 /* Given a symbol and an initialization expression, add code to initialize
9599 the symbol to the function entry. */
9601 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9605 gfc_namespace *ns = sym->ns;
9607 /* Search for the function namespace if this is a contained
9608 function without an explicit result. */
9609 if (sym->attr.function && sym == sym->result
9610 && sym->name != sym->ns->proc_name->name)
9613 for (;ns; ns = ns->sibling)
9614 if (strcmp (ns->proc_name->name, sym->name) == 0)
9620 gfc_free_expr (init);
9624 /* Build an l-value expression for the result. */
9625 lval = gfc_lval_expr_from_sym (sym);
9627 /* Add the code at scope entry. */
9628 init_st = gfc_get_code ();
9629 init_st->next = ns->code;
9632 /* Assign the default initializer to the l-value. */
9633 init_st->loc = sym->declared_at;
9634 init_st->op = EXEC_INIT_ASSIGN;
9635 init_st->expr1 = lval;
9636 init_st->expr2 = init;
9639 /* Assign the default initializer to a derived type variable or result. */
9642 apply_default_init (gfc_symbol *sym)
9644 gfc_expr *init = NULL;
9646 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9649 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9650 init = gfc_default_initializer (&sym->ts);
9652 if (init == NULL && sym->ts.type != BT_CLASS)
9655 build_init_assign (sym, init);
9656 sym->attr.referenced = 1;
9659 /* Build an initializer for a local integer, real, complex, logical, or
9660 character variable, based on the command line flags finit-local-zero,
9661 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9662 null if the symbol should not have a default initialization. */
9664 build_default_init_expr (gfc_symbol *sym)
9667 gfc_expr *init_expr;
9670 /* These symbols should never have a default initialization. */
9671 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9672 || sym->attr.external
9674 || sym->attr.pointer
9675 || sym->attr.in_equivalence
9676 || sym->attr.in_common
9679 || sym->attr.cray_pointee
9680 || sym->attr.cray_pointer)
9683 /* Now we'll try to build an initializer expression. */
9684 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9687 /* We will only initialize integers, reals, complex, logicals, and
9688 characters, and only if the corresponding command-line flags
9689 were set. Otherwise, we free init_expr and return null. */
9690 switch (sym->ts.type)
9693 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9694 mpz_set_si (init_expr->value.integer,
9695 gfc_option.flag_init_integer_value);
9698 gfc_free_expr (init_expr);
9704 switch (gfc_option.flag_init_real)
9706 case GFC_INIT_REAL_SNAN:
9707 init_expr->is_snan = 1;
9709 case GFC_INIT_REAL_NAN:
9710 mpfr_set_nan (init_expr->value.real);
9713 case GFC_INIT_REAL_INF:
9714 mpfr_set_inf (init_expr->value.real, 1);
9717 case GFC_INIT_REAL_NEG_INF:
9718 mpfr_set_inf (init_expr->value.real, -1);
9721 case GFC_INIT_REAL_ZERO:
9722 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9726 gfc_free_expr (init_expr);
9733 switch (gfc_option.flag_init_real)
9735 case GFC_INIT_REAL_SNAN:
9736 init_expr->is_snan = 1;
9738 case GFC_INIT_REAL_NAN:
9739 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9740 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9743 case GFC_INIT_REAL_INF:
9744 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9745 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9748 case GFC_INIT_REAL_NEG_INF:
9749 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9750 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9753 case GFC_INIT_REAL_ZERO:
9754 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9758 gfc_free_expr (init_expr);
9765 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9766 init_expr->value.logical = 0;
9767 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9768 init_expr->value.logical = 1;
9771 gfc_free_expr (init_expr);
9777 /* For characters, the length must be constant in order to
9778 create a default initializer. */
9779 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9780 && sym->ts.u.cl->length
9781 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9783 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9784 init_expr->value.character.length = char_len;
9785 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9786 for (i = 0; i < char_len; i++)
9787 init_expr->value.character.string[i]
9788 = (unsigned char) gfc_option.flag_init_character_value;
9792 gfc_free_expr (init_expr);
9798 gfc_free_expr (init_expr);
9804 /* Add an initialization expression to a local variable. */
9806 apply_default_init_local (gfc_symbol *sym)
9808 gfc_expr *init = NULL;
9810 /* The symbol should be a variable or a function return value. */
9811 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9812 || (sym->attr.function && sym->result != sym))
9815 /* Try to build the initializer expression. If we can't initialize
9816 this symbol, then init will be NULL. */
9817 init = build_default_init_expr (sym);
9821 /* For saved variables, we don't want to add an initializer at
9822 function entry, so we just add a static initializer. */
9823 if (sym->attr.save || sym->ns->save_all
9824 || gfc_option.flag_max_stack_var_size == 0)
9826 /* Don't clobber an existing initializer! */
9827 gcc_assert (sym->value == NULL);
9832 build_init_assign (sym, init);
9836 /* Resolution of common features of flavors variable and procedure. */
9839 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9841 /* Constraints on deferred shape variable. */
9842 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9844 if (sym->attr.allocatable)
9846 if (sym->attr.dimension)
9848 gfc_error ("Allocatable array '%s' at %L must have "
9849 "a deferred shape", sym->name, &sym->declared_at);
9852 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9853 "may not be ALLOCATABLE", sym->name,
9854 &sym->declared_at) == FAILURE)
9858 if (sym->attr.pointer && sym->attr.dimension)
9860 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9861 sym->name, &sym->declared_at);
9867 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9868 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9870 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9871 sym->name, &sym->declared_at);
9876 /* Constraints on polymorphic variables. */
9877 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9880 if (sym->attr.class_ok
9881 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9883 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9884 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9890 /* Assume that use associated symbols were checked in the module ns.
9891 Class-variables that are associate-names are also something special
9892 and excepted from the test. */
9893 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9895 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9896 "or pointer", sym->name, &sym->declared_at);
9905 /* Additional checks for symbols with flavor variable and derived
9906 type. To be called from resolve_fl_variable. */
9909 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9911 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9913 /* Check to see if a derived type is blocked from being host
9914 associated by the presence of another class I symbol in the same
9915 namespace. 14.6.1.3 of the standard and the discussion on
9916 comp.lang.fortran. */
9917 if (sym->ns != sym->ts.u.derived->ns
9918 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9921 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9922 if (s && s->attr.flavor != FL_DERIVED)
9924 gfc_error ("The type '%s' cannot be host associated at %L "
9925 "because it is blocked by an incompatible object "
9926 "of the same name declared at %L",
9927 sym->ts.u.derived->name, &sym->declared_at,
9933 /* 4th constraint in section 11.3: "If an object of a type for which
9934 component-initialization is specified (R429) appears in the
9935 specification-part of a module and does not have the ALLOCATABLE
9936 or POINTER attribute, the object shall have the SAVE attribute."
9938 The check for initializers is performed with
9939 gfc_has_default_initializer because gfc_default_initializer generates
9940 a hidden default for allocatable components. */
9941 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9942 && sym->ns->proc_name->attr.flavor == FL_MODULE
9943 && !sym->ns->save_all && !sym->attr.save
9944 && !sym->attr.pointer && !sym->attr.allocatable
9945 && gfc_has_default_initializer (sym->ts.u.derived)
9946 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9947 "module variable '%s' at %L, needed due to "
9948 "the default initialization", sym->name,
9949 &sym->declared_at) == FAILURE)
9952 /* Assign default initializer. */
9953 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9954 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9956 sym->value = gfc_default_initializer (&sym->ts);
9963 /* Resolve symbols with flavor variable. */
9966 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9968 int no_init_flag, automatic_flag;
9970 const char *auto_save_msg;
9972 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9975 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9978 /* Set this flag to check that variables are parameters of all entries.
9979 This check is effected by the call to gfc_resolve_expr through
9980 is_non_constant_shape_array. */
9981 specification_expr = 1;
9983 if (sym->ns->proc_name
9984 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9985 || sym->ns->proc_name->attr.is_main_program)
9986 && !sym->attr.use_assoc
9987 && !sym->attr.allocatable
9988 && !sym->attr.pointer
9989 && is_non_constant_shape_array (sym))
9991 /* The shape of a main program or module array needs to be
9993 gfc_error ("The module or main program array '%s' at %L must "
9994 "have constant shape", sym->name, &sym->declared_at);
9995 specification_expr = 0;
9999 /* Constraints on deferred type parameter. */
10000 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10002 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10003 "requires either the pointer or allocatable attribute",
10004 sym->name, &sym->declared_at);
10008 if (sym->ts.type == BT_CHARACTER)
10010 /* Make sure that character string variables with assumed length are
10011 dummy arguments. */
10012 e = sym->ts.u.cl->length;
10013 if (e == NULL && !sym->attr.dummy && !sym->attr.result
10014 && !sym->ts.deferred)
10016 gfc_error ("Entity with assumed character length at %L must be a "
10017 "dummy argument or a PARAMETER", &sym->declared_at);
10021 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10023 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10027 if (!gfc_is_constant_expr (e)
10028 && !(e->expr_type == EXPR_VARIABLE
10029 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
10030 && sym->ns->proc_name
10031 && (sym->ns->proc_name->attr.flavor == FL_MODULE
10032 || sym->ns->proc_name->attr.is_main_program)
10033 && !sym->attr.use_assoc)
10035 gfc_error ("'%s' at %L must have constant character length "
10036 "in this context", sym->name, &sym->declared_at);
10041 if (sym->value == NULL && sym->attr.referenced)
10042 apply_default_init_local (sym); /* Try to apply a default initialization. */
10044 /* Determine if the symbol may not have an initializer. */
10045 no_init_flag = automatic_flag = 0;
10046 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10047 || sym->attr.intrinsic || sym->attr.result)
10049 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10050 && is_non_constant_shape_array (sym))
10052 no_init_flag = automatic_flag = 1;
10054 /* Also, they must not have the SAVE attribute.
10055 SAVE_IMPLICIT is checked below. */
10056 if (sym->attr.save == SAVE_EXPLICIT)
10058 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10063 /* Ensure that any initializer is simplified. */
10065 gfc_simplify_expr (sym->value, 1);
10067 /* Reject illegal initializers. */
10068 if (!sym->mark && sym->value)
10070 if (sym->attr.allocatable)
10071 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10072 sym->name, &sym->declared_at);
10073 else if (sym->attr.external)
10074 gfc_error ("External '%s' at %L cannot have an initializer",
10075 sym->name, &sym->declared_at);
10076 else if (sym->attr.dummy
10077 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10078 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10079 sym->name, &sym->declared_at);
10080 else if (sym->attr.intrinsic)
10081 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10082 sym->name, &sym->declared_at);
10083 else if (sym->attr.result)
10084 gfc_error ("Function result '%s' at %L cannot have an initializer",
10085 sym->name, &sym->declared_at);
10086 else if (automatic_flag)
10087 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10088 sym->name, &sym->declared_at);
10090 goto no_init_error;
10095 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10096 return resolve_fl_variable_derived (sym, no_init_flag);
10102 /* Resolve a procedure. */
10105 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10107 gfc_formal_arglist *arg;
10109 if (sym->attr.function
10110 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10113 if (sym->ts.type == BT_CHARACTER)
10115 gfc_charlen *cl = sym->ts.u.cl;
10117 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10118 && resolve_charlen (cl) == FAILURE)
10121 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10122 && sym->attr.proc == PROC_ST_FUNCTION)
10124 gfc_error ("Character-valued statement function '%s' at %L must "
10125 "have constant length", sym->name, &sym->declared_at);
10130 /* Ensure that derived type for are not of a private type. Internal
10131 module procedures are excluded by 2.2.3.3 - i.e., they are not
10132 externally accessible and can access all the objects accessible in
10134 if (!(sym->ns->parent
10135 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10136 && gfc_check_access(sym->attr.access, sym->ns->default_access))
10138 gfc_interface *iface;
10140 for (arg = sym->formal; arg; arg = arg->next)
10143 && arg->sym->ts.type == BT_DERIVED
10144 && !arg->sym->ts.u.derived->attr.use_assoc
10145 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10146 arg->sym->ts.u.derived->ns->default_access)
10147 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10148 "PRIVATE type and cannot be a dummy argument"
10149 " of '%s', which is PUBLIC at %L",
10150 arg->sym->name, sym->name, &sym->declared_at)
10153 /* Stop this message from recurring. */
10154 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10159 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10160 PRIVATE to the containing module. */
10161 for (iface = sym->generic; iface; iface = iface->next)
10163 for (arg = iface->sym->formal; arg; arg = arg->next)
10166 && arg->sym->ts.type == BT_DERIVED
10167 && !arg->sym->ts.u.derived->attr.use_assoc
10168 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10169 arg->sym->ts.u.derived->ns->default_access)
10170 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10171 "'%s' in PUBLIC interface '%s' at %L "
10172 "takes dummy arguments of '%s' which is "
10173 "PRIVATE", iface->sym->name, sym->name,
10174 &iface->sym->declared_at,
10175 gfc_typename (&arg->sym->ts)) == FAILURE)
10177 /* Stop this message from recurring. */
10178 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10184 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10185 PRIVATE to the containing module. */
10186 for (iface = sym->generic; iface; iface = iface->next)
10188 for (arg = iface->sym->formal; arg; arg = arg->next)
10191 && arg->sym->ts.type == BT_DERIVED
10192 && !arg->sym->ts.u.derived->attr.use_assoc
10193 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10194 arg->sym->ts.u.derived->ns->default_access)
10195 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10196 "'%s' in PUBLIC interface '%s' at %L "
10197 "takes dummy arguments of '%s' which is "
10198 "PRIVATE", iface->sym->name, sym->name,
10199 &iface->sym->declared_at,
10200 gfc_typename (&arg->sym->ts)) == FAILURE)
10202 /* Stop this message from recurring. */
10203 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10210 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10211 && !sym->attr.proc_pointer)
10213 gfc_error ("Function '%s' at %L cannot have an initializer",
10214 sym->name, &sym->declared_at);
10218 /* An external symbol may not have an initializer because it is taken to be
10219 a procedure. Exception: Procedure Pointers. */
10220 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10222 gfc_error ("External object '%s' at %L may not have an initializer",
10223 sym->name, &sym->declared_at);
10227 /* An elemental function is required to return a scalar 12.7.1 */
10228 if (sym->attr.elemental && sym->attr.function && sym->as)
10230 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10231 "result", sym->name, &sym->declared_at);
10232 /* Reset so that the error only occurs once. */
10233 sym->attr.elemental = 0;
10237 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10238 char-len-param shall not be array-valued, pointer-valued, recursive
10239 or pure. ....snip... A character value of * may only be used in the
10240 following ways: (i) Dummy arg of procedure - dummy associates with
10241 actual length; (ii) To declare a named constant; or (iii) External
10242 function - but length must be declared in calling scoping unit. */
10243 if (sym->attr.function
10244 && sym->ts.type == BT_CHARACTER
10245 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10247 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10248 || (sym->attr.recursive) || (sym->attr.pure))
10250 if (sym->as && sym->as->rank)
10251 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10252 "array-valued", sym->name, &sym->declared_at);
10254 if (sym->attr.pointer)
10255 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10256 "pointer-valued", sym->name, &sym->declared_at);
10258 if (sym->attr.pure)
10259 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10260 "pure", sym->name, &sym->declared_at);
10262 if (sym->attr.recursive)
10263 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10264 "recursive", sym->name, &sym->declared_at);
10269 /* Appendix B.2 of the standard. Contained functions give an
10270 error anyway. Fixed-form is likely to be F77/legacy. */
10271 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10272 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10273 "CHARACTER(*) function '%s' at %L",
10274 sym->name, &sym->declared_at);
10277 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10279 gfc_formal_arglist *curr_arg;
10280 int has_non_interop_arg = 0;
10282 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10283 sym->common_block) == FAILURE)
10285 /* Clear these to prevent looking at them again if there was an
10287 sym->attr.is_bind_c = 0;
10288 sym->attr.is_c_interop = 0;
10289 sym->ts.is_c_interop = 0;
10293 /* So far, no errors have been found. */
10294 sym->attr.is_c_interop = 1;
10295 sym->ts.is_c_interop = 1;
10298 curr_arg = sym->formal;
10299 while (curr_arg != NULL)
10301 /* Skip implicitly typed dummy args here. */
10302 if (curr_arg->sym->attr.implicit_type == 0)
10303 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10304 /* If something is found to fail, record the fact so we
10305 can mark the symbol for the procedure as not being
10306 BIND(C) to try and prevent multiple errors being
10308 has_non_interop_arg = 1;
10310 curr_arg = curr_arg->next;
10313 /* See if any of the arguments were not interoperable and if so, clear
10314 the procedure symbol to prevent duplicate error messages. */
10315 if (has_non_interop_arg != 0)
10317 sym->attr.is_c_interop = 0;
10318 sym->ts.is_c_interop = 0;
10319 sym->attr.is_bind_c = 0;
10323 if (!sym->attr.proc_pointer)
10325 if (sym->attr.save == SAVE_EXPLICIT)
10327 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10328 "in '%s' at %L", sym->name, &sym->declared_at);
10331 if (sym->attr.intent)
10333 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10334 "in '%s' at %L", sym->name, &sym->declared_at);
10337 if (sym->attr.subroutine && sym->attr.result)
10339 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10340 "in '%s' at %L", sym->name, &sym->declared_at);
10343 if (sym->attr.external && sym->attr.function
10344 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10345 || sym->attr.contained))
10347 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10348 "in '%s' at %L", sym->name, &sym->declared_at);
10351 if (strcmp ("ppr@", sym->name) == 0)
10353 gfc_error ("Procedure pointer result '%s' at %L "
10354 "is missing the pointer attribute",
10355 sym->ns->proc_name->name, &sym->declared_at);
10364 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10365 been defined and we now know their defined arguments, check that they fulfill
10366 the requirements of the standard for procedures used as finalizers. */
10369 gfc_resolve_finalizers (gfc_symbol* derived)
10371 gfc_finalizer* list;
10372 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10373 gfc_try result = SUCCESS;
10374 bool seen_scalar = false;
10376 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10379 /* Walk over the list of finalizer-procedures, check them, and if any one
10380 does not fit in with the standard's definition, print an error and remove
10381 it from the list. */
10382 prev_link = &derived->f2k_derived->finalizers;
10383 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10389 /* Skip this finalizer if we already resolved it. */
10390 if (list->proc_tree)
10392 prev_link = &(list->next);
10396 /* Check this exists and is a SUBROUTINE. */
10397 if (!list->proc_sym->attr.subroutine)
10399 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10400 list->proc_sym->name, &list->where);
10404 /* We should have exactly one argument. */
10405 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10407 gfc_error ("FINAL procedure at %L must have exactly one argument",
10411 arg = list->proc_sym->formal->sym;
10413 /* This argument must be of our type. */
10414 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10416 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10417 &arg->declared_at, derived->name);
10421 /* It must neither be a pointer nor allocatable nor optional. */
10422 if (arg->attr.pointer)
10424 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10425 &arg->declared_at);
10428 if (arg->attr.allocatable)
10430 gfc_error ("Argument of FINAL procedure at %L must not be"
10431 " ALLOCATABLE", &arg->declared_at);
10434 if (arg->attr.optional)
10436 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10437 &arg->declared_at);
10441 /* It must not be INTENT(OUT). */
10442 if (arg->attr.intent == INTENT_OUT)
10444 gfc_error ("Argument of FINAL procedure at %L must not be"
10445 " INTENT(OUT)", &arg->declared_at);
10449 /* Warn if the procedure is non-scalar and not assumed shape. */
10450 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10451 && arg->as->type != AS_ASSUMED_SHAPE)
10452 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10453 " shape argument", &arg->declared_at);
10455 /* Check that it does not match in kind and rank with a FINAL procedure
10456 defined earlier. To really loop over the *earlier* declarations,
10457 we need to walk the tail of the list as new ones were pushed at the
10459 /* TODO: Handle kind parameters once they are implemented. */
10460 my_rank = (arg->as ? arg->as->rank : 0);
10461 for (i = list->next; i; i = i->next)
10463 /* Argument list might be empty; that is an error signalled earlier,
10464 but we nevertheless continued resolving. */
10465 if (i->proc_sym->formal)
10467 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10468 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10469 if (i_rank == my_rank)
10471 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10472 " rank (%d) as '%s'",
10473 list->proc_sym->name, &list->where, my_rank,
10474 i->proc_sym->name);
10480 /* Is this the/a scalar finalizer procedure? */
10481 if (!arg->as || arg->as->rank == 0)
10482 seen_scalar = true;
10484 /* Find the symtree for this procedure. */
10485 gcc_assert (!list->proc_tree);
10486 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10488 prev_link = &list->next;
10491 /* Remove wrong nodes immediately from the list so we don't risk any
10492 troubles in the future when they might fail later expectations. */
10496 *prev_link = list->next;
10497 gfc_free_finalizer (i);
10500 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10501 were nodes in the list, must have been for arrays. It is surely a good
10502 idea to have a scalar version there if there's something to finalize. */
10503 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10504 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10505 " defined at %L, suggest also scalar one",
10506 derived->name, &derived->declared_at);
10508 /* TODO: Remove this error when finalization is finished. */
10509 gfc_error ("Finalization at %L is not yet implemented",
10510 &derived->declared_at);
10516 /* Check that it is ok for the typebound procedure proc to override the
10520 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10523 const gfc_symbol* proc_target;
10524 const gfc_symbol* old_target;
10525 unsigned proc_pass_arg, old_pass_arg, argpos;
10526 gfc_formal_arglist* proc_formal;
10527 gfc_formal_arglist* old_formal;
10529 /* This procedure should only be called for non-GENERIC proc. */
10530 gcc_assert (!proc->n.tb->is_generic);
10532 /* If the overwritten procedure is GENERIC, this is an error. */
10533 if (old->n.tb->is_generic)
10535 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10536 old->name, &proc->n.tb->where);
10540 where = proc->n.tb->where;
10541 proc_target = proc->n.tb->u.specific->n.sym;
10542 old_target = old->n.tb->u.specific->n.sym;
10544 /* Check that overridden binding is not NON_OVERRIDABLE. */
10545 if (old->n.tb->non_overridable)
10547 gfc_error ("'%s' at %L overrides a procedure binding declared"
10548 " NON_OVERRIDABLE", proc->name, &where);
10552 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10553 if (!old->n.tb->deferred && proc->n.tb->deferred)
10555 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10556 " non-DEFERRED binding", proc->name, &where);
10560 /* If the overridden binding is PURE, the overriding must be, too. */
10561 if (old_target->attr.pure && !proc_target->attr.pure)
10563 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10564 proc->name, &where);
10568 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10569 is not, the overriding must not be either. */
10570 if (old_target->attr.elemental && !proc_target->attr.elemental)
10572 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10573 " ELEMENTAL", proc->name, &where);
10576 if (!old_target->attr.elemental && proc_target->attr.elemental)
10578 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10579 " be ELEMENTAL, either", proc->name, &where);
10583 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10585 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10587 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10588 " SUBROUTINE", proc->name, &where);
10592 /* If the overridden binding is a FUNCTION, the overriding must also be a
10593 FUNCTION and have the same characteristics. */
10594 if (old_target->attr.function)
10596 if (!proc_target->attr.function)
10598 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10599 " FUNCTION", proc->name, &where);
10603 /* FIXME: Do more comprehensive checking (including, for instance, the
10604 rank and array-shape). */
10605 gcc_assert (proc_target->result && old_target->result);
10606 if (!gfc_compare_types (&proc_target->result->ts,
10607 &old_target->result->ts))
10609 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10610 " matching result types", proc->name, &where);
10615 /* If the overridden binding is PUBLIC, the overriding one must not be
10617 if (old->n.tb->access == ACCESS_PUBLIC
10618 && proc->n.tb->access == ACCESS_PRIVATE)
10620 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10621 " PRIVATE", proc->name, &where);
10625 /* Compare the formal argument lists of both procedures. This is also abused
10626 to find the position of the passed-object dummy arguments of both
10627 bindings as at least the overridden one might not yet be resolved and we
10628 need those positions in the check below. */
10629 proc_pass_arg = old_pass_arg = 0;
10630 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10632 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10635 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10636 proc_formal && old_formal;
10637 proc_formal = proc_formal->next, old_formal = old_formal->next)
10639 if (proc->n.tb->pass_arg
10640 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10641 proc_pass_arg = argpos;
10642 if (old->n.tb->pass_arg
10643 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10644 old_pass_arg = argpos;
10646 /* Check that the names correspond. */
10647 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10649 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10650 " to match the corresponding argument of the overridden"
10651 " procedure", proc_formal->sym->name, proc->name, &where,
10652 old_formal->sym->name);
10656 /* Check that the types correspond if neither is the passed-object
10658 /* FIXME: Do more comprehensive testing here. */
10659 if (proc_pass_arg != argpos && old_pass_arg != argpos
10660 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10662 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10663 "in respect to the overridden procedure",
10664 proc_formal->sym->name, proc->name, &where);
10670 if (proc_formal || old_formal)
10672 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10673 " the overridden procedure", proc->name, &where);
10677 /* If the overridden binding is NOPASS, the overriding one must also be
10679 if (old->n.tb->nopass && !proc->n.tb->nopass)
10681 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10682 " NOPASS", proc->name, &where);
10686 /* If the overridden binding is PASS(x), the overriding one must also be
10687 PASS and the passed-object dummy arguments must correspond. */
10688 if (!old->n.tb->nopass)
10690 if (proc->n.tb->nopass)
10692 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10693 " PASS", proc->name, &where);
10697 if (proc_pass_arg != old_pass_arg)
10699 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10700 " the same position as the passed-object dummy argument of"
10701 " the overridden procedure", proc->name, &where);
10710 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10713 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10714 const char* generic_name, locus where)
10719 gcc_assert (t1->specific && t2->specific);
10720 gcc_assert (!t1->specific->is_generic);
10721 gcc_assert (!t2->specific->is_generic);
10723 sym1 = t1->specific->u.specific->n.sym;
10724 sym2 = t2->specific->u.specific->n.sym;
10729 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10730 if (sym1->attr.subroutine != sym2->attr.subroutine
10731 || sym1->attr.function != sym2->attr.function)
10733 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10734 " GENERIC '%s' at %L",
10735 sym1->name, sym2->name, generic_name, &where);
10739 /* Compare the interfaces. */
10740 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10742 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10743 sym1->name, sym2->name, generic_name, &where);
10751 /* Worker function for resolving a generic procedure binding; this is used to
10752 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10754 The difference between those cases is finding possible inherited bindings
10755 that are overridden, as one has to look for them in tb_sym_root,
10756 tb_uop_root or tb_op, respectively. Thus the caller must already find
10757 the super-type and set p->overridden correctly. */
10760 resolve_tb_generic_targets (gfc_symbol* super_type,
10761 gfc_typebound_proc* p, const char* name)
10763 gfc_tbp_generic* target;
10764 gfc_symtree* first_target;
10765 gfc_symtree* inherited;
10767 gcc_assert (p && p->is_generic);
10769 /* Try to find the specific bindings for the symtrees in our target-list. */
10770 gcc_assert (p->u.generic);
10771 for (target = p->u.generic; target; target = target->next)
10772 if (!target->specific)
10774 gfc_typebound_proc* overridden_tbp;
10775 gfc_tbp_generic* g;
10776 const char* target_name;
10778 target_name = target->specific_st->name;
10780 /* Defined for this type directly. */
10781 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10783 target->specific = target->specific_st->n.tb;
10784 goto specific_found;
10787 /* Look for an inherited specific binding. */
10790 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10795 gcc_assert (inherited->n.tb);
10796 target->specific = inherited->n.tb;
10797 goto specific_found;
10801 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10802 " at %L", target_name, name, &p->where);
10805 /* Once we've found the specific binding, check it is not ambiguous with
10806 other specifics already found or inherited for the same GENERIC. */
10808 gcc_assert (target->specific);
10810 /* This must really be a specific binding! */
10811 if (target->specific->is_generic)
10813 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10814 " '%s' is GENERIC, too", name, &p->where, target_name);
10818 /* Check those already resolved on this type directly. */
10819 for (g = p->u.generic; g; g = g->next)
10820 if (g != target && g->specific
10821 && check_generic_tbp_ambiguity (target, g, name, p->where)
10825 /* Check for ambiguity with inherited specific targets. */
10826 for (overridden_tbp = p->overridden; overridden_tbp;
10827 overridden_tbp = overridden_tbp->overridden)
10828 if (overridden_tbp->is_generic)
10830 for (g = overridden_tbp->u.generic; g; g = g->next)
10832 gcc_assert (g->specific);
10833 if (check_generic_tbp_ambiguity (target, g,
10834 name, p->where) == FAILURE)
10840 /* If we attempt to "overwrite" a specific binding, this is an error. */
10841 if (p->overridden && !p->overridden->is_generic)
10843 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10844 " the same name", name, &p->where);
10848 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10849 all must have the same attributes here. */
10850 first_target = p->u.generic->specific->u.specific;
10851 gcc_assert (first_target);
10852 p->subroutine = first_target->n.sym->attr.subroutine;
10853 p->function = first_target->n.sym->attr.function;
10859 /* Resolve a GENERIC procedure binding for a derived type. */
10862 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10864 gfc_symbol* super_type;
10866 /* Find the overridden binding if any. */
10867 st->n.tb->overridden = NULL;
10868 super_type = gfc_get_derived_super_type (derived);
10871 gfc_symtree* overridden;
10872 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10875 if (overridden && overridden->n.tb)
10876 st->n.tb->overridden = overridden->n.tb;
10879 /* Resolve using worker function. */
10880 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10884 /* Retrieve the target-procedure of an operator binding and do some checks in
10885 common for intrinsic and user-defined type-bound operators. */
10888 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10890 gfc_symbol* target_proc;
10892 gcc_assert (target->specific && !target->specific->is_generic);
10893 target_proc = target->specific->u.specific->n.sym;
10894 gcc_assert (target_proc);
10896 /* All operator bindings must have a passed-object dummy argument. */
10897 if (target->specific->nopass)
10899 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10903 return target_proc;
10907 /* Resolve a type-bound intrinsic operator. */
10910 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10911 gfc_typebound_proc* p)
10913 gfc_symbol* super_type;
10914 gfc_tbp_generic* target;
10916 /* If there's already an error here, do nothing (but don't fail again). */
10920 /* Operators should always be GENERIC bindings. */
10921 gcc_assert (p->is_generic);
10923 /* Look for an overridden binding. */
10924 super_type = gfc_get_derived_super_type (derived);
10925 if (super_type && super_type->f2k_derived)
10926 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10929 p->overridden = NULL;
10931 /* Resolve general GENERIC properties using worker function. */
10932 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10935 /* Check the targets to be procedures of correct interface. */
10936 for (target = p->u.generic; target; target = target->next)
10938 gfc_symbol* target_proc;
10940 target_proc = get_checked_tb_operator_target (target, p->where);
10944 if (!gfc_check_operator_interface (target_proc, op, p->where))
10956 /* Resolve a type-bound user operator (tree-walker callback). */
10958 static gfc_symbol* resolve_bindings_derived;
10959 static gfc_try resolve_bindings_result;
10961 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10964 resolve_typebound_user_op (gfc_symtree* stree)
10966 gfc_symbol* super_type;
10967 gfc_tbp_generic* target;
10969 gcc_assert (stree && stree->n.tb);
10971 if (stree->n.tb->error)
10974 /* Operators should always be GENERIC bindings. */
10975 gcc_assert (stree->n.tb->is_generic);
10977 /* Find overridden procedure, if any. */
10978 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10979 if (super_type && super_type->f2k_derived)
10981 gfc_symtree* overridden;
10982 overridden = gfc_find_typebound_user_op (super_type, NULL,
10983 stree->name, true, NULL);
10985 if (overridden && overridden->n.tb)
10986 stree->n.tb->overridden = overridden->n.tb;
10989 stree->n.tb->overridden = NULL;
10991 /* Resolve basically using worker function. */
10992 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10996 /* Check the targets to be functions of correct interface. */
10997 for (target = stree->n.tb->u.generic; target; target = target->next)
10999 gfc_symbol* target_proc;
11001 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11005 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11012 resolve_bindings_result = FAILURE;
11013 stree->n.tb->error = 1;
11017 /* Resolve the type-bound procedures for a derived type. */
11020 resolve_typebound_procedure (gfc_symtree* stree)
11024 gfc_symbol* me_arg;
11025 gfc_symbol* super_type;
11026 gfc_component* comp;
11028 gcc_assert (stree);
11030 /* Undefined specific symbol from GENERIC target definition. */
11034 if (stree->n.tb->error)
11037 /* If this is a GENERIC binding, use that routine. */
11038 if (stree->n.tb->is_generic)
11040 if (resolve_typebound_generic (resolve_bindings_derived, stree)
11046 /* Get the target-procedure to check it. */
11047 gcc_assert (!stree->n.tb->is_generic);
11048 gcc_assert (stree->n.tb->u.specific);
11049 proc = stree->n.tb->u.specific->n.sym;
11050 where = stree->n.tb->where;
11052 /* Default access should already be resolved from the parser. */
11053 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11055 /* It should be a module procedure or an external procedure with explicit
11056 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11057 if ((!proc->attr.subroutine && !proc->attr.function)
11058 || (proc->attr.proc != PROC_MODULE
11059 && proc->attr.if_source != IFSRC_IFBODY)
11060 || (proc->attr.abstract && !stree->n.tb->deferred))
11062 gfc_error ("'%s' must be a module procedure or an external procedure with"
11063 " an explicit interface at %L", proc->name, &where);
11066 stree->n.tb->subroutine = proc->attr.subroutine;
11067 stree->n.tb->function = proc->attr.function;
11069 /* Find the super-type of the current derived type. We could do this once and
11070 store in a global if speed is needed, but as long as not I believe this is
11071 more readable and clearer. */
11072 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11074 /* If PASS, resolve and check arguments if not already resolved / loaded
11075 from a .mod file. */
11076 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11078 if (stree->n.tb->pass_arg)
11080 gfc_formal_arglist* i;
11082 /* If an explicit passing argument name is given, walk the arg-list
11083 and look for it. */
11086 stree->n.tb->pass_arg_num = 1;
11087 for (i = proc->formal; i; i = i->next)
11089 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11094 ++stree->n.tb->pass_arg_num;
11099 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11101 proc->name, stree->n.tb->pass_arg, &where,
11102 stree->n.tb->pass_arg);
11108 /* Otherwise, take the first one; there should in fact be at least
11110 stree->n.tb->pass_arg_num = 1;
11113 gfc_error ("Procedure '%s' with PASS at %L must have at"
11114 " least one argument", proc->name, &where);
11117 me_arg = proc->formal->sym;
11120 /* Now check that the argument-type matches and the passed-object
11121 dummy argument is generally fine. */
11123 gcc_assert (me_arg);
11125 if (me_arg->ts.type != BT_CLASS)
11127 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11128 " at %L", proc->name, &where);
11132 if (CLASS_DATA (me_arg)->ts.u.derived
11133 != resolve_bindings_derived)
11135 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11136 " the derived-type '%s'", me_arg->name, proc->name,
11137 me_arg->name, &where, resolve_bindings_derived->name);
11141 gcc_assert (me_arg->ts.type == BT_CLASS);
11142 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11144 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11145 " scalar", proc->name, &where);
11148 if (CLASS_DATA (me_arg)->attr.allocatable)
11150 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11151 " be ALLOCATABLE", proc->name, &where);
11154 if (CLASS_DATA (me_arg)->attr.class_pointer)
11156 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11157 " be POINTER", proc->name, &where);
11162 /* If we are extending some type, check that we don't override a procedure
11163 flagged NON_OVERRIDABLE. */
11164 stree->n.tb->overridden = NULL;
11167 gfc_symtree* overridden;
11168 overridden = gfc_find_typebound_proc (super_type, NULL,
11169 stree->name, true, NULL);
11171 if (overridden && overridden->n.tb)
11172 stree->n.tb->overridden = overridden->n.tb;
11174 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11178 /* See if there's a name collision with a component directly in this type. */
11179 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11180 if (!strcmp (comp->name, stree->name))
11182 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11184 stree->name, &where, resolve_bindings_derived->name);
11188 /* Try to find a name collision with an inherited component. */
11189 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11191 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11192 " component of '%s'",
11193 stree->name, &where, resolve_bindings_derived->name);
11197 stree->n.tb->error = 0;
11201 resolve_bindings_result = FAILURE;
11202 stree->n.tb->error = 1;
11207 resolve_typebound_procedures (gfc_symbol* derived)
11211 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11214 resolve_bindings_derived = derived;
11215 resolve_bindings_result = SUCCESS;
11217 /* Make sure the vtab has been generated. */
11218 gfc_find_derived_vtab (derived);
11220 if (derived->f2k_derived->tb_sym_root)
11221 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11222 &resolve_typebound_procedure);
11224 if (derived->f2k_derived->tb_uop_root)
11225 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11226 &resolve_typebound_user_op);
11228 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11230 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11231 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11233 resolve_bindings_result = FAILURE;
11236 return resolve_bindings_result;
11240 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11241 to give all identical derived types the same backend_decl. */
11243 add_dt_to_dt_list (gfc_symbol *derived)
11245 gfc_dt_list *dt_list;
11247 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11248 if (derived == dt_list->derived)
11251 dt_list = gfc_get_dt_list ();
11252 dt_list->next = gfc_derived_types;
11253 dt_list->derived = derived;
11254 gfc_derived_types = dt_list;
11258 /* Ensure that a derived-type is really not abstract, meaning that every
11259 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11262 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11267 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11269 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11272 if (st->n.tb && st->n.tb->deferred)
11274 gfc_symtree* overriding;
11275 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11278 gcc_assert (overriding->n.tb);
11279 if (overriding->n.tb->deferred)
11281 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11282 " '%s' is DEFERRED and not overridden",
11283 sub->name, &sub->declared_at, st->name);
11292 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11294 /* The algorithm used here is to recursively travel up the ancestry of sub
11295 and for each ancestor-type, check all bindings. If any of them is
11296 DEFERRED, look it up starting from sub and see if the found (overriding)
11297 binding is not DEFERRED.
11298 This is not the most efficient way to do this, but it should be ok and is
11299 clearer than something sophisticated. */
11301 gcc_assert (ancestor && !sub->attr.abstract);
11303 if (!ancestor->attr.abstract)
11306 /* Walk bindings of this ancestor. */
11307 if (ancestor->f2k_derived)
11310 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11315 /* Find next ancestor type and recurse on it. */
11316 ancestor = gfc_get_derived_super_type (ancestor);
11318 return ensure_not_abstract (sub, ancestor);
11324 /* Resolve the components of a derived type. */
11327 resolve_fl_derived (gfc_symbol *sym)
11329 gfc_symbol* super_type;
11332 super_type = gfc_get_derived_super_type (sym);
11334 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11336 /* Fix up incomplete CLASS symbols. */
11337 gfc_component *data = gfc_find_component (sym, "_data", true, true);
11338 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
11339 if (vptr->ts.u.derived == NULL)
11341 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11343 vptr->ts.u.derived = vtab->ts.u.derived;
11348 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11350 gfc_error ("As extending type '%s' at %L has a coarray component, "
11351 "parent type '%s' shall also have one", sym->name,
11352 &sym->declared_at, super_type->name);
11356 /* Ensure the extended type gets resolved before we do. */
11357 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11360 /* An ABSTRACT type must be extensible. */
11361 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11363 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11364 sym->name, &sym->declared_at);
11368 for (c = sym->components; c != NULL; c = c->next)
11371 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11372 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11374 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11375 "deferred shape", c->name, &c->loc);
11380 if (c->attr.codimension && c->ts.type == BT_DERIVED
11381 && c->ts.u.derived->ts.is_iso_c)
11383 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11384 "shall not be a coarray", c->name, &c->loc);
11389 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11390 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11391 || c->attr.allocatable))
11393 gfc_error ("Component '%s' at %L with coarray component "
11394 "shall be a nonpointer, nonallocatable scalar",
11400 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11402 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11403 "is not an array pointer", c->name, &c->loc);
11407 if (c->attr.proc_pointer && c->ts.interface)
11409 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11410 gfc_error ("Interface '%s', used by procedure pointer component "
11411 "'%s' at %L, is declared in a later PROCEDURE statement",
11412 c->ts.interface->name, c->name, &c->loc);
11414 /* Get the attributes from the interface (now resolved). */
11415 if (c->ts.interface->attr.if_source
11416 || c->ts.interface->attr.intrinsic)
11418 gfc_symbol *ifc = c->ts.interface;
11420 if (ifc->formal && !ifc->formal_ns)
11421 resolve_symbol (ifc);
11423 if (ifc->attr.intrinsic)
11424 resolve_intrinsic (ifc, &ifc->declared_at);
11428 c->ts = ifc->result->ts;
11429 c->attr.allocatable = ifc->result->attr.allocatable;
11430 c->attr.pointer = ifc->result->attr.pointer;
11431 c->attr.dimension = ifc->result->attr.dimension;
11432 c->as = gfc_copy_array_spec (ifc->result->as);
11437 c->attr.allocatable = ifc->attr.allocatable;
11438 c->attr.pointer = ifc->attr.pointer;
11439 c->attr.dimension = ifc->attr.dimension;
11440 c->as = gfc_copy_array_spec (ifc->as);
11442 c->ts.interface = ifc;
11443 c->attr.function = ifc->attr.function;
11444 c->attr.subroutine = ifc->attr.subroutine;
11445 gfc_copy_formal_args_ppc (c, ifc);
11447 c->attr.pure = ifc->attr.pure;
11448 c->attr.elemental = ifc->attr.elemental;
11449 c->attr.recursive = ifc->attr.recursive;
11450 c->attr.always_explicit = ifc->attr.always_explicit;
11451 c->attr.ext_attr |= ifc->attr.ext_attr;
11452 /* Replace symbols in array spec. */
11456 for (i = 0; i < c->as->rank; i++)
11458 gfc_expr_replace_comp (c->as->lower[i], c);
11459 gfc_expr_replace_comp (c->as->upper[i], c);
11462 /* Copy char length. */
11463 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11465 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11466 gfc_expr_replace_comp (cl->length, c);
11467 if (cl->length && !cl->resolved
11468 && gfc_resolve_expr (cl->length) == FAILURE)
11473 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11475 gfc_error ("Interface '%s' of procedure pointer component "
11476 "'%s' at %L must be explicit", c->ts.interface->name,
11481 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11483 /* Since PPCs are not implicitly typed, a PPC without an explicit
11484 interface must be a subroutine. */
11485 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11488 /* Procedure pointer components: Check PASS arg. */
11489 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11490 && !sym->attr.vtype)
11492 gfc_symbol* me_arg;
11494 if (c->tb->pass_arg)
11496 gfc_formal_arglist* i;
11498 /* If an explicit passing argument name is given, walk the arg-list
11499 and look for it. */
11502 c->tb->pass_arg_num = 1;
11503 for (i = c->formal; i; i = i->next)
11505 if (!strcmp (i->sym->name, c->tb->pass_arg))
11510 c->tb->pass_arg_num++;
11515 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11516 "at %L has no argument '%s'", c->name,
11517 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11524 /* Otherwise, take the first one; there should in fact be at least
11526 c->tb->pass_arg_num = 1;
11529 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11530 "must have at least one argument",
11535 me_arg = c->formal->sym;
11538 /* Now check that the argument-type matches. */
11539 gcc_assert (me_arg);
11540 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11541 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11542 || (me_arg->ts.type == BT_CLASS
11543 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11545 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11546 " the derived type '%s'", me_arg->name, c->name,
11547 me_arg->name, &c->loc, sym->name);
11552 /* Check for C453. */
11553 if (me_arg->attr.dimension)
11555 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11556 "must be scalar", me_arg->name, c->name, me_arg->name,
11562 if (me_arg->attr.pointer)
11564 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11565 "may not have the POINTER attribute", me_arg->name,
11566 c->name, me_arg->name, &c->loc);
11571 if (me_arg->attr.allocatable)
11573 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11574 "may not be ALLOCATABLE", me_arg->name, c->name,
11575 me_arg->name, &c->loc);
11580 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11581 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11582 " at %L", c->name, &c->loc);
11586 /* Check type-spec if this is not the parent-type component. */
11587 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11588 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11591 /* If this type is an extension, set the accessibility of the parent
11593 if (super_type && c == sym->components
11594 && strcmp (super_type->name, c->name) == 0)
11595 c->attr.access = super_type->attr.access;
11597 /* If this type is an extension, see if this component has the same name
11598 as an inherited type-bound procedure. */
11599 if (super_type && !sym->attr.is_class
11600 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11602 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11603 " inherited type-bound procedure",
11604 c->name, sym->name, &c->loc);
11608 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11610 if (c->ts.u.cl->length == NULL
11611 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11612 || !gfc_is_constant_expr (c->ts.u.cl->length))
11614 gfc_error ("Character length of component '%s' needs to "
11615 "be a constant specification expression at %L",
11617 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11622 if (c->ts.type == BT_DERIVED
11623 && sym->component_access != ACCESS_PRIVATE
11624 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11625 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11626 && !c->ts.u.derived->attr.use_assoc
11627 && !gfc_check_access (c->ts.u.derived->attr.access,
11628 c->ts.u.derived->ns->default_access)
11629 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11630 "is a PRIVATE type and cannot be a component of "
11631 "'%s', which is PUBLIC at %L", c->name,
11632 sym->name, &sym->declared_at) == FAILURE)
11635 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11637 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11638 "type %s", c->name, &c->loc, sym->name);
11642 if (sym->attr.sequence)
11644 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11646 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11647 "not have the SEQUENCE attribute",
11648 c->ts.u.derived->name, &sym->declared_at);
11653 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11654 && c->attr.pointer && c->ts.u.derived->components == NULL
11655 && !c->ts.u.derived->attr.zero_comp)
11657 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11658 "that has not been declared", c->name, sym->name,
11663 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11664 && CLASS_DATA (c)->ts.u.derived->components == NULL
11665 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11667 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11668 "that has not been declared", c->name, sym->name,
11674 if (c->ts.type == BT_CLASS
11675 && !(CLASS_DATA (c)->attr.class_pointer
11676 || CLASS_DATA (c)->attr.allocatable))
11678 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11679 "or pointer", c->name, &c->loc);
11683 /* Ensure that all the derived type components are put on the
11684 derived type list; even in formal namespaces, where derived type
11685 pointer components might not have been declared. */
11686 if (c->ts.type == BT_DERIVED
11688 && c->ts.u.derived->components
11690 && sym != c->ts.u.derived)
11691 add_dt_to_dt_list (c->ts.u.derived);
11693 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11694 || c->attr.proc_pointer
11695 || c->attr.allocatable)) == FAILURE)
11699 /* Resolve the type-bound procedures. */
11700 if (resolve_typebound_procedures (sym) == FAILURE)
11703 /* Resolve the finalizer procedures. */
11704 if (gfc_resolve_finalizers (sym) == FAILURE)
11707 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11708 all DEFERRED bindings are overridden. */
11709 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11710 && !sym->attr.is_class
11711 && ensure_not_abstract (sym, super_type) == FAILURE)
11714 /* Add derived type to the derived type list. */
11715 add_dt_to_dt_list (sym);
11722 resolve_fl_namelist (gfc_symbol *sym)
11727 for (nl = sym->namelist; nl; nl = nl->next)
11729 /* Reject namelist arrays of assumed shape. */
11730 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11731 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11732 "must not have assumed shape in namelist "
11733 "'%s' at %L", nl->sym->name, sym->name,
11734 &sym->declared_at) == FAILURE)
11737 /* Reject namelist arrays that are not constant shape. */
11738 if (is_non_constant_shape_array (nl->sym))
11740 gfc_error ("NAMELIST array object '%s' must have constant "
11741 "shape in namelist '%s' at %L", nl->sym->name,
11742 sym->name, &sym->declared_at);
11746 /* Namelist objects cannot have allocatable or pointer components. */
11747 if (nl->sym->ts.type != BT_DERIVED)
11750 if (nl->sym->ts.u.derived->attr.alloc_comp)
11752 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11753 "have ALLOCATABLE components",
11754 nl->sym->name, sym->name, &sym->declared_at);
11758 if (nl->sym->ts.u.derived->attr.pointer_comp)
11760 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11761 "have POINTER components",
11762 nl->sym->name, sym->name, &sym->declared_at);
11767 /* Reject PRIVATE objects in a PUBLIC namelist. */
11768 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11770 for (nl = sym->namelist; nl; nl = nl->next)
11772 if (!nl->sym->attr.use_assoc
11773 && !is_sym_host_assoc (nl->sym, sym->ns)
11774 && !gfc_check_access(nl->sym->attr.access,
11775 nl->sym->ns->default_access))
11777 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11778 "cannot be member of PUBLIC namelist '%s' at %L",
11779 nl->sym->name, sym->name, &sym->declared_at);
11783 /* Types with private components that came here by USE-association. */
11784 if (nl->sym->ts.type == BT_DERIVED
11785 && derived_inaccessible (nl->sym->ts.u.derived))
11787 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11788 "components and cannot be member of namelist '%s' at %L",
11789 nl->sym->name, sym->name, &sym->declared_at);
11793 /* Types with private components that are defined in the same module. */
11794 if (nl->sym->ts.type == BT_DERIVED
11795 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11796 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11797 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11798 nl->sym->ns->default_access))
11800 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11801 "cannot be a member of PUBLIC namelist '%s' at %L",
11802 nl->sym->name, sym->name, &sym->declared_at);
11809 /* 14.1.2 A module or internal procedure represent local entities
11810 of the same type as a namelist member and so are not allowed. */
11811 for (nl = sym->namelist; nl; nl = nl->next)
11813 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11816 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11817 if ((nl->sym == sym->ns->proc_name)
11819 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11823 if (nl->sym && nl->sym->name)
11824 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11825 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11827 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11828 "attribute in '%s' at %L", nlsym->name,
11829 &sym->declared_at);
11839 resolve_fl_parameter (gfc_symbol *sym)
11841 /* A parameter array's shape needs to be constant. */
11842 if (sym->as != NULL
11843 && (sym->as->type == AS_DEFERRED
11844 || is_non_constant_shape_array (sym)))
11846 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11847 "or of deferred shape", sym->name, &sym->declared_at);
11851 /* Make sure a parameter that has been implicitly typed still
11852 matches the implicit type, since PARAMETER statements can precede
11853 IMPLICIT statements. */
11854 if (sym->attr.implicit_type
11855 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11858 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11859 "later IMPLICIT type", sym->name, &sym->declared_at);
11863 /* Make sure the types of derived parameters are consistent. This
11864 type checking is deferred until resolution because the type may
11865 refer to a derived type from the host. */
11866 if (sym->ts.type == BT_DERIVED
11867 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11869 gfc_error ("Incompatible derived type in PARAMETER at %L",
11870 &sym->value->where);
11877 /* Do anything necessary to resolve a symbol. Right now, we just
11878 assume that an otherwise unknown symbol is a variable. This sort
11879 of thing commonly happens for symbols in module. */
11882 resolve_symbol (gfc_symbol *sym)
11884 int check_constant, mp_flag;
11885 gfc_symtree *symtree;
11886 gfc_symtree *this_symtree;
11890 /* Avoid double resolution of function result symbols. */
11891 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11892 && (sym->ns != gfc_current_ns))
11895 if (sym->attr.flavor == FL_UNKNOWN)
11898 /* If we find that a flavorless symbol is an interface in one of the
11899 parent namespaces, find its symtree in this namespace, free the
11900 symbol and set the symtree to point to the interface symbol. */
11901 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11903 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11904 if (symtree && (symtree->n.sym->generic ||
11905 (symtree->n.sym->attr.flavor == FL_PROCEDURE
11906 && sym->ns->construct_entities)))
11908 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11910 gfc_release_symbol (sym);
11911 symtree->n.sym->refs++;
11912 this_symtree->n.sym = symtree->n.sym;
11917 /* Otherwise give it a flavor according to such attributes as
11919 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11920 sym->attr.flavor = FL_VARIABLE;
11923 sym->attr.flavor = FL_PROCEDURE;
11924 if (sym->attr.dimension)
11925 sym->attr.function = 1;
11929 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11930 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11932 if (sym->attr.procedure && sym->ts.interface
11933 && sym->attr.if_source != IFSRC_DECL
11934 && resolve_procedure_interface (sym) == FAILURE)
11937 if (sym->attr.is_protected && !sym->attr.proc_pointer
11938 && (sym->attr.procedure || sym->attr.external))
11940 if (sym->attr.external)
11941 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11942 "at %L", &sym->declared_at);
11944 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11945 "at %L", &sym->declared_at);
11952 if (sym->attr.contiguous
11953 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11954 && !sym->attr.pointer)))
11956 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11957 "array pointer or an assumed-shape array", sym->name,
11958 &sym->declared_at);
11962 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11965 /* Symbols that are module procedures with results (functions) have
11966 the types and array specification copied for type checking in
11967 procedures that call them, as well as for saving to a module
11968 file. These symbols can't stand the scrutiny that their results
11970 mp_flag = (sym->result != NULL && sym->result != sym);
11972 /* Make sure that the intrinsic is consistent with its internal
11973 representation. This needs to be done before assigning a default
11974 type to avoid spurious warnings. */
11975 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11976 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11979 /* Resolve associate names. */
11981 resolve_assoc_var (sym, true);
11983 /* Assign default type to symbols that need one and don't have one. */
11984 if (sym->ts.type == BT_UNKNOWN)
11986 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11987 gfc_set_default_type (sym, 1, NULL);
11989 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11990 && !sym->attr.function && !sym->attr.subroutine
11991 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11992 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11994 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11996 /* The specific case of an external procedure should emit an error
11997 in the case that there is no implicit type. */
11999 gfc_set_default_type (sym, sym->attr.external, NULL);
12002 /* Result may be in another namespace. */
12003 resolve_symbol (sym->result);
12005 if (!sym->result->attr.proc_pointer)
12007 sym->ts = sym->result->ts;
12008 sym->as = gfc_copy_array_spec (sym->result->as);
12009 sym->attr.dimension = sym->result->attr.dimension;
12010 sym->attr.pointer = sym->result->attr.pointer;
12011 sym->attr.allocatable = sym->result->attr.allocatable;
12012 sym->attr.contiguous = sym->result->attr.contiguous;
12018 /* Assumed size arrays and assumed shape arrays must be dummy
12019 arguments. Array-spec's of implied-shape should have been resolved to
12020 AS_EXPLICIT already. */
12024 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
12025 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
12026 || sym->as->type == AS_ASSUMED_SHAPE)
12027 && sym->attr.dummy == 0)
12029 if (sym->as->type == AS_ASSUMED_SIZE)
12030 gfc_error ("Assumed size array at %L must be a dummy argument",
12031 &sym->declared_at);
12033 gfc_error ("Assumed shape array at %L must be a dummy argument",
12034 &sym->declared_at);
12039 /* Make sure symbols with known intent or optional are really dummy
12040 variable. Because of ENTRY statement, this has to be deferred
12041 until resolution time. */
12043 if (!sym->attr.dummy
12044 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12046 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12050 if (sym->attr.value && !sym->attr.dummy)
12052 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12053 "it is not a dummy argument", sym->name, &sym->declared_at);
12057 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12059 gfc_charlen *cl = sym->ts.u.cl;
12060 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12062 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12063 "attribute must have constant length",
12064 sym->name, &sym->declared_at);
12068 if (sym->ts.is_c_interop
12069 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12071 gfc_error ("C interoperable character dummy variable '%s' at %L "
12072 "with VALUE attribute must have length one",
12073 sym->name, &sym->declared_at);
12078 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12079 do this for something that was implicitly typed because that is handled
12080 in gfc_set_default_type. Handle dummy arguments and procedure
12081 definitions separately. Also, anything that is use associated is not
12082 handled here but instead is handled in the module it is declared in.
12083 Finally, derived type definitions are allowed to be BIND(C) since that
12084 only implies that they're interoperable, and they are checked fully for
12085 interoperability when a variable is declared of that type. */
12086 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12087 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12088 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12090 gfc_try t = SUCCESS;
12092 /* First, make sure the variable is declared at the
12093 module-level scope (J3/04-007, Section 15.3). */
12094 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12095 sym->attr.in_common == 0)
12097 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12098 "is neither a COMMON block nor declared at the "
12099 "module level scope", sym->name, &(sym->declared_at));
12102 else if (sym->common_head != NULL)
12104 t = verify_com_block_vars_c_interop (sym->common_head);
12108 /* If type() declaration, we need to verify that the components
12109 of the given type are all C interoperable, etc. */
12110 if (sym->ts.type == BT_DERIVED &&
12111 sym->ts.u.derived->attr.is_c_interop != 1)
12113 /* Make sure the user marked the derived type as BIND(C). If
12114 not, call the verify routine. This could print an error
12115 for the derived type more than once if multiple variables
12116 of that type are declared. */
12117 if (sym->ts.u.derived->attr.is_bind_c != 1)
12118 verify_bind_c_derived_type (sym->ts.u.derived);
12122 /* Verify the variable itself as C interoperable if it
12123 is BIND(C). It is not possible for this to succeed if
12124 the verify_bind_c_derived_type failed, so don't have to handle
12125 any error returned by verify_bind_c_derived_type. */
12126 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12127 sym->common_block);
12132 /* clear the is_bind_c flag to prevent reporting errors more than
12133 once if something failed. */
12134 sym->attr.is_bind_c = 0;
12139 /* If a derived type symbol has reached this point, without its
12140 type being declared, we have an error. Notice that most
12141 conditions that produce undefined derived types have already
12142 been dealt with. However, the likes of:
12143 implicit type(t) (t) ..... call foo (t) will get us here if
12144 the type is not declared in the scope of the implicit
12145 statement. Change the type to BT_UNKNOWN, both because it is so
12146 and to prevent an ICE. */
12147 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
12148 && !sym->ts.u.derived->attr.zero_comp)
12150 gfc_error ("The derived type '%s' at %L is of type '%s', "
12151 "which has not been defined", sym->name,
12152 &sym->declared_at, sym->ts.u.derived->name);
12153 sym->ts.type = BT_UNKNOWN;
12157 /* Make sure that the derived type has been resolved and that the
12158 derived type is visible in the symbol's namespace, if it is a
12159 module function and is not PRIVATE. */
12160 if (sym->ts.type == BT_DERIVED
12161 && sym->ts.u.derived->attr.use_assoc
12162 && sym->ns->proc_name
12163 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12167 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12170 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12171 if (!ds && sym->attr.function
12172 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12174 symtree = gfc_new_symtree (&sym->ns->sym_root,
12175 sym->ts.u.derived->name);
12176 symtree->n.sym = sym->ts.u.derived;
12177 sym->ts.u.derived->refs++;
12181 /* Unless the derived-type declaration is use associated, Fortran 95
12182 does not allow public entries of private derived types.
12183 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12184 161 in 95-006r3. */
12185 if (sym->ts.type == BT_DERIVED
12186 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12187 && !sym->ts.u.derived->attr.use_assoc
12188 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12189 && !gfc_check_access (sym->ts.u.derived->attr.access,
12190 sym->ts.u.derived->ns->default_access)
12191 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12192 "of PRIVATE derived type '%s'",
12193 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12194 : "variable", sym->name, &sym->declared_at,
12195 sym->ts.u.derived->name) == FAILURE)
12198 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12199 default initialization is defined (5.1.2.4.4). */
12200 if (sym->ts.type == BT_DERIVED
12202 && sym->attr.intent == INTENT_OUT
12204 && sym->as->type == AS_ASSUMED_SIZE)
12206 for (c = sym->ts.u.derived->components; c; c = c->next)
12208 if (c->initializer)
12210 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12211 "ASSUMED SIZE and so cannot have a default initializer",
12212 sym->name, &sym->declared_at);
12219 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12220 || sym->attr.codimension)
12221 && sym->attr.result)
12222 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12223 "a coarray component", sym->name, &sym->declared_at);
12226 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12227 && sym->ts.u.derived->ts.is_iso_c)
12228 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12229 "shall not be a coarray", sym->name, &sym->declared_at);
12232 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12233 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12234 || sym->attr.allocatable))
12235 gfc_error ("Variable '%s' at %L with coarray component "
12236 "shall be a nonpointer, nonallocatable scalar",
12237 sym->name, &sym->declared_at);
12239 /* F2008, C526. The function-result case was handled above. */
12240 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12241 || sym->attr.codimension)
12242 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12243 || sym->ns->proc_name->attr.flavor == FL_MODULE
12244 || sym->ns->proc_name->attr.is_main_program
12245 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12246 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12247 "component and is not ALLOCATABLE, SAVE nor a "
12248 "dummy argument", sym->name, &sym->declared_at);
12249 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12250 else if (sym->attr.codimension && !sym->attr.allocatable
12251 && sym->as && sym->as->cotype == AS_DEFERRED)
12252 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12253 "deferred shape", sym->name, &sym->declared_at);
12254 else if (sym->attr.codimension && sym->attr.allocatable
12255 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12256 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12257 "deferred shape", sym->name, &sym->declared_at);
12261 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12262 || (sym->attr.codimension && sym->attr.allocatable))
12263 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12264 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12265 "allocatable coarray or have coarray components",
12266 sym->name, &sym->declared_at);
12268 if (sym->attr.codimension && sym->attr.dummy
12269 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12270 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12271 "procedure '%s'", sym->name, &sym->declared_at,
12272 sym->ns->proc_name->name);
12274 switch (sym->attr.flavor)
12277 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12282 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12287 if (resolve_fl_namelist (sym) == FAILURE)
12292 if (resolve_fl_parameter (sym) == FAILURE)
12300 /* Resolve array specifier. Check as well some constraints
12301 on COMMON blocks. */
12303 check_constant = sym->attr.in_common && !sym->attr.pointer;
12305 /* Set the formal_arg_flag so that check_conflict will not throw
12306 an error for host associated variables in the specification
12307 expression for an array_valued function. */
12308 if (sym->attr.function && sym->as)
12309 formal_arg_flag = 1;
12311 gfc_resolve_array_spec (sym->as, check_constant);
12313 formal_arg_flag = 0;
12315 /* Resolve formal namespaces. */
12316 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12317 && !sym->attr.contained && !sym->attr.intrinsic)
12318 gfc_resolve (sym->formal_ns);
12320 /* Make sure the formal namespace is present. */
12321 if (sym->formal && !sym->formal_ns)
12323 gfc_formal_arglist *formal = sym->formal;
12324 while (formal && !formal->sym)
12325 formal = formal->next;
12329 sym->formal_ns = formal->sym->ns;
12330 sym->formal_ns->refs++;
12334 /* Check threadprivate restrictions. */
12335 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12336 && (!sym->attr.in_common
12337 && sym->module == NULL
12338 && (sym->ns->proc_name == NULL
12339 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12340 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12342 /* If we have come this far we can apply default-initializers, as
12343 described in 14.7.5, to those variables that have not already
12344 been assigned one. */
12345 if (sym->ts.type == BT_DERIVED
12346 && sym->ns == gfc_current_ns
12348 && !sym->attr.allocatable
12349 && !sym->attr.alloc_comp)
12351 symbol_attribute *a = &sym->attr;
12353 if ((!a->save && !a->dummy && !a->pointer
12354 && !a->in_common && !a->use_assoc
12355 && (a->referenced || a->result)
12356 && !(a->function && sym != sym->result))
12357 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12358 apply_default_init (sym);
12361 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12362 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12363 && !CLASS_DATA (sym)->attr.class_pointer
12364 && !CLASS_DATA (sym)->attr.allocatable)
12365 apply_default_init (sym);
12367 /* If this symbol has a type-spec, check it. */
12368 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12369 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12370 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12376 /************* Resolve DATA statements *************/
12380 gfc_data_value *vnode;
12386 /* Advance the values structure to point to the next value in the data list. */
12389 next_data_value (void)
12391 while (mpz_cmp_ui (values.left, 0) == 0)
12394 if (values.vnode->next == NULL)
12397 values.vnode = values.vnode->next;
12398 mpz_set (values.left, values.vnode->repeat);
12406 check_data_variable (gfc_data_variable *var, locus *where)
12412 ar_type mark = AR_UNKNOWN;
12414 mpz_t section_index[GFC_MAX_DIMENSIONS];
12420 if (gfc_resolve_expr (var->expr) == FAILURE)
12424 mpz_init_set_si (offset, 0);
12427 if (e->expr_type != EXPR_VARIABLE)
12428 gfc_internal_error ("check_data_variable(): Bad expression");
12430 sym = e->symtree->n.sym;
12432 if (sym->ns->is_block_data && !sym->attr.in_common)
12434 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12435 sym->name, &sym->declared_at);
12438 if (e->ref == NULL && sym->as)
12440 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12441 " declaration", sym->name, where);
12445 has_pointer = sym->attr.pointer;
12447 for (ref = e->ref; ref; ref = ref->next)
12449 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12452 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12454 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12460 && ref->type == REF_ARRAY
12461 && ref->u.ar.type != AR_FULL)
12463 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12464 "be a full array", sym->name, where);
12469 if (e->rank == 0 || has_pointer)
12471 mpz_init_set_ui (size, 1);
12478 /* Find the array section reference. */
12479 for (ref = e->ref; ref; ref = ref->next)
12481 if (ref->type != REF_ARRAY)
12483 if (ref->u.ar.type == AR_ELEMENT)
12489 /* Set marks according to the reference pattern. */
12490 switch (ref->u.ar.type)
12498 /* Get the start position of array section. */
12499 gfc_get_section_index (ar, section_index, &offset);
12504 gcc_unreachable ();
12507 if (gfc_array_size (e, &size) == FAILURE)
12509 gfc_error ("Nonconstant array section at %L in DATA statement",
12511 mpz_clear (offset);
12518 while (mpz_cmp_ui (size, 0) > 0)
12520 if (next_data_value () == FAILURE)
12522 gfc_error ("DATA statement at %L has more variables than values",
12528 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12532 /* If we have more than one element left in the repeat count,
12533 and we have more than one element left in the target variable,
12534 then create a range assignment. */
12535 /* FIXME: Only done for full arrays for now, since array sections
12537 if (mark == AR_FULL && ref && ref->next == NULL
12538 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12542 if (mpz_cmp (size, values.left) >= 0)
12544 mpz_init_set (range, values.left);
12545 mpz_sub (size, size, values.left);
12546 mpz_set_ui (values.left, 0);
12550 mpz_init_set (range, size);
12551 mpz_sub (values.left, values.left, size);
12552 mpz_set_ui (size, 0);
12555 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12558 mpz_add (offset, offset, range);
12565 /* Assign initial value to symbol. */
12568 mpz_sub_ui (values.left, values.left, 1);
12569 mpz_sub_ui (size, size, 1);
12571 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12575 if (mark == AR_FULL)
12576 mpz_add_ui (offset, offset, 1);
12578 /* Modify the array section indexes and recalculate the offset
12579 for next element. */
12580 else if (mark == AR_SECTION)
12581 gfc_advance_section (section_index, ar, &offset);
12585 if (mark == AR_SECTION)
12587 for (i = 0; i < ar->dimen; i++)
12588 mpz_clear (section_index[i]);
12592 mpz_clear (offset);
12598 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12600 /* Iterate over a list of elements in a DATA statement. */
12603 traverse_data_list (gfc_data_variable *var, locus *where)
12606 iterator_stack frame;
12607 gfc_expr *e, *start, *end, *step;
12608 gfc_try retval = SUCCESS;
12610 mpz_init (frame.value);
12613 start = gfc_copy_expr (var->iter.start);
12614 end = gfc_copy_expr (var->iter.end);
12615 step = gfc_copy_expr (var->iter.step);
12617 if (gfc_simplify_expr (start, 1) == FAILURE
12618 || start->expr_type != EXPR_CONSTANT)
12620 gfc_error ("start of implied-do loop at %L could not be "
12621 "simplified to a constant value", &start->where);
12625 if (gfc_simplify_expr (end, 1) == FAILURE
12626 || end->expr_type != EXPR_CONSTANT)
12628 gfc_error ("end of implied-do loop at %L could not be "
12629 "simplified to a constant value", &start->where);
12633 if (gfc_simplify_expr (step, 1) == FAILURE
12634 || step->expr_type != EXPR_CONSTANT)
12636 gfc_error ("step of implied-do loop at %L could not be "
12637 "simplified to a constant value", &start->where);
12642 mpz_set (trip, end->value.integer);
12643 mpz_sub (trip, trip, start->value.integer);
12644 mpz_add (trip, trip, step->value.integer);
12646 mpz_div (trip, trip, step->value.integer);
12648 mpz_set (frame.value, start->value.integer);
12650 frame.prev = iter_stack;
12651 frame.variable = var->iter.var->symtree;
12652 iter_stack = &frame;
12654 while (mpz_cmp_ui (trip, 0) > 0)
12656 if (traverse_data_var (var->list, where) == FAILURE)
12662 e = gfc_copy_expr (var->expr);
12663 if (gfc_simplify_expr (e, 1) == FAILURE)
12670 mpz_add (frame.value, frame.value, step->value.integer);
12672 mpz_sub_ui (trip, trip, 1);
12676 mpz_clear (frame.value);
12679 gfc_free_expr (start);
12680 gfc_free_expr (end);
12681 gfc_free_expr (step);
12683 iter_stack = frame.prev;
12688 /* Type resolve variables in the variable list of a DATA statement. */
12691 traverse_data_var (gfc_data_variable *var, locus *where)
12695 for (; var; var = var->next)
12697 if (var->expr == NULL)
12698 t = traverse_data_list (var, where);
12700 t = check_data_variable (var, where);
12710 /* Resolve the expressions and iterators associated with a data statement.
12711 This is separate from the assignment checking because data lists should
12712 only be resolved once. */
12715 resolve_data_variables (gfc_data_variable *d)
12717 for (; d; d = d->next)
12719 if (d->list == NULL)
12721 if (gfc_resolve_expr (d->expr) == FAILURE)
12726 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12729 if (resolve_data_variables (d->list) == FAILURE)
12738 /* Resolve a single DATA statement. We implement this by storing a pointer to
12739 the value list into static variables, and then recursively traversing the
12740 variables list, expanding iterators and such. */
12743 resolve_data (gfc_data *d)
12746 if (resolve_data_variables (d->var) == FAILURE)
12749 values.vnode = d->value;
12750 if (d->value == NULL)
12751 mpz_set_ui (values.left, 0);
12753 mpz_set (values.left, d->value->repeat);
12755 if (traverse_data_var (d->var, &d->where) == FAILURE)
12758 /* At this point, we better not have any values left. */
12760 if (next_data_value () == SUCCESS)
12761 gfc_error ("DATA statement at %L has more values than variables",
12766 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12767 accessed by host or use association, is a dummy argument to a pure function,
12768 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12769 is storage associated with any such variable, shall not be used in the
12770 following contexts: (clients of this function). */
12772 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12773 procedure. Returns zero if assignment is OK, nonzero if there is a
12776 gfc_impure_variable (gfc_symbol *sym)
12781 if (sym->attr.use_assoc || sym->attr.in_common)
12784 /* Check if the symbol's ns is inside the pure procedure. */
12785 for (ns = gfc_current_ns; ns; ns = ns->parent)
12789 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12793 proc = sym->ns->proc_name;
12794 if (sym->attr.dummy && gfc_pure (proc)
12795 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12797 proc->attr.function))
12800 /* TODO: Sort out what can be storage associated, if anything, and include
12801 it here. In principle equivalences should be scanned but it does not
12802 seem to be possible to storage associate an impure variable this way. */
12807 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12808 current namespace is inside a pure procedure. */
12811 gfc_pure (gfc_symbol *sym)
12813 symbol_attribute attr;
12818 /* Check if the current namespace or one of its parents
12819 belongs to a pure procedure. */
12820 for (ns = gfc_current_ns; ns; ns = ns->parent)
12822 sym = ns->proc_name;
12826 if (attr.flavor == FL_PROCEDURE && attr.pure)
12834 return attr.flavor == FL_PROCEDURE && attr.pure;
12838 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
12839 checks if the current namespace is implicitly pure. Note that this
12840 function returns false for a PURE procedure. */
12843 gfc_implicit_pure (gfc_symbol *sym)
12845 symbol_attribute attr;
12849 /* Check if the current namespace is implicit_pure. */
12850 sym = gfc_current_ns->proc_name;
12854 if (attr.flavor == FL_PROCEDURE
12855 && attr.implicit_pure && !attr.pure)
12862 return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
12866 /* Test whether the current procedure is elemental or not. */
12869 gfc_elemental (gfc_symbol *sym)
12871 symbol_attribute attr;
12874 sym = gfc_current_ns->proc_name;
12879 return attr.flavor == FL_PROCEDURE && attr.elemental;
12883 /* Warn about unused labels. */
12886 warn_unused_fortran_label (gfc_st_label *label)
12891 warn_unused_fortran_label (label->left);
12893 if (label->defined == ST_LABEL_UNKNOWN)
12896 switch (label->referenced)
12898 case ST_LABEL_UNKNOWN:
12899 gfc_warning ("Label %d at %L defined but not used", label->value,
12903 case ST_LABEL_BAD_TARGET:
12904 gfc_warning ("Label %d at %L defined but cannot be used",
12905 label->value, &label->where);
12912 warn_unused_fortran_label (label->right);
12916 /* Returns the sequence type of a symbol or sequence. */
12919 sequence_type (gfc_typespec ts)
12928 if (ts.u.derived->components == NULL)
12929 return SEQ_NONDEFAULT;
12931 result = sequence_type (ts.u.derived->components->ts);
12932 for (c = ts.u.derived->components->next; c; c = c->next)
12933 if (sequence_type (c->ts) != result)
12939 if (ts.kind != gfc_default_character_kind)
12940 return SEQ_NONDEFAULT;
12942 return SEQ_CHARACTER;
12945 if (ts.kind != gfc_default_integer_kind)
12946 return SEQ_NONDEFAULT;
12948 return SEQ_NUMERIC;
12951 if (!(ts.kind == gfc_default_real_kind
12952 || ts.kind == gfc_default_double_kind))
12953 return SEQ_NONDEFAULT;
12955 return SEQ_NUMERIC;
12958 if (ts.kind != gfc_default_complex_kind)
12959 return SEQ_NONDEFAULT;
12961 return SEQ_NUMERIC;
12964 if (ts.kind != gfc_default_logical_kind)
12965 return SEQ_NONDEFAULT;
12967 return SEQ_NUMERIC;
12970 return SEQ_NONDEFAULT;
12975 /* Resolve derived type EQUIVALENCE object. */
12978 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12980 gfc_component *c = derived->components;
12985 /* Shall not be an object of nonsequence derived type. */
12986 if (!derived->attr.sequence)
12988 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12989 "attribute to be an EQUIVALENCE object", sym->name,
12994 /* Shall not have allocatable components. */
12995 if (derived->attr.alloc_comp)
12997 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12998 "components to be an EQUIVALENCE object",sym->name,
13003 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13005 gfc_error ("Derived type variable '%s' at %L with default "
13006 "initialization cannot be in EQUIVALENCE with a variable "
13007 "in COMMON", sym->name, &e->where);
13011 for (; c ; c = c->next)
13013 if (c->ts.type == BT_DERIVED
13014 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13017 /* Shall not be an object of sequence derived type containing a pointer
13018 in the structure. */
13019 if (c->attr.pointer)
13021 gfc_error ("Derived type variable '%s' at %L with pointer "
13022 "component(s) cannot be an EQUIVALENCE object",
13023 sym->name, &e->where);
13031 /* Resolve equivalence object.
13032 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13033 an allocatable array, an object of nonsequence derived type, an object of
13034 sequence derived type containing a pointer at any level of component
13035 selection, an automatic object, a function name, an entry name, a result
13036 name, a named constant, a structure component, or a subobject of any of
13037 the preceding objects. A substring shall not have length zero. A
13038 derived type shall not have components with default initialization nor
13039 shall two objects of an equivalence group be initialized.
13040 Either all or none of the objects shall have an protected attribute.
13041 The simple constraints are done in symbol.c(check_conflict) and the rest
13042 are implemented here. */
13045 resolve_equivalence (gfc_equiv *eq)
13048 gfc_symbol *first_sym;
13051 locus *last_where = NULL;
13052 seq_type eq_type, last_eq_type;
13053 gfc_typespec *last_ts;
13054 int object, cnt_protected;
13057 last_ts = &eq->expr->symtree->n.sym->ts;
13059 first_sym = eq->expr->symtree->n.sym;
13063 for (object = 1; eq; eq = eq->eq, object++)
13067 e->ts = e->symtree->n.sym->ts;
13068 /* match_varspec might not know yet if it is seeing
13069 array reference or substring reference, as it doesn't
13071 if (e->ref && e->ref->type == REF_ARRAY)
13073 gfc_ref *ref = e->ref;
13074 sym = e->symtree->n.sym;
13076 if (sym->attr.dimension)
13078 ref->u.ar.as = sym->as;
13082 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13083 if (e->ts.type == BT_CHARACTER
13085 && ref->type == REF_ARRAY
13086 && ref->u.ar.dimen == 1
13087 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13088 && ref->u.ar.stride[0] == NULL)
13090 gfc_expr *start = ref->u.ar.start[0];
13091 gfc_expr *end = ref->u.ar.end[0];
13094 /* Optimize away the (:) reference. */
13095 if (start == NULL && end == NULL)
13098 e->ref = ref->next;
13100 e->ref->next = ref->next;
13105 ref->type = REF_SUBSTRING;
13107 start = gfc_get_int_expr (gfc_default_integer_kind,
13109 ref->u.ss.start = start;
13110 if (end == NULL && e->ts.u.cl)
13111 end = gfc_copy_expr (e->ts.u.cl->length);
13112 ref->u.ss.end = end;
13113 ref->u.ss.length = e->ts.u.cl;
13120 /* Any further ref is an error. */
13123 gcc_assert (ref->type == REF_ARRAY);
13124 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13130 if (gfc_resolve_expr (e) == FAILURE)
13133 sym = e->symtree->n.sym;
13135 if (sym->attr.is_protected)
13137 if (cnt_protected > 0 && cnt_protected != object)
13139 gfc_error ("Either all or none of the objects in the "
13140 "EQUIVALENCE set at %L shall have the "
13141 "PROTECTED attribute",
13146 /* Shall not equivalence common block variables in a PURE procedure. */
13147 if (sym->ns->proc_name
13148 && sym->ns->proc_name->attr.pure
13149 && sym->attr.in_common)
13151 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13152 "object in the pure procedure '%s'",
13153 sym->name, &e->where, sym->ns->proc_name->name);
13157 /* Shall not be a named constant. */
13158 if (e->expr_type == EXPR_CONSTANT)
13160 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13161 "object", sym->name, &e->where);
13165 if (e->ts.type == BT_DERIVED
13166 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13169 /* Check that the types correspond correctly:
13171 A numeric sequence structure may be equivalenced to another sequence
13172 structure, an object of default integer type, default real type, double
13173 precision real type, default logical type such that components of the
13174 structure ultimately only become associated to objects of the same
13175 kind. A character sequence structure may be equivalenced to an object
13176 of default character kind or another character sequence structure.
13177 Other objects may be equivalenced only to objects of the same type and
13178 kind parameters. */
13180 /* Identical types are unconditionally OK. */
13181 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13182 goto identical_types;
13184 last_eq_type = sequence_type (*last_ts);
13185 eq_type = sequence_type (sym->ts);
13187 /* Since the pair of objects is not of the same type, mixed or
13188 non-default sequences can be rejected. */
13190 msg = "Sequence %s with mixed components in EQUIVALENCE "
13191 "statement at %L with different type objects";
13193 && last_eq_type == SEQ_MIXED
13194 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13196 || (eq_type == SEQ_MIXED
13197 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13198 &e->where) == FAILURE))
13201 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13202 "statement at %L with objects of different type";
13204 && last_eq_type == SEQ_NONDEFAULT
13205 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13206 last_where) == FAILURE)
13207 || (eq_type == SEQ_NONDEFAULT
13208 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13209 &e->where) == FAILURE))
13212 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13213 "EQUIVALENCE statement at %L";
13214 if (last_eq_type == SEQ_CHARACTER
13215 && eq_type != SEQ_CHARACTER
13216 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13217 &e->where) == FAILURE)
13220 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13221 "EQUIVALENCE statement at %L";
13222 if (last_eq_type == SEQ_NUMERIC
13223 && eq_type != SEQ_NUMERIC
13224 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13225 &e->where) == FAILURE)
13230 last_where = &e->where;
13235 /* Shall not be an automatic array. */
13236 if (e->ref->type == REF_ARRAY
13237 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13239 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13240 "an EQUIVALENCE object", sym->name, &e->where);
13247 /* Shall not be a structure component. */
13248 if (r->type == REF_COMPONENT)
13250 gfc_error ("Structure component '%s' at %L cannot be an "
13251 "EQUIVALENCE object",
13252 r->u.c.component->name, &e->where);
13256 /* A substring shall not have length zero. */
13257 if (r->type == REF_SUBSTRING)
13259 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13261 gfc_error ("Substring at %L has length zero",
13262 &r->u.ss.start->where);
13272 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13275 resolve_fntype (gfc_namespace *ns)
13277 gfc_entry_list *el;
13280 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13283 /* If there are any entries, ns->proc_name is the entry master
13284 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13286 sym = ns->entries->sym;
13288 sym = ns->proc_name;
13289 if (sym->result == sym
13290 && sym->ts.type == BT_UNKNOWN
13291 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13292 && !sym->attr.untyped)
13294 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13295 sym->name, &sym->declared_at);
13296 sym->attr.untyped = 1;
13299 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13300 && !sym->attr.contained
13301 && !gfc_check_access (sym->ts.u.derived->attr.access,
13302 sym->ts.u.derived->ns->default_access)
13303 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13305 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13306 "%L of PRIVATE type '%s'", sym->name,
13307 &sym->declared_at, sym->ts.u.derived->name);
13311 for (el = ns->entries->next; el; el = el->next)
13313 if (el->sym->result == el->sym
13314 && el->sym->ts.type == BT_UNKNOWN
13315 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13316 && !el->sym->attr.untyped)
13318 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13319 el->sym->name, &el->sym->declared_at);
13320 el->sym->attr.untyped = 1;
13326 /* 12.3.2.1.1 Defined operators. */
13329 check_uop_procedure (gfc_symbol *sym, locus where)
13331 gfc_formal_arglist *formal;
13333 if (!sym->attr.function)
13335 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13336 sym->name, &where);
13340 if (sym->ts.type == BT_CHARACTER
13341 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13342 && !(sym->result && sym->result->ts.u.cl
13343 && sym->result->ts.u.cl->length))
13345 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13346 "character length", sym->name, &where);
13350 formal = sym->formal;
13351 if (!formal || !formal->sym)
13353 gfc_error ("User operator procedure '%s' at %L must have at least "
13354 "one argument", sym->name, &where);
13358 if (formal->sym->attr.intent != INTENT_IN)
13360 gfc_error ("First argument of operator interface at %L must be "
13361 "INTENT(IN)", &where);
13365 if (formal->sym->attr.optional)
13367 gfc_error ("First argument of operator interface at %L cannot be "
13368 "optional", &where);
13372 formal = formal->next;
13373 if (!formal || !formal->sym)
13376 if (formal->sym->attr.intent != INTENT_IN)
13378 gfc_error ("Second argument of operator interface at %L must be "
13379 "INTENT(IN)", &where);
13383 if (formal->sym->attr.optional)
13385 gfc_error ("Second argument of operator interface at %L cannot be "
13386 "optional", &where);
13392 gfc_error ("Operator interface at %L must have, at most, two "
13393 "arguments", &where);
13401 gfc_resolve_uops (gfc_symtree *symtree)
13403 gfc_interface *itr;
13405 if (symtree == NULL)
13408 gfc_resolve_uops (symtree->left);
13409 gfc_resolve_uops (symtree->right);
13411 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13412 check_uop_procedure (itr->sym, itr->sym->declared_at);
13416 /* Examine all of the expressions associated with a program unit,
13417 assign types to all intermediate expressions, make sure that all
13418 assignments are to compatible types and figure out which names
13419 refer to which functions or subroutines. It doesn't check code
13420 block, which is handled by resolve_code. */
13423 resolve_types (gfc_namespace *ns)
13429 gfc_namespace* old_ns = gfc_current_ns;
13431 /* Check that all IMPLICIT types are ok. */
13432 if (!ns->seen_implicit_none)
13435 for (letter = 0; letter != GFC_LETTERS; ++letter)
13436 if (ns->set_flag[letter]
13437 && resolve_typespec_used (&ns->default_type[letter],
13438 &ns->implicit_loc[letter],
13443 gfc_current_ns = ns;
13445 resolve_entries (ns);
13447 resolve_common_vars (ns->blank_common.head, false);
13448 resolve_common_blocks (ns->common_root);
13450 resolve_contained_functions (ns);
13452 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13454 for (cl = ns->cl_list; cl; cl = cl->next)
13455 resolve_charlen (cl);
13457 gfc_traverse_ns (ns, resolve_symbol);
13459 resolve_fntype (ns);
13461 for (n = ns->contained; n; n = n->sibling)
13463 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13464 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13465 "also be PURE", n->proc_name->name,
13466 &n->proc_name->declared_at);
13472 gfc_check_interfaces (ns);
13474 gfc_traverse_ns (ns, resolve_values);
13480 for (d = ns->data; d; d = d->next)
13484 gfc_traverse_ns (ns, gfc_formalize_init_value);
13486 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13488 if (ns->common_root != NULL)
13489 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13491 for (eq = ns->equiv; eq; eq = eq->next)
13492 resolve_equivalence (eq);
13494 /* Warn about unused labels. */
13495 if (warn_unused_label)
13496 warn_unused_fortran_label (ns->st_labels);
13498 gfc_resolve_uops (ns->uop_root);
13500 gfc_current_ns = old_ns;
13504 /* Call resolve_code recursively. */
13507 resolve_codes (gfc_namespace *ns)
13510 bitmap_obstack old_obstack;
13512 if (ns->resolved == 1)
13515 for (n = ns->contained; n; n = n->sibling)
13518 gfc_current_ns = ns;
13520 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13521 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13524 /* Set to an out of range value. */
13525 current_entry_id = -1;
13527 old_obstack = labels_obstack;
13528 bitmap_obstack_initialize (&labels_obstack);
13530 resolve_code (ns->code, ns);
13532 bitmap_obstack_release (&labels_obstack);
13533 labels_obstack = old_obstack;
13537 /* This function is called after a complete program unit has been compiled.
13538 Its purpose is to examine all of the expressions associated with a program
13539 unit, assign types to all intermediate expressions, make sure that all
13540 assignments are to compatible types and figure out which names refer to
13541 which functions or subroutines. */
13544 gfc_resolve (gfc_namespace *ns)
13546 gfc_namespace *old_ns;
13547 code_stack *old_cs_base;
13553 old_ns = gfc_current_ns;
13554 old_cs_base = cs_base;
13556 resolve_types (ns);
13557 resolve_codes (ns);
13559 gfc_current_ns = old_ns;
13560 cs_base = old_cs_base;
13563 gfc_run_passes (ns);