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;
2015 /* Stash away derived types so that the backend_decls do not
2017 old_dt_list = gfc_derived_types;
2018 gfc_derived_types = NULL;
2020 gfc_resolve (gsym->ns);
2022 /* Store the new derived types with the global namespace. */
2023 if (gfc_derived_types)
2024 gsym->ns->derived_types = gfc_derived_types;
2026 /* Restore the derived types of this namespace. */
2027 gfc_derived_types = old_dt_list;
2030 /* Make sure that translation for the gsymbol occurs before
2031 the procedure currently being resolved. */
2032 ns = gfc_global_ns_list;
2033 for (; ns && ns != gsym->ns; ns = ns->sibling)
2035 if (ns->sibling == gsym->ns)
2037 ns->sibling = gsym->ns->sibling;
2038 gsym->ns->sibling = gfc_global_ns_list;
2039 gfc_global_ns_list = gsym->ns;
2044 def_sym = gsym->ns->proc_name;
2045 if (def_sym->attr.entry_master)
2047 gfc_entry_list *entry;
2048 for (entry = gsym->ns->entries; entry; entry = entry->next)
2049 if (strcmp (entry->sym->name, sym->name) == 0)
2051 def_sym = entry->sym;
2056 /* Differences in constant character lengths. */
2057 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2059 long int l1 = 0, l2 = 0;
2060 gfc_charlen *cl1 = sym->ts.u.cl;
2061 gfc_charlen *cl2 = def_sym->ts.u.cl;
2064 && cl1->length != NULL
2065 && cl1->length->expr_type == EXPR_CONSTANT)
2066 l1 = mpz_get_si (cl1->length->value.integer);
2069 && cl2->length != NULL
2070 && cl2->length->expr_type == EXPR_CONSTANT)
2071 l2 = mpz_get_si (cl2->length->value.integer);
2073 if (l1 && l2 && l1 != l2)
2074 gfc_error ("Character length mismatch in return type of "
2075 "function '%s' at %L (%ld/%ld)", sym->name,
2076 &sym->declared_at, l1, l2);
2079 /* Type mismatch of function return type and expected type. */
2080 if (sym->attr.function
2081 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2082 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2083 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2084 gfc_typename (&def_sym->ts));
2086 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2088 gfc_formal_arglist *arg = def_sym->formal;
2089 for ( ; arg; arg = arg->next)
2092 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2093 else if (arg->sym->attr.allocatable
2094 || arg->sym->attr.asynchronous
2095 || arg->sym->attr.optional
2096 || arg->sym->attr.pointer
2097 || arg->sym->attr.target
2098 || arg->sym->attr.value
2099 || arg->sym->attr.volatile_)
2101 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2102 "has an attribute that requires an explicit "
2103 "interface for this procedure", arg->sym->name,
2104 sym->name, &sym->declared_at);
2107 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2108 else if (arg->sym && arg->sym->as
2109 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2111 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2112 "argument '%s' must have an explicit interface",
2113 sym->name, &sym->declared_at, arg->sym->name);
2116 /* F2008, 12.4.2.2 (2c) */
2117 else if (arg->sym->attr.codimension)
2119 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2120 "'%s' must have an explicit interface",
2121 sym->name, &sym->declared_at, arg->sym->name);
2124 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2125 else if (false) /* TODO: is a parametrized derived type */
2127 gfc_error ("Procedure '%s' at %L with parametrized derived "
2128 "type argument '%s' must have an explicit "
2129 "interface", sym->name, &sym->declared_at,
2133 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2134 else if (arg->sym->ts.type == BT_CLASS)
2136 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2137 "argument '%s' must have an explicit interface",
2138 sym->name, &sym->declared_at, arg->sym->name);
2143 if (def_sym->attr.function)
2145 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2146 if (def_sym->as && def_sym->as->rank
2147 && (!sym->as || sym->as->rank != def_sym->as->rank))
2148 gfc_error ("The reference to function '%s' at %L either needs an "
2149 "explicit INTERFACE or the rank is incorrect", sym->name,
2152 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2153 if ((def_sym->result->attr.pointer
2154 || def_sym->result->attr.allocatable)
2155 && (sym->attr.if_source != IFSRC_IFBODY
2156 || def_sym->result->attr.pointer
2157 != sym->result->attr.pointer
2158 || def_sym->result->attr.allocatable
2159 != sym->result->attr.allocatable))
2160 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2161 "result must have an explicit interface", sym->name,
2164 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2165 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2166 && def_sym->ts.u.cl->length != NULL)
2168 gfc_charlen *cl = sym->ts.u.cl;
2170 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2171 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2173 gfc_error ("Nonconstant character-length function '%s' at %L "
2174 "must have an explicit interface", sym->name,
2180 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2181 if (def_sym->attr.elemental && !sym->attr.elemental)
2183 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2184 "interface", sym->name, &sym->declared_at);
2187 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2188 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2190 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2191 "an explicit interface", sym->name, &sym->declared_at);
2194 if (gfc_option.flag_whole_file == 1
2195 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2196 && !(gfc_option.warn_std & GFC_STD_GNU)))
2197 gfc_errors_to_warnings (1);
2199 if (sym->attr.if_source != IFSRC_IFBODY)
2200 gfc_procedure_use (def_sym, actual, where);
2202 gfc_errors_to_warnings (0);
2205 if (gsym->type == GSYM_UNKNOWN)
2208 gsym->where = *where;
2215 /************* Function resolution *************/
2217 /* Resolve a function call known to be generic.
2218 Section 14.1.2.4.1. */
2221 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2225 if (sym->attr.generic)
2227 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2230 expr->value.function.name = s->name;
2231 expr->value.function.esym = s;
2233 if (s->ts.type != BT_UNKNOWN)
2235 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2236 expr->ts = s->result->ts;
2239 expr->rank = s->as->rank;
2240 else if (s->result != NULL && s->result->as != NULL)
2241 expr->rank = s->result->as->rank;
2243 gfc_set_sym_referenced (expr->value.function.esym);
2248 /* TODO: Need to search for elemental references in generic
2252 if (sym->attr.intrinsic)
2253 return gfc_intrinsic_func_interface (expr, 0);
2260 resolve_generic_f (gfc_expr *expr)
2265 sym = expr->symtree->n.sym;
2269 m = resolve_generic_f0 (expr, sym);
2272 else if (m == MATCH_ERROR)
2276 if (sym->ns->parent == NULL)
2278 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2282 if (!generic_sym (sym))
2286 /* Last ditch attempt. See if the reference is to an intrinsic
2287 that possesses a matching interface. 14.1.2.4 */
2288 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2290 gfc_error ("There is no specific function for the generic '%s' at %L",
2291 expr->symtree->n.sym->name, &expr->where);
2295 m = gfc_intrinsic_func_interface (expr, 0);
2299 gfc_error ("Generic function '%s' at %L is not consistent with a "
2300 "specific intrinsic interface", expr->symtree->n.sym->name,
2307 /* Resolve a function call known to be specific. */
2310 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2314 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2316 if (sym->attr.dummy)
2318 sym->attr.proc = PROC_DUMMY;
2322 sym->attr.proc = PROC_EXTERNAL;
2326 if (sym->attr.proc == PROC_MODULE
2327 || sym->attr.proc == PROC_ST_FUNCTION
2328 || sym->attr.proc == PROC_INTERNAL)
2331 if (sym->attr.intrinsic)
2333 m = gfc_intrinsic_func_interface (expr, 1);
2337 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2338 "with an intrinsic", sym->name, &expr->where);
2346 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2349 expr->ts = sym->result->ts;
2352 expr->value.function.name = sym->name;
2353 expr->value.function.esym = sym;
2354 if (sym->as != NULL)
2355 expr->rank = sym->as->rank;
2362 resolve_specific_f (gfc_expr *expr)
2367 sym = expr->symtree->n.sym;
2371 m = resolve_specific_f0 (sym, expr);
2374 if (m == MATCH_ERROR)
2377 if (sym->ns->parent == NULL)
2380 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2386 gfc_error ("Unable to resolve the specific function '%s' at %L",
2387 expr->symtree->n.sym->name, &expr->where);
2393 /* Resolve a procedure call not known to be generic nor specific. */
2396 resolve_unknown_f (gfc_expr *expr)
2401 sym = expr->symtree->n.sym;
2403 if (sym->attr.dummy)
2405 sym->attr.proc = PROC_DUMMY;
2406 expr->value.function.name = sym->name;
2410 /* See if we have an intrinsic function reference. */
2412 if (gfc_is_intrinsic (sym, 0, expr->where))
2414 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2419 /* The reference is to an external name. */
2421 sym->attr.proc = PROC_EXTERNAL;
2422 expr->value.function.name = sym->name;
2423 expr->value.function.esym = expr->symtree->n.sym;
2425 if (sym->as != NULL)
2426 expr->rank = sym->as->rank;
2428 /* Type of the expression is either the type of the symbol or the
2429 default type of the symbol. */
2432 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2434 if (sym->ts.type != BT_UNKNOWN)
2438 ts = gfc_get_default_type (sym->name, sym->ns);
2440 if (ts->type == BT_UNKNOWN)
2442 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2443 sym->name, &expr->where);
2454 /* Return true, if the symbol is an external procedure. */
2456 is_external_proc (gfc_symbol *sym)
2458 if (!sym->attr.dummy && !sym->attr.contained
2459 && !(sym->attr.intrinsic
2460 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2461 && sym->attr.proc != PROC_ST_FUNCTION
2462 && !sym->attr.proc_pointer
2463 && !sym->attr.use_assoc
2471 /* Figure out if a function reference is pure or not. Also set the name
2472 of the function for a potential error message. Return nonzero if the
2473 function is PURE, zero if not. */
2475 pure_stmt_function (gfc_expr *, gfc_symbol *);
2478 pure_function (gfc_expr *e, const char **name)
2484 if (e->symtree != NULL
2485 && e->symtree->n.sym != NULL
2486 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2487 return pure_stmt_function (e, e->symtree->n.sym);
2489 if (e->value.function.esym)
2491 pure = gfc_pure (e->value.function.esym);
2492 *name = e->value.function.esym->name;
2494 else if (e->value.function.isym)
2496 pure = e->value.function.isym->pure
2497 || e->value.function.isym->elemental;
2498 *name = e->value.function.isym->name;
2502 /* Implicit functions are not pure. */
2504 *name = e->value.function.name;
2512 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2513 int *f ATTRIBUTE_UNUSED)
2517 /* Don't bother recursing into other statement functions
2518 since they will be checked individually for purity. */
2519 if (e->expr_type != EXPR_FUNCTION
2521 || e->symtree->n.sym == sym
2522 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2525 return pure_function (e, &name) ? false : true;
2530 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2532 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2537 is_scalar_expr_ptr (gfc_expr *expr)
2539 gfc_try retval = SUCCESS;
2544 /* See if we have a gfc_ref, which means we have a substring, array
2545 reference, or a component. */
2546 if (expr->ref != NULL)
2549 while (ref->next != NULL)
2555 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2556 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2561 if (ref->u.ar.type == AR_ELEMENT)
2563 else if (ref->u.ar.type == AR_FULL)
2565 /* The user can give a full array if the array is of size 1. */
2566 if (ref->u.ar.as != NULL
2567 && ref->u.ar.as->rank == 1
2568 && ref->u.ar.as->type == AS_EXPLICIT
2569 && ref->u.ar.as->lower[0] != NULL
2570 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2571 && ref->u.ar.as->upper[0] != NULL
2572 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2574 /* If we have a character string, we need to check if
2575 its length is one. */
2576 if (expr->ts.type == BT_CHARACTER)
2578 if (expr->ts.u.cl == NULL
2579 || expr->ts.u.cl->length == NULL
2580 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2586 /* We have constant lower and upper bounds. If the
2587 difference between is 1, it can be considered a
2589 FIXME: Use gfc_dep_compare_expr instead. */
2590 start = (int) mpz_get_si
2591 (ref->u.ar.as->lower[0]->value.integer);
2592 end = (int) mpz_get_si
2593 (ref->u.ar.as->upper[0]->value.integer);
2594 if (end - start + 1 != 1)
2609 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2611 /* Character string. Make sure it's of length 1. */
2612 if (expr->ts.u.cl == NULL
2613 || expr->ts.u.cl->length == NULL
2614 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2617 else if (expr->rank != 0)
2624 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2625 and, in the case of c_associated, set the binding label based on
2629 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2630 gfc_symbol **new_sym)
2632 char name[GFC_MAX_SYMBOL_LEN + 1];
2633 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2634 int optional_arg = 0;
2635 gfc_try retval = SUCCESS;
2636 gfc_symbol *args_sym;
2637 gfc_typespec *arg_ts;
2638 symbol_attribute arg_attr;
2640 if (args->expr->expr_type == EXPR_CONSTANT
2641 || args->expr->expr_type == EXPR_OP
2642 || args->expr->expr_type == EXPR_NULL)
2644 gfc_error ("Argument to '%s' at %L is not a variable",
2645 sym->name, &(args->expr->where));
2649 args_sym = args->expr->symtree->n.sym;
2651 /* The typespec for the actual arg should be that stored in the expr
2652 and not necessarily that of the expr symbol (args_sym), because
2653 the actual expression could be a part-ref of the expr symbol. */
2654 arg_ts = &(args->expr->ts);
2655 arg_attr = gfc_expr_attr (args->expr);
2657 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2659 /* If the user gave two args then they are providing something for
2660 the optional arg (the second cptr). Therefore, set the name and
2661 binding label to the c_associated for two cptrs. Otherwise,
2662 set c_associated to expect one cptr. */
2666 sprintf (name, "%s_2", sym->name);
2667 sprintf (binding_label, "%s_2", sym->binding_label);
2673 sprintf (name, "%s_1", sym->name);
2674 sprintf (binding_label, "%s_1", sym->binding_label);
2678 /* Get a new symbol for the version of c_associated that
2680 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2682 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2683 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2685 sprintf (name, "%s", sym->name);
2686 sprintf (binding_label, "%s", sym->binding_label);
2688 /* Error check the call. */
2689 if (args->next != NULL)
2691 gfc_error_now ("More actual than formal arguments in '%s' "
2692 "call at %L", name, &(args->expr->where));
2695 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2697 /* Make sure we have either the target or pointer attribute. */
2698 if (!arg_attr.target && !arg_attr.pointer)
2700 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2701 "a TARGET or an associated pointer",
2703 sym->name, &(args->expr->where));
2707 /* See if we have interoperable type and type param. */
2708 if (verify_c_interop (arg_ts) == SUCCESS
2709 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2711 if (args_sym->attr.target == 1)
2713 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2714 has the target attribute and is interoperable. */
2715 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2716 allocatable variable that has the TARGET attribute and
2717 is not an array of zero size. */
2718 if (args_sym->attr.allocatable == 1)
2720 if (args_sym->attr.dimension != 0
2721 && (args_sym->as && args_sym->as->rank == 0))
2723 gfc_error_now ("Allocatable variable '%s' used as a "
2724 "parameter to '%s' at %L must not be "
2725 "an array of zero size",
2726 args_sym->name, sym->name,
2727 &(args->expr->where));
2733 /* A non-allocatable target variable with C
2734 interoperable type and type parameters must be
2736 if (args_sym && args_sym->attr.dimension)
2738 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2740 gfc_error ("Assumed-shape array '%s' at %L "
2741 "cannot be an argument to the "
2742 "procedure '%s' because "
2743 "it is not C interoperable",
2745 &(args->expr->where), sym->name);
2748 else if (args_sym->as->type == AS_DEFERRED)
2750 gfc_error ("Deferred-shape array '%s' at %L "
2751 "cannot be an argument to the "
2752 "procedure '%s' because "
2753 "it is not C interoperable",
2755 &(args->expr->where), sym->name);
2760 /* Make sure it's not a character string. Arrays of
2761 any type should be ok if the variable is of a C
2762 interoperable type. */
2763 if (arg_ts->type == BT_CHARACTER)
2764 if (arg_ts->u.cl != NULL
2765 && (arg_ts->u.cl->length == NULL
2766 || arg_ts->u.cl->length->expr_type
2769 (arg_ts->u.cl->length->value.integer, 1)
2771 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2773 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2774 "at %L must have a length of 1",
2775 args_sym->name, sym->name,
2776 &(args->expr->where));
2781 else if (arg_attr.pointer
2782 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2784 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2786 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2787 "associated scalar POINTER", args_sym->name,
2788 sym->name, &(args->expr->where));
2794 /* The parameter is not required to be C interoperable. If it
2795 is not C interoperable, it must be a nonpolymorphic scalar
2796 with no length type parameters. It still must have either
2797 the pointer or target attribute, and it can be
2798 allocatable (but must be allocated when c_loc is called). */
2799 if (args->expr->rank != 0
2800 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2802 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2803 "scalar", args_sym->name, sym->name,
2804 &(args->expr->where));
2807 else if (arg_ts->type == BT_CHARACTER
2808 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2810 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2811 "%L must have a length of 1",
2812 args_sym->name, sym->name,
2813 &(args->expr->where));
2816 else if (arg_ts->type == BT_CLASS)
2818 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2819 "polymorphic", args_sym->name, sym->name,
2820 &(args->expr->where));
2825 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2827 if (args_sym->attr.flavor != FL_PROCEDURE)
2829 /* TODO: Update this error message to allow for procedure
2830 pointers once they are implemented. */
2831 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2833 args_sym->name, sym->name,
2834 &(args->expr->where));
2837 else if (args_sym->attr.is_bind_c != 1)
2839 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2841 args_sym->name, sym->name,
2842 &(args->expr->where));
2847 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2852 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2853 "iso_c_binding function: '%s'!\n", sym->name);
2860 /* Resolve a function call, which means resolving the arguments, then figuring
2861 out which entity the name refers to. */
2864 resolve_function (gfc_expr *expr)
2866 gfc_actual_arglist *arg;
2871 procedure_type p = PROC_INTRINSIC;
2872 bool no_formal_args;
2876 sym = expr->symtree->n.sym;
2878 /* If this is a procedure pointer component, it has already been resolved. */
2879 if (gfc_is_proc_ptr_comp (expr, NULL))
2882 if (sym && sym->attr.intrinsic
2883 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2886 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2888 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2892 /* If this ia a deferred TBP with an abstract interface (which may
2893 of course be referenced), expr->value.function.esym will be set. */
2894 if (sym && sym->attr.abstract && !expr->value.function.esym)
2896 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2897 sym->name, &expr->where);
2901 /* Switch off assumed size checking and do this again for certain kinds
2902 of procedure, once the procedure itself is resolved. */
2903 need_full_assumed_size++;
2905 if (expr->symtree && expr->symtree->n.sym)
2906 p = expr->symtree->n.sym->attr.proc;
2908 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2909 inquiry_argument = true;
2910 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2912 if (resolve_actual_arglist (expr->value.function.actual,
2913 p, no_formal_args) == FAILURE)
2915 inquiry_argument = false;
2919 inquiry_argument = false;
2921 /* Need to setup the call to the correct c_associated, depending on
2922 the number of cptrs to user gives to compare. */
2923 if (sym && sym->attr.is_iso_c == 1)
2925 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2929 /* Get the symtree for the new symbol (resolved func).
2930 the old one will be freed later, when it's no longer used. */
2931 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2934 /* Resume assumed_size checking. */
2935 need_full_assumed_size--;
2937 /* If the procedure is external, check for usage. */
2938 if (sym && is_external_proc (sym))
2939 resolve_global_procedure (sym, &expr->where,
2940 &expr->value.function.actual, 0);
2942 if (sym && sym->ts.type == BT_CHARACTER
2944 && sym->ts.u.cl->length == NULL
2946 && expr->value.function.esym == NULL
2947 && !sym->attr.contained)
2949 /* Internal procedures are taken care of in resolve_contained_fntype. */
2950 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2951 "be used at %L since it is not a dummy argument",
2952 sym->name, &expr->where);
2956 /* See if function is already resolved. */
2958 if (expr->value.function.name != NULL)
2960 if (expr->ts.type == BT_UNKNOWN)
2966 /* Apply the rules of section 14.1.2. */
2968 switch (procedure_kind (sym))
2971 t = resolve_generic_f (expr);
2974 case PTYPE_SPECIFIC:
2975 t = resolve_specific_f (expr);
2979 t = resolve_unknown_f (expr);
2983 gfc_internal_error ("resolve_function(): bad function type");
2987 /* If the expression is still a function (it might have simplified),
2988 then we check to see if we are calling an elemental function. */
2990 if (expr->expr_type != EXPR_FUNCTION)
2993 temp = need_full_assumed_size;
2994 need_full_assumed_size = 0;
2996 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2999 if (omp_workshare_flag
3000 && expr->value.function.esym
3001 && ! gfc_elemental (expr->value.function.esym))
3003 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3004 "in WORKSHARE construct", expr->value.function.esym->name,
3009 #define GENERIC_ID expr->value.function.isym->id
3010 else if (expr->value.function.actual != NULL
3011 && expr->value.function.isym != NULL
3012 && GENERIC_ID != GFC_ISYM_LBOUND
3013 && GENERIC_ID != GFC_ISYM_LEN
3014 && GENERIC_ID != GFC_ISYM_LOC
3015 && GENERIC_ID != GFC_ISYM_PRESENT)
3017 /* Array intrinsics must also have the last upper bound of an
3018 assumed size array argument. UBOUND and SIZE have to be
3019 excluded from the check if the second argument is anything
3022 for (arg = expr->value.function.actual; arg; arg = arg->next)
3024 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3025 && arg->next != NULL && arg->next->expr)
3027 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3030 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3033 if ((int)mpz_get_si (arg->next->expr->value.integer)
3038 if (arg->expr != NULL
3039 && arg->expr->rank > 0
3040 && resolve_assumed_size_actual (arg->expr))
3046 need_full_assumed_size = temp;
3049 if (!pure_function (expr, &name) && name)
3053 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3054 "FORALL %s", name, &expr->where,
3055 forall_flag == 2 ? "mask" : "block");
3058 else if (gfc_pure (NULL))
3060 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3061 "procedure within a PURE procedure", name, &expr->where);
3066 if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
3067 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3069 /* Functions without the RECURSIVE attribution are not allowed to
3070 * call themselves. */
3071 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3074 esym = expr->value.function.esym;
3076 if (is_illegal_recursion (esym, gfc_current_ns))
3078 if (esym->attr.entry && esym->ns->entries)
3079 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3080 " function '%s' is not RECURSIVE",
3081 esym->name, &expr->where, esym->ns->entries->sym->name);
3083 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3084 " is not RECURSIVE", esym->name, &expr->where);
3090 /* Character lengths of use associated functions may contains references to
3091 symbols not referenced from the current program unit otherwise. Make sure
3092 those symbols are marked as referenced. */
3094 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3095 && expr->value.function.esym->attr.use_assoc)
3097 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3100 /* Make sure that the expression has a typespec that works. */
3101 if (expr->ts.type == BT_UNKNOWN)
3103 if (expr->symtree->n.sym->result
3104 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3105 && !expr->symtree->n.sym->result->attr.proc_pointer)
3106 expr->ts = expr->symtree->n.sym->result->ts;
3113 /************* Subroutine resolution *************/
3116 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3122 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3123 sym->name, &c->loc);
3124 else if (gfc_pure (NULL))
3125 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3131 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3135 if (sym->attr.generic)
3137 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3140 c->resolved_sym = s;
3141 pure_subroutine (c, s);
3145 /* TODO: Need to search for elemental references in generic interface. */
3148 if (sym->attr.intrinsic)
3149 return gfc_intrinsic_sub_interface (c, 0);
3156 resolve_generic_s (gfc_code *c)
3161 sym = c->symtree->n.sym;
3165 m = resolve_generic_s0 (c, sym);
3168 else if (m == MATCH_ERROR)
3172 if (sym->ns->parent == NULL)
3174 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3178 if (!generic_sym (sym))
3182 /* Last ditch attempt. See if the reference is to an intrinsic
3183 that possesses a matching interface. 14.1.2.4 */
3184 sym = c->symtree->n.sym;
3186 if (!gfc_is_intrinsic (sym, 1, c->loc))
3188 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3189 sym->name, &c->loc);
3193 m = gfc_intrinsic_sub_interface (c, 0);
3197 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3198 "intrinsic subroutine interface", sym->name, &c->loc);
3204 /* Set the name and binding label of the subroutine symbol in the call
3205 expression represented by 'c' to include the type and kind of the
3206 second parameter. This function is for resolving the appropriate
3207 version of c_f_pointer() and c_f_procpointer(). For example, a
3208 call to c_f_pointer() for a default integer pointer could have a
3209 name of c_f_pointer_i4. If no second arg exists, which is an error
3210 for these two functions, it defaults to the generic symbol's name
3211 and binding label. */
3214 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3215 char *name, char *binding_label)
3217 gfc_expr *arg = NULL;
3221 /* The second arg of c_f_pointer and c_f_procpointer determines
3222 the type and kind for the procedure name. */
3223 arg = c->ext.actual->next->expr;
3227 /* Set up the name to have the given symbol's name,
3228 plus the type and kind. */
3229 /* a derived type is marked with the type letter 'u' */
3230 if (arg->ts.type == BT_DERIVED)
3233 kind = 0; /* set the kind as 0 for now */
3237 type = gfc_type_letter (arg->ts.type);
3238 kind = arg->ts.kind;
3241 if (arg->ts.type == BT_CHARACTER)
3242 /* Kind info for character strings not needed. */
3245 sprintf (name, "%s_%c%d", sym->name, type, kind);
3246 /* Set up the binding label as the given symbol's label plus
3247 the type and kind. */
3248 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3252 /* If the second arg is missing, set the name and label as
3253 was, cause it should at least be found, and the missing
3254 arg error will be caught by compare_parameters(). */
3255 sprintf (name, "%s", sym->name);
3256 sprintf (binding_label, "%s", sym->binding_label);
3263 /* Resolve a generic version of the iso_c_binding procedure given
3264 (sym) to the specific one based on the type and kind of the
3265 argument(s). Currently, this function resolves c_f_pointer() and
3266 c_f_procpointer based on the type and kind of the second argument
3267 (FPTR). Other iso_c_binding procedures aren't specially handled.
3268 Upon successfully exiting, c->resolved_sym will hold the resolved
3269 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3273 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3275 gfc_symbol *new_sym;
3276 /* this is fine, since we know the names won't use the max */
3277 char name[GFC_MAX_SYMBOL_LEN + 1];
3278 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3279 /* default to success; will override if find error */
3280 match m = MATCH_YES;
3282 /* Make sure the actual arguments are in the necessary order (based on the
3283 formal args) before resolving. */
3284 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3286 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3287 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3289 set_name_and_label (c, sym, name, binding_label);
3291 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3293 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3295 /* Make sure we got a third arg if the second arg has non-zero
3296 rank. We must also check that the type and rank are
3297 correct since we short-circuit this check in
3298 gfc_procedure_use() (called above to sort actual args). */
3299 if (c->ext.actual->next->expr->rank != 0)
3301 if(c->ext.actual->next->next == NULL
3302 || c->ext.actual->next->next->expr == NULL)
3305 gfc_error ("Missing SHAPE parameter for call to %s "
3306 "at %L", sym->name, &(c->loc));
3308 else if (c->ext.actual->next->next->expr->ts.type
3310 || c->ext.actual->next->next->expr->rank != 1)
3313 gfc_error ("SHAPE parameter for call to %s at %L must "
3314 "be a rank 1 INTEGER array", sym->name,
3321 if (m != MATCH_ERROR)
3323 /* the 1 means to add the optional arg to formal list */
3324 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3326 /* for error reporting, say it's declared where the original was */
3327 new_sym->declared_at = sym->declared_at;
3332 /* no differences for c_loc or c_funloc */
3336 /* set the resolved symbol */
3337 if (m != MATCH_ERROR)
3338 c->resolved_sym = new_sym;
3340 c->resolved_sym = sym;
3346 /* Resolve a subroutine call known to be specific. */
3349 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3353 if(sym->attr.is_iso_c)
3355 m = gfc_iso_c_sub_interface (c,sym);
3359 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3361 if (sym->attr.dummy)
3363 sym->attr.proc = PROC_DUMMY;
3367 sym->attr.proc = PROC_EXTERNAL;
3371 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3374 if (sym->attr.intrinsic)
3376 m = gfc_intrinsic_sub_interface (c, 1);
3380 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3381 "with an intrinsic", sym->name, &c->loc);
3389 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3391 c->resolved_sym = sym;
3392 pure_subroutine (c, sym);
3399 resolve_specific_s (gfc_code *c)
3404 sym = c->symtree->n.sym;
3408 m = resolve_specific_s0 (c, sym);
3411 if (m == MATCH_ERROR)
3414 if (sym->ns->parent == NULL)
3417 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3423 sym = c->symtree->n.sym;
3424 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3425 sym->name, &c->loc);
3431 /* Resolve a subroutine call not known to be generic nor specific. */
3434 resolve_unknown_s (gfc_code *c)
3438 sym = c->symtree->n.sym;
3440 if (sym->attr.dummy)
3442 sym->attr.proc = PROC_DUMMY;
3446 /* See if we have an intrinsic function reference. */
3448 if (gfc_is_intrinsic (sym, 1, c->loc))
3450 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3455 /* The reference is to an external name. */
3458 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3460 c->resolved_sym = sym;
3462 pure_subroutine (c, sym);
3468 /* Resolve a subroutine call. Although it was tempting to use the same code
3469 for functions, subroutines and functions are stored differently and this
3470 makes things awkward. */
3473 resolve_call (gfc_code *c)
3476 procedure_type ptype = PROC_INTRINSIC;
3477 gfc_symbol *csym, *sym;
3478 bool no_formal_args;
3480 csym = c->symtree ? c->symtree->n.sym : NULL;
3482 if (csym && csym->ts.type != BT_UNKNOWN)
3484 gfc_error ("'%s' at %L has a type, which is not consistent with "
3485 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3489 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3492 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3493 sym = st ? st->n.sym : NULL;
3494 if (sym && csym != sym
3495 && sym->ns == gfc_current_ns
3496 && sym->attr.flavor == FL_PROCEDURE
3497 && sym->attr.contained)
3500 if (csym->attr.generic)
3501 c->symtree->n.sym = sym;
3504 csym = c->symtree->n.sym;
3508 /* If this ia a deferred TBP with an abstract interface
3509 (which may of course be referenced), c->expr1 will be set. */
3510 if (csym && csym->attr.abstract && !c->expr1)
3512 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3513 csym->name, &c->loc);
3517 /* Subroutines without the RECURSIVE attribution are not allowed to
3518 * call themselves. */
3519 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3521 if (csym->attr.entry && csym->ns->entries)
3522 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3523 " subroutine '%s' is not RECURSIVE",
3524 csym->name, &c->loc, csym->ns->entries->sym->name);
3526 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3527 " is not RECURSIVE", csym->name, &c->loc);
3532 /* Switch off assumed size checking and do this again for certain kinds
3533 of procedure, once the procedure itself is resolved. */
3534 need_full_assumed_size++;
3537 ptype = csym->attr.proc;
3539 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3540 if (resolve_actual_arglist (c->ext.actual, ptype,
3541 no_formal_args) == FAILURE)
3544 /* Resume assumed_size checking. */
3545 need_full_assumed_size--;
3547 /* If external, check for usage. */
3548 if (csym && is_external_proc (csym))
3549 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3552 if (c->resolved_sym == NULL)
3554 c->resolved_isym = NULL;
3555 switch (procedure_kind (csym))
3558 t = resolve_generic_s (c);
3561 case PTYPE_SPECIFIC:
3562 t = resolve_specific_s (c);
3566 t = resolve_unknown_s (c);
3570 gfc_internal_error ("resolve_subroutine(): bad function type");
3574 /* Some checks of elemental subroutine actual arguments. */
3575 if (resolve_elemental_actual (NULL, c) == FAILURE)
3582 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3583 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3584 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3585 if their shapes do not match. If either op1->shape or op2->shape is
3586 NULL, return SUCCESS. */
3589 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3596 if (op1->shape != NULL && op2->shape != NULL)
3598 for (i = 0; i < op1->rank; i++)
3600 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3602 gfc_error ("Shapes for operands at %L and %L are not conformable",
3603 &op1->where, &op2->where);
3614 /* Resolve an operator expression node. This can involve replacing the
3615 operation with a user defined function call. */
3618 resolve_operator (gfc_expr *e)
3620 gfc_expr *op1, *op2;
3622 bool dual_locus_error;
3625 /* Resolve all subnodes-- give them types. */
3627 switch (e->value.op.op)
3630 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3633 /* Fall through... */
3636 case INTRINSIC_UPLUS:
3637 case INTRINSIC_UMINUS:
3638 case INTRINSIC_PARENTHESES:
3639 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3644 /* Typecheck the new node. */
3646 op1 = e->value.op.op1;
3647 op2 = e->value.op.op2;
3648 dual_locus_error = false;
3650 if ((op1 && op1->expr_type == EXPR_NULL)
3651 || (op2 && op2->expr_type == EXPR_NULL))
3653 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3657 switch (e->value.op.op)
3659 case INTRINSIC_UPLUS:
3660 case INTRINSIC_UMINUS:
3661 if (op1->ts.type == BT_INTEGER
3662 || op1->ts.type == BT_REAL
3663 || op1->ts.type == BT_COMPLEX)
3669 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3670 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3673 case INTRINSIC_PLUS:
3674 case INTRINSIC_MINUS:
3675 case INTRINSIC_TIMES:
3676 case INTRINSIC_DIVIDE:
3677 case INTRINSIC_POWER:
3678 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3680 gfc_type_convert_binary (e, 1);
3685 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3686 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3687 gfc_typename (&op2->ts));
3690 case INTRINSIC_CONCAT:
3691 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3692 && op1->ts.kind == op2->ts.kind)
3694 e->ts.type = BT_CHARACTER;
3695 e->ts.kind = op1->ts.kind;
3700 _("Operands of string concatenation operator at %%L are %s/%s"),
3701 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3707 case INTRINSIC_NEQV:
3708 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3710 e->ts.type = BT_LOGICAL;
3711 e->ts.kind = gfc_kind_max (op1, op2);
3712 if (op1->ts.kind < e->ts.kind)
3713 gfc_convert_type (op1, &e->ts, 2);
3714 else if (op2->ts.kind < e->ts.kind)
3715 gfc_convert_type (op2, &e->ts, 2);
3719 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3720 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3721 gfc_typename (&op2->ts));
3726 if (op1->ts.type == BT_LOGICAL)
3728 e->ts.type = BT_LOGICAL;
3729 e->ts.kind = op1->ts.kind;
3733 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3734 gfc_typename (&op1->ts));
3738 case INTRINSIC_GT_OS:
3740 case INTRINSIC_GE_OS:
3742 case INTRINSIC_LT_OS:
3744 case INTRINSIC_LE_OS:
3745 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3747 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3751 /* Fall through... */
3754 case INTRINSIC_EQ_OS:
3756 case INTRINSIC_NE_OS:
3757 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3758 && op1->ts.kind == op2->ts.kind)
3760 e->ts.type = BT_LOGICAL;
3761 e->ts.kind = gfc_default_logical_kind;
3765 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3767 gfc_type_convert_binary (e, 1);
3769 e->ts.type = BT_LOGICAL;
3770 e->ts.kind = gfc_default_logical_kind;
3774 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3776 _("Logicals at %%L must be compared with %s instead of %s"),
3777 (e->value.op.op == INTRINSIC_EQ
3778 || e->value.op.op == INTRINSIC_EQ_OS)
3779 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3782 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3783 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3784 gfc_typename (&op2->ts));
3788 case INTRINSIC_USER:
3789 if (e->value.op.uop->op == NULL)
3790 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3791 else if (op2 == NULL)
3792 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3793 e->value.op.uop->name, gfc_typename (&op1->ts));
3796 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3797 e->value.op.uop->name, gfc_typename (&op1->ts),
3798 gfc_typename (&op2->ts));
3799 e->value.op.uop->op->sym->attr.referenced = 1;
3804 case INTRINSIC_PARENTHESES:
3806 if (e->ts.type == BT_CHARACTER)
3807 e->ts.u.cl = op1->ts.u.cl;
3811 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3814 /* Deal with arrayness of an operand through an operator. */
3818 switch (e->value.op.op)
3820 case INTRINSIC_PLUS:
3821 case INTRINSIC_MINUS:
3822 case INTRINSIC_TIMES:
3823 case INTRINSIC_DIVIDE:
3824 case INTRINSIC_POWER:
3825 case INTRINSIC_CONCAT:
3829 case INTRINSIC_NEQV:
3831 case INTRINSIC_EQ_OS:
3833 case INTRINSIC_NE_OS:
3835 case INTRINSIC_GT_OS:
3837 case INTRINSIC_GE_OS:
3839 case INTRINSIC_LT_OS:
3841 case INTRINSIC_LE_OS:
3843 if (op1->rank == 0 && op2->rank == 0)
3846 if (op1->rank == 0 && op2->rank != 0)
3848 e->rank = op2->rank;
3850 if (e->shape == NULL)
3851 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3854 if (op1->rank != 0 && op2->rank == 0)
3856 e->rank = op1->rank;
3858 if (e->shape == NULL)
3859 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3862 if (op1->rank != 0 && op2->rank != 0)
3864 if (op1->rank == op2->rank)
3866 e->rank = op1->rank;
3867 if (e->shape == NULL)
3869 t = compare_shapes (op1, op2);
3873 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3878 /* Allow higher level expressions to work. */
3881 /* Try user-defined operators, and otherwise throw an error. */
3882 dual_locus_error = true;
3884 _("Inconsistent ranks for operator at %%L and %%L"));
3891 case INTRINSIC_PARENTHESES:
3893 case INTRINSIC_UPLUS:
3894 case INTRINSIC_UMINUS:
3895 /* Simply copy arrayness attribute */
3896 e->rank = op1->rank;
3898 if (e->shape == NULL)
3899 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3907 /* Attempt to simplify the expression. */
3910 t = gfc_simplify_expr (e, 0);
3911 /* Some calls do not succeed in simplification and return FAILURE
3912 even though there is no error; e.g. variable references to
3913 PARAMETER arrays. */
3914 if (!gfc_is_constant_expr (e))
3923 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3930 if (dual_locus_error)
3931 gfc_error (msg, &op1->where, &op2->where);
3933 gfc_error (msg, &e->where);
3939 /************** Array resolution subroutines **************/
3942 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3945 /* Compare two integer expressions. */
3948 compare_bound (gfc_expr *a, gfc_expr *b)
3952 if (a == NULL || a->expr_type != EXPR_CONSTANT
3953 || b == NULL || b->expr_type != EXPR_CONSTANT)
3956 /* If either of the types isn't INTEGER, we must have
3957 raised an error earlier. */
3959 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3962 i = mpz_cmp (a->value.integer, b->value.integer);
3972 /* Compare an integer expression with an integer. */
3975 compare_bound_int (gfc_expr *a, int b)
3979 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3982 if (a->ts.type != BT_INTEGER)
3983 gfc_internal_error ("compare_bound_int(): Bad expression");
3985 i = mpz_cmp_si (a->value.integer, b);
3995 /* Compare an integer expression with a mpz_t. */
3998 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4002 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4005 if (a->ts.type != BT_INTEGER)
4006 gfc_internal_error ("compare_bound_int(): Bad expression");
4008 i = mpz_cmp (a->value.integer, b);
4018 /* Compute the last value of a sequence given by a triplet.
4019 Return 0 if it wasn't able to compute the last value, or if the
4020 sequence if empty, and 1 otherwise. */
4023 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4024 gfc_expr *stride, mpz_t last)
4028 if (start == NULL || start->expr_type != EXPR_CONSTANT
4029 || end == NULL || end->expr_type != EXPR_CONSTANT
4030 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4033 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4034 || (stride != NULL && stride->ts.type != BT_INTEGER))
4037 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4039 if (compare_bound (start, end) == CMP_GT)
4041 mpz_set (last, end->value.integer);
4045 if (compare_bound_int (stride, 0) == CMP_GT)
4047 /* Stride is positive */
4048 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4053 /* Stride is negative */
4054 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4059 mpz_sub (rem, end->value.integer, start->value.integer);
4060 mpz_tdiv_r (rem, rem, stride->value.integer);
4061 mpz_sub (last, end->value.integer, rem);
4068 /* Compare a single dimension of an array reference to the array
4072 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4076 if (ar->dimen_type[i] == DIMEN_STAR)
4078 gcc_assert (ar->stride[i] == NULL);
4079 /* This implies [*] as [*:] and [*:3] are not possible. */
4080 if (ar->start[i] == NULL)
4082 gcc_assert (ar->end[i] == NULL);
4087 /* Given start, end and stride values, calculate the minimum and
4088 maximum referenced indexes. */
4090 switch (ar->dimen_type[i])
4097 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4100 gfc_warning ("Array reference at %L is out of bounds "
4101 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4102 mpz_get_si (ar->start[i]->value.integer),
4103 mpz_get_si (as->lower[i]->value.integer), i+1);
4105 gfc_warning ("Array reference at %L is out of bounds "
4106 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4107 mpz_get_si (ar->start[i]->value.integer),
4108 mpz_get_si (as->lower[i]->value.integer),
4112 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4115 gfc_warning ("Array reference at %L is out of bounds "
4116 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4117 mpz_get_si (ar->start[i]->value.integer),
4118 mpz_get_si (as->upper[i]->value.integer), i+1);
4120 gfc_warning ("Array reference at %L is out of bounds "
4121 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4122 mpz_get_si (ar->start[i]->value.integer),
4123 mpz_get_si (as->upper[i]->value.integer),
4132 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4133 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4135 comparison comp_start_end = compare_bound (AR_START, AR_END);
4137 /* Check for zero stride, which is not allowed. */
4138 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4140 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4144 /* if start == len || (stride > 0 && start < len)
4145 || (stride < 0 && start > len),
4146 then the array section contains at least one element. In this
4147 case, there is an out-of-bounds access if
4148 (start < lower || start > upper). */
4149 if (compare_bound (AR_START, AR_END) == CMP_EQ
4150 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4151 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4152 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4153 && comp_start_end == CMP_GT))
4155 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4157 gfc_warning ("Lower array reference at %L is out of bounds "
4158 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4159 mpz_get_si (AR_START->value.integer),
4160 mpz_get_si (as->lower[i]->value.integer), i+1);
4163 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4165 gfc_warning ("Lower array reference at %L is out of bounds "
4166 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4167 mpz_get_si (AR_START->value.integer),
4168 mpz_get_si (as->upper[i]->value.integer), i+1);
4173 /* If we can compute the highest index of the array section,
4174 then it also has to be between lower and upper. */
4175 mpz_init (last_value);
4176 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4179 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4181 gfc_warning ("Upper array reference at %L is out of bounds "
4182 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4183 mpz_get_si (last_value),
4184 mpz_get_si (as->lower[i]->value.integer), i+1);
4185 mpz_clear (last_value);
4188 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4190 gfc_warning ("Upper array reference at %L is out of bounds "
4191 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4192 mpz_get_si (last_value),
4193 mpz_get_si (as->upper[i]->value.integer), i+1);
4194 mpz_clear (last_value);
4198 mpz_clear (last_value);
4206 gfc_internal_error ("check_dimension(): Bad array reference");
4213 /* Compare an array reference with an array specification. */
4216 compare_spec_to_ref (gfc_array_ref *ar)
4223 /* TODO: Full array sections are only allowed as actual parameters. */
4224 if (as->type == AS_ASSUMED_SIZE
4225 && (/*ar->type == AR_FULL
4226 ||*/ (ar->type == AR_SECTION
4227 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4229 gfc_error ("Rightmost upper bound of assumed size array section "
4230 "not specified at %L", &ar->where);
4234 if (ar->type == AR_FULL)
4237 if (as->rank != ar->dimen)
4239 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4240 &ar->where, ar->dimen, as->rank);
4244 /* ar->codimen == 0 is a local array. */
4245 if (as->corank != ar->codimen && ar->codimen != 0)
4247 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4248 &ar->where, ar->codimen, as->corank);
4252 for (i = 0; i < as->rank; i++)
4253 if (check_dimension (i, ar, as) == FAILURE)
4256 /* Local access has no coarray spec. */
4257 if (ar->codimen != 0)
4258 for (i = as->rank; i < as->rank + as->corank; i++)
4260 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4262 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4263 i + 1 - as->rank, &ar->where);
4266 if (check_dimension (i, ar, as) == FAILURE)
4274 /* Resolve one part of an array index. */
4277 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4278 int force_index_integer_kind)
4285 if (gfc_resolve_expr (index) == FAILURE)
4288 if (check_scalar && index->rank != 0)
4290 gfc_error ("Array index at %L must be scalar", &index->where);
4294 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4296 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4297 &index->where, gfc_basic_typename (index->ts.type));
4301 if (index->ts.type == BT_REAL)
4302 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4303 &index->where) == FAILURE)
4306 if ((index->ts.kind != gfc_index_integer_kind
4307 && force_index_integer_kind)
4308 || index->ts.type != BT_INTEGER)
4311 ts.type = BT_INTEGER;
4312 ts.kind = gfc_index_integer_kind;
4314 gfc_convert_type_warn (index, &ts, 2, 0);
4320 /* Resolve one part of an array index. */
4323 gfc_resolve_index (gfc_expr *index, int check_scalar)
4325 return gfc_resolve_index_1 (index, check_scalar, 1);
4328 /* Resolve a dim argument to an intrinsic function. */
4331 gfc_resolve_dim_arg (gfc_expr *dim)
4336 if (gfc_resolve_expr (dim) == FAILURE)
4341 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4346 if (dim->ts.type != BT_INTEGER)
4348 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4352 if (dim->ts.kind != gfc_index_integer_kind)
4357 ts.type = BT_INTEGER;
4358 ts.kind = gfc_index_integer_kind;
4360 gfc_convert_type_warn (dim, &ts, 2, 0);
4366 /* Given an expression that contains array references, update those array
4367 references to point to the right array specifications. While this is
4368 filled in during matching, this information is difficult to save and load
4369 in a module, so we take care of it here.
4371 The idea here is that the original array reference comes from the
4372 base symbol. We traverse the list of reference structures, setting
4373 the stored reference to references. Component references can
4374 provide an additional array specification. */
4377 find_array_spec (gfc_expr *e)
4381 gfc_symbol *derived;
4384 if (e->symtree->n.sym->ts.type == BT_CLASS)
4385 as = CLASS_DATA (e->symtree->n.sym)->as;
4387 as = e->symtree->n.sym->as;
4390 for (ref = e->ref; ref; ref = ref->next)
4395 gfc_internal_error ("find_array_spec(): Missing spec");
4402 if (derived == NULL)
4403 derived = e->symtree->n.sym->ts.u.derived;
4405 if (derived->attr.is_class)
4406 derived = derived->components->ts.u.derived;
4408 c = derived->components;
4410 for (; c; c = c->next)
4411 if (c == ref->u.c.component)
4413 /* Track the sequence of component references. */
4414 if (c->ts.type == BT_DERIVED)
4415 derived = c->ts.u.derived;
4420 gfc_internal_error ("find_array_spec(): Component not found");
4422 if (c->attr.dimension)
4425 gfc_internal_error ("find_array_spec(): unused as(1)");
4436 gfc_internal_error ("find_array_spec(): unused as(2)");
4440 /* Resolve an array reference. */
4443 resolve_array_ref (gfc_array_ref *ar)
4445 int i, check_scalar;
4448 for (i = 0; i < ar->dimen + ar->codimen; i++)
4450 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4452 /* Do not force gfc_index_integer_kind for the start. We can
4453 do fine with any integer kind. This avoids temporary arrays
4454 created for indexing with a vector. */
4455 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4457 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4459 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4464 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4468 ar->dimen_type[i] = DIMEN_ELEMENT;
4472 ar->dimen_type[i] = DIMEN_VECTOR;
4473 if (e->expr_type == EXPR_VARIABLE
4474 && e->symtree->n.sym->ts.type == BT_DERIVED)
4475 ar->start[i] = gfc_get_parentheses (e);
4479 gfc_error ("Array index at %L is an array of rank %d",
4480 &ar->c_where[i], e->rank);
4484 /* Fill in the upper bound, which may be lower than the
4485 specified one for something like a(2:10:5), which is
4486 identical to a(2:7:5). Only relevant for strides not equal
4488 if (ar->dimen_type[i] == DIMEN_RANGE
4489 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4490 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4494 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4496 if (ar->end[i] == NULL)
4499 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4501 mpz_set (ar->end[i]->value.integer, end);
4503 else if (ar->end[i]->ts.type == BT_INTEGER
4504 && ar->end[i]->expr_type == EXPR_CONSTANT)
4506 mpz_set (ar->end[i]->value.integer, end);
4517 if (ar->type == AR_FULL && ar->as->rank == 0)
4518 ar->type = AR_ELEMENT;
4520 /* If the reference type is unknown, figure out what kind it is. */
4522 if (ar->type == AR_UNKNOWN)
4524 ar->type = AR_ELEMENT;
4525 for (i = 0; i < ar->dimen; i++)
4526 if (ar->dimen_type[i] == DIMEN_RANGE
4527 || ar->dimen_type[i] == DIMEN_VECTOR)
4529 ar->type = AR_SECTION;
4534 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4542 resolve_substring (gfc_ref *ref)
4544 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4546 if (ref->u.ss.start != NULL)
4548 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4551 if (ref->u.ss.start->ts.type != BT_INTEGER)
4553 gfc_error ("Substring start index at %L must be of type INTEGER",
4554 &ref->u.ss.start->where);
4558 if (ref->u.ss.start->rank != 0)
4560 gfc_error ("Substring start index at %L must be scalar",
4561 &ref->u.ss.start->where);
4565 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4566 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4567 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4569 gfc_error ("Substring start index at %L is less than one",
4570 &ref->u.ss.start->where);
4575 if (ref->u.ss.end != NULL)
4577 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4580 if (ref->u.ss.end->ts.type != BT_INTEGER)
4582 gfc_error ("Substring end index at %L must be of type INTEGER",
4583 &ref->u.ss.end->where);
4587 if (ref->u.ss.end->rank != 0)
4589 gfc_error ("Substring end index at %L must be scalar",
4590 &ref->u.ss.end->where);
4594 if (ref->u.ss.length != NULL
4595 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4596 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4597 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4599 gfc_error ("Substring end index at %L exceeds the string length",
4600 &ref->u.ss.start->where);
4604 if (compare_bound_mpz_t (ref->u.ss.end,
4605 gfc_integer_kinds[k].huge) == CMP_GT
4606 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4607 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4609 gfc_error ("Substring end index at %L is too large",
4610 &ref->u.ss.end->where);
4619 /* This function supplies missing substring charlens. */
4622 gfc_resolve_substring_charlen (gfc_expr *e)
4625 gfc_expr *start, *end;
4627 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4628 if (char_ref->type == REF_SUBSTRING)
4634 gcc_assert (char_ref->next == NULL);
4638 if (e->ts.u.cl->length)
4639 gfc_free_expr (e->ts.u.cl->length);
4640 else if (e->expr_type == EXPR_VARIABLE
4641 && e->symtree->n.sym->attr.dummy)
4645 e->ts.type = BT_CHARACTER;
4646 e->ts.kind = gfc_default_character_kind;
4649 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4651 if (char_ref->u.ss.start)
4652 start = gfc_copy_expr (char_ref->u.ss.start);
4654 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4656 if (char_ref->u.ss.end)
4657 end = gfc_copy_expr (char_ref->u.ss.end);
4658 else if (e->expr_type == EXPR_VARIABLE)
4659 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4666 /* Length = (end - start +1). */
4667 e->ts.u.cl->length = gfc_subtract (end, start);
4668 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4669 gfc_get_int_expr (gfc_default_integer_kind,
4672 e->ts.u.cl->length->ts.type = BT_INTEGER;
4673 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4675 /* Make sure that the length is simplified. */
4676 gfc_simplify_expr (e->ts.u.cl->length, 1);
4677 gfc_resolve_expr (e->ts.u.cl->length);
4681 /* Resolve subtype references. */
4684 resolve_ref (gfc_expr *expr)
4686 int current_part_dimension, n_components, seen_part_dimension;
4689 for (ref = expr->ref; ref; ref = ref->next)
4690 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4692 find_array_spec (expr);
4696 for (ref = expr->ref; ref; ref = ref->next)
4700 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4708 resolve_substring (ref);
4712 /* Check constraints on part references. */
4714 current_part_dimension = 0;
4715 seen_part_dimension = 0;
4718 for (ref = expr->ref; ref; ref = ref->next)
4723 switch (ref->u.ar.type)
4726 /* Coarray scalar. */
4727 if (ref->u.ar.as->rank == 0)
4729 current_part_dimension = 0;
4734 current_part_dimension = 1;
4738 current_part_dimension = 0;
4742 gfc_internal_error ("resolve_ref(): Bad array reference");
4748 if (current_part_dimension || seen_part_dimension)
4751 if (ref->u.c.component->attr.pointer
4752 || ref->u.c.component->attr.proc_pointer)
4754 gfc_error ("Component to the right of a part reference "
4755 "with nonzero rank must not have the POINTER "
4756 "attribute at %L", &expr->where);
4759 else if (ref->u.c.component->attr.allocatable)
4761 gfc_error ("Component to the right of a part reference "
4762 "with nonzero rank must not have the ALLOCATABLE "
4763 "attribute at %L", &expr->where);
4775 if (((ref->type == REF_COMPONENT && n_components > 1)
4776 || ref->next == NULL)
4777 && current_part_dimension
4778 && seen_part_dimension)
4780 gfc_error ("Two or more part references with nonzero rank must "
4781 "not be specified at %L", &expr->where);
4785 if (ref->type == REF_COMPONENT)
4787 if (current_part_dimension)
4788 seen_part_dimension = 1;
4790 /* reset to make sure */
4791 current_part_dimension = 0;
4799 /* Given an expression, determine its shape. This is easier than it sounds.
4800 Leaves the shape array NULL if it is not possible to determine the shape. */
4803 expression_shape (gfc_expr *e)
4805 mpz_t array[GFC_MAX_DIMENSIONS];
4808 if (e->rank == 0 || e->shape != NULL)
4811 for (i = 0; i < e->rank; i++)
4812 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4815 e->shape = gfc_get_shape (e->rank);
4817 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4822 for (i--; i >= 0; i--)
4823 mpz_clear (array[i]);
4827 /* Given a variable expression node, compute the rank of the expression by
4828 examining the base symbol and any reference structures it may have. */
4831 expression_rank (gfc_expr *e)
4836 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4837 could lead to serious confusion... */
4838 gcc_assert (e->expr_type != EXPR_COMPCALL);
4842 if (e->expr_type == EXPR_ARRAY)
4844 /* Constructors can have a rank different from one via RESHAPE(). */
4846 if (e->symtree == NULL)
4852 e->rank = (e->symtree->n.sym->as == NULL)
4853 ? 0 : e->symtree->n.sym->as->rank;
4859 for (ref = e->ref; ref; ref = ref->next)
4861 if (ref->type != REF_ARRAY)
4864 if (ref->u.ar.type == AR_FULL)
4866 rank = ref->u.ar.as->rank;
4870 if (ref->u.ar.type == AR_SECTION)
4872 /* Figure out the rank of the section. */
4874 gfc_internal_error ("expression_rank(): Two array specs");
4876 for (i = 0; i < ref->u.ar.dimen; i++)
4877 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4878 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4888 expression_shape (e);
4892 /* Resolve a variable expression. */
4895 resolve_variable (gfc_expr *e)
4902 if (e->symtree == NULL)
4904 sym = e->symtree->n.sym;
4906 /* If this is an associate-name, it may be parsed with an array reference
4907 in error even though the target is scalar. Fail directly in this case. */
4908 if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
4911 /* On the other hand, the parser may not have known this is an array;
4912 in this case, we have to add a FULL reference. */
4913 if (sym->assoc && sym->attr.dimension && !e->ref)
4915 e->ref = gfc_get_ref ();
4916 e->ref->type = REF_ARRAY;
4917 e->ref->u.ar.type = AR_FULL;
4918 e->ref->u.ar.dimen = 0;
4921 if (e->ref && resolve_ref (e) == FAILURE)
4924 if (sym->attr.flavor == FL_PROCEDURE
4925 && (!sym->attr.function
4926 || (sym->attr.function && sym->result
4927 && sym->result->attr.proc_pointer
4928 && !sym->result->attr.function)))
4930 e->ts.type = BT_PROCEDURE;
4931 goto resolve_procedure;
4934 if (sym->ts.type != BT_UNKNOWN)
4935 gfc_variable_attr (e, &e->ts);
4938 /* Must be a simple variable reference. */
4939 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4944 if (check_assumed_size_reference (sym, e))
4947 /* Deal with forward references to entries during resolve_code, to
4948 satisfy, at least partially, 12.5.2.5. */
4949 if (gfc_current_ns->entries
4950 && current_entry_id == sym->entry_id
4953 && cs_base->current->op != EXEC_ENTRY)
4955 gfc_entry_list *entry;
4956 gfc_formal_arglist *formal;
4960 /* If the symbol is a dummy... */
4961 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4963 entry = gfc_current_ns->entries;
4966 /* ...test if the symbol is a parameter of previous entries. */
4967 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4968 for (formal = entry->sym->formal; formal; formal = formal->next)
4970 if (formal->sym && sym->name == formal->sym->name)
4974 /* If it has not been seen as a dummy, this is an error. */
4977 if (specification_expr)
4978 gfc_error ("Variable '%s', used in a specification expression"
4979 ", is referenced at %L before the ENTRY statement "
4980 "in which it is a parameter",
4981 sym->name, &cs_base->current->loc);
4983 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4984 "statement in which it is a parameter",
4985 sym->name, &cs_base->current->loc);
4990 /* Now do the same check on the specification expressions. */
4991 specification_expr = 1;
4992 if (sym->ts.type == BT_CHARACTER
4993 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4997 for (n = 0; n < sym->as->rank; n++)
4999 specification_expr = 1;
5000 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5002 specification_expr = 1;
5003 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5006 specification_expr = 0;
5009 /* Update the symbol's entry level. */
5010 sym->entry_id = current_entry_id + 1;
5013 /* If a symbol has been host_associated mark it. This is used latter,
5014 to identify if aliasing is possible via host association. */
5015 if (sym->attr.flavor == FL_VARIABLE
5016 && gfc_current_ns->parent
5017 && (gfc_current_ns->parent == sym->ns
5018 || (gfc_current_ns->parent->parent
5019 && gfc_current_ns->parent->parent == sym->ns)))
5020 sym->attr.host_assoc = 1;
5023 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5026 /* F2008, C617 and C1229. */
5027 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5028 && gfc_is_coindexed (e))
5030 gfc_ref *ref, *ref2 = NULL;
5032 for (ref = e->ref; ref; ref = ref->next)
5034 if (ref->type == REF_COMPONENT)
5036 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5040 for ( ; ref; ref = ref->next)
5041 if (ref->type == REF_COMPONENT)
5044 /* Expression itself is not coindexed object. */
5045 if (ref && e->ts.type == BT_CLASS)
5047 gfc_error ("Polymorphic subobject of coindexed object at %L",
5052 /* Expression itself is coindexed object. */
5056 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5057 for ( ; c; c = c->next)
5058 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5060 gfc_error ("Coindexed object with polymorphic allocatable "
5061 "subcomponent at %L", &e->where);
5072 /* Checks to see that the correct symbol has been host associated.
5073 The only situation where this arises is that in which a twice
5074 contained function is parsed after the host association is made.
5075 Therefore, on detecting this, change the symbol in the expression
5076 and convert the array reference into an actual arglist if the old
5077 symbol is a variable. */
5079 check_host_association (gfc_expr *e)
5081 gfc_symbol *sym, *old_sym;
5085 gfc_actual_arglist *arg, *tail = NULL;
5086 bool retval = e->expr_type == EXPR_FUNCTION;
5088 /* If the expression is the result of substitution in
5089 interface.c(gfc_extend_expr) because there is no way in
5090 which the host association can be wrong. */
5091 if (e->symtree == NULL
5092 || e->symtree->n.sym == NULL
5093 || e->user_operator)
5096 old_sym = e->symtree->n.sym;
5098 if (gfc_current_ns->parent
5099 && old_sym->ns != gfc_current_ns)
5101 /* Use the 'USE' name so that renamed module symbols are
5102 correctly handled. */
5103 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5105 if (sym && old_sym != sym
5106 && sym->ts.type == old_sym->ts.type
5107 && sym->attr.flavor == FL_PROCEDURE
5108 && sym->attr.contained)
5110 /* Clear the shape, since it might not be valid. */
5111 if (e->shape != NULL)
5113 for (n = 0; n < e->rank; n++)
5114 mpz_clear (e->shape[n]);
5116 gfc_free (e->shape);
5119 /* Give the expression the right symtree! */
5120 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5121 gcc_assert (st != NULL);
5123 if (old_sym->attr.flavor == FL_PROCEDURE
5124 || e->expr_type == EXPR_FUNCTION)
5126 /* Original was function so point to the new symbol, since
5127 the actual argument list is already attached to the
5129 e->value.function.esym = NULL;
5134 /* Original was variable so convert array references into
5135 an actual arglist. This does not need any checking now
5136 since gfc_resolve_function will take care of it. */
5137 e->value.function.actual = NULL;
5138 e->expr_type = EXPR_FUNCTION;
5141 /* Ambiguity will not arise if the array reference is not
5142 the last reference. */
5143 for (ref = e->ref; ref; ref = ref->next)
5144 if (ref->type == REF_ARRAY && ref->next == NULL)
5147 gcc_assert (ref->type == REF_ARRAY);
5149 /* Grab the start expressions from the array ref and
5150 copy them into actual arguments. */
5151 for (n = 0; n < ref->u.ar.dimen; n++)
5153 arg = gfc_get_actual_arglist ();
5154 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5155 if (e->value.function.actual == NULL)
5156 tail = e->value.function.actual = arg;
5164 /* Dump the reference list and set the rank. */
5165 gfc_free_ref_list (e->ref);
5167 e->rank = sym->as ? sym->as->rank : 0;
5170 gfc_resolve_expr (e);
5174 /* This might have changed! */
5175 return e->expr_type == EXPR_FUNCTION;
5180 gfc_resolve_character_operator (gfc_expr *e)
5182 gfc_expr *op1 = e->value.op.op1;
5183 gfc_expr *op2 = e->value.op.op2;
5184 gfc_expr *e1 = NULL;
5185 gfc_expr *e2 = NULL;
5187 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5189 if (op1->ts.u.cl && op1->ts.u.cl->length)
5190 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5191 else if (op1->expr_type == EXPR_CONSTANT)
5192 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5193 op1->value.character.length);
5195 if (op2->ts.u.cl && op2->ts.u.cl->length)
5196 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5197 else if (op2->expr_type == EXPR_CONSTANT)
5198 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5199 op2->value.character.length);
5201 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5206 e->ts.u.cl->length = gfc_add (e1, e2);
5207 e->ts.u.cl->length->ts.type = BT_INTEGER;
5208 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5209 gfc_simplify_expr (e->ts.u.cl->length, 0);
5210 gfc_resolve_expr (e->ts.u.cl->length);
5216 /* Ensure that an character expression has a charlen and, if possible, a
5217 length expression. */
5220 fixup_charlen (gfc_expr *e)
5222 /* The cases fall through so that changes in expression type and the need
5223 for multiple fixes are picked up. In all circumstances, a charlen should
5224 be available for the middle end to hang a backend_decl on. */
5225 switch (e->expr_type)
5228 gfc_resolve_character_operator (e);
5231 if (e->expr_type == EXPR_ARRAY)
5232 gfc_resolve_character_array_constructor (e);
5234 case EXPR_SUBSTRING:
5235 if (!e->ts.u.cl && e->ref)
5236 gfc_resolve_substring_charlen (e);
5240 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5247 /* Update an actual argument to include the passed-object for type-bound
5248 procedures at the right position. */
5250 static gfc_actual_arglist*
5251 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5254 gcc_assert (argpos > 0);
5258 gfc_actual_arglist* result;
5260 result = gfc_get_actual_arglist ();
5264 result->name = name;
5270 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5272 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5277 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5280 extract_compcall_passed_object (gfc_expr* e)
5284 gcc_assert (e->expr_type == EXPR_COMPCALL);
5286 if (e->value.compcall.base_object)
5287 po = gfc_copy_expr (e->value.compcall.base_object);
5290 po = gfc_get_expr ();
5291 po->expr_type = EXPR_VARIABLE;
5292 po->symtree = e->symtree;
5293 po->ref = gfc_copy_ref (e->ref);
5294 po->where = e->where;
5297 if (gfc_resolve_expr (po) == FAILURE)
5304 /* Update the arglist of an EXPR_COMPCALL expression to include the
5308 update_compcall_arglist (gfc_expr* e)
5311 gfc_typebound_proc* tbp;
5313 tbp = e->value.compcall.tbp;
5318 po = extract_compcall_passed_object (e);
5322 if (tbp->nopass || e->value.compcall.ignore_pass)
5328 gcc_assert (tbp->pass_arg_num > 0);
5329 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5337 /* Extract the passed object from a PPC call (a copy of it). */
5340 extract_ppc_passed_object (gfc_expr *e)
5345 po = gfc_get_expr ();
5346 po->expr_type = EXPR_VARIABLE;
5347 po->symtree = e->symtree;
5348 po->ref = gfc_copy_ref (e->ref);
5349 po->where = e->where;
5351 /* Remove PPC reference. */
5353 while ((*ref)->next)
5354 ref = &(*ref)->next;
5355 gfc_free_ref_list (*ref);
5358 if (gfc_resolve_expr (po) == FAILURE)
5365 /* Update the actual arglist of a procedure pointer component to include the
5369 update_ppc_arglist (gfc_expr* e)
5373 gfc_typebound_proc* tb;
5375 if (!gfc_is_proc_ptr_comp (e, &ppc))
5382 else if (tb->nopass)
5385 po = extract_ppc_passed_object (e);
5392 gfc_error ("Passed-object at %L must be scalar", &e->where);
5397 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5399 gfc_error ("Base object for procedure-pointer component call at %L is of"
5400 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5404 gcc_assert (tb->pass_arg_num > 0);
5405 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5413 /* Check that the object a TBP is called on is valid, i.e. it must not be
5414 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5417 check_typebound_baseobject (gfc_expr* e)
5420 gfc_try return_value = FAILURE;
5422 base = extract_compcall_passed_object (e);
5426 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5429 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5431 gfc_error ("Base object for type-bound procedure call at %L is of"
5432 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5436 /* F08:C1230. If the procedure called is NOPASS,
5437 the base object must be scalar. */
5438 if (e->value.compcall.tbp->nopass && base->rank > 0)
5440 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5441 " be scalar", &e->where);
5445 /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
5448 gfc_error ("Non-scalar base object at %L currently not implemented",
5453 return_value = SUCCESS;
5456 gfc_free_expr (base);
5457 return return_value;
5461 /* Resolve a call to a type-bound procedure, either function or subroutine,
5462 statically from the data in an EXPR_COMPCALL expression. The adapted
5463 arglist and the target-procedure symtree are returned. */
5466 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5467 gfc_actual_arglist** actual)
5469 gcc_assert (e->expr_type == EXPR_COMPCALL);
5470 gcc_assert (!e->value.compcall.tbp->is_generic);
5472 /* Update the actual arglist for PASS. */
5473 if (update_compcall_arglist (e) == FAILURE)
5476 *actual = e->value.compcall.actual;
5477 *target = e->value.compcall.tbp->u.specific;
5479 gfc_free_ref_list (e->ref);
5481 e->value.compcall.actual = NULL;
5487 /* Get the ultimate declared type from an expression. In addition,
5488 return the last class/derived type reference and the copy of the
5491 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5494 gfc_symbol *declared;
5501 *new_ref = gfc_copy_ref (e->ref);
5503 for (ref = e->ref; ref; ref = ref->next)
5505 if (ref->type != REF_COMPONENT)
5508 if (ref->u.c.component->ts.type == BT_CLASS
5509 || ref->u.c.component->ts.type == BT_DERIVED)
5511 declared = ref->u.c.component->ts.u.derived;
5517 if (declared == NULL)
5518 declared = e->symtree->n.sym->ts.u.derived;
5524 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5525 which of the specific bindings (if any) matches the arglist and transform
5526 the expression into a call of that binding. */
5529 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5531 gfc_typebound_proc* genproc;
5532 const char* genname;
5534 gfc_symbol *derived;
5536 gcc_assert (e->expr_type == EXPR_COMPCALL);
5537 genname = e->value.compcall.name;
5538 genproc = e->value.compcall.tbp;
5540 if (!genproc->is_generic)
5543 /* Try the bindings on this type and in the inheritance hierarchy. */
5544 for (; genproc; genproc = genproc->overridden)
5548 gcc_assert (genproc->is_generic);
5549 for (g = genproc->u.generic; g; g = g->next)
5552 gfc_actual_arglist* args;
5555 gcc_assert (g->specific);
5557 if (g->specific->error)
5560 target = g->specific->u.specific->n.sym;
5562 /* Get the right arglist by handling PASS/NOPASS. */
5563 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5564 if (!g->specific->nopass)
5567 po = extract_compcall_passed_object (e);
5571 gcc_assert (g->specific->pass_arg_num > 0);
5572 gcc_assert (!g->specific->error);
5573 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5574 g->specific->pass_arg);
5576 resolve_actual_arglist (args, target->attr.proc,
5577 is_external_proc (target) && !target->formal);
5579 /* Check if this arglist matches the formal. */
5580 matches = gfc_arglist_matches_symbol (&args, target);
5582 /* Clean up and break out of the loop if we've found it. */
5583 gfc_free_actual_arglist (args);
5586 e->value.compcall.tbp = g->specific;
5587 genname = g->specific_st->name;
5588 /* Pass along the name for CLASS methods, where the vtab
5589 procedure pointer component has to be referenced. */
5597 /* Nothing matching found! */
5598 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5599 " '%s' at %L", genname, &e->where);
5603 /* Make sure that we have the right specific instance for the name. */
5604 derived = get_declared_from_expr (NULL, NULL, e);
5606 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5608 e->value.compcall.tbp = st->n.tb;
5614 /* Resolve a call to a type-bound subroutine. */
5617 resolve_typebound_call (gfc_code* c, const char **name)
5619 gfc_actual_arglist* newactual;
5620 gfc_symtree* target;
5622 /* Check that's really a SUBROUTINE. */
5623 if (!c->expr1->value.compcall.tbp->subroutine)
5625 gfc_error ("'%s' at %L should be a SUBROUTINE",
5626 c->expr1->value.compcall.name, &c->loc);
5630 if (check_typebound_baseobject (c->expr1) == FAILURE)
5633 /* Pass along the name for CLASS methods, where the vtab
5634 procedure pointer component has to be referenced. */
5636 *name = c->expr1->value.compcall.name;
5638 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5641 /* Transform into an ordinary EXEC_CALL for now. */
5643 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5646 c->ext.actual = newactual;
5647 c->symtree = target;
5648 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5650 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5652 gfc_free_expr (c->expr1);
5653 c->expr1 = gfc_get_expr ();
5654 c->expr1->expr_type = EXPR_FUNCTION;
5655 c->expr1->symtree = target;
5656 c->expr1->where = c->loc;
5658 return resolve_call (c);
5662 /* Resolve a component-call expression. */
5664 resolve_compcall (gfc_expr* e, const char **name)
5666 gfc_actual_arglist* newactual;
5667 gfc_symtree* target;
5669 /* Check that's really a FUNCTION. */
5670 if (!e->value.compcall.tbp->function)
5672 gfc_error ("'%s' at %L should be a FUNCTION",
5673 e->value.compcall.name, &e->where);
5677 /* These must not be assign-calls! */
5678 gcc_assert (!e->value.compcall.assign);
5680 if (check_typebound_baseobject (e) == FAILURE)
5683 /* Pass along the name for CLASS methods, where the vtab
5684 procedure pointer component has to be referenced. */
5686 *name = e->value.compcall.name;
5688 if (resolve_typebound_generic_call (e, name) == FAILURE)
5690 gcc_assert (!e->value.compcall.tbp->is_generic);
5692 /* Take the rank from the function's symbol. */
5693 if (e->value.compcall.tbp->u.specific->n.sym->as)
5694 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5696 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5697 arglist to the TBP's binding target. */
5699 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5702 e->value.function.actual = newactual;
5703 e->value.function.name = NULL;
5704 e->value.function.esym = target->n.sym;
5705 e->value.function.isym = NULL;
5706 e->symtree = target;
5707 e->ts = target->n.sym->ts;
5708 e->expr_type = EXPR_FUNCTION;
5710 /* Resolution is not necessary if this is a class subroutine; this
5711 function only has to identify the specific proc. Resolution of
5712 the call will be done next in resolve_typebound_call. */
5713 return gfc_resolve_expr (e);
5718 /* Resolve a typebound function, or 'method'. First separate all
5719 the non-CLASS references by calling resolve_compcall directly. */
5722 resolve_typebound_function (gfc_expr* e)
5724 gfc_symbol *declared;
5735 /* Deal with typebound operators for CLASS objects. */
5736 expr = e->value.compcall.base_object;
5737 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5739 /* Since the typebound operators are generic, we have to ensure
5740 that any delays in resolution are corrected and that the vtab
5743 declared = ts.u.derived;
5744 c = gfc_find_component (declared, "_vptr", true, true);
5745 if (c->ts.u.derived == NULL)
5746 c->ts.u.derived = gfc_find_derived_vtab (declared);
5748 if (resolve_compcall (e, &name) == FAILURE)
5751 /* Use the generic name if it is there. */
5752 name = name ? name : e->value.function.esym->name;
5753 e->symtree = expr->symtree;
5754 e->ref = gfc_copy_ref (expr->ref);
5755 gfc_add_vptr_component (e);
5756 gfc_add_component_ref (e, name);
5757 e->value.function.esym = NULL;
5762 return resolve_compcall (e, NULL);
5764 if (resolve_ref (e) == FAILURE)
5767 /* Get the CLASS declared type. */
5768 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5770 /* Weed out cases of the ultimate component being a derived type. */
5771 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5772 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5774 gfc_free_ref_list (new_ref);
5775 return resolve_compcall (e, NULL);
5778 c = gfc_find_component (declared, "_data", true, true);
5779 declared = c->ts.u.derived;
5781 /* Treat the call as if it is a typebound procedure, in order to roll
5782 out the correct name for the specific function. */
5783 if (resolve_compcall (e, &name) == FAILURE)
5787 /* Then convert the expression to a procedure pointer component call. */
5788 e->value.function.esym = NULL;
5794 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5795 gfc_add_vptr_component (e);
5796 gfc_add_component_ref (e, name);
5798 /* Recover the typespec for the expression. This is really only
5799 necessary for generic procedures, where the additional call
5800 to gfc_add_component_ref seems to throw the collection of the
5801 correct typespec. */
5806 /* Resolve a typebound subroutine, or 'method'. First separate all
5807 the non-CLASS references by calling resolve_typebound_call
5811 resolve_typebound_subroutine (gfc_code *code)
5813 gfc_symbol *declared;
5822 st = code->expr1->symtree;
5824 /* Deal with typebound operators for CLASS objects. */
5825 expr = code->expr1->value.compcall.base_object;
5826 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5827 && code->expr1->value.compcall.name)
5829 /* Since the typebound operators are generic, we have to ensure
5830 that any delays in resolution are corrected and that the vtab
5832 ts = expr->symtree->n.sym->ts;
5833 declared = ts.u.derived;
5834 c = gfc_find_component (declared, "_vptr", true, true);
5835 if (c->ts.u.derived == NULL)
5836 c->ts.u.derived = gfc_find_derived_vtab (declared);
5838 if (resolve_typebound_call (code, &name) == FAILURE)
5841 /* Use the generic name if it is there. */
5842 name = name ? name : code->expr1->value.function.esym->name;
5843 code->expr1->symtree = expr->symtree;
5844 expr->symtree->n.sym->ts.u.derived = declared;
5845 gfc_add_vptr_component (code->expr1);
5846 gfc_add_component_ref (code->expr1, name);
5847 code->expr1->value.function.esym = NULL;
5852 return resolve_typebound_call (code, NULL);
5854 if (resolve_ref (code->expr1) == FAILURE)
5857 /* Get the CLASS declared type. */
5858 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5860 /* Weed out cases of the ultimate component being a derived type. */
5861 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5862 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5864 gfc_free_ref_list (new_ref);
5865 return resolve_typebound_call (code, NULL);
5868 if (resolve_typebound_call (code, &name) == FAILURE)
5870 ts = code->expr1->ts;
5872 /* Then convert the expression to a procedure pointer component call. */
5873 code->expr1->value.function.esym = NULL;
5874 code->expr1->symtree = st;
5877 code->expr1->ref = new_ref;
5879 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5880 gfc_add_vptr_component (code->expr1);
5881 gfc_add_component_ref (code->expr1, name);
5883 /* Recover the typespec for the expression. This is really only
5884 necessary for generic procedures, where the additional call
5885 to gfc_add_component_ref seems to throw the collection of the
5886 correct typespec. */
5887 code->expr1->ts = ts;
5892 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5895 resolve_ppc_call (gfc_code* c)
5897 gfc_component *comp;
5900 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5903 c->resolved_sym = c->expr1->symtree->n.sym;
5904 c->expr1->expr_type = EXPR_VARIABLE;
5906 if (!comp->attr.subroutine)
5907 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5909 if (resolve_ref (c->expr1) == FAILURE)
5912 if (update_ppc_arglist (c->expr1) == FAILURE)
5915 c->ext.actual = c->expr1->value.compcall.actual;
5917 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5918 comp->formal == NULL) == FAILURE)
5921 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5927 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5930 resolve_expr_ppc (gfc_expr* e)
5932 gfc_component *comp;
5935 b = gfc_is_proc_ptr_comp (e, &comp);
5938 /* Convert to EXPR_FUNCTION. */
5939 e->expr_type = EXPR_FUNCTION;
5940 e->value.function.isym = NULL;
5941 e->value.function.actual = e->value.compcall.actual;
5943 if (comp->as != NULL)
5944 e->rank = comp->as->rank;
5946 if (!comp->attr.function)
5947 gfc_add_function (&comp->attr, comp->name, &e->where);
5949 if (resolve_ref (e) == FAILURE)
5952 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5953 comp->formal == NULL) == FAILURE)
5956 if (update_ppc_arglist (e) == FAILURE)
5959 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5966 gfc_is_expandable_expr (gfc_expr *e)
5968 gfc_constructor *con;
5970 if (e->expr_type == EXPR_ARRAY)
5972 /* Traverse the constructor looking for variables that are flavor
5973 parameter. Parameters must be expanded since they are fully used at
5975 con = gfc_constructor_first (e->value.constructor);
5976 for (; con; con = gfc_constructor_next (con))
5978 if (con->expr->expr_type == EXPR_VARIABLE
5979 && con->expr->symtree
5980 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5981 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5983 if (con->expr->expr_type == EXPR_ARRAY
5984 && gfc_is_expandable_expr (con->expr))
5992 /* Resolve an expression. That is, make sure that types of operands agree
5993 with their operators, intrinsic operators are converted to function calls
5994 for overloaded types and unresolved function references are resolved. */
5997 gfc_resolve_expr (gfc_expr *e)
6005 /* inquiry_argument only applies to variables. */
6006 inquiry_save = inquiry_argument;
6007 if (e->expr_type != EXPR_VARIABLE)
6008 inquiry_argument = false;
6010 switch (e->expr_type)
6013 t = resolve_operator (e);
6019 if (check_host_association (e))
6020 t = resolve_function (e);
6023 t = resolve_variable (e);
6025 expression_rank (e);
6028 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6029 && e->ref->type != REF_SUBSTRING)
6030 gfc_resolve_substring_charlen (e);
6035 t = resolve_typebound_function (e);
6038 case EXPR_SUBSTRING:
6039 t = resolve_ref (e);
6048 t = resolve_expr_ppc (e);
6053 if (resolve_ref (e) == FAILURE)
6056 t = gfc_resolve_array_constructor (e);
6057 /* Also try to expand a constructor. */
6060 expression_rank (e);
6061 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6062 gfc_expand_constructor (e, false);
6065 /* This provides the opportunity for the length of constructors with
6066 character valued function elements to propagate the string length
6067 to the expression. */
6068 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6070 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6071 here rather then add a duplicate test for it above. */
6072 gfc_expand_constructor (e, false);
6073 t = gfc_resolve_character_array_constructor (e);
6078 case EXPR_STRUCTURE:
6079 t = resolve_ref (e);
6083 t = resolve_structure_cons (e, 0);
6087 t = gfc_simplify_expr (e, 0);
6091 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6094 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6097 inquiry_argument = inquiry_save;
6103 /* Resolve an expression from an iterator. They must be scalar and have
6104 INTEGER or (optionally) REAL type. */
6107 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6108 const char *name_msgid)
6110 if (gfc_resolve_expr (expr) == FAILURE)
6113 if (expr->rank != 0)
6115 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6119 if (expr->ts.type != BT_INTEGER)
6121 if (expr->ts.type == BT_REAL)
6124 return gfc_notify_std (GFC_STD_F95_DEL,
6125 "Deleted feature: %s at %L must be integer",
6126 _(name_msgid), &expr->where);
6129 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6136 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6144 /* Resolve the expressions in an iterator structure. If REAL_OK is
6145 false allow only INTEGER type iterators, otherwise allow REAL types. */
6148 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6150 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6154 if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
6158 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6159 "Start expression in DO loop") == FAILURE)
6162 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6163 "End expression in DO loop") == FAILURE)
6166 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6167 "Step expression in DO loop") == FAILURE)
6170 if (iter->step->expr_type == EXPR_CONSTANT)
6172 if ((iter->step->ts.type == BT_INTEGER
6173 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6174 || (iter->step->ts.type == BT_REAL
6175 && mpfr_sgn (iter->step->value.real) == 0))
6177 gfc_error ("Step expression in DO loop at %L cannot be zero",
6178 &iter->step->where);
6183 /* Convert start, end, and step to the same type as var. */
6184 if (iter->start->ts.kind != iter->var->ts.kind
6185 || iter->start->ts.type != iter->var->ts.type)
6186 gfc_convert_type (iter->start, &iter->var->ts, 2);
6188 if (iter->end->ts.kind != iter->var->ts.kind
6189 || iter->end->ts.type != iter->var->ts.type)
6190 gfc_convert_type (iter->end, &iter->var->ts, 2);
6192 if (iter->step->ts.kind != iter->var->ts.kind
6193 || iter->step->ts.type != iter->var->ts.type)
6194 gfc_convert_type (iter->step, &iter->var->ts, 2);
6196 if (iter->start->expr_type == EXPR_CONSTANT
6197 && iter->end->expr_type == EXPR_CONSTANT
6198 && iter->step->expr_type == EXPR_CONSTANT)
6201 if (iter->start->ts.type == BT_INTEGER)
6203 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6204 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6208 sgn = mpfr_sgn (iter->step->value.real);
6209 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6211 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6212 gfc_warning ("DO loop at %L will be executed zero times",
6213 &iter->step->where);
6220 /* Traversal function for find_forall_index. f == 2 signals that
6221 that variable itself is not to be checked - only the references. */
6224 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6226 if (expr->expr_type != EXPR_VARIABLE)
6229 /* A scalar assignment */
6230 if (!expr->ref || *f == 1)
6232 if (expr->symtree->n.sym == sym)
6244 /* Check whether the FORALL index appears in the expression or not.
6245 Returns SUCCESS if SYM is found in EXPR. */
6248 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6250 if (gfc_traverse_expr (expr, sym, forall_index, f))
6257 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6258 to be a scalar INTEGER variable. The subscripts and stride are scalar
6259 INTEGERs, and if stride is a constant it must be nonzero.
6260 Furthermore "A subscript or stride in a forall-triplet-spec shall
6261 not contain a reference to any index-name in the
6262 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6265 resolve_forall_iterators (gfc_forall_iterator *it)
6267 gfc_forall_iterator *iter, *iter2;
6269 for (iter = it; iter; iter = iter->next)
6271 if (gfc_resolve_expr (iter->var) == SUCCESS
6272 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6273 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6276 if (gfc_resolve_expr (iter->start) == SUCCESS
6277 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6278 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6279 &iter->start->where);
6280 if (iter->var->ts.kind != iter->start->ts.kind)
6281 gfc_convert_type (iter->start, &iter->var->ts, 2);
6283 if (gfc_resolve_expr (iter->end) == SUCCESS
6284 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6285 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6287 if (iter->var->ts.kind != iter->end->ts.kind)
6288 gfc_convert_type (iter->end, &iter->var->ts, 2);
6290 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6292 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6293 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6294 &iter->stride->where, "INTEGER");
6296 if (iter->stride->expr_type == EXPR_CONSTANT
6297 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6298 gfc_error ("FORALL stride expression at %L cannot be zero",
6299 &iter->stride->where);
6301 if (iter->var->ts.kind != iter->stride->ts.kind)
6302 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6305 for (iter = it; iter; iter = iter->next)
6306 for (iter2 = iter; iter2; iter2 = iter2->next)
6308 if (find_forall_index (iter2->start,
6309 iter->var->symtree->n.sym, 0) == SUCCESS
6310 || find_forall_index (iter2->end,
6311 iter->var->symtree->n.sym, 0) == SUCCESS
6312 || find_forall_index (iter2->stride,
6313 iter->var->symtree->n.sym, 0) == SUCCESS)
6314 gfc_error ("FORALL index '%s' may not appear in triplet "
6315 "specification at %L", iter->var->symtree->name,
6316 &iter2->start->where);
6321 /* Given a pointer to a symbol that is a derived type, see if it's
6322 inaccessible, i.e. if it's defined in another module and the components are
6323 PRIVATE. The search is recursive if necessary. Returns zero if no
6324 inaccessible components are found, nonzero otherwise. */
6327 derived_inaccessible (gfc_symbol *sym)
6331 if (sym->attr.use_assoc && sym->attr.private_comp)
6334 for (c = sym->components; c; c = c->next)
6336 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6344 /* Resolve the argument of a deallocate expression. The expression must be
6345 a pointer or a full array. */
6348 resolve_deallocate_expr (gfc_expr *e)
6350 symbol_attribute attr;
6351 int allocatable, pointer;
6356 if (gfc_resolve_expr (e) == FAILURE)
6359 if (e->expr_type != EXPR_VARIABLE)
6362 sym = e->symtree->n.sym;
6364 if (sym->ts.type == BT_CLASS)
6366 allocatable = CLASS_DATA (sym)->attr.allocatable;
6367 pointer = CLASS_DATA (sym)->attr.class_pointer;
6371 allocatable = sym->attr.allocatable;
6372 pointer = sym->attr.pointer;
6374 for (ref = e->ref; ref; ref = ref->next)
6379 if (ref->u.ar.type != AR_FULL)
6384 c = ref->u.c.component;
6385 if (c->ts.type == BT_CLASS)
6387 allocatable = CLASS_DATA (c)->attr.allocatable;
6388 pointer = CLASS_DATA (c)->attr.class_pointer;
6392 allocatable = c->attr.allocatable;
6393 pointer = c->attr.pointer;
6403 attr = gfc_expr_attr (e);
6405 if (allocatable == 0 && attr.pointer == 0)
6408 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6414 && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
6416 if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
6423 /* Returns true if the expression e contains a reference to the symbol sym. */
6425 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6427 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6434 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6436 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6440 /* Given the expression node e for an allocatable/pointer of derived type to be
6441 allocated, get the expression node to be initialized afterwards (needed for
6442 derived types with default initializers, and derived types with allocatable
6443 components that need nullification.) */
6446 gfc_expr_to_initialize (gfc_expr *e)
6452 result = gfc_copy_expr (e);
6454 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6455 for (ref = result->ref; ref; ref = ref->next)
6456 if (ref->type == REF_ARRAY && ref->next == NULL)
6458 ref->u.ar.type = AR_FULL;
6460 for (i = 0; i < ref->u.ar.dimen; i++)
6461 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6463 result->rank = ref->u.ar.dimen;
6471 /* If the last ref of an expression is an array ref, return a copy of the
6472 expression with that one removed. Otherwise, a copy of the original
6473 expression. This is used for allocate-expressions and pointer assignment
6474 LHS, where there may be an array specification that needs to be stripped
6475 off when using gfc_check_vardef_context. */
6478 remove_last_array_ref (gfc_expr* e)
6483 e2 = gfc_copy_expr (e);
6484 for (r = &e2->ref; *r; r = &(*r)->next)
6485 if ((*r)->type == REF_ARRAY && !(*r)->next)
6487 gfc_free_ref_list (*r);
6496 /* Used in resolve_allocate_expr to check that a allocation-object and
6497 a source-expr are conformable. This does not catch all possible
6498 cases; in particular a runtime checking is needed. */
6501 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6504 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6506 /* First compare rank. */
6507 if (tail && e1->rank != tail->u.ar.as->rank)
6509 gfc_error ("Source-expr at %L must be scalar or have the "
6510 "same rank as the allocate-object at %L",
6511 &e1->where, &e2->where);
6522 for (i = 0; i < e1->rank; i++)
6524 if (tail->u.ar.end[i])
6526 mpz_set (s, tail->u.ar.end[i]->value.integer);
6527 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6528 mpz_add_ui (s, s, 1);
6532 mpz_set (s, tail->u.ar.start[i]->value.integer);
6535 if (mpz_cmp (e1->shape[i], s) != 0)
6537 gfc_error ("Source-expr at %L and allocate-object at %L must "
6538 "have the same shape", &e1->where, &e2->where);
6551 /* Resolve the expression in an ALLOCATE statement, doing the additional
6552 checks to see whether the expression is OK or not. The expression must
6553 have a trailing array reference that gives the size of the array. */
6556 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6558 int i, pointer, allocatable, dimension, is_abstract;
6560 symbol_attribute attr;
6561 gfc_ref *ref, *ref2;
6564 gfc_symbol *sym = NULL;
6569 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6570 checking of coarrays. */
6571 for (ref = e->ref; ref; ref = ref->next)
6572 if (ref->next == NULL)
6575 if (ref && ref->type == REF_ARRAY)
6576 ref->u.ar.in_allocate = true;
6578 if (gfc_resolve_expr (e) == FAILURE)
6581 /* Make sure the expression is allocatable or a pointer. If it is
6582 pointer, the next-to-last reference must be a pointer. */
6586 sym = e->symtree->n.sym;
6588 /* Check whether ultimate component is abstract and CLASS. */
6591 if (e->expr_type != EXPR_VARIABLE)
6594 attr = gfc_expr_attr (e);
6595 pointer = attr.pointer;
6596 dimension = attr.dimension;
6597 codimension = attr.codimension;
6601 if (sym->ts.type == BT_CLASS)
6603 allocatable = CLASS_DATA (sym)->attr.allocatable;
6604 pointer = CLASS_DATA (sym)->attr.class_pointer;
6605 dimension = CLASS_DATA (sym)->attr.dimension;
6606 codimension = CLASS_DATA (sym)->attr.codimension;
6607 is_abstract = CLASS_DATA (sym)->attr.abstract;
6611 allocatable = sym->attr.allocatable;
6612 pointer = sym->attr.pointer;
6613 dimension = sym->attr.dimension;
6614 codimension = sym->attr.codimension;
6617 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6622 if (ref->next != NULL)
6628 if (gfc_is_coindexed (e))
6630 gfc_error ("Coindexed allocatable object at %L",
6635 c = ref->u.c.component;
6636 if (c->ts.type == BT_CLASS)
6638 allocatable = CLASS_DATA (c)->attr.allocatable;
6639 pointer = CLASS_DATA (c)->attr.class_pointer;
6640 dimension = CLASS_DATA (c)->attr.dimension;
6641 codimension = CLASS_DATA (c)->attr.codimension;
6642 is_abstract = CLASS_DATA (c)->attr.abstract;
6646 allocatable = c->attr.allocatable;
6647 pointer = c->attr.pointer;
6648 dimension = c->attr.dimension;
6649 codimension = c->attr.codimension;
6650 is_abstract = c->attr.abstract;
6662 if (allocatable == 0 && pointer == 0)
6664 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6669 /* Some checks for the SOURCE tag. */
6672 /* Check F03:C631. */
6673 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6675 gfc_error ("Type of entity at %L is type incompatible with "
6676 "source-expr at %L", &e->where, &code->expr3->where);
6680 /* Check F03:C632 and restriction following Note 6.18. */
6681 if (code->expr3->rank > 0
6682 && conformable_arrays (code->expr3, e) == FAILURE)
6685 /* Check F03:C633. */
6686 if (code->expr3->ts.kind != e->ts.kind)
6688 gfc_error ("The allocate-object at %L and the source-expr at %L "
6689 "shall have the same kind type parameter",
6690 &e->where, &code->expr3->where);
6695 /* Check F08:C629. */
6696 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6699 gcc_assert (e->ts.type == BT_CLASS);
6700 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6701 "type-spec or source-expr", sym->name, &e->where);
6705 /* In the variable definition context checks, gfc_expr_attr is used
6706 on the expression. This is fooled by the array specification
6707 present in e, thus we have to eliminate that one temporarily. */
6708 e2 = remove_last_array_ref (e);
6710 if (t == SUCCESS && pointer)
6711 t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
6713 t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
6720 /* Set up default initializer if needed. */
6724 if (code->ext.alloc.ts.type == BT_DERIVED)
6725 ts = code->ext.alloc.ts;
6729 if (ts.type == BT_CLASS)
6730 ts = ts.u.derived->components->ts;
6732 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6734 gfc_code *init_st = gfc_get_code ();
6735 init_st->loc = code->loc;
6736 init_st->op = EXEC_INIT_ASSIGN;
6737 init_st->expr1 = gfc_expr_to_initialize (e);
6738 init_st->expr2 = init_e;
6739 init_st->next = code->next;
6740 code->next = init_st;
6743 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6745 /* Default initialization via MOLD (non-polymorphic). */
6746 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6747 gfc_resolve_expr (rhs);
6748 gfc_free_expr (code->expr3);
6752 if (e->ts.type == BT_CLASS)
6754 /* Make sure the vtab symbol is present when
6755 the module variables are generated. */
6756 gfc_typespec ts = e->ts;
6758 ts = code->expr3->ts;
6759 else if (code->ext.alloc.ts.type == BT_DERIVED)
6760 ts = code->ext.alloc.ts;
6761 gfc_find_derived_vtab (ts.u.derived);
6764 if (pointer || (dimension == 0 && codimension == 0))
6767 /* Make sure the last reference node is an array specifiction. */
6769 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6770 || (dimension && ref2->u.ar.dimen == 0))
6772 gfc_error ("Array specification required in ALLOCATE statement "
6773 "at %L", &e->where);
6777 /* Make sure that the array section reference makes sense in the
6778 context of an ALLOCATE specification. */
6782 if (codimension && ar->codimen == 0)
6784 gfc_error ("Coarray specification required in ALLOCATE statement "
6785 "at %L", &e->where);
6789 for (i = 0; i < ar->dimen; i++)
6791 if (ref2->u.ar.type == AR_ELEMENT)
6794 switch (ar->dimen_type[i])
6800 if (ar->start[i] != NULL
6801 && ar->end[i] != NULL
6802 && ar->stride[i] == NULL)
6805 /* Fall Through... */
6810 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6816 for (a = code->ext.alloc.list; a; a = a->next)
6818 sym = a->expr->symtree->n.sym;
6820 /* TODO - check derived type components. */
6821 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6824 if ((ar->start[i] != NULL
6825 && gfc_find_sym_in_expr (sym, ar->start[i]))
6826 || (ar->end[i] != NULL
6827 && gfc_find_sym_in_expr (sym, ar->end[i])))
6829 gfc_error ("'%s' must not appear in the array specification at "
6830 "%L in the same ALLOCATE statement where it is "
6831 "itself allocated", sym->name, &ar->where);
6837 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6839 if (ar->dimen_type[i] == DIMEN_ELEMENT
6840 || ar->dimen_type[i] == DIMEN_RANGE)
6842 if (i == (ar->dimen + ar->codimen - 1))
6844 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6845 "statement at %L", &e->where);
6851 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6852 && ar->stride[i] == NULL)
6855 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6860 if (codimension && ar->as->rank == 0)
6862 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6863 "at %L", &e->where);
6870 gfc_error ("Support for entity at %L with deferred type parameter "
6871 "not yet implemented", &e->where);
6881 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6883 gfc_expr *stat, *errmsg, *pe, *qe;
6884 gfc_alloc *a, *p, *q;
6887 errmsg = code->expr2;
6889 /* Check the stat variable. */
6892 gfc_check_vardef_context (stat, false, _("STAT variable"));
6894 if ((stat->ts.type != BT_INTEGER
6895 && !(stat->ref && (stat->ref->type == REF_ARRAY
6896 || stat->ref->type == REF_COMPONENT)))
6898 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6899 "variable", &stat->where);
6901 for (p = code->ext.alloc.list; p; p = p->next)
6902 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6904 gfc_ref *ref1, *ref2;
6907 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6908 ref1 = ref1->next, ref2 = ref2->next)
6910 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6912 if (ref1->u.c.component->name != ref2->u.c.component->name)
6921 gfc_error ("Stat-variable at %L shall not be %sd within "
6922 "the same %s statement", &stat->where, fcn, fcn);
6928 /* Check the errmsg variable. */
6932 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6935 gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
6937 if ((errmsg->ts.type != BT_CHARACTER
6939 && (errmsg->ref->type == REF_ARRAY
6940 || errmsg->ref->type == REF_COMPONENT)))
6941 || errmsg->rank > 0 )
6942 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6943 "variable", &errmsg->where);
6945 for (p = code->ext.alloc.list; p; p = p->next)
6946 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6948 gfc_ref *ref1, *ref2;
6951 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6952 ref1 = ref1->next, ref2 = ref2->next)
6954 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6956 if (ref1->u.c.component->name != ref2->u.c.component->name)
6965 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6966 "the same %s statement", &errmsg->where, fcn, fcn);
6972 /* Check that an allocate-object appears only once in the statement.
6973 FIXME: Checking derived types is disabled. */
6974 for (p = code->ext.alloc.list; p; p = p->next)
6977 for (q = p->next; q; q = q->next)
6980 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
6982 /* This is a potential collision. */
6983 gfc_ref *pr = pe->ref;
6984 gfc_ref *qr = qe->ref;
6986 /* Follow the references until
6987 a) They start to differ, in which case there is no error;
6988 you can deallocate a%b and a%c in a single statement
6989 b) Both of them stop, which is an error
6990 c) One of them stops, which is also an error. */
6993 if (pr == NULL && qr == NULL)
6995 gfc_error ("Allocate-object at %L also appears at %L",
6996 &pe->where, &qe->where);
6999 else if (pr != NULL && qr == NULL)
7001 gfc_error ("Allocate-object at %L is subobject of"
7002 " object at %L", &pe->where, &qe->where);
7005 else if (pr == NULL && qr != NULL)
7007 gfc_error ("Allocate-object at %L is subobject of"
7008 " object at %L", &qe->where, &pe->where);
7011 /* Here, pr != NULL && qr != NULL */
7012 gcc_assert(pr->type == qr->type);
7013 if (pr->type == REF_ARRAY)
7015 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7017 gcc_assert (qr->type == REF_ARRAY);
7019 if (pr->next && qr->next)
7021 gfc_array_ref *par = &(pr->u.ar);
7022 gfc_array_ref *qar = &(qr->u.ar);
7023 if (gfc_dep_compare_expr (par->start[0],
7024 qar->start[0]) != 0)
7030 if (pr->u.c.component->name != qr->u.c.component->name)
7041 if (strcmp (fcn, "ALLOCATE") == 0)
7043 for (a = code->ext.alloc.list; a; a = a->next)
7044 resolve_allocate_expr (a->expr, code);
7048 for (a = code->ext.alloc.list; a; a = a->next)
7049 resolve_deallocate_expr (a->expr);
7054 /************ SELECT CASE resolution subroutines ************/
7056 /* Callback function for our mergesort variant. Determines interval
7057 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7058 op1 > op2. Assumes we're not dealing with the default case.
7059 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7060 There are nine situations to check. */
7063 compare_cases (const gfc_case *op1, const gfc_case *op2)
7067 if (op1->low == NULL) /* op1 = (:L) */
7069 /* op2 = (:N), so overlap. */
7071 /* op2 = (M:) or (M:N), L < M */
7072 if (op2->low != NULL
7073 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7076 else if (op1->high == NULL) /* op1 = (K:) */
7078 /* op2 = (M:), so overlap. */
7080 /* op2 = (:N) or (M:N), K > N */
7081 if (op2->high != NULL
7082 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7085 else /* op1 = (K:L) */
7087 if (op2->low == NULL) /* op2 = (:N), K > N */
7088 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7090 else if (op2->high == NULL) /* op2 = (M:), L < M */
7091 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7093 else /* op2 = (M:N) */
7097 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7100 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7109 /* Merge-sort a double linked case list, detecting overlap in the
7110 process. LIST is the head of the double linked case list before it
7111 is sorted. Returns the head of the sorted list if we don't see any
7112 overlap, or NULL otherwise. */
7115 check_case_overlap (gfc_case *list)
7117 gfc_case *p, *q, *e, *tail;
7118 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7120 /* If the passed list was empty, return immediately. */
7127 /* Loop unconditionally. The only exit from this loop is a return
7128 statement, when we've finished sorting the case list. */
7135 /* Count the number of merges we do in this pass. */
7138 /* Loop while there exists a merge to be done. */
7143 /* Count this merge. */
7146 /* Cut the list in two pieces by stepping INSIZE places
7147 forward in the list, starting from P. */
7150 for (i = 0; i < insize; i++)
7159 /* Now we have two lists. Merge them! */
7160 while (psize > 0 || (qsize > 0 && q != NULL))
7162 /* See from which the next case to merge comes from. */
7165 /* P is empty so the next case must come from Q. */
7170 else if (qsize == 0 || q == NULL)
7179 cmp = compare_cases (p, q);
7182 /* The whole case range for P is less than the
7190 /* The whole case range for Q is greater than
7191 the case range for P. */
7198 /* The cases overlap, or they are the same
7199 element in the list. Either way, we must
7200 issue an error and get the next case from P. */
7201 /* FIXME: Sort P and Q by line number. */
7202 gfc_error ("CASE label at %L overlaps with CASE "
7203 "label at %L", &p->where, &q->where);
7211 /* Add the next element to the merged list. */
7220 /* P has now stepped INSIZE places along, and so has Q. So
7221 they're the same. */
7226 /* If we have done only one merge or none at all, we've
7227 finished sorting the cases. */
7236 /* Otherwise repeat, merging lists twice the size. */
7242 /* Check to see if an expression is suitable for use in a CASE statement.
7243 Makes sure that all case expressions are scalar constants of the same
7244 type. Return FAILURE if anything is wrong. */
7247 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7249 if (e == NULL) return SUCCESS;
7251 if (e->ts.type != case_expr->ts.type)
7253 gfc_error ("Expression in CASE statement at %L must be of type %s",
7254 &e->where, gfc_basic_typename (case_expr->ts.type));
7258 /* C805 (R808) For a given case-construct, each case-value shall be of
7259 the same type as case-expr. For character type, length differences
7260 are allowed, but the kind type parameters shall be the same. */
7262 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7264 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7265 &e->where, case_expr->ts.kind);
7269 /* Convert the case value kind to that of case expression kind,
7272 if (e->ts.kind != case_expr->ts.kind)
7273 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7277 gfc_error ("Expression in CASE statement at %L must be scalar",
7286 /* Given a completely parsed select statement, we:
7288 - Validate all expressions and code within the SELECT.
7289 - Make sure that the selection expression is not of the wrong type.
7290 - Make sure that no case ranges overlap.
7291 - Eliminate unreachable cases and unreachable code resulting from
7292 removing case labels.
7294 The standard does allow unreachable cases, e.g. CASE (5:3). But
7295 they are a hassle for code generation, and to prevent that, we just
7296 cut them out here. This is not necessary for overlapping cases
7297 because they are illegal and we never even try to generate code.
7299 We have the additional caveat that a SELECT construct could have
7300 been a computed GOTO in the source code. Fortunately we can fairly
7301 easily work around that here: The case_expr for a "real" SELECT CASE
7302 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7303 we have to do is make sure that the case_expr is a scalar integer
7307 resolve_select (gfc_code *code)
7310 gfc_expr *case_expr;
7311 gfc_case *cp, *default_case, *tail, *head;
7312 int seen_unreachable;
7318 if (code->expr1 == NULL)
7320 /* This was actually a computed GOTO statement. */
7321 case_expr = code->expr2;
7322 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7323 gfc_error ("Selection expression in computed GOTO statement "
7324 "at %L must be a scalar integer expression",
7327 /* Further checking is not necessary because this SELECT was built
7328 by the compiler, so it should always be OK. Just move the
7329 case_expr from expr2 to expr so that we can handle computed
7330 GOTOs as normal SELECTs from here on. */
7331 code->expr1 = code->expr2;
7336 case_expr = code->expr1;
7338 type = case_expr->ts.type;
7339 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7341 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7342 &case_expr->where, gfc_typename (&case_expr->ts));
7344 /* Punt. Going on here just produce more garbage error messages. */
7348 if (case_expr->rank != 0)
7350 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7351 "expression", &case_expr->where);
7358 /* Raise a warning if an INTEGER case value exceeds the range of
7359 the case-expr. Later, all expressions will be promoted to the
7360 largest kind of all case-labels. */
7362 if (type == BT_INTEGER)
7363 for (body = code->block; body; body = body->block)
7364 for (cp = body->ext.case_list; cp; cp = cp->next)
7367 && gfc_check_integer_range (cp->low->value.integer,
7368 case_expr->ts.kind) != ARITH_OK)
7369 gfc_warning ("Expression in CASE statement at %L is "
7370 "not in the range of %s", &cp->low->where,
7371 gfc_typename (&case_expr->ts));
7374 && cp->low != cp->high
7375 && gfc_check_integer_range (cp->high->value.integer,
7376 case_expr->ts.kind) != ARITH_OK)
7377 gfc_warning ("Expression in CASE statement at %L is "
7378 "not in the range of %s", &cp->high->where,
7379 gfc_typename (&case_expr->ts));
7382 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7383 of the SELECT CASE expression and its CASE values. Walk the lists
7384 of case values, and if we find a mismatch, promote case_expr to
7385 the appropriate kind. */
7387 if (type == BT_LOGICAL || type == BT_INTEGER)
7389 for (body = code->block; body; body = body->block)
7391 /* Walk the case label list. */
7392 for (cp = body->ext.case_list; cp; cp = cp->next)
7394 /* Intercept the DEFAULT case. It does not have a kind. */
7395 if (cp->low == NULL && cp->high == NULL)
7398 /* Unreachable case ranges are discarded, so ignore. */
7399 if (cp->low != NULL && cp->high != NULL
7400 && cp->low != cp->high
7401 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7405 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7406 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7408 if (cp->high != NULL
7409 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7410 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7415 /* Assume there is no DEFAULT case. */
7416 default_case = NULL;
7421 for (body = code->block; body; body = body->block)
7423 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7425 seen_unreachable = 0;
7427 /* Walk the case label list, making sure that all case labels
7429 for (cp = body->ext.case_list; cp; cp = cp->next)
7431 /* Count the number of cases in the whole construct. */
7434 /* Intercept the DEFAULT case. */
7435 if (cp->low == NULL && cp->high == NULL)
7437 if (default_case != NULL)
7439 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7440 "by a second DEFAULT CASE at %L",
7441 &default_case->where, &cp->where);
7452 /* Deal with single value cases and case ranges. Errors are
7453 issued from the validation function. */
7454 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7455 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7461 if (type == BT_LOGICAL
7462 && ((cp->low == NULL || cp->high == NULL)
7463 || cp->low != cp->high))
7465 gfc_error ("Logical range in CASE statement at %L is not "
7466 "allowed", &cp->low->where);
7471 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7474 value = cp->low->value.logical == 0 ? 2 : 1;
7475 if (value & seen_logical)
7477 gfc_error ("Constant logical value in CASE statement "
7478 "is repeated at %L",
7483 seen_logical |= value;
7486 if (cp->low != NULL && cp->high != NULL
7487 && cp->low != cp->high
7488 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7490 if (gfc_option.warn_surprising)
7491 gfc_warning ("Range specification at %L can never "
7492 "be matched", &cp->where);
7494 cp->unreachable = 1;
7495 seen_unreachable = 1;
7499 /* If the case range can be matched, it can also overlap with
7500 other cases. To make sure it does not, we put it in a
7501 double linked list here. We sort that with a merge sort
7502 later on to detect any overlapping cases. */
7506 head->right = head->left = NULL;
7511 tail->right->left = tail;
7518 /* It there was a failure in the previous case label, give up
7519 for this case label list. Continue with the next block. */
7523 /* See if any case labels that are unreachable have been seen.
7524 If so, we eliminate them. This is a bit of a kludge because
7525 the case lists for a single case statement (label) is a
7526 single forward linked lists. */
7527 if (seen_unreachable)
7529 /* Advance until the first case in the list is reachable. */
7530 while (body->ext.case_list != NULL
7531 && body->ext.case_list->unreachable)
7533 gfc_case *n = body->ext.case_list;
7534 body->ext.case_list = body->ext.case_list->next;
7536 gfc_free_case_list (n);
7539 /* Strip all other unreachable cases. */
7540 if (body->ext.case_list)
7542 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7544 if (cp->next->unreachable)
7546 gfc_case *n = cp->next;
7547 cp->next = cp->next->next;
7549 gfc_free_case_list (n);
7556 /* See if there were overlapping cases. If the check returns NULL,
7557 there was overlap. In that case we don't do anything. If head
7558 is non-NULL, we prepend the DEFAULT case. The sorted list can
7559 then used during code generation for SELECT CASE constructs with
7560 a case expression of a CHARACTER type. */
7563 head = check_case_overlap (head);
7565 /* Prepend the default_case if it is there. */
7566 if (head != NULL && default_case)
7568 default_case->left = NULL;
7569 default_case->right = head;
7570 head->left = default_case;
7574 /* Eliminate dead blocks that may be the result if we've seen
7575 unreachable case labels for a block. */
7576 for (body = code; body && body->block; body = body->block)
7578 if (body->block->ext.case_list == NULL)
7580 /* Cut the unreachable block from the code chain. */
7581 gfc_code *c = body->block;
7582 body->block = c->block;
7584 /* Kill the dead block, but not the blocks below it. */
7586 gfc_free_statements (c);
7590 /* More than two cases is legal but insane for logical selects.
7591 Issue a warning for it. */
7592 if (gfc_option.warn_surprising && type == BT_LOGICAL
7594 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7599 /* Check if a derived type is extensible. */
7602 gfc_type_is_extensible (gfc_symbol *sym)
7604 return !(sym->attr.is_bind_c || sym->attr.sequence);
7608 /* Resolve an associate name: Resolve target and ensure the type-spec is
7609 correct as well as possibly the array-spec. */
7612 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7616 gcc_assert (sym->assoc);
7617 gcc_assert (sym->attr.flavor == FL_VARIABLE);
7619 /* If this is for SELECT TYPE, the target may not yet be set. In that
7620 case, return. Resolution will be called later manually again when
7622 target = sym->assoc->target;
7625 gcc_assert (!sym->assoc->dangling);
7627 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7630 /* For variable targets, we get some attributes from the target. */
7631 if (target->expr_type == EXPR_VARIABLE)
7635 gcc_assert (target->symtree);
7636 tsym = target->symtree->n.sym;
7638 sym->attr.asynchronous = tsym->attr.asynchronous;
7639 sym->attr.volatile_ = tsym->attr.volatile_;
7641 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7644 /* Get type if this was not already set. Note that it can be
7645 some other type than the target in case this is a SELECT TYPE
7646 selector! So we must not update when the type is already there. */
7647 if (sym->ts.type == BT_UNKNOWN)
7648 sym->ts = target->ts;
7649 gcc_assert (sym->ts.type != BT_UNKNOWN);
7651 /* See if this is a valid association-to-variable. */
7652 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7653 && !gfc_has_vector_subscript (target));
7655 /* Finally resolve if this is an array or not. */
7656 if (sym->attr.dimension && target->rank == 0)
7658 gfc_error ("Associate-name '%s' at %L is used as array",
7659 sym->name, &sym->declared_at);
7660 sym->attr.dimension = 0;
7663 if (target->rank > 0)
7664 sym->attr.dimension = 1;
7666 if (sym->attr.dimension)
7668 sym->as = gfc_get_array_spec ();
7669 sym->as->rank = target->rank;
7670 sym->as->type = AS_DEFERRED;
7672 /* Target must not be coindexed, thus the associate-variable
7674 sym->as->corank = 0;
7679 /* Resolve a SELECT TYPE statement. */
7682 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7684 gfc_symbol *selector_type;
7685 gfc_code *body, *new_st, *if_st, *tail;
7686 gfc_code *class_is = NULL, *default_case = NULL;
7689 char name[GFC_MAX_SYMBOL_LEN];
7693 ns = code->ext.block.ns;
7696 /* Check for F03:C813. */
7697 if (code->expr1->ts.type != BT_CLASS
7698 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7700 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7701 "at %L", &code->loc);
7707 if (code->expr1->symtree->n.sym->attr.untyped)
7708 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7709 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7712 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7714 /* Loop over TYPE IS / CLASS IS cases. */
7715 for (body = code->block; body; body = body->block)
7717 c = body->ext.case_list;
7719 /* Check F03:C815. */
7720 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7721 && !gfc_type_is_extensible (c->ts.u.derived))
7723 gfc_error ("Derived type '%s' at %L must be extensible",
7724 c->ts.u.derived->name, &c->where);
7729 /* Check F03:C816. */
7730 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7731 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7733 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7734 c->ts.u.derived->name, &c->where, selector_type->name);
7739 /* Intercept the DEFAULT case. */
7740 if (c->ts.type == BT_UNKNOWN)
7742 /* Check F03:C818. */
7745 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7746 "by a second DEFAULT CASE at %L",
7747 &default_case->ext.case_list->where, &c->where);
7752 default_case = body;
7759 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7760 target if present. If there are any EXIT statements referring to the
7761 SELECT TYPE construct, this is no problem because the gfc_code
7762 reference stays the same and EXIT is equally possible from the BLOCK
7763 it is changed to. */
7764 code->op = EXEC_BLOCK;
7767 gfc_association_list* assoc;
7769 assoc = gfc_get_association_list ();
7770 assoc->st = code->expr1->symtree;
7771 assoc->target = gfc_copy_expr (code->expr2);
7772 /* assoc->variable will be set by resolve_assoc_var. */
7774 code->ext.block.assoc = assoc;
7775 code->expr1->symtree->n.sym->assoc = assoc;
7777 resolve_assoc_var (code->expr1->symtree->n.sym, false);
7780 code->ext.block.assoc = NULL;
7782 /* Add EXEC_SELECT to switch on type. */
7783 new_st = gfc_get_code ();
7784 new_st->op = code->op;
7785 new_st->expr1 = code->expr1;
7786 new_st->expr2 = code->expr2;
7787 new_st->block = code->block;
7788 code->expr1 = code->expr2 = NULL;
7793 ns->code->next = new_st;
7795 code->op = EXEC_SELECT;
7796 gfc_add_vptr_component (code->expr1);
7797 gfc_add_hash_component (code->expr1);
7799 /* Loop over TYPE IS / CLASS IS cases. */
7800 for (body = code->block; body; body = body->block)
7802 c = body->ext.case_list;
7804 if (c->ts.type == BT_DERIVED)
7805 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7806 c->ts.u.derived->hash_value);
7808 else if (c->ts.type == BT_UNKNOWN)
7811 /* Associate temporary to selector. This should only be done
7812 when this case is actually true, so build a new ASSOCIATE
7813 that does precisely this here (instead of using the
7816 if (c->ts.type == BT_CLASS)
7817 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
7819 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
7820 st = gfc_find_symtree (ns->sym_root, name);
7821 gcc_assert (st->n.sym->assoc);
7822 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7823 if (c->ts.type == BT_DERIVED)
7824 gfc_add_data_component (st->n.sym->assoc->target);
7826 new_st = gfc_get_code ();
7827 new_st->op = EXEC_BLOCK;
7828 new_st->ext.block.ns = gfc_build_block_ns (ns);
7829 new_st->ext.block.ns->code = body->next;
7830 body->next = new_st;
7832 /* Chain in the new list only if it is marked as dangling. Otherwise
7833 there is a CASE label overlap and this is already used. Just ignore,
7834 the error is diagonsed elsewhere. */
7835 if (st->n.sym->assoc->dangling)
7837 new_st->ext.block.assoc = st->n.sym->assoc;
7838 st->n.sym->assoc->dangling = 0;
7841 resolve_assoc_var (st->n.sym, false);
7844 /* Take out CLASS IS cases for separate treatment. */
7846 while (body && body->block)
7848 if (body->block->ext.case_list->ts.type == BT_CLASS)
7850 /* Add to class_is list. */
7851 if (class_is == NULL)
7853 class_is = body->block;
7858 for (tail = class_is; tail->block; tail = tail->block) ;
7859 tail->block = body->block;
7862 /* Remove from EXEC_SELECT list. */
7863 body->block = body->block->block;
7876 /* Add a default case to hold the CLASS IS cases. */
7877 for (tail = code; tail->block; tail = tail->block) ;
7878 tail->block = gfc_get_code ();
7880 tail->op = EXEC_SELECT_TYPE;
7881 tail->ext.case_list = gfc_get_case ();
7882 tail->ext.case_list->ts.type = BT_UNKNOWN;
7884 default_case = tail;
7887 /* More than one CLASS IS block? */
7888 if (class_is->block)
7892 /* Sort CLASS IS blocks by extension level. */
7896 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7899 /* F03:C817 (check for doubles). */
7900 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7901 == c2->ext.case_list->ts.u.derived->hash_value)
7903 gfc_error ("Double CLASS IS block in SELECT TYPE "
7904 "statement at %L", &c2->ext.case_list->where);
7907 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7908 < c2->ext.case_list->ts.u.derived->attr.extension)
7911 (*c1)->block = c2->block;
7921 /* Generate IF chain. */
7922 if_st = gfc_get_code ();
7923 if_st->op = EXEC_IF;
7925 for (body = class_is; body; body = body->block)
7927 new_st->block = gfc_get_code ();
7928 new_st = new_st->block;
7929 new_st->op = EXEC_IF;
7930 /* Set up IF condition: Call _gfortran_is_extension_of. */
7931 new_st->expr1 = gfc_get_expr ();
7932 new_st->expr1->expr_type = EXPR_FUNCTION;
7933 new_st->expr1->ts.type = BT_LOGICAL;
7934 new_st->expr1->ts.kind = 4;
7935 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7936 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7937 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7938 /* Set up arguments. */
7939 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7940 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7941 new_st->expr1->value.function.actual->expr->where = code->loc;
7942 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
7943 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7944 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7945 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7946 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7947 new_st->next = body->next;
7949 if (default_case->next)
7951 new_st->block = gfc_get_code ();
7952 new_st = new_st->block;
7953 new_st->op = EXEC_IF;
7954 new_st->next = default_case->next;
7957 /* Replace CLASS DEFAULT code by the IF chain. */
7958 default_case->next = if_st;
7961 /* Resolve the internal code. This can not be done earlier because
7962 it requires that the sym->assoc of selectors is set already. */
7963 gfc_current_ns = ns;
7964 gfc_resolve_blocks (code->block, gfc_current_ns);
7965 gfc_current_ns = old_ns;
7967 resolve_select (code);
7971 /* Resolve a transfer statement. This is making sure that:
7972 -- a derived type being transferred has only non-pointer components
7973 -- a derived type being transferred doesn't have private components, unless
7974 it's being transferred from the module where the type was defined
7975 -- we're not trying to transfer a whole assumed size array. */
7978 resolve_transfer (gfc_code *code)
7987 while (exp != NULL && exp->expr_type == EXPR_OP
7988 && exp->value.op.op == INTRINSIC_PARENTHESES)
7989 exp = exp->value.op.op1;
7991 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7992 && exp->expr_type != EXPR_FUNCTION))
7995 /* If we are reading, the variable will be changed. Note that
7996 code->ext.dt may be NULL if the TRANSFER is related to
7997 an INQUIRE statement -- but in this case, we are not reading, either. */
7998 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
7999 && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
8002 sym = exp->symtree->n.sym;
8005 /* Go to actual component transferred. */
8006 for (ref = exp->ref; ref; ref = ref->next)
8007 if (ref->type == REF_COMPONENT)
8008 ts = &ref->u.c.component->ts;
8010 if (ts->type == BT_CLASS)
8012 /* FIXME: Test for defined input/output. */
8013 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8014 "it is processed by a defined input/output procedure",
8019 if (ts->type == BT_DERIVED)
8021 /* Check that transferred derived type doesn't contain POINTER
8023 if (ts->u.derived->attr.pointer_comp)
8025 gfc_error ("Data transfer element at %L cannot have "
8026 "POINTER components", &code->loc);
8030 if (ts->u.derived->attr.alloc_comp)
8032 gfc_error ("Data transfer element at %L cannot have "
8033 "ALLOCATABLE components", &code->loc);
8037 if (derived_inaccessible (ts->u.derived))
8039 gfc_error ("Data transfer element at %L cannot have "
8040 "PRIVATE components",&code->loc);
8045 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
8046 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8048 gfc_error ("Data transfer element at %L cannot be a full reference to "
8049 "an assumed-size array", &code->loc);
8055 /*********** Toplevel code resolution subroutines ***********/
8057 /* Find the set of labels that are reachable from this block. We also
8058 record the last statement in each block. */
8061 find_reachable_labels (gfc_code *block)
8068 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8070 /* Collect labels in this block. We don't keep those corresponding
8071 to END {IF|SELECT}, these are checked in resolve_branch by going
8072 up through the code_stack. */
8073 for (c = block; c; c = c->next)
8075 if (c->here && c->op != EXEC_END_BLOCK)
8076 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8079 /* Merge with labels from parent block. */
8082 gcc_assert (cs_base->prev->reachable_labels);
8083 bitmap_ior_into (cs_base->reachable_labels,
8084 cs_base->prev->reachable_labels);
8090 resolve_sync (gfc_code *code)
8092 /* Check imageset. The * case matches expr1 == NULL. */
8095 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8096 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8097 "INTEGER expression", &code->expr1->where);
8098 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8099 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8100 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8101 &code->expr1->where);
8102 else if (code->expr1->expr_type == EXPR_ARRAY
8103 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8105 gfc_constructor *cons;
8106 cons = gfc_constructor_first (code->expr1->value.constructor);
8107 for (; cons; cons = gfc_constructor_next (cons))
8108 if (cons->expr->expr_type == EXPR_CONSTANT
8109 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8110 gfc_error ("Imageset argument at %L must between 1 and "
8111 "num_images()", &cons->expr->where);
8117 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8118 || code->expr2->expr_type != EXPR_VARIABLE))
8119 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8120 &code->expr2->where);
8124 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8125 || code->expr3->expr_type != EXPR_VARIABLE))
8126 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8127 &code->expr3->where);
8131 /* Given a branch to a label, see if the branch is conforming.
8132 The code node describes where the branch is located. */
8135 resolve_branch (gfc_st_label *label, gfc_code *code)
8142 /* Step one: is this a valid branching target? */
8144 if (label->defined == ST_LABEL_UNKNOWN)
8146 gfc_error ("Label %d referenced at %L is never defined", label->value,
8151 if (label->defined != ST_LABEL_TARGET)
8153 gfc_error ("Statement at %L is not a valid branch target statement "
8154 "for the branch statement at %L", &label->where, &code->loc);
8158 /* Step two: make sure this branch is not a branch to itself ;-) */
8160 if (code->here == label)
8162 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8166 /* Step three: See if the label is in the same block as the
8167 branching statement. The hard work has been done by setting up
8168 the bitmap reachable_labels. */
8170 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8172 /* Check now whether there is a CRITICAL construct; if so, check
8173 whether the label is still visible outside of the CRITICAL block,
8174 which is invalid. */
8175 for (stack = cs_base; stack; stack = stack->prev)
8176 if (stack->current->op == EXEC_CRITICAL
8177 && bitmap_bit_p (stack->reachable_labels, label->value))
8178 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8179 " at %L", &code->loc, &label->where);
8184 /* Step four: If we haven't found the label in the bitmap, it may
8185 still be the label of the END of the enclosing block, in which
8186 case we find it by going up the code_stack. */
8188 for (stack = cs_base; stack; stack = stack->prev)
8190 if (stack->current->next && stack->current->next->here == label)
8192 if (stack->current->op == EXEC_CRITICAL)
8194 /* Note: A label at END CRITICAL does not leave the CRITICAL
8195 construct as END CRITICAL is still part of it. */
8196 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8197 " at %L", &code->loc, &label->where);
8204 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
8208 /* The label is not in an enclosing block, so illegal. This was
8209 allowed in Fortran 66, so we allow it as extension. No
8210 further checks are necessary in this case. */
8211 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8212 "as the GOTO statement at %L", &label->where,
8218 /* Check whether EXPR1 has the same shape as EXPR2. */
8221 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8223 mpz_t shape[GFC_MAX_DIMENSIONS];
8224 mpz_t shape2[GFC_MAX_DIMENSIONS];
8225 gfc_try result = FAILURE;
8228 /* Compare the rank. */
8229 if (expr1->rank != expr2->rank)
8232 /* Compare the size of each dimension. */
8233 for (i=0; i<expr1->rank; i++)
8235 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8238 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8241 if (mpz_cmp (shape[i], shape2[i]))
8245 /* When either of the two expression is an assumed size array, we
8246 ignore the comparison of dimension sizes. */
8251 for (i--; i >= 0; i--)
8253 mpz_clear (shape[i]);
8254 mpz_clear (shape2[i]);
8260 /* Check whether a WHERE assignment target or a WHERE mask expression
8261 has the same shape as the outmost WHERE mask expression. */
8264 resolve_where (gfc_code *code, gfc_expr *mask)
8270 cblock = code->block;
8272 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8273 In case of nested WHERE, only the outmost one is stored. */
8274 if (mask == NULL) /* outmost WHERE */
8276 else /* inner WHERE */
8283 /* Check if the mask-expr has a consistent shape with the
8284 outmost WHERE mask-expr. */
8285 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8286 gfc_error ("WHERE mask at %L has inconsistent shape",
8287 &cblock->expr1->where);
8290 /* the assignment statement of a WHERE statement, or the first
8291 statement in where-body-construct of a WHERE construct */
8292 cnext = cblock->next;
8297 /* WHERE assignment statement */
8300 /* Check shape consistent for WHERE assignment target. */
8301 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8302 gfc_error ("WHERE assignment target at %L has "
8303 "inconsistent shape", &cnext->expr1->where);
8307 case EXEC_ASSIGN_CALL:
8308 resolve_call (cnext);
8309 if (!cnext->resolved_sym->attr.elemental)
8310 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8311 &cnext->ext.actual->expr->where);
8314 /* WHERE or WHERE construct is part of a where-body-construct */
8316 resolve_where (cnext, e);
8320 gfc_error ("Unsupported statement inside WHERE at %L",
8323 /* the next statement within the same where-body-construct */
8324 cnext = cnext->next;
8326 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8327 cblock = cblock->block;
8332 /* Resolve assignment in FORALL construct.
8333 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8334 FORALL index variables. */
8337 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8341 for (n = 0; n < nvar; n++)
8343 gfc_symbol *forall_index;
8345 forall_index = var_expr[n]->symtree->n.sym;
8347 /* Check whether the assignment target is one of the FORALL index
8349 if ((code->expr1->expr_type == EXPR_VARIABLE)
8350 && (code->expr1->symtree->n.sym == forall_index))
8351 gfc_error ("Assignment to a FORALL index variable at %L",
8352 &code->expr1->where);
8355 /* If one of the FORALL index variables doesn't appear in the
8356 assignment variable, then there could be a many-to-one
8357 assignment. Emit a warning rather than an error because the
8358 mask could be resolving this problem. */
8359 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8360 gfc_warning ("The FORALL with index '%s' is not used on the "
8361 "left side of the assignment at %L and so might "
8362 "cause multiple assignment to this object",
8363 var_expr[n]->symtree->name, &code->expr1->where);
8369 /* Resolve WHERE statement in FORALL construct. */
8372 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8373 gfc_expr **var_expr)
8378 cblock = code->block;
8381 /* the assignment statement of a WHERE statement, or the first
8382 statement in where-body-construct of a WHERE construct */
8383 cnext = cblock->next;
8388 /* WHERE assignment statement */
8390 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8393 /* WHERE operator assignment statement */
8394 case EXEC_ASSIGN_CALL:
8395 resolve_call (cnext);
8396 if (!cnext->resolved_sym->attr.elemental)
8397 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8398 &cnext->ext.actual->expr->where);
8401 /* WHERE or WHERE construct is part of a where-body-construct */
8403 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8407 gfc_error ("Unsupported statement inside WHERE at %L",
8410 /* the next statement within the same where-body-construct */
8411 cnext = cnext->next;
8413 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8414 cblock = cblock->block;
8419 /* Traverse the FORALL body to check whether the following errors exist:
8420 1. For assignment, check if a many-to-one assignment happens.
8421 2. For WHERE statement, check the WHERE body to see if there is any
8422 many-to-one assignment. */
8425 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8429 c = code->block->next;
8435 case EXEC_POINTER_ASSIGN:
8436 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8439 case EXEC_ASSIGN_CALL:
8443 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8444 there is no need to handle it here. */
8448 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8453 /* The next statement in the FORALL body. */
8459 /* Counts the number of iterators needed inside a forall construct, including
8460 nested forall constructs. This is used to allocate the needed memory
8461 in gfc_resolve_forall. */
8464 gfc_count_forall_iterators (gfc_code *code)
8466 int max_iters, sub_iters, current_iters;
8467 gfc_forall_iterator *fa;
8469 gcc_assert(code->op == EXEC_FORALL);
8473 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8476 code = code->block->next;
8480 if (code->op == EXEC_FORALL)
8482 sub_iters = gfc_count_forall_iterators (code);
8483 if (sub_iters > max_iters)
8484 max_iters = sub_iters;
8489 return current_iters + max_iters;
8493 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8494 gfc_resolve_forall_body to resolve the FORALL body. */
8497 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8499 static gfc_expr **var_expr;
8500 static int total_var = 0;
8501 static int nvar = 0;
8503 gfc_forall_iterator *fa;
8508 /* Start to resolve a FORALL construct */
8509 if (forall_save == 0)
8511 /* Count the total number of FORALL index in the nested FORALL
8512 construct in order to allocate the VAR_EXPR with proper size. */
8513 total_var = gfc_count_forall_iterators (code);
8515 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8516 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8519 /* The information about FORALL iterator, including FORALL index start, end
8520 and stride. The FORALL index can not appear in start, end or stride. */
8521 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8523 /* Check if any outer FORALL index name is the same as the current
8525 for (i = 0; i < nvar; i++)
8527 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8529 gfc_error ("An outer FORALL construct already has an index "
8530 "with this name %L", &fa->var->where);
8534 /* Record the current FORALL index. */
8535 var_expr[nvar] = gfc_copy_expr (fa->var);
8539 /* No memory leak. */
8540 gcc_assert (nvar <= total_var);
8543 /* Resolve the FORALL body. */
8544 gfc_resolve_forall_body (code, nvar, var_expr);
8546 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8547 gfc_resolve_blocks (code->block, ns);
8551 /* Free only the VAR_EXPRs allocated in this frame. */
8552 for (i = nvar; i < tmp; i++)
8553 gfc_free_expr (var_expr[i]);
8557 /* We are in the outermost FORALL construct. */
8558 gcc_assert (forall_save == 0);
8560 /* VAR_EXPR is not needed any more. */
8561 gfc_free (var_expr);
8567 /* Resolve a BLOCK construct statement. */
8570 resolve_block_construct (gfc_code* code)
8572 /* Resolve the BLOCK's namespace. */
8573 gfc_resolve (code->ext.block.ns);
8575 /* For an ASSOCIATE block, the associations (and their targets) are already
8576 resolved during resolve_symbol. */
8580 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8583 static void resolve_code (gfc_code *, gfc_namespace *);
8586 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8590 for (; b; b = b->block)
8592 t = gfc_resolve_expr (b->expr1);
8593 if (gfc_resolve_expr (b->expr2) == FAILURE)
8599 if (t == SUCCESS && b->expr1 != NULL
8600 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8601 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8608 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8609 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8614 resolve_branch (b->label1, b);
8618 resolve_block_construct (b);
8622 case EXEC_SELECT_TYPE:
8633 case EXEC_OMP_ATOMIC:
8634 case EXEC_OMP_CRITICAL:
8636 case EXEC_OMP_MASTER:
8637 case EXEC_OMP_ORDERED:
8638 case EXEC_OMP_PARALLEL:
8639 case EXEC_OMP_PARALLEL_DO:
8640 case EXEC_OMP_PARALLEL_SECTIONS:
8641 case EXEC_OMP_PARALLEL_WORKSHARE:
8642 case EXEC_OMP_SECTIONS:
8643 case EXEC_OMP_SINGLE:
8645 case EXEC_OMP_TASKWAIT:
8646 case EXEC_OMP_WORKSHARE:
8650 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8653 resolve_code (b->next, ns);
8658 /* Does everything to resolve an ordinary assignment. Returns true
8659 if this is an interface assignment. */
8661 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8671 if (gfc_extend_assign (code, ns) == SUCCESS)
8675 if (code->op == EXEC_ASSIGN_CALL)
8677 lhs = code->ext.actual->expr;
8678 rhsptr = &code->ext.actual->next->expr;
8682 gfc_actual_arglist* args;
8683 gfc_typebound_proc* tbp;
8685 gcc_assert (code->op == EXEC_COMPCALL);
8687 args = code->expr1->value.compcall.actual;
8689 rhsptr = &args->next->expr;
8691 tbp = code->expr1->value.compcall.tbp;
8692 gcc_assert (!tbp->is_generic);
8695 /* Make a temporary rhs when there is a default initializer
8696 and rhs is the same symbol as the lhs. */
8697 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8698 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8699 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8700 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8701 *rhsptr = gfc_get_parentheses (*rhsptr);
8710 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8711 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8712 &code->loc) == FAILURE)
8715 /* Handle the case of a BOZ literal on the RHS. */
8716 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8719 if (gfc_option.warn_surprising)
8720 gfc_warning ("BOZ literal at %L is bitwise transferred "
8721 "non-integer symbol '%s'", &code->loc,
8722 lhs->symtree->n.sym->name);
8724 if (!gfc_convert_boz (rhs, &lhs->ts))
8726 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8728 if (rc == ARITH_UNDERFLOW)
8729 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8730 ". This check can be disabled with the option "
8731 "-fno-range-check", &rhs->where);
8732 else if (rc == ARITH_OVERFLOW)
8733 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8734 ". This check can be disabled with the option "
8735 "-fno-range-check", &rhs->where);
8736 else if (rc == ARITH_NAN)
8737 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8738 ". This check can be disabled with the option "
8739 "-fno-range-check", &rhs->where);
8744 if (lhs->ts.type == BT_CHARACTER
8745 && gfc_option.warn_character_truncation)
8747 if (lhs->ts.u.cl != NULL
8748 && lhs->ts.u.cl->length != NULL
8749 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8750 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8752 if (rhs->expr_type == EXPR_CONSTANT)
8753 rlen = rhs->value.character.length;
8755 else if (rhs->ts.u.cl != NULL
8756 && rhs->ts.u.cl->length != NULL
8757 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8758 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8760 if (rlen && llen && rlen > llen)
8761 gfc_warning_now ("CHARACTER expression will be truncated "
8762 "in assignment (%d/%d) at %L",
8763 llen, rlen, &code->loc);
8766 /* Ensure that a vector index expression for the lvalue is evaluated
8767 to a temporary if the lvalue symbol is referenced in it. */
8770 for (ref = lhs->ref; ref; ref= ref->next)
8771 if (ref->type == REF_ARRAY)
8773 for (n = 0; n < ref->u.ar.dimen; n++)
8774 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8775 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8776 ref->u.ar.start[n]))
8778 = gfc_get_parentheses (ref->u.ar.start[n]);
8782 if (gfc_pure (NULL))
8784 if (lhs->ts.type == BT_DERIVED
8785 && lhs->expr_type == EXPR_VARIABLE
8786 && lhs->ts.u.derived->attr.pointer_comp
8787 && rhs->expr_type == EXPR_VARIABLE
8788 && (gfc_impure_variable (rhs->symtree->n.sym)
8789 || gfc_is_coindexed (rhs)))
8792 if (gfc_is_coindexed (rhs))
8793 gfc_error ("Coindexed expression at %L is assigned to "
8794 "a derived type variable with a POINTER "
8795 "component in a PURE procedure",
8798 gfc_error ("The impure variable at %L is assigned to "
8799 "a derived type variable with a POINTER "
8800 "component in a PURE procedure (12.6)",
8805 /* Fortran 2008, C1283. */
8806 if (gfc_is_coindexed (lhs))
8808 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8809 "procedure", &rhs->where);
8814 if (gfc_implicit_pure (NULL))
8816 if (lhs->expr_type == EXPR_VARIABLE
8817 && lhs->symtree->n.sym != gfc_current_ns->proc_name
8818 && lhs->symtree->n.sym->ns != gfc_current_ns)
8819 gfc_current_ns->proc_name->attr.implicit_pure = 0;
8821 if (lhs->ts.type == BT_DERIVED
8822 && lhs->expr_type == EXPR_VARIABLE
8823 && lhs->ts.u.derived->attr.pointer_comp
8824 && rhs->expr_type == EXPR_VARIABLE
8825 && (gfc_impure_variable (rhs->symtree->n.sym)
8826 || gfc_is_coindexed (rhs)))
8827 gfc_current_ns->proc_name->attr.implicit_pure = 0;
8829 /* Fortran 2008, C1283. */
8830 if (gfc_is_coindexed (lhs))
8831 gfc_current_ns->proc_name->attr.implicit_pure = 0;
8835 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8836 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8837 if (lhs->ts.type == BT_CLASS)
8839 gfc_error ("Variable must not be polymorphic in assignment at %L",
8844 /* F2008, Section 7.2.1.2. */
8845 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8847 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8848 "component in assignment at %L", &lhs->where);
8852 gfc_check_assign (lhs, rhs, 1);
8857 /* Given a block of code, recursively resolve everything pointed to by this
8861 resolve_code (gfc_code *code, gfc_namespace *ns)
8863 int omp_workshare_save;
8868 frame.prev = cs_base;
8872 find_reachable_labels (code);
8874 for (; code; code = code->next)
8876 frame.current = code;
8877 forall_save = forall_flag;
8879 if (code->op == EXEC_FORALL)
8882 gfc_resolve_forall (code, ns, forall_save);
8885 else if (code->block)
8887 omp_workshare_save = -1;
8890 case EXEC_OMP_PARALLEL_WORKSHARE:
8891 omp_workshare_save = omp_workshare_flag;
8892 omp_workshare_flag = 1;
8893 gfc_resolve_omp_parallel_blocks (code, ns);
8895 case EXEC_OMP_PARALLEL:
8896 case EXEC_OMP_PARALLEL_DO:
8897 case EXEC_OMP_PARALLEL_SECTIONS:
8899 omp_workshare_save = omp_workshare_flag;
8900 omp_workshare_flag = 0;
8901 gfc_resolve_omp_parallel_blocks (code, ns);
8904 gfc_resolve_omp_do_blocks (code, ns);
8906 case EXEC_SELECT_TYPE:
8907 /* Blocks are handled in resolve_select_type because we have
8908 to transform the SELECT TYPE into ASSOCIATE first. */
8910 case EXEC_OMP_WORKSHARE:
8911 omp_workshare_save = omp_workshare_flag;
8912 omp_workshare_flag = 1;
8915 gfc_resolve_blocks (code->block, ns);
8919 if (omp_workshare_save != -1)
8920 omp_workshare_flag = omp_workshare_save;
8924 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8925 t = gfc_resolve_expr (code->expr1);
8926 forall_flag = forall_save;
8928 if (gfc_resolve_expr (code->expr2) == FAILURE)
8931 if (code->op == EXEC_ALLOCATE
8932 && gfc_resolve_expr (code->expr3) == FAILURE)
8938 case EXEC_END_BLOCK:
8942 case EXEC_ERROR_STOP:
8946 case EXEC_ASSIGN_CALL:
8951 case EXEC_SYNC_IMAGES:
8952 case EXEC_SYNC_MEMORY:
8953 resolve_sync (code);
8957 /* Keep track of which entry we are up to. */
8958 current_entry_id = code->ext.entry->id;
8962 resolve_where (code, NULL);
8966 if (code->expr1 != NULL)
8968 if (code->expr1->ts.type != BT_INTEGER)
8969 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8970 "INTEGER variable", &code->expr1->where);
8971 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8972 gfc_error ("Variable '%s' has not been assigned a target "
8973 "label at %L", code->expr1->symtree->n.sym->name,
8974 &code->expr1->where);
8977 resolve_branch (code->label1, code);
8981 if (code->expr1 != NULL
8982 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8983 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8984 "INTEGER return specifier", &code->expr1->where);
8987 case EXEC_INIT_ASSIGN:
8988 case EXEC_END_PROCEDURE:
8995 if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
8999 if (resolve_ordinary_assign (code, ns))
9001 if (code->op == EXEC_COMPCALL)
9008 case EXEC_LABEL_ASSIGN:
9009 if (code->label1->defined == ST_LABEL_UNKNOWN)
9010 gfc_error ("Label %d referenced at %L is never defined",
9011 code->label1->value, &code->label1->where);
9013 && (code->expr1->expr_type != EXPR_VARIABLE
9014 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9015 || code->expr1->symtree->n.sym->ts.kind
9016 != gfc_default_integer_kind
9017 || code->expr1->symtree->n.sym->as != NULL))
9018 gfc_error ("ASSIGN statement at %L requires a scalar "
9019 "default INTEGER variable", &code->expr1->where);
9022 case EXEC_POINTER_ASSIGN:
9029 /* This is both a variable definition and pointer assignment
9030 context, so check both of them. For rank remapping, a final
9031 array ref may be present on the LHS and fool gfc_expr_attr
9032 used in gfc_check_vardef_context. Remove it. */
9033 e = remove_last_array_ref (code->expr1);
9034 t = gfc_check_vardef_context (e, true, _("pointer assignment"));
9036 t = gfc_check_vardef_context (e, false, _("pointer assignment"));
9041 gfc_check_pointer_assign (code->expr1, code->expr2);
9045 case EXEC_ARITHMETIC_IF:
9047 && code->expr1->ts.type != BT_INTEGER
9048 && code->expr1->ts.type != BT_REAL)
9049 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9050 "expression", &code->expr1->where);
9052 resolve_branch (code->label1, code);
9053 resolve_branch (code->label2, code);
9054 resolve_branch (code->label3, code);
9058 if (t == SUCCESS && code->expr1 != NULL
9059 && (code->expr1->ts.type != BT_LOGICAL
9060 || code->expr1->rank != 0))
9061 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9062 &code->expr1->where);
9067 resolve_call (code);
9072 resolve_typebound_subroutine (code);
9076 resolve_ppc_call (code);
9080 /* Select is complicated. Also, a SELECT construct could be
9081 a transformed computed GOTO. */
9082 resolve_select (code);
9085 case EXEC_SELECT_TYPE:
9086 resolve_select_type (code, ns);
9090 resolve_block_construct (code);
9094 if (code->ext.iterator != NULL)
9096 gfc_iterator *iter = code->ext.iterator;
9097 if (gfc_resolve_iterator (iter, true) != FAILURE)
9098 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9103 if (code->expr1 == NULL)
9104 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9106 && (code->expr1->rank != 0
9107 || code->expr1->ts.type != BT_LOGICAL))
9108 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9109 "a scalar LOGICAL expression", &code->expr1->where);
9114 resolve_allocate_deallocate (code, "ALLOCATE");
9118 case EXEC_DEALLOCATE:
9120 resolve_allocate_deallocate (code, "DEALLOCATE");
9125 if (gfc_resolve_open (code->ext.open) == FAILURE)
9128 resolve_branch (code->ext.open->err, code);
9132 if (gfc_resolve_close (code->ext.close) == FAILURE)
9135 resolve_branch (code->ext.close->err, code);
9138 case EXEC_BACKSPACE:
9142 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9145 resolve_branch (code->ext.filepos->err, code);
9149 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9152 resolve_branch (code->ext.inquire->err, code);
9156 gcc_assert (code->ext.inquire != NULL);
9157 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9160 resolve_branch (code->ext.inquire->err, code);
9164 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9167 resolve_branch (code->ext.wait->err, code);
9168 resolve_branch (code->ext.wait->end, code);
9169 resolve_branch (code->ext.wait->eor, code);
9174 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9177 resolve_branch (code->ext.dt->err, code);
9178 resolve_branch (code->ext.dt->end, code);
9179 resolve_branch (code->ext.dt->eor, code);
9183 resolve_transfer (code);
9187 resolve_forall_iterators (code->ext.forall_iterator);
9189 if (code->expr1 != NULL
9190 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9191 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9192 "expression", &code->expr1->where);
9195 case EXEC_OMP_ATOMIC:
9196 case EXEC_OMP_BARRIER:
9197 case EXEC_OMP_CRITICAL:
9198 case EXEC_OMP_FLUSH:
9200 case EXEC_OMP_MASTER:
9201 case EXEC_OMP_ORDERED:
9202 case EXEC_OMP_SECTIONS:
9203 case EXEC_OMP_SINGLE:
9204 case EXEC_OMP_TASKWAIT:
9205 case EXEC_OMP_WORKSHARE:
9206 gfc_resolve_omp_directive (code, ns);
9209 case EXEC_OMP_PARALLEL:
9210 case EXEC_OMP_PARALLEL_DO:
9211 case EXEC_OMP_PARALLEL_SECTIONS:
9212 case EXEC_OMP_PARALLEL_WORKSHARE:
9214 omp_workshare_save = omp_workshare_flag;
9215 omp_workshare_flag = 0;
9216 gfc_resolve_omp_directive (code, ns);
9217 omp_workshare_flag = omp_workshare_save;
9221 gfc_internal_error ("resolve_code(): Bad statement code");
9225 cs_base = frame.prev;
9229 /* Resolve initial values and make sure they are compatible with
9233 resolve_values (gfc_symbol *sym)
9237 if (sym->value == NULL)
9240 if (sym->value->expr_type == EXPR_STRUCTURE)
9241 t= resolve_structure_cons (sym->value, 1);
9243 t = gfc_resolve_expr (sym->value);
9248 gfc_check_assign_symbol (sym, sym->value);
9252 /* Verify the binding labels for common blocks that are BIND(C). The label
9253 for a BIND(C) common block must be identical in all scoping units in which
9254 the common block is declared. Further, the binding label can not collide
9255 with any other global entity in the program. */
9258 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9260 if (comm_block_tree->n.common->is_bind_c == 1)
9262 gfc_gsymbol *binding_label_gsym;
9263 gfc_gsymbol *comm_name_gsym;
9265 /* See if a global symbol exists by the common block's name. It may
9266 be NULL if the common block is use-associated. */
9267 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9268 comm_block_tree->n.common->name);
9269 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9270 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9271 "with the global entity '%s' at %L",
9272 comm_block_tree->n.common->binding_label,
9273 comm_block_tree->n.common->name,
9274 &(comm_block_tree->n.common->where),
9275 comm_name_gsym->name, &(comm_name_gsym->where));
9276 else if (comm_name_gsym != NULL
9277 && strcmp (comm_name_gsym->name,
9278 comm_block_tree->n.common->name) == 0)
9280 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9282 if (comm_name_gsym->binding_label == NULL)
9283 /* No binding label for common block stored yet; save this one. */
9284 comm_name_gsym->binding_label =
9285 comm_block_tree->n.common->binding_label;
9287 if (strcmp (comm_name_gsym->binding_label,
9288 comm_block_tree->n.common->binding_label) != 0)
9290 /* Common block names match but binding labels do not. */
9291 gfc_error ("Binding label '%s' for common block '%s' at %L "
9292 "does not match the binding label '%s' for common "
9294 comm_block_tree->n.common->binding_label,
9295 comm_block_tree->n.common->name,
9296 &(comm_block_tree->n.common->where),
9297 comm_name_gsym->binding_label,
9298 comm_name_gsym->name,
9299 &(comm_name_gsym->where));
9304 /* There is no binding label (NAME="") so we have nothing further to
9305 check and nothing to add as a global symbol for the label. */
9306 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9309 binding_label_gsym =
9310 gfc_find_gsymbol (gfc_gsym_root,
9311 comm_block_tree->n.common->binding_label);
9312 if (binding_label_gsym == NULL)
9314 /* Need to make a global symbol for the binding label to prevent
9315 it from colliding with another. */
9316 binding_label_gsym =
9317 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9318 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9319 binding_label_gsym->type = GSYM_COMMON;
9323 /* If comm_name_gsym is NULL, the name common block is use
9324 associated and the name could be colliding. */
9325 if (binding_label_gsym->type != GSYM_COMMON)
9326 gfc_error ("Binding label '%s' for common block '%s' at %L "
9327 "collides with the global entity '%s' at %L",
9328 comm_block_tree->n.common->binding_label,
9329 comm_block_tree->n.common->name,
9330 &(comm_block_tree->n.common->where),
9331 binding_label_gsym->name,
9332 &(binding_label_gsym->where));
9333 else if (comm_name_gsym != NULL
9334 && (strcmp (binding_label_gsym->name,
9335 comm_name_gsym->binding_label) != 0)
9336 && (strcmp (binding_label_gsym->sym_name,
9337 comm_name_gsym->name) != 0))
9338 gfc_error ("Binding label '%s' for common block '%s' at %L "
9339 "collides with global entity '%s' at %L",
9340 binding_label_gsym->name, binding_label_gsym->sym_name,
9341 &(comm_block_tree->n.common->where),
9342 comm_name_gsym->name, &(comm_name_gsym->where));
9350 /* Verify any BIND(C) derived types in the namespace so we can report errors
9351 for them once, rather than for each variable declared of that type. */
9354 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9356 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9357 && derived_sym->attr.is_bind_c == 1)
9358 verify_bind_c_derived_type (derived_sym);
9364 /* Verify that any binding labels used in a given namespace do not collide
9365 with the names or binding labels of any global symbols. */
9368 gfc_verify_binding_labels (gfc_symbol *sym)
9372 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9373 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9375 gfc_gsymbol *bind_c_sym;
9377 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9378 if (bind_c_sym != NULL
9379 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9381 if (sym->attr.if_source == IFSRC_DECL
9382 && (bind_c_sym->type != GSYM_SUBROUTINE
9383 && bind_c_sym->type != GSYM_FUNCTION)
9384 && ((sym->attr.contained == 1
9385 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9386 || (sym->attr.use_assoc == 1
9387 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9389 /* Make sure global procedures don't collide with anything. */
9390 gfc_error ("Binding label '%s' at %L collides with the global "
9391 "entity '%s' at %L", sym->binding_label,
9392 &(sym->declared_at), bind_c_sym->name,
9393 &(bind_c_sym->where));
9396 else if (sym->attr.contained == 0
9397 && (sym->attr.if_source == IFSRC_IFBODY
9398 && sym->attr.flavor == FL_PROCEDURE)
9399 && (bind_c_sym->sym_name != NULL
9400 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9402 /* Make sure procedures in interface bodies don't collide. */
9403 gfc_error ("Binding label '%s' in interface body at %L collides "
9404 "with the global entity '%s' at %L",
9406 &(sym->declared_at), bind_c_sym->name,
9407 &(bind_c_sym->where));
9410 else if (sym->attr.contained == 0
9411 && sym->attr.if_source == IFSRC_UNKNOWN)
9412 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9413 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9414 || sym->attr.use_assoc == 0)
9416 gfc_error ("Binding label '%s' at %L collides with global "
9417 "entity '%s' at %L", sym->binding_label,
9418 &(sym->declared_at), bind_c_sym->name,
9419 &(bind_c_sym->where));
9424 /* Clear the binding label to prevent checking multiple times. */
9425 sym->binding_label[0] = '\0';
9427 else if (bind_c_sym == NULL)
9429 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9430 bind_c_sym->where = sym->declared_at;
9431 bind_c_sym->sym_name = sym->name;
9433 if (sym->attr.use_assoc == 1)
9434 bind_c_sym->mod_name = sym->module;
9436 if (sym->ns->proc_name != NULL)
9437 bind_c_sym->mod_name = sym->ns->proc_name->name;
9439 if (sym->attr.contained == 0)
9441 if (sym->attr.subroutine)
9442 bind_c_sym->type = GSYM_SUBROUTINE;
9443 else if (sym->attr.function)
9444 bind_c_sym->type = GSYM_FUNCTION;
9452 /* Resolve an index expression. */
9455 resolve_index_expr (gfc_expr *e)
9457 if (gfc_resolve_expr (e) == FAILURE)
9460 if (gfc_simplify_expr (e, 0) == FAILURE)
9463 if (gfc_specification_expr (e) == FAILURE)
9470 /* Resolve a charlen structure. */
9473 resolve_charlen (gfc_charlen *cl)
9482 specification_expr = 1;
9484 if (resolve_index_expr (cl->length) == FAILURE)
9486 specification_expr = 0;
9490 /* "If the character length parameter value evaluates to a negative
9491 value, the length of character entities declared is zero." */
9492 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9494 if (gfc_option.warn_surprising)
9495 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9496 " the length has been set to zero",
9497 &cl->length->where, i);
9498 gfc_replace_expr (cl->length,
9499 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9502 /* Check that the character length is not too large. */
9503 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9504 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9505 && cl->length->ts.type == BT_INTEGER
9506 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9508 gfc_error ("String length at %L is too large", &cl->length->where);
9516 /* Test for non-constant shape arrays. */
9519 is_non_constant_shape_array (gfc_symbol *sym)
9525 not_constant = false;
9526 if (sym->as != NULL)
9528 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9529 has not been simplified; parameter array references. Do the
9530 simplification now. */
9531 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9533 e = sym->as->lower[i];
9534 if (e && (resolve_index_expr (e) == FAILURE
9535 || !gfc_is_constant_expr (e)))
9536 not_constant = true;
9537 e = sym->as->upper[i];
9538 if (e && (resolve_index_expr (e) == FAILURE
9539 || !gfc_is_constant_expr (e)))
9540 not_constant = true;
9543 return not_constant;
9546 /* Given a symbol and an initialization expression, add code to initialize
9547 the symbol to the function entry. */
9549 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9553 gfc_namespace *ns = sym->ns;
9555 /* Search for the function namespace if this is a contained
9556 function without an explicit result. */
9557 if (sym->attr.function && sym == sym->result
9558 && sym->name != sym->ns->proc_name->name)
9561 for (;ns; ns = ns->sibling)
9562 if (strcmp (ns->proc_name->name, sym->name) == 0)
9568 gfc_free_expr (init);
9572 /* Build an l-value expression for the result. */
9573 lval = gfc_lval_expr_from_sym (sym);
9575 /* Add the code at scope entry. */
9576 init_st = gfc_get_code ();
9577 init_st->next = ns->code;
9580 /* Assign the default initializer to the l-value. */
9581 init_st->loc = sym->declared_at;
9582 init_st->op = EXEC_INIT_ASSIGN;
9583 init_st->expr1 = lval;
9584 init_st->expr2 = init;
9587 /* Assign the default initializer to a derived type variable or result. */
9590 apply_default_init (gfc_symbol *sym)
9592 gfc_expr *init = NULL;
9594 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9597 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9598 init = gfc_default_initializer (&sym->ts);
9600 if (init == NULL && sym->ts.type != BT_CLASS)
9603 build_init_assign (sym, init);
9604 sym->attr.referenced = 1;
9607 /* Build an initializer for a local integer, real, complex, logical, or
9608 character variable, based on the command line flags finit-local-zero,
9609 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9610 null if the symbol should not have a default initialization. */
9612 build_default_init_expr (gfc_symbol *sym)
9615 gfc_expr *init_expr;
9618 /* These symbols should never have a default initialization. */
9619 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9620 || sym->attr.external
9622 || sym->attr.pointer
9623 || sym->attr.in_equivalence
9624 || sym->attr.in_common
9627 || sym->attr.cray_pointee
9628 || sym->attr.cray_pointer)
9631 /* Now we'll try to build an initializer expression. */
9632 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9635 /* We will only initialize integers, reals, complex, logicals, and
9636 characters, and only if the corresponding command-line flags
9637 were set. Otherwise, we free init_expr and return null. */
9638 switch (sym->ts.type)
9641 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9642 mpz_set_si (init_expr->value.integer,
9643 gfc_option.flag_init_integer_value);
9646 gfc_free_expr (init_expr);
9652 switch (gfc_option.flag_init_real)
9654 case GFC_INIT_REAL_SNAN:
9655 init_expr->is_snan = 1;
9657 case GFC_INIT_REAL_NAN:
9658 mpfr_set_nan (init_expr->value.real);
9661 case GFC_INIT_REAL_INF:
9662 mpfr_set_inf (init_expr->value.real, 1);
9665 case GFC_INIT_REAL_NEG_INF:
9666 mpfr_set_inf (init_expr->value.real, -1);
9669 case GFC_INIT_REAL_ZERO:
9670 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9674 gfc_free_expr (init_expr);
9681 switch (gfc_option.flag_init_real)
9683 case GFC_INIT_REAL_SNAN:
9684 init_expr->is_snan = 1;
9686 case GFC_INIT_REAL_NAN:
9687 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9688 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9691 case GFC_INIT_REAL_INF:
9692 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9693 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9696 case GFC_INIT_REAL_NEG_INF:
9697 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9698 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9701 case GFC_INIT_REAL_ZERO:
9702 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9706 gfc_free_expr (init_expr);
9713 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9714 init_expr->value.logical = 0;
9715 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9716 init_expr->value.logical = 1;
9719 gfc_free_expr (init_expr);
9725 /* For characters, the length must be constant in order to
9726 create a default initializer. */
9727 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9728 && sym->ts.u.cl->length
9729 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9731 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9732 init_expr->value.character.length = char_len;
9733 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9734 for (i = 0; i < char_len; i++)
9735 init_expr->value.character.string[i]
9736 = (unsigned char) gfc_option.flag_init_character_value;
9740 gfc_free_expr (init_expr);
9746 gfc_free_expr (init_expr);
9752 /* Add an initialization expression to a local variable. */
9754 apply_default_init_local (gfc_symbol *sym)
9756 gfc_expr *init = NULL;
9758 /* The symbol should be a variable or a function return value. */
9759 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9760 || (sym->attr.function && sym->result != sym))
9763 /* Try to build the initializer expression. If we can't initialize
9764 this symbol, then init will be NULL. */
9765 init = build_default_init_expr (sym);
9769 /* For saved variables, we don't want to add an initializer at
9770 function entry, so we just add a static initializer. */
9771 if (sym->attr.save || sym->ns->save_all
9772 || gfc_option.flag_max_stack_var_size == 0)
9774 /* Don't clobber an existing initializer! */
9775 gcc_assert (sym->value == NULL);
9780 build_init_assign (sym, init);
9784 /* Resolution of common features of flavors variable and procedure. */
9787 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9789 /* Constraints on deferred shape variable. */
9790 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9792 if (sym->attr.allocatable)
9794 if (sym->attr.dimension)
9796 gfc_error ("Allocatable array '%s' at %L must have "
9797 "a deferred shape", sym->name, &sym->declared_at);
9800 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9801 "may not be ALLOCATABLE", sym->name,
9802 &sym->declared_at) == FAILURE)
9806 if (sym->attr.pointer && sym->attr.dimension)
9808 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9809 sym->name, &sym->declared_at);
9815 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9816 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9818 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9819 sym->name, &sym->declared_at);
9824 /* Constraints on polymorphic variables. */
9825 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9828 if (sym->attr.class_ok
9829 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9831 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9832 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9838 /* Assume that use associated symbols were checked in the module ns.
9839 Class-variables that are associate-names are also something special
9840 and excepted from the test. */
9841 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
9843 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9844 "or pointer", sym->name, &sym->declared_at);
9853 /* Additional checks for symbols with flavor variable and derived
9854 type. To be called from resolve_fl_variable. */
9857 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9859 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9861 /* Check to see if a derived type is blocked from being host
9862 associated by the presence of another class I symbol in the same
9863 namespace. 14.6.1.3 of the standard and the discussion on
9864 comp.lang.fortran. */
9865 if (sym->ns != sym->ts.u.derived->ns
9866 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9869 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9870 if (s && s->attr.flavor != FL_DERIVED)
9872 gfc_error ("The type '%s' cannot be host associated at %L "
9873 "because it is blocked by an incompatible object "
9874 "of the same name declared at %L",
9875 sym->ts.u.derived->name, &sym->declared_at,
9881 /* 4th constraint in section 11.3: "If an object of a type for which
9882 component-initialization is specified (R429) appears in the
9883 specification-part of a module and does not have the ALLOCATABLE
9884 or POINTER attribute, the object shall have the SAVE attribute."
9886 The check for initializers is performed with
9887 gfc_has_default_initializer because gfc_default_initializer generates
9888 a hidden default for allocatable components. */
9889 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9890 && sym->ns->proc_name->attr.flavor == FL_MODULE
9891 && !sym->ns->save_all && !sym->attr.save
9892 && !sym->attr.pointer && !sym->attr.allocatable
9893 && gfc_has_default_initializer (sym->ts.u.derived)
9894 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9895 "module variable '%s' at %L, needed due to "
9896 "the default initialization", sym->name,
9897 &sym->declared_at) == FAILURE)
9900 /* Assign default initializer. */
9901 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9902 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9904 sym->value = gfc_default_initializer (&sym->ts);
9911 /* Resolve symbols with flavor variable. */
9914 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9916 int no_init_flag, automatic_flag;
9918 const char *auto_save_msg;
9920 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9923 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9926 /* Set this flag to check that variables are parameters of all entries.
9927 This check is effected by the call to gfc_resolve_expr through
9928 is_non_constant_shape_array. */
9929 specification_expr = 1;
9931 if (sym->ns->proc_name
9932 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9933 || sym->ns->proc_name->attr.is_main_program)
9934 && !sym->attr.use_assoc
9935 && !sym->attr.allocatable
9936 && !sym->attr.pointer
9937 && is_non_constant_shape_array (sym))
9939 /* The shape of a main program or module array needs to be
9941 gfc_error ("The module or main program array '%s' at %L must "
9942 "have constant shape", sym->name, &sym->declared_at);
9943 specification_expr = 0;
9947 /* Constraints on deferred type parameter. */
9948 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
9950 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
9951 "requires either the pointer or allocatable attribute",
9952 sym->name, &sym->declared_at);
9956 if (sym->ts.type == BT_CHARACTER)
9958 /* Make sure that character string variables with assumed length are
9960 e = sym->ts.u.cl->length;
9961 if (e == NULL && !sym->attr.dummy && !sym->attr.result
9962 && !sym->ts.deferred)
9964 gfc_error ("Entity with assumed character length at %L must be a "
9965 "dummy argument or a PARAMETER", &sym->declared_at);
9969 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9971 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9975 if (!gfc_is_constant_expr (e)
9976 && !(e->expr_type == EXPR_VARIABLE
9977 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9978 && sym->ns->proc_name
9979 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9980 || sym->ns->proc_name->attr.is_main_program)
9981 && !sym->attr.use_assoc)
9983 gfc_error ("'%s' at %L must have constant character length "
9984 "in this context", sym->name, &sym->declared_at);
9989 if (sym->value == NULL && sym->attr.referenced)
9990 apply_default_init_local (sym); /* Try to apply a default initialization. */
9992 /* Determine if the symbol may not have an initializer. */
9993 no_init_flag = automatic_flag = 0;
9994 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9995 || sym->attr.intrinsic || sym->attr.result)
9997 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9998 && is_non_constant_shape_array (sym))
10000 no_init_flag = automatic_flag = 1;
10002 /* Also, they must not have the SAVE attribute.
10003 SAVE_IMPLICIT is checked below. */
10004 if (sym->attr.save == SAVE_EXPLICIT)
10006 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10011 /* Ensure that any initializer is simplified. */
10013 gfc_simplify_expr (sym->value, 1);
10015 /* Reject illegal initializers. */
10016 if (!sym->mark && sym->value)
10018 if (sym->attr.allocatable)
10019 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10020 sym->name, &sym->declared_at);
10021 else if (sym->attr.external)
10022 gfc_error ("External '%s' at %L cannot have an initializer",
10023 sym->name, &sym->declared_at);
10024 else if (sym->attr.dummy
10025 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10026 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10027 sym->name, &sym->declared_at);
10028 else if (sym->attr.intrinsic)
10029 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10030 sym->name, &sym->declared_at);
10031 else if (sym->attr.result)
10032 gfc_error ("Function result '%s' at %L cannot have an initializer",
10033 sym->name, &sym->declared_at);
10034 else if (automatic_flag)
10035 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10036 sym->name, &sym->declared_at);
10038 goto no_init_error;
10043 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10044 return resolve_fl_variable_derived (sym, no_init_flag);
10050 /* Resolve a procedure. */
10053 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10055 gfc_formal_arglist *arg;
10057 if (sym->attr.function
10058 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10061 if (sym->ts.type == BT_CHARACTER)
10063 gfc_charlen *cl = sym->ts.u.cl;
10065 if (cl && cl->length && gfc_is_constant_expr (cl->length)
10066 && resolve_charlen (cl) == FAILURE)
10069 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10070 && sym->attr.proc == PROC_ST_FUNCTION)
10072 gfc_error ("Character-valued statement function '%s' at %L must "
10073 "have constant length", sym->name, &sym->declared_at);
10078 /* Ensure that derived type for are not of a private type. Internal
10079 module procedures are excluded by 2.2.3.3 - i.e., they are not
10080 externally accessible and can access all the objects accessible in
10082 if (!(sym->ns->parent
10083 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10084 && gfc_check_access(sym->attr.access, sym->ns->default_access))
10086 gfc_interface *iface;
10088 for (arg = sym->formal; arg; arg = arg->next)
10091 && arg->sym->ts.type == BT_DERIVED
10092 && !arg->sym->ts.u.derived->attr.use_assoc
10093 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10094 arg->sym->ts.u.derived->ns->default_access)
10095 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10096 "PRIVATE type and cannot be a dummy argument"
10097 " of '%s', which is PUBLIC at %L",
10098 arg->sym->name, sym->name, &sym->declared_at)
10101 /* Stop this message from recurring. */
10102 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10107 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10108 PRIVATE to the containing module. */
10109 for (iface = sym->generic; iface; iface = iface->next)
10111 for (arg = iface->sym->formal; arg; arg = arg->next)
10114 && arg->sym->ts.type == BT_DERIVED
10115 && !arg->sym->ts.u.derived->attr.use_assoc
10116 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10117 arg->sym->ts.u.derived->ns->default_access)
10118 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10119 "'%s' in PUBLIC interface '%s' at %L "
10120 "takes dummy arguments of '%s' which is "
10121 "PRIVATE", iface->sym->name, sym->name,
10122 &iface->sym->declared_at,
10123 gfc_typename (&arg->sym->ts)) == FAILURE)
10125 /* Stop this message from recurring. */
10126 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10132 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10133 PRIVATE to the containing module. */
10134 for (iface = sym->generic; iface; iface = iface->next)
10136 for (arg = iface->sym->formal; arg; arg = arg->next)
10139 && arg->sym->ts.type == BT_DERIVED
10140 && !arg->sym->ts.u.derived->attr.use_assoc
10141 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
10142 arg->sym->ts.u.derived->ns->default_access)
10143 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10144 "'%s' in PUBLIC interface '%s' at %L "
10145 "takes dummy arguments of '%s' which is "
10146 "PRIVATE", iface->sym->name, sym->name,
10147 &iface->sym->declared_at,
10148 gfc_typename (&arg->sym->ts)) == FAILURE)
10150 /* Stop this message from recurring. */
10151 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10158 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10159 && !sym->attr.proc_pointer)
10161 gfc_error ("Function '%s' at %L cannot have an initializer",
10162 sym->name, &sym->declared_at);
10166 /* An external symbol may not have an initializer because it is taken to be
10167 a procedure. Exception: Procedure Pointers. */
10168 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10170 gfc_error ("External object '%s' at %L may not have an initializer",
10171 sym->name, &sym->declared_at);
10175 /* An elemental function is required to return a scalar 12.7.1 */
10176 if (sym->attr.elemental && sym->attr.function && sym->as)
10178 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10179 "result", sym->name, &sym->declared_at);
10180 /* Reset so that the error only occurs once. */
10181 sym->attr.elemental = 0;
10185 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10186 char-len-param shall not be array-valued, pointer-valued, recursive
10187 or pure. ....snip... A character value of * may only be used in the
10188 following ways: (i) Dummy arg of procedure - dummy associates with
10189 actual length; (ii) To declare a named constant; or (iii) External
10190 function - but length must be declared in calling scoping unit. */
10191 if (sym->attr.function
10192 && sym->ts.type == BT_CHARACTER
10193 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10195 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10196 || (sym->attr.recursive) || (sym->attr.pure))
10198 if (sym->as && sym->as->rank)
10199 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10200 "array-valued", sym->name, &sym->declared_at);
10202 if (sym->attr.pointer)
10203 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10204 "pointer-valued", sym->name, &sym->declared_at);
10206 if (sym->attr.pure)
10207 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10208 "pure", sym->name, &sym->declared_at);
10210 if (sym->attr.recursive)
10211 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10212 "recursive", sym->name, &sym->declared_at);
10217 /* Appendix B.2 of the standard. Contained functions give an
10218 error anyway. Fixed-form is likely to be F77/legacy. */
10219 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
10220 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10221 "CHARACTER(*) function '%s' at %L",
10222 sym->name, &sym->declared_at);
10225 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10227 gfc_formal_arglist *curr_arg;
10228 int has_non_interop_arg = 0;
10230 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10231 sym->common_block) == FAILURE)
10233 /* Clear these to prevent looking at them again if there was an
10235 sym->attr.is_bind_c = 0;
10236 sym->attr.is_c_interop = 0;
10237 sym->ts.is_c_interop = 0;
10241 /* So far, no errors have been found. */
10242 sym->attr.is_c_interop = 1;
10243 sym->ts.is_c_interop = 1;
10246 curr_arg = sym->formal;
10247 while (curr_arg != NULL)
10249 /* Skip implicitly typed dummy args here. */
10250 if (curr_arg->sym->attr.implicit_type == 0)
10251 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
10252 /* If something is found to fail, record the fact so we
10253 can mark the symbol for the procedure as not being
10254 BIND(C) to try and prevent multiple errors being
10256 has_non_interop_arg = 1;
10258 curr_arg = curr_arg->next;
10261 /* See if any of the arguments were not interoperable and if so, clear
10262 the procedure symbol to prevent duplicate error messages. */
10263 if (has_non_interop_arg != 0)
10265 sym->attr.is_c_interop = 0;
10266 sym->ts.is_c_interop = 0;
10267 sym->attr.is_bind_c = 0;
10271 if (!sym->attr.proc_pointer)
10273 if (sym->attr.save == SAVE_EXPLICIT)
10275 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10276 "in '%s' at %L", sym->name, &sym->declared_at);
10279 if (sym->attr.intent)
10281 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10282 "in '%s' at %L", sym->name, &sym->declared_at);
10285 if (sym->attr.subroutine && sym->attr.result)
10287 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10288 "in '%s' at %L", sym->name, &sym->declared_at);
10291 if (sym->attr.external && sym->attr.function
10292 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10293 || sym->attr.contained))
10295 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10296 "in '%s' at %L", sym->name, &sym->declared_at);
10299 if (strcmp ("ppr@", sym->name) == 0)
10301 gfc_error ("Procedure pointer result '%s' at %L "
10302 "is missing the pointer attribute",
10303 sym->ns->proc_name->name, &sym->declared_at);
10312 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10313 been defined and we now know their defined arguments, check that they fulfill
10314 the requirements of the standard for procedures used as finalizers. */
10317 gfc_resolve_finalizers (gfc_symbol* derived)
10319 gfc_finalizer* list;
10320 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10321 gfc_try result = SUCCESS;
10322 bool seen_scalar = false;
10324 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10327 /* Walk over the list of finalizer-procedures, check them, and if any one
10328 does not fit in with the standard's definition, print an error and remove
10329 it from the list. */
10330 prev_link = &derived->f2k_derived->finalizers;
10331 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10337 /* Skip this finalizer if we already resolved it. */
10338 if (list->proc_tree)
10340 prev_link = &(list->next);
10344 /* Check this exists and is a SUBROUTINE. */
10345 if (!list->proc_sym->attr.subroutine)
10347 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10348 list->proc_sym->name, &list->where);
10352 /* We should have exactly one argument. */
10353 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10355 gfc_error ("FINAL procedure at %L must have exactly one argument",
10359 arg = list->proc_sym->formal->sym;
10361 /* This argument must be of our type. */
10362 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10364 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10365 &arg->declared_at, derived->name);
10369 /* It must neither be a pointer nor allocatable nor optional. */
10370 if (arg->attr.pointer)
10372 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10373 &arg->declared_at);
10376 if (arg->attr.allocatable)
10378 gfc_error ("Argument of FINAL procedure at %L must not be"
10379 " ALLOCATABLE", &arg->declared_at);
10382 if (arg->attr.optional)
10384 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10385 &arg->declared_at);
10389 /* It must not be INTENT(OUT). */
10390 if (arg->attr.intent == INTENT_OUT)
10392 gfc_error ("Argument of FINAL procedure at %L must not be"
10393 " INTENT(OUT)", &arg->declared_at);
10397 /* Warn if the procedure is non-scalar and not assumed shape. */
10398 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10399 && arg->as->type != AS_ASSUMED_SHAPE)
10400 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10401 " shape argument", &arg->declared_at);
10403 /* Check that it does not match in kind and rank with a FINAL procedure
10404 defined earlier. To really loop over the *earlier* declarations,
10405 we need to walk the tail of the list as new ones were pushed at the
10407 /* TODO: Handle kind parameters once they are implemented. */
10408 my_rank = (arg->as ? arg->as->rank : 0);
10409 for (i = list->next; i; i = i->next)
10411 /* Argument list might be empty; that is an error signalled earlier,
10412 but we nevertheless continued resolving. */
10413 if (i->proc_sym->formal)
10415 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10416 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10417 if (i_rank == my_rank)
10419 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10420 " rank (%d) as '%s'",
10421 list->proc_sym->name, &list->where, my_rank,
10422 i->proc_sym->name);
10428 /* Is this the/a scalar finalizer procedure? */
10429 if (!arg->as || arg->as->rank == 0)
10430 seen_scalar = true;
10432 /* Find the symtree for this procedure. */
10433 gcc_assert (!list->proc_tree);
10434 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10436 prev_link = &list->next;
10439 /* Remove wrong nodes immediately from the list so we don't risk any
10440 troubles in the future when they might fail later expectations. */
10444 *prev_link = list->next;
10445 gfc_free_finalizer (i);
10448 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10449 were nodes in the list, must have been for arrays. It is surely a good
10450 idea to have a scalar version there if there's something to finalize. */
10451 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10452 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10453 " defined at %L, suggest also scalar one",
10454 derived->name, &derived->declared_at);
10456 /* TODO: Remove this error when finalization is finished. */
10457 gfc_error ("Finalization at %L is not yet implemented",
10458 &derived->declared_at);
10464 /* Check that it is ok for the typebound procedure proc to override the
10468 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10471 const gfc_symbol* proc_target;
10472 const gfc_symbol* old_target;
10473 unsigned proc_pass_arg, old_pass_arg, argpos;
10474 gfc_formal_arglist* proc_formal;
10475 gfc_formal_arglist* old_formal;
10477 /* This procedure should only be called for non-GENERIC proc. */
10478 gcc_assert (!proc->n.tb->is_generic);
10480 /* If the overwritten procedure is GENERIC, this is an error. */
10481 if (old->n.tb->is_generic)
10483 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10484 old->name, &proc->n.tb->where);
10488 where = proc->n.tb->where;
10489 proc_target = proc->n.tb->u.specific->n.sym;
10490 old_target = old->n.tb->u.specific->n.sym;
10492 /* Check that overridden binding is not NON_OVERRIDABLE. */
10493 if (old->n.tb->non_overridable)
10495 gfc_error ("'%s' at %L overrides a procedure binding declared"
10496 " NON_OVERRIDABLE", proc->name, &where);
10500 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10501 if (!old->n.tb->deferred && proc->n.tb->deferred)
10503 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10504 " non-DEFERRED binding", proc->name, &where);
10508 /* If the overridden binding is PURE, the overriding must be, too. */
10509 if (old_target->attr.pure && !proc_target->attr.pure)
10511 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10512 proc->name, &where);
10516 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10517 is not, the overriding must not be either. */
10518 if (old_target->attr.elemental && !proc_target->attr.elemental)
10520 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10521 " ELEMENTAL", proc->name, &where);
10524 if (!old_target->attr.elemental && proc_target->attr.elemental)
10526 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10527 " be ELEMENTAL, either", proc->name, &where);
10531 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10533 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10535 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10536 " SUBROUTINE", proc->name, &where);
10540 /* If the overridden binding is a FUNCTION, the overriding must also be a
10541 FUNCTION and have the same characteristics. */
10542 if (old_target->attr.function)
10544 if (!proc_target->attr.function)
10546 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10547 " FUNCTION", proc->name, &where);
10551 /* FIXME: Do more comprehensive checking (including, for instance, the
10552 rank and array-shape). */
10553 gcc_assert (proc_target->result && old_target->result);
10554 if (!gfc_compare_types (&proc_target->result->ts,
10555 &old_target->result->ts))
10557 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10558 " matching result types", proc->name, &where);
10563 /* If the overridden binding is PUBLIC, the overriding one must not be
10565 if (old->n.tb->access == ACCESS_PUBLIC
10566 && proc->n.tb->access == ACCESS_PRIVATE)
10568 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10569 " PRIVATE", proc->name, &where);
10573 /* Compare the formal argument lists of both procedures. This is also abused
10574 to find the position of the passed-object dummy arguments of both
10575 bindings as at least the overridden one might not yet be resolved and we
10576 need those positions in the check below. */
10577 proc_pass_arg = old_pass_arg = 0;
10578 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10580 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10583 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10584 proc_formal && old_formal;
10585 proc_formal = proc_formal->next, old_formal = old_formal->next)
10587 if (proc->n.tb->pass_arg
10588 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10589 proc_pass_arg = argpos;
10590 if (old->n.tb->pass_arg
10591 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10592 old_pass_arg = argpos;
10594 /* Check that the names correspond. */
10595 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10597 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10598 " to match the corresponding argument of the overridden"
10599 " procedure", proc_formal->sym->name, proc->name, &where,
10600 old_formal->sym->name);
10604 /* Check that the types correspond if neither is the passed-object
10606 /* FIXME: Do more comprehensive testing here. */
10607 if (proc_pass_arg != argpos && old_pass_arg != argpos
10608 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10610 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10611 "in respect to the overridden procedure",
10612 proc_formal->sym->name, proc->name, &where);
10618 if (proc_formal || old_formal)
10620 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10621 " the overridden procedure", proc->name, &where);
10625 /* If the overridden binding is NOPASS, the overriding one must also be
10627 if (old->n.tb->nopass && !proc->n.tb->nopass)
10629 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10630 " NOPASS", proc->name, &where);
10634 /* If the overridden binding is PASS(x), the overriding one must also be
10635 PASS and the passed-object dummy arguments must correspond. */
10636 if (!old->n.tb->nopass)
10638 if (proc->n.tb->nopass)
10640 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10641 " PASS", proc->name, &where);
10645 if (proc_pass_arg != old_pass_arg)
10647 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10648 " the same position as the passed-object dummy argument of"
10649 " the overridden procedure", proc->name, &where);
10658 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10661 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10662 const char* generic_name, locus where)
10667 gcc_assert (t1->specific && t2->specific);
10668 gcc_assert (!t1->specific->is_generic);
10669 gcc_assert (!t2->specific->is_generic);
10671 sym1 = t1->specific->u.specific->n.sym;
10672 sym2 = t2->specific->u.specific->n.sym;
10677 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10678 if (sym1->attr.subroutine != sym2->attr.subroutine
10679 || sym1->attr.function != sym2->attr.function)
10681 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10682 " GENERIC '%s' at %L",
10683 sym1->name, sym2->name, generic_name, &where);
10687 /* Compare the interfaces. */
10688 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10690 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10691 sym1->name, sym2->name, generic_name, &where);
10699 /* Worker function for resolving a generic procedure binding; this is used to
10700 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10702 The difference between those cases is finding possible inherited bindings
10703 that are overridden, as one has to look for them in tb_sym_root,
10704 tb_uop_root or tb_op, respectively. Thus the caller must already find
10705 the super-type and set p->overridden correctly. */
10708 resolve_tb_generic_targets (gfc_symbol* super_type,
10709 gfc_typebound_proc* p, const char* name)
10711 gfc_tbp_generic* target;
10712 gfc_symtree* first_target;
10713 gfc_symtree* inherited;
10715 gcc_assert (p && p->is_generic);
10717 /* Try to find the specific bindings for the symtrees in our target-list. */
10718 gcc_assert (p->u.generic);
10719 for (target = p->u.generic; target; target = target->next)
10720 if (!target->specific)
10722 gfc_typebound_proc* overridden_tbp;
10723 gfc_tbp_generic* g;
10724 const char* target_name;
10726 target_name = target->specific_st->name;
10728 /* Defined for this type directly. */
10729 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10731 target->specific = target->specific_st->n.tb;
10732 goto specific_found;
10735 /* Look for an inherited specific binding. */
10738 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10743 gcc_assert (inherited->n.tb);
10744 target->specific = inherited->n.tb;
10745 goto specific_found;
10749 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10750 " at %L", target_name, name, &p->where);
10753 /* Once we've found the specific binding, check it is not ambiguous with
10754 other specifics already found or inherited for the same GENERIC. */
10756 gcc_assert (target->specific);
10758 /* This must really be a specific binding! */
10759 if (target->specific->is_generic)
10761 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10762 " '%s' is GENERIC, too", name, &p->where, target_name);
10766 /* Check those already resolved on this type directly. */
10767 for (g = p->u.generic; g; g = g->next)
10768 if (g != target && g->specific
10769 && check_generic_tbp_ambiguity (target, g, name, p->where)
10773 /* Check for ambiguity with inherited specific targets. */
10774 for (overridden_tbp = p->overridden; overridden_tbp;
10775 overridden_tbp = overridden_tbp->overridden)
10776 if (overridden_tbp->is_generic)
10778 for (g = overridden_tbp->u.generic; g; g = g->next)
10780 gcc_assert (g->specific);
10781 if (check_generic_tbp_ambiguity (target, g,
10782 name, p->where) == FAILURE)
10788 /* If we attempt to "overwrite" a specific binding, this is an error. */
10789 if (p->overridden && !p->overridden->is_generic)
10791 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10792 " the same name", name, &p->where);
10796 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10797 all must have the same attributes here. */
10798 first_target = p->u.generic->specific->u.specific;
10799 gcc_assert (first_target);
10800 p->subroutine = first_target->n.sym->attr.subroutine;
10801 p->function = first_target->n.sym->attr.function;
10807 /* Resolve a GENERIC procedure binding for a derived type. */
10810 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10812 gfc_symbol* super_type;
10814 /* Find the overridden binding if any. */
10815 st->n.tb->overridden = NULL;
10816 super_type = gfc_get_derived_super_type (derived);
10819 gfc_symtree* overridden;
10820 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10823 if (overridden && overridden->n.tb)
10824 st->n.tb->overridden = overridden->n.tb;
10827 /* Resolve using worker function. */
10828 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10832 /* Retrieve the target-procedure of an operator binding and do some checks in
10833 common for intrinsic and user-defined type-bound operators. */
10836 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10838 gfc_symbol* target_proc;
10840 gcc_assert (target->specific && !target->specific->is_generic);
10841 target_proc = target->specific->u.specific->n.sym;
10842 gcc_assert (target_proc);
10844 /* All operator bindings must have a passed-object dummy argument. */
10845 if (target->specific->nopass)
10847 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10851 return target_proc;
10855 /* Resolve a type-bound intrinsic operator. */
10858 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10859 gfc_typebound_proc* p)
10861 gfc_symbol* super_type;
10862 gfc_tbp_generic* target;
10864 /* If there's already an error here, do nothing (but don't fail again). */
10868 /* Operators should always be GENERIC bindings. */
10869 gcc_assert (p->is_generic);
10871 /* Look for an overridden binding. */
10872 super_type = gfc_get_derived_super_type (derived);
10873 if (super_type && super_type->f2k_derived)
10874 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10877 p->overridden = NULL;
10879 /* Resolve general GENERIC properties using worker function. */
10880 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10883 /* Check the targets to be procedures of correct interface. */
10884 for (target = p->u.generic; target; target = target->next)
10886 gfc_symbol* target_proc;
10888 target_proc = get_checked_tb_operator_target (target, p->where);
10892 if (!gfc_check_operator_interface (target_proc, op, p->where))
10904 /* Resolve a type-bound user operator (tree-walker callback). */
10906 static gfc_symbol* resolve_bindings_derived;
10907 static gfc_try resolve_bindings_result;
10909 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10912 resolve_typebound_user_op (gfc_symtree* stree)
10914 gfc_symbol* super_type;
10915 gfc_tbp_generic* target;
10917 gcc_assert (stree && stree->n.tb);
10919 if (stree->n.tb->error)
10922 /* Operators should always be GENERIC bindings. */
10923 gcc_assert (stree->n.tb->is_generic);
10925 /* Find overridden procedure, if any. */
10926 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10927 if (super_type && super_type->f2k_derived)
10929 gfc_symtree* overridden;
10930 overridden = gfc_find_typebound_user_op (super_type, NULL,
10931 stree->name, true, NULL);
10933 if (overridden && overridden->n.tb)
10934 stree->n.tb->overridden = overridden->n.tb;
10937 stree->n.tb->overridden = NULL;
10939 /* Resolve basically using worker function. */
10940 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10944 /* Check the targets to be functions of correct interface. */
10945 for (target = stree->n.tb->u.generic; target; target = target->next)
10947 gfc_symbol* target_proc;
10949 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10953 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10960 resolve_bindings_result = FAILURE;
10961 stree->n.tb->error = 1;
10965 /* Resolve the type-bound procedures for a derived type. */
10968 resolve_typebound_procedure (gfc_symtree* stree)
10972 gfc_symbol* me_arg;
10973 gfc_symbol* super_type;
10974 gfc_component* comp;
10976 gcc_assert (stree);
10978 /* Undefined specific symbol from GENERIC target definition. */
10982 if (stree->n.tb->error)
10985 /* If this is a GENERIC binding, use that routine. */
10986 if (stree->n.tb->is_generic)
10988 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10994 /* Get the target-procedure to check it. */
10995 gcc_assert (!stree->n.tb->is_generic);
10996 gcc_assert (stree->n.tb->u.specific);
10997 proc = stree->n.tb->u.specific->n.sym;
10998 where = stree->n.tb->where;
11000 /* Default access should already be resolved from the parser. */
11001 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11003 /* It should be a module procedure or an external procedure with explicit
11004 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11005 if ((!proc->attr.subroutine && !proc->attr.function)
11006 || (proc->attr.proc != PROC_MODULE
11007 && proc->attr.if_source != IFSRC_IFBODY)
11008 || (proc->attr.abstract && !stree->n.tb->deferred))
11010 gfc_error ("'%s' must be a module procedure or an external procedure with"
11011 " an explicit interface at %L", proc->name, &where);
11014 stree->n.tb->subroutine = proc->attr.subroutine;
11015 stree->n.tb->function = proc->attr.function;
11017 /* Find the super-type of the current derived type. We could do this once and
11018 store in a global if speed is needed, but as long as not I believe this is
11019 more readable and clearer. */
11020 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11022 /* If PASS, resolve and check arguments if not already resolved / loaded
11023 from a .mod file. */
11024 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11026 if (stree->n.tb->pass_arg)
11028 gfc_formal_arglist* i;
11030 /* If an explicit passing argument name is given, walk the arg-list
11031 and look for it. */
11034 stree->n.tb->pass_arg_num = 1;
11035 for (i = proc->formal; i; i = i->next)
11037 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11042 ++stree->n.tb->pass_arg_num;
11047 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11049 proc->name, stree->n.tb->pass_arg, &where,
11050 stree->n.tb->pass_arg);
11056 /* Otherwise, take the first one; there should in fact be at least
11058 stree->n.tb->pass_arg_num = 1;
11061 gfc_error ("Procedure '%s' with PASS at %L must have at"
11062 " least one argument", proc->name, &where);
11065 me_arg = proc->formal->sym;
11068 /* Now check that the argument-type matches and the passed-object
11069 dummy argument is generally fine. */
11071 gcc_assert (me_arg);
11073 if (me_arg->ts.type != BT_CLASS)
11075 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11076 " at %L", proc->name, &where);
11080 if (CLASS_DATA (me_arg)->ts.u.derived
11081 != resolve_bindings_derived)
11083 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11084 " the derived-type '%s'", me_arg->name, proc->name,
11085 me_arg->name, &where, resolve_bindings_derived->name);
11089 gcc_assert (me_arg->ts.type == BT_CLASS);
11090 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11092 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11093 " scalar", proc->name, &where);
11096 if (CLASS_DATA (me_arg)->attr.allocatable)
11098 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11099 " be ALLOCATABLE", proc->name, &where);
11102 if (CLASS_DATA (me_arg)->attr.class_pointer)
11104 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11105 " be POINTER", proc->name, &where);
11110 /* If we are extending some type, check that we don't override a procedure
11111 flagged NON_OVERRIDABLE. */
11112 stree->n.tb->overridden = NULL;
11115 gfc_symtree* overridden;
11116 overridden = gfc_find_typebound_proc (super_type, NULL,
11117 stree->name, true, NULL);
11119 if (overridden && overridden->n.tb)
11120 stree->n.tb->overridden = overridden->n.tb;
11122 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
11126 /* See if there's a name collision with a component directly in this type. */
11127 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11128 if (!strcmp (comp->name, stree->name))
11130 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11132 stree->name, &where, resolve_bindings_derived->name);
11136 /* Try to find a name collision with an inherited component. */
11137 if (super_type && gfc_find_component (super_type, stree->name, true, true))
11139 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11140 " component of '%s'",
11141 stree->name, &where, resolve_bindings_derived->name);
11145 stree->n.tb->error = 0;
11149 resolve_bindings_result = FAILURE;
11150 stree->n.tb->error = 1;
11155 resolve_typebound_procedures (gfc_symbol* derived)
11159 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11162 resolve_bindings_derived = derived;
11163 resolve_bindings_result = SUCCESS;
11165 /* Make sure the vtab has been generated. */
11166 gfc_find_derived_vtab (derived);
11168 if (derived->f2k_derived->tb_sym_root)
11169 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11170 &resolve_typebound_procedure);
11172 if (derived->f2k_derived->tb_uop_root)
11173 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11174 &resolve_typebound_user_op);
11176 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11178 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11179 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11181 resolve_bindings_result = FAILURE;
11184 return resolve_bindings_result;
11188 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11189 to give all identical derived types the same backend_decl. */
11191 add_dt_to_dt_list (gfc_symbol *derived)
11193 gfc_dt_list *dt_list;
11195 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11196 if (derived == dt_list->derived)
11199 dt_list = gfc_get_dt_list ();
11200 dt_list->next = gfc_derived_types;
11201 dt_list->derived = derived;
11202 gfc_derived_types = dt_list;
11206 /* Ensure that a derived-type is really not abstract, meaning that every
11207 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11210 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11215 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11217 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11220 if (st->n.tb && st->n.tb->deferred)
11222 gfc_symtree* overriding;
11223 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11226 gcc_assert (overriding->n.tb);
11227 if (overriding->n.tb->deferred)
11229 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11230 " '%s' is DEFERRED and not overridden",
11231 sub->name, &sub->declared_at, st->name);
11240 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11242 /* The algorithm used here is to recursively travel up the ancestry of sub
11243 and for each ancestor-type, check all bindings. If any of them is
11244 DEFERRED, look it up starting from sub and see if the found (overriding)
11245 binding is not DEFERRED.
11246 This is not the most efficient way to do this, but it should be ok and is
11247 clearer than something sophisticated. */
11249 gcc_assert (ancestor && !sub->attr.abstract);
11251 if (!ancestor->attr.abstract)
11254 /* Walk bindings of this ancestor. */
11255 if (ancestor->f2k_derived)
11258 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11263 /* Find next ancestor type and recurse on it. */
11264 ancestor = gfc_get_derived_super_type (ancestor);
11266 return ensure_not_abstract (sub, ancestor);
11272 /* Resolve the components of a derived type. */
11275 resolve_fl_derived (gfc_symbol *sym)
11277 gfc_symbol* super_type;
11280 super_type = gfc_get_derived_super_type (sym);
11282 if (sym->attr.is_class && sym->ts.u.derived == NULL)
11284 /* Fix up incomplete CLASS symbols. */
11285 gfc_component *data = gfc_find_component (sym, "_data", true, true);
11286 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
11287 if (vptr->ts.u.derived == NULL)
11289 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11291 vptr->ts.u.derived = vtab->ts.u.derived;
11296 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11298 gfc_error ("As extending type '%s' at %L has a coarray component, "
11299 "parent type '%s' shall also have one", sym->name,
11300 &sym->declared_at, super_type->name);
11304 /* Ensure the extended type gets resolved before we do. */
11305 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11308 /* An ABSTRACT type must be extensible. */
11309 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11311 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11312 sym->name, &sym->declared_at);
11316 for (c = sym->components; c != NULL; c = c->next)
11319 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11320 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11322 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11323 "deferred shape", c->name, &c->loc);
11328 if (c->attr.codimension && c->ts.type == BT_DERIVED
11329 && c->ts.u.derived->ts.is_iso_c)
11331 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11332 "shall not be a coarray", c->name, &c->loc);
11337 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11338 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11339 || c->attr.allocatable))
11341 gfc_error ("Component '%s' at %L with coarray component "
11342 "shall be a nonpointer, nonallocatable scalar",
11348 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11350 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11351 "is not an array pointer", c->name, &c->loc);
11355 if (c->attr.proc_pointer && c->ts.interface)
11357 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11358 gfc_error ("Interface '%s', used by procedure pointer component "
11359 "'%s' at %L, is declared in a later PROCEDURE statement",
11360 c->ts.interface->name, c->name, &c->loc);
11362 /* Get the attributes from the interface (now resolved). */
11363 if (c->ts.interface->attr.if_source
11364 || c->ts.interface->attr.intrinsic)
11366 gfc_symbol *ifc = c->ts.interface;
11368 if (ifc->formal && !ifc->formal_ns)
11369 resolve_symbol (ifc);
11371 if (ifc->attr.intrinsic)
11372 resolve_intrinsic (ifc, &ifc->declared_at);
11376 c->ts = ifc->result->ts;
11377 c->attr.allocatable = ifc->result->attr.allocatable;
11378 c->attr.pointer = ifc->result->attr.pointer;
11379 c->attr.dimension = ifc->result->attr.dimension;
11380 c->as = gfc_copy_array_spec (ifc->result->as);
11385 c->attr.allocatable = ifc->attr.allocatable;
11386 c->attr.pointer = ifc->attr.pointer;
11387 c->attr.dimension = ifc->attr.dimension;
11388 c->as = gfc_copy_array_spec (ifc->as);
11390 c->ts.interface = ifc;
11391 c->attr.function = ifc->attr.function;
11392 c->attr.subroutine = ifc->attr.subroutine;
11393 gfc_copy_formal_args_ppc (c, ifc);
11395 c->attr.pure = ifc->attr.pure;
11396 c->attr.elemental = ifc->attr.elemental;
11397 c->attr.recursive = ifc->attr.recursive;
11398 c->attr.always_explicit = ifc->attr.always_explicit;
11399 c->attr.ext_attr |= ifc->attr.ext_attr;
11400 /* Replace symbols in array spec. */
11404 for (i = 0; i < c->as->rank; i++)
11406 gfc_expr_replace_comp (c->as->lower[i], c);
11407 gfc_expr_replace_comp (c->as->upper[i], c);
11410 /* Copy char length. */
11411 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11413 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11414 gfc_expr_replace_comp (cl->length, c);
11415 if (cl->length && !cl->resolved
11416 && gfc_resolve_expr (cl->length) == FAILURE)
11421 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11423 gfc_error ("Interface '%s' of procedure pointer component "
11424 "'%s' at %L must be explicit", c->ts.interface->name,
11429 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11431 /* Since PPCs are not implicitly typed, a PPC without an explicit
11432 interface must be a subroutine. */
11433 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11436 /* Procedure pointer components: Check PASS arg. */
11437 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11438 && !sym->attr.vtype)
11440 gfc_symbol* me_arg;
11442 if (c->tb->pass_arg)
11444 gfc_formal_arglist* i;
11446 /* If an explicit passing argument name is given, walk the arg-list
11447 and look for it. */
11450 c->tb->pass_arg_num = 1;
11451 for (i = c->formal; i; i = i->next)
11453 if (!strcmp (i->sym->name, c->tb->pass_arg))
11458 c->tb->pass_arg_num++;
11463 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11464 "at %L has no argument '%s'", c->name,
11465 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11472 /* Otherwise, take the first one; there should in fact be at least
11474 c->tb->pass_arg_num = 1;
11477 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11478 "must have at least one argument",
11483 me_arg = c->formal->sym;
11486 /* Now check that the argument-type matches. */
11487 gcc_assert (me_arg);
11488 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11489 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11490 || (me_arg->ts.type == BT_CLASS
11491 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11493 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11494 " the derived type '%s'", me_arg->name, c->name,
11495 me_arg->name, &c->loc, sym->name);
11500 /* Check for C453. */
11501 if (me_arg->attr.dimension)
11503 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11504 "must be scalar", me_arg->name, c->name, me_arg->name,
11510 if (me_arg->attr.pointer)
11512 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11513 "may not have the POINTER attribute", me_arg->name,
11514 c->name, me_arg->name, &c->loc);
11519 if (me_arg->attr.allocatable)
11521 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11522 "may not be ALLOCATABLE", me_arg->name, c->name,
11523 me_arg->name, &c->loc);
11528 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11529 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11530 " at %L", c->name, &c->loc);
11534 /* Check type-spec if this is not the parent-type component. */
11535 if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11536 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11539 /* If this type is an extension, set the accessibility of the parent
11541 if (super_type && c == sym->components
11542 && strcmp (super_type->name, c->name) == 0)
11543 c->attr.access = super_type->attr.access;
11545 /* If this type is an extension, see if this component has the same name
11546 as an inherited type-bound procedure. */
11547 if (super_type && !sym->attr.is_class
11548 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11550 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11551 " inherited type-bound procedure",
11552 c->name, sym->name, &c->loc);
11556 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11558 if (c->ts.u.cl->length == NULL
11559 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11560 || !gfc_is_constant_expr (c->ts.u.cl->length))
11562 gfc_error ("Character length of component '%s' needs to "
11563 "be a constant specification expression at %L",
11565 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11570 if (c->ts.type == BT_DERIVED
11571 && sym->component_access != ACCESS_PRIVATE
11572 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11573 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11574 && !c->ts.u.derived->attr.use_assoc
11575 && !gfc_check_access (c->ts.u.derived->attr.access,
11576 c->ts.u.derived->ns->default_access)
11577 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11578 "is a PRIVATE type and cannot be a component of "
11579 "'%s', which is PUBLIC at %L", c->name,
11580 sym->name, &sym->declared_at) == FAILURE)
11583 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11585 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11586 "type %s", c->name, &c->loc, sym->name);
11590 if (sym->attr.sequence)
11592 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11594 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11595 "not have the SEQUENCE attribute",
11596 c->ts.u.derived->name, &sym->declared_at);
11601 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11602 && c->attr.pointer && c->ts.u.derived->components == NULL
11603 && !c->ts.u.derived->attr.zero_comp)
11605 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11606 "that has not been declared", c->name, sym->name,
11611 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11612 && CLASS_DATA (c)->ts.u.derived->components == NULL
11613 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11615 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11616 "that has not been declared", c->name, sym->name,
11622 if (c->ts.type == BT_CLASS
11623 && !(CLASS_DATA (c)->attr.class_pointer
11624 || CLASS_DATA (c)->attr.allocatable))
11626 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11627 "or pointer", c->name, &c->loc);
11631 /* Ensure that all the derived type components are put on the
11632 derived type list; even in formal namespaces, where derived type
11633 pointer components might not have been declared. */
11634 if (c->ts.type == BT_DERIVED
11636 && c->ts.u.derived->components
11638 && sym != c->ts.u.derived)
11639 add_dt_to_dt_list (c->ts.u.derived);
11641 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11642 || c->attr.proc_pointer
11643 || c->attr.allocatable)) == FAILURE)
11647 /* Resolve the type-bound procedures. */
11648 if (resolve_typebound_procedures (sym) == FAILURE)
11651 /* Resolve the finalizer procedures. */
11652 if (gfc_resolve_finalizers (sym) == FAILURE)
11655 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11656 all DEFERRED bindings are overridden. */
11657 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11658 && !sym->attr.is_class
11659 && ensure_not_abstract (sym, super_type) == FAILURE)
11662 /* Add derived type to the derived type list. */
11663 add_dt_to_dt_list (sym);
11670 resolve_fl_namelist (gfc_symbol *sym)
11675 for (nl = sym->namelist; nl; nl = nl->next)
11677 /* Reject namelist arrays of assumed shape. */
11678 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11679 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11680 "must not have assumed shape in namelist "
11681 "'%s' at %L", nl->sym->name, sym->name,
11682 &sym->declared_at) == FAILURE)
11685 /* Reject namelist arrays that are not constant shape. */
11686 if (is_non_constant_shape_array (nl->sym))
11688 gfc_error ("NAMELIST array object '%s' must have constant "
11689 "shape in namelist '%s' at %L", nl->sym->name,
11690 sym->name, &sym->declared_at);
11694 /* Namelist objects cannot have allocatable or pointer components. */
11695 if (nl->sym->ts.type != BT_DERIVED)
11698 if (nl->sym->ts.u.derived->attr.alloc_comp)
11700 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11701 "have ALLOCATABLE components",
11702 nl->sym->name, sym->name, &sym->declared_at);
11706 if (nl->sym->ts.u.derived->attr.pointer_comp)
11708 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11709 "have POINTER components",
11710 nl->sym->name, sym->name, &sym->declared_at);
11715 /* Reject PRIVATE objects in a PUBLIC namelist. */
11716 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11718 for (nl = sym->namelist; nl; nl = nl->next)
11720 if (!nl->sym->attr.use_assoc
11721 && !is_sym_host_assoc (nl->sym, sym->ns)
11722 && !gfc_check_access(nl->sym->attr.access,
11723 nl->sym->ns->default_access))
11725 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11726 "cannot be member of PUBLIC namelist '%s' at %L",
11727 nl->sym->name, sym->name, &sym->declared_at);
11731 /* Types with private components that came here by USE-association. */
11732 if (nl->sym->ts.type == BT_DERIVED
11733 && derived_inaccessible (nl->sym->ts.u.derived))
11735 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11736 "components and cannot be member of namelist '%s' at %L",
11737 nl->sym->name, sym->name, &sym->declared_at);
11741 /* Types with private components that are defined in the same module. */
11742 if (nl->sym->ts.type == BT_DERIVED
11743 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11744 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11745 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11746 nl->sym->ns->default_access))
11748 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11749 "cannot be a member of PUBLIC namelist '%s' at %L",
11750 nl->sym->name, sym->name, &sym->declared_at);
11757 /* 14.1.2 A module or internal procedure represent local entities
11758 of the same type as a namelist member and so are not allowed. */
11759 for (nl = sym->namelist; nl; nl = nl->next)
11761 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11764 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11765 if ((nl->sym == sym->ns->proc_name)
11767 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11771 if (nl->sym && nl->sym->name)
11772 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11773 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11775 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11776 "attribute in '%s' at %L", nlsym->name,
11777 &sym->declared_at);
11787 resolve_fl_parameter (gfc_symbol *sym)
11789 /* A parameter array's shape needs to be constant. */
11790 if (sym->as != NULL
11791 && (sym->as->type == AS_DEFERRED
11792 || is_non_constant_shape_array (sym)))
11794 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11795 "or of deferred shape", sym->name, &sym->declared_at);
11799 /* Make sure a parameter that has been implicitly typed still
11800 matches the implicit type, since PARAMETER statements can precede
11801 IMPLICIT statements. */
11802 if (sym->attr.implicit_type
11803 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11806 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11807 "later IMPLICIT type", sym->name, &sym->declared_at);
11811 /* Make sure the types of derived parameters are consistent. This
11812 type checking is deferred until resolution because the type may
11813 refer to a derived type from the host. */
11814 if (sym->ts.type == BT_DERIVED
11815 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11817 gfc_error ("Incompatible derived type in PARAMETER at %L",
11818 &sym->value->where);
11825 /* Do anything necessary to resolve a symbol. Right now, we just
11826 assume that an otherwise unknown symbol is a variable. This sort
11827 of thing commonly happens for symbols in module. */
11830 resolve_symbol (gfc_symbol *sym)
11832 int check_constant, mp_flag;
11833 gfc_symtree *symtree;
11834 gfc_symtree *this_symtree;
11838 /* Avoid double resolution of function result symbols. */
11839 if ((sym->result || sym->attr.result) && !sym->attr.dummy
11840 && (sym->ns != gfc_current_ns))
11843 if (sym->attr.flavor == FL_UNKNOWN)
11846 /* If we find that a flavorless symbol is an interface in one of the
11847 parent namespaces, find its symtree in this namespace, free the
11848 symbol and set the symtree to point to the interface symbol. */
11849 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11851 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11852 if (symtree && (symtree->n.sym->generic ||
11853 (symtree->n.sym->attr.flavor == FL_PROCEDURE
11854 && sym->ns->construct_entities)))
11856 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11858 gfc_release_symbol (sym);
11859 symtree->n.sym->refs++;
11860 this_symtree->n.sym = symtree->n.sym;
11865 /* Otherwise give it a flavor according to such attributes as
11867 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11868 sym->attr.flavor = FL_VARIABLE;
11871 sym->attr.flavor = FL_PROCEDURE;
11872 if (sym->attr.dimension)
11873 sym->attr.function = 1;
11877 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11878 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11880 if (sym->attr.procedure && sym->ts.interface
11881 && sym->attr.if_source != IFSRC_DECL
11882 && resolve_procedure_interface (sym) == FAILURE)
11885 if (sym->attr.is_protected && !sym->attr.proc_pointer
11886 && (sym->attr.procedure || sym->attr.external))
11888 if (sym->attr.external)
11889 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11890 "at %L", &sym->declared_at);
11892 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11893 "at %L", &sym->declared_at);
11900 if (sym->attr.contiguous
11901 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11902 && !sym->attr.pointer)))
11904 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11905 "array pointer or an assumed-shape array", sym->name,
11906 &sym->declared_at);
11910 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11913 /* Symbols that are module procedures with results (functions) have
11914 the types and array specification copied for type checking in
11915 procedures that call them, as well as for saving to a module
11916 file. These symbols can't stand the scrutiny that their results
11918 mp_flag = (sym->result != NULL && sym->result != sym);
11920 /* Make sure that the intrinsic is consistent with its internal
11921 representation. This needs to be done before assigning a default
11922 type to avoid spurious warnings. */
11923 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11924 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11927 /* Resolve associate names. */
11929 resolve_assoc_var (sym, true);
11931 /* Assign default type to symbols that need one and don't have one. */
11932 if (sym->ts.type == BT_UNKNOWN)
11934 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11935 gfc_set_default_type (sym, 1, NULL);
11937 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11938 && !sym->attr.function && !sym->attr.subroutine
11939 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11940 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11942 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11944 /* The specific case of an external procedure should emit an error
11945 in the case that there is no implicit type. */
11947 gfc_set_default_type (sym, sym->attr.external, NULL);
11950 /* Result may be in another namespace. */
11951 resolve_symbol (sym->result);
11953 if (!sym->result->attr.proc_pointer)
11955 sym->ts = sym->result->ts;
11956 sym->as = gfc_copy_array_spec (sym->result->as);
11957 sym->attr.dimension = sym->result->attr.dimension;
11958 sym->attr.pointer = sym->result->attr.pointer;
11959 sym->attr.allocatable = sym->result->attr.allocatable;
11960 sym->attr.contiguous = sym->result->attr.contiguous;
11966 /* Assumed size arrays and assumed shape arrays must be dummy
11967 arguments. Array-spec's of implied-shape should have been resolved to
11968 AS_EXPLICIT already. */
11972 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11973 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11974 || sym->as->type == AS_ASSUMED_SHAPE)
11975 && sym->attr.dummy == 0)
11977 if (sym->as->type == AS_ASSUMED_SIZE)
11978 gfc_error ("Assumed size array at %L must be a dummy argument",
11979 &sym->declared_at);
11981 gfc_error ("Assumed shape array at %L must be a dummy argument",
11982 &sym->declared_at);
11987 /* Make sure symbols with known intent or optional are really dummy
11988 variable. Because of ENTRY statement, this has to be deferred
11989 until resolution time. */
11991 if (!sym->attr.dummy
11992 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11994 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11998 if (sym->attr.value && !sym->attr.dummy)
12000 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12001 "it is not a dummy argument", sym->name, &sym->declared_at);
12005 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12007 gfc_charlen *cl = sym->ts.u.cl;
12008 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12010 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12011 "attribute must have constant length",
12012 sym->name, &sym->declared_at);
12016 if (sym->ts.is_c_interop
12017 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12019 gfc_error ("C interoperable character dummy variable '%s' at %L "
12020 "with VALUE attribute must have length one",
12021 sym->name, &sym->declared_at);
12026 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12027 do this for something that was implicitly typed because that is handled
12028 in gfc_set_default_type. Handle dummy arguments and procedure
12029 definitions separately. Also, anything that is use associated is not
12030 handled here but instead is handled in the module it is declared in.
12031 Finally, derived type definitions are allowed to be BIND(C) since that
12032 only implies that they're interoperable, and they are checked fully for
12033 interoperability when a variable is declared of that type. */
12034 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12035 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12036 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12038 gfc_try t = SUCCESS;
12040 /* First, make sure the variable is declared at the
12041 module-level scope (J3/04-007, Section 15.3). */
12042 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12043 sym->attr.in_common == 0)
12045 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12046 "is neither a COMMON block nor declared at the "
12047 "module level scope", sym->name, &(sym->declared_at));
12050 else if (sym->common_head != NULL)
12052 t = verify_com_block_vars_c_interop (sym->common_head);
12056 /* If type() declaration, we need to verify that the components
12057 of the given type are all C interoperable, etc. */
12058 if (sym->ts.type == BT_DERIVED &&
12059 sym->ts.u.derived->attr.is_c_interop != 1)
12061 /* Make sure the user marked the derived type as BIND(C). If
12062 not, call the verify routine. This could print an error
12063 for the derived type more than once if multiple variables
12064 of that type are declared. */
12065 if (sym->ts.u.derived->attr.is_bind_c != 1)
12066 verify_bind_c_derived_type (sym->ts.u.derived);
12070 /* Verify the variable itself as C interoperable if it
12071 is BIND(C). It is not possible for this to succeed if
12072 the verify_bind_c_derived_type failed, so don't have to handle
12073 any error returned by verify_bind_c_derived_type. */
12074 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12075 sym->common_block);
12080 /* clear the is_bind_c flag to prevent reporting errors more than
12081 once if something failed. */
12082 sym->attr.is_bind_c = 0;
12087 /* If a derived type symbol has reached this point, without its
12088 type being declared, we have an error. Notice that most
12089 conditions that produce undefined derived types have already
12090 been dealt with. However, the likes of:
12091 implicit type(t) (t) ..... call foo (t) will get us here if
12092 the type is not declared in the scope of the implicit
12093 statement. Change the type to BT_UNKNOWN, both because it is so
12094 and to prevent an ICE. */
12095 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
12096 && !sym->ts.u.derived->attr.zero_comp)
12098 gfc_error ("The derived type '%s' at %L is of type '%s', "
12099 "which has not been defined", sym->name,
12100 &sym->declared_at, sym->ts.u.derived->name);
12101 sym->ts.type = BT_UNKNOWN;
12105 /* Make sure that the derived type has been resolved and that the
12106 derived type is visible in the symbol's namespace, if it is a
12107 module function and is not PRIVATE. */
12108 if (sym->ts.type == BT_DERIVED
12109 && sym->ts.u.derived->attr.use_assoc
12110 && sym->ns->proc_name
12111 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12115 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12118 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12119 if (!ds && sym->attr.function
12120 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12122 symtree = gfc_new_symtree (&sym->ns->sym_root,
12123 sym->ts.u.derived->name);
12124 symtree->n.sym = sym->ts.u.derived;
12125 sym->ts.u.derived->refs++;
12129 /* Unless the derived-type declaration is use associated, Fortran 95
12130 does not allow public entries of private derived types.
12131 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12132 161 in 95-006r3. */
12133 if (sym->ts.type == BT_DERIVED
12134 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12135 && !sym->ts.u.derived->attr.use_assoc
12136 && gfc_check_access (sym->attr.access, sym->ns->default_access)
12137 && !gfc_check_access (sym->ts.u.derived->attr.access,
12138 sym->ts.u.derived->ns->default_access)
12139 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12140 "of PRIVATE derived type '%s'",
12141 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12142 : "variable", sym->name, &sym->declared_at,
12143 sym->ts.u.derived->name) == FAILURE)
12146 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12147 default initialization is defined (5.1.2.4.4). */
12148 if (sym->ts.type == BT_DERIVED
12150 && sym->attr.intent == INTENT_OUT
12152 && sym->as->type == AS_ASSUMED_SIZE)
12154 for (c = sym->ts.u.derived->components; c; c = c->next)
12156 if (c->initializer)
12158 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12159 "ASSUMED SIZE and so cannot have a default initializer",
12160 sym->name, &sym->declared_at);
12167 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12168 || sym->attr.codimension)
12169 && sym->attr.result)
12170 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12171 "a coarray component", sym->name, &sym->declared_at);
12174 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12175 && sym->ts.u.derived->ts.is_iso_c)
12176 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12177 "shall not be a coarray", sym->name, &sym->declared_at);
12180 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12181 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12182 || sym->attr.allocatable))
12183 gfc_error ("Variable '%s' at %L with coarray component "
12184 "shall be a nonpointer, nonallocatable scalar",
12185 sym->name, &sym->declared_at);
12187 /* F2008, C526. The function-result case was handled above. */
12188 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12189 || sym->attr.codimension)
12190 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12191 || sym->ns->proc_name->attr.flavor == FL_MODULE
12192 || sym->ns->proc_name->attr.is_main_program
12193 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12194 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12195 "component and is not ALLOCATABLE, SAVE nor a "
12196 "dummy argument", sym->name, &sym->declared_at);
12197 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12198 else if (sym->attr.codimension && !sym->attr.allocatable
12199 && sym->as && sym->as->cotype == AS_DEFERRED)
12200 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12201 "deferred shape", sym->name, &sym->declared_at);
12202 else if (sym->attr.codimension && sym->attr.allocatable
12203 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12204 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12205 "deferred shape", sym->name, &sym->declared_at);
12209 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12210 || (sym->attr.codimension && sym->attr.allocatable))
12211 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12212 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12213 "allocatable coarray or have coarray components",
12214 sym->name, &sym->declared_at);
12216 if (sym->attr.codimension && sym->attr.dummy
12217 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12218 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12219 "procedure '%s'", sym->name, &sym->declared_at,
12220 sym->ns->proc_name->name);
12222 switch (sym->attr.flavor)
12225 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12230 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12235 if (resolve_fl_namelist (sym) == FAILURE)
12240 if (resolve_fl_parameter (sym) == FAILURE)
12248 /* Resolve array specifier. Check as well some constraints
12249 on COMMON blocks. */
12251 check_constant = sym->attr.in_common && !sym->attr.pointer;
12253 /* Set the formal_arg_flag so that check_conflict will not throw
12254 an error for host associated variables in the specification
12255 expression for an array_valued function. */
12256 if (sym->attr.function && sym->as)
12257 formal_arg_flag = 1;
12259 gfc_resolve_array_spec (sym->as, check_constant);
12261 formal_arg_flag = 0;
12263 /* Resolve formal namespaces. */
12264 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12265 && !sym->attr.contained && !sym->attr.intrinsic)
12266 gfc_resolve (sym->formal_ns);
12268 /* Make sure the formal namespace is present. */
12269 if (sym->formal && !sym->formal_ns)
12271 gfc_formal_arglist *formal = sym->formal;
12272 while (formal && !formal->sym)
12273 formal = formal->next;
12277 sym->formal_ns = formal->sym->ns;
12278 sym->formal_ns->refs++;
12282 /* Check threadprivate restrictions. */
12283 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12284 && (!sym->attr.in_common
12285 && sym->module == NULL
12286 && (sym->ns->proc_name == NULL
12287 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12288 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12290 /* If we have come this far we can apply default-initializers, as
12291 described in 14.7.5, to those variables that have not already
12292 been assigned one. */
12293 if (sym->ts.type == BT_DERIVED
12294 && sym->ns == gfc_current_ns
12296 && !sym->attr.allocatable
12297 && !sym->attr.alloc_comp)
12299 symbol_attribute *a = &sym->attr;
12301 if ((!a->save && !a->dummy && !a->pointer
12302 && !a->in_common && !a->use_assoc
12303 && (a->referenced || a->result)
12304 && !(a->function && sym != sym->result))
12305 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12306 apply_default_init (sym);
12309 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12310 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12311 && !CLASS_DATA (sym)->attr.class_pointer
12312 && !CLASS_DATA (sym)->attr.allocatable)
12313 apply_default_init (sym);
12315 /* If this symbol has a type-spec, check it. */
12316 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12317 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12318 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12324 /************* Resolve DATA statements *************/
12328 gfc_data_value *vnode;
12334 /* Advance the values structure to point to the next value in the data list. */
12337 next_data_value (void)
12339 while (mpz_cmp_ui (values.left, 0) == 0)
12342 if (values.vnode->next == NULL)
12345 values.vnode = values.vnode->next;
12346 mpz_set (values.left, values.vnode->repeat);
12354 check_data_variable (gfc_data_variable *var, locus *where)
12360 ar_type mark = AR_UNKNOWN;
12362 mpz_t section_index[GFC_MAX_DIMENSIONS];
12368 if (gfc_resolve_expr (var->expr) == FAILURE)
12372 mpz_init_set_si (offset, 0);
12375 if (e->expr_type != EXPR_VARIABLE)
12376 gfc_internal_error ("check_data_variable(): Bad expression");
12378 sym = e->symtree->n.sym;
12380 if (sym->ns->is_block_data && !sym->attr.in_common)
12382 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12383 sym->name, &sym->declared_at);
12386 if (e->ref == NULL && sym->as)
12388 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12389 " declaration", sym->name, where);
12393 has_pointer = sym->attr.pointer;
12395 for (ref = e->ref; ref; ref = ref->next)
12397 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12400 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12402 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12408 && ref->type == REF_ARRAY
12409 && ref->u.ar.type != AR_FULL)
12411 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12412 "be a full array", sym->name, where);
12417 if (e->rank == 0 || has_pointer)
12419 mpz_init_set_ui (size, 1);
12426 /* Find the array section reference. */
12427 for (ref = e->ref; ref; ref = ref->next)
12429 if (ref->type != REF_ARRAY)
12431 if (ref->u.ar.type == AR_ELEMENT)
12437 /* Set marks according to the reference pattern. */
12438 switch (ref->u.ar.type)
12446 /* Get the start position of array section. */
12447 gfc_get_section_index (ar, section_index, &offset);
12452 gcc_unreachable ();
12455 if (gfc_array_size (e, &size) == FAILURE)
12457 gfc_error ("Nonconstant array section at %L in DATA statement",
12459 mpz_clear (offset);
12466 while (mpz_cmp_ui (size, 0) > 0)
12468 if (next_data_value () == FAILURE)
12470 gfc_error ("DATA statement at %L has more variables than values",
12476 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12480 /* If we have more than one element left in the repeat count,
12481 and we have more than one element left in the target variable,
12482 then create a range assignment. */
12483 /* FIXME: Only done for full arrays for now, since array sections
12485 if (mark == AR_FULL && ref && ref->next == NULL
12486 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12490 if (mpz_cmp (size, values.left) >= 0)
12492 mpz_init_set (range, values.left);
12493 mpz_sub (size, size, values.left);
12494 mpz_set_ui (values.left, 0);
12498 mpz_init_set (range, size);
12499 mpz_sub (values.left, values.left, size);
12500 mpz_set_ui (size, 0);
12503 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12506 mpz_add (offset, offset, range);
12513 /* Assign initial value to symbol. */
12516 mpz_sub_ui (values.left, values.left, 1);
12517 mpz_sub_ui (size, size, 1);
12519 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12523 if (mark == AR_FULL)
12524 mpz_add_ui (offset, offset, 1);
12526 /* Modify the array section indexes and recalculate the offset
12527 for next element. */
12528 else if (mark == AR_SECTION)
12529 gfc_advance_section (section_index, ar, &offset);
12533 if (mark == AR_SECTION)
12535 for (i = 0; i < ar->dimen; i++)
12536 mpz_clear (section_index[i]);
12540 mpz_clear (offset);
12546 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12548 /* Iterate over a list of elements in a DATA statement. */
12551 traverse_data_list (gfc_data_variable *var, locus *where)
12554 iterator_stack frame;
12555 gfc_expr *e, *start, *end, *step;
12556 gfc_try retval = SUCCESS;
12558 mpz_init (frame.value);
12561 start = gfc_copy_expr (var->iter.start);
12562 end = gfc_copy_expr (var->iter.end);
12563 step = gfc_copy_expr (var->iter.step);
12565 if (gfc_simplify_expr (start, 1) == FAILURE
12566 || start->expr_type != EXPR_CONSTANT)
12568 gfc_error ("start of implied-do loop at %L could not be "
12569 "simplified to a constant value", &start->where);
12573 if (gfc_simplify_expr (end, 1) == FAILURE
12574 || end->expr_type != EXPR_CONSTANT)
12576 gfc_error ("end of implied-do loop at %L could not be "
12577 "simplified to a constant value", &start->where);
12581 if (gfc_simplify_expr (step, 1) == FAILURE
12582 || step->expr_type != EXPR_CONSTANT)
12584 gfc_error ("step of implied-do loop at %L could not be "
12585 "simplified to a constant value", &start->where);
12590 mpz_set (trip, end->value.integer);
12591 mpz_sub (trip, trip, start->value.integer);
12592 mpz_add (trip, trip, step->value.integer);
12594 mpz_div (trip, trip, step->value.integer);
12596 mpz_set (frame.value, start->value.integer);
12598 frame.prev = iter_stack;
12599 frame.variable = var->iter.var->symtree;
12600 iter_stack = &frame;
12602 while (mpz_cmp_ui (trip, 0) > 0)
12604 if (traverse_data_var (var->list, where) == FAILURE)
12610 e = gfc_copy_expr (var->expr);
12611 if (gfc_simplify_expr (e, 1) == FAILURE)
12618 mpz_add (frame.value, frame.value, step->value.integer);
12620 mpz_sub_ui (trip, trip, 1);
12624 mpz_clear (frame.value);
12627 gfc_free_expr (start);
12628 gfc_free_expr (end);
12629 gfc_free_expr (step);
12631 iter_stack = frame.prev;
12636 /* Type resolve variables in the variable list of a DATA statement. */
12639 traverse_data_var (gfc_data_variable *var, locus *where)
12643 for (; var; var = var->next)
12645 if (var->expr == NULL)
12646 t = traverse_data_list (var, where);
12648 t = check_data_variable (var, where);
12658 /* Resolve the expressions and iterators associated with a data statement.
12659 This is separate from the assignment checking because data lists should
12660 only be resolved once. */
12663 resolve_data_variables (gfc_data_variable *d)
12665 for (; d; d = d->next)
12667 if (d->list == NULL)
12669 if (gfc_resolve_expr (d->expr) == FAILURE)
12674 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12677 if (resolve_data_variables (d->list) == FAILURE)
12686 /* Resolve a single DATA statement. We implement this by storing a pointer to
12687 the value list into static variables, and then recursively traversing the
12688 variables list, expanding iterators and such. */
12691 resolve_data (gfc_data *d)
12694 if (resolve_data_variables (d->var) == FAILURE)
12697 values.vnode = d->value;
12698 if (d->value == NULL)
12699 mpz_set_ui (values.left, 0);
12701 mpz_set (values.left, d->value->repeat);
12703 if (traverse_data_var (d->var, &d->where) == FAILURE)
12706 /* At this point, we better not have any values left. */
12708 if (next_data_value () == SUCCESS)
12709 gfc_error ("DATA statement at %L has more values than variables",
12714 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12715 accessed by host or use association, is a dummy argument to a pure function,
12716 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12717 is storage associated with any such variable, shall not be used in the
12718 following contexts: (clients of this function). */
12720 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12721 procedure. Returns zero if assignment is OK, nonzero if there is a
12724 gfc_impure_variable (gfc_symbol *sym)
12729 if (sym->attr.use_assoc || sym->attr.in_common)
12732 /* Check if the symbol's ns is inside the pure procedure. */
12733 for (ns = gfc_current_ns; ns; ns = ns->parent)
12737 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12741 proc = sym->ns->proc_name;
12742 if (sym->attr.dummy && gfc_pure (proc)
12743 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12745 proc->attr.function))
12748 /* TODO: Sort out what can be storage associated, if anything, and include
12749 it here. In principle equivalences should be scanned but it does not
12750 seem to be possible to storage associate an impure variable this way. */
12755 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12756 current namespace is inside a pure procedure. */
12759 gfc_pure (gfc_symbol *sym)
12761 symbol_attribute attr;
12766 /* Check if the current namespace or one of its parents
12767 belongs to a pure procedure. */
12768 for (ns = gfc_current_ns; ns; ns = ns->parent)
12770 sym = ns->proc_name;
12774 if (attr.flavor == FL_PROCEDURE && attr.pure)
12782 return attr.flavor == FL_PROCEDURE && attr.pure;
12786 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
12787 checks if the current namespace is implicitly pure. Note that this
12788 function returns false for a PURE procedure. */
12791 gfc_implicit_pure (gfc_symbol *sym)
12793 symbol_attribute attr;
12797 /* Check if the current namespace is implicit_pure. */
12798 sym = gfc_current_ns->proc_name;
12802 if (attr.flavor == FL_PROCEDURE
12803 && attr.implicit_pure && !attr.pure)
12810 return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
12814 /* Test whether the current procedure is elemental or not. */
12817 gfc_elemental (gfc_symbol *sym)
12819 symbol_attribute attr;
12822 sym = gfc_current_ns->proc_name;
12827 return attr.flavor == FL_PROCEDURE && attr.elemental;
12831 /* Warn about unused labels. */
12834 warn_unused_fortran_label (gfc_st_label *label)
12839 warn_unused_fortran_label (label->left);
12841 if (label->defined == ST_LABEL_UNKNOWN)
12844 switch (label->referenced)
12846 case ST_LABEL_UNKNOWN:
12847 gfc_warning ("Label %d at %L defined but not used", label->value,
12851 case ST_LABEL_BAD_TARGET:
12852 gfc_warning ("Label %d at %L defined but cannot be used",
12853 label->value, &label->where);
12860 warn_unused_fortran_label (label->right);
12864 /* Returns the sequence type of a symbol or sequence. */
12867 sequence_type (gfc_typespec ts)
12876 if (ts.u.derived->components == NULL)
12877 return SEQ_NONDEFAULT;
12879 result = sequence_type (ts.u.derived->components->ts);
12880 for (c = ts.u.derived->components->next; c; c = c->next)
12881 if (sequence_type (c->ts) != result)
12887 if (ts.kind != gfc_default_character_kind)
12888 return SEQ_NONDEFAULT;
12890 return SEQ_CHARACTER;
12893 if (ts.kind != gfc_default_integer_kind)
12894 return SEQ_NONDEFAULT;
12896 return SEQ_NUMERIC;
12899 if (!(ts.kind == gfc_default_real_kind
12900 || ts.kind == gfc_default_double_kind))
12901 return SEQ_NONDEFAULT;
12903 return SEQ_NUMERIC;
12906 if (ts.kind != gfc_default_complex_kind)
12907 return SEQ_NONDEFAULT;
12909 return SEQ_NUMERIC;
12912 if (ts.kind != gfc_default_logical_kind)
12913 return SEQ_NONDEFAULT;
12915 return SEQ_NUMERIC;
12918 return SEQ_NONDEFAULT;
12923 /* Resolve derived type EQUIVALENCE object. */
12926 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12928 gfc_component *c = derived->components;
12933 /* Shall not be an object of nonsequence derived type. */
12934 if (!derived->attr.sequence)
12936 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12937 "attribute to be an EQUIVALENCE object", sym->name,
12942 /* Shall not have allocatable components. */
12943 if (derived->attr.alloc_comp)
12945 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12946 "components to be an EQUIVALENCE object",sym->name,
12951 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12953 gfc_error ("Derived type variable '%s' at %L with default "
12954 "initialization cannot be in EQUIVALENCE with a variable "
12955 "in COMMON", sym->name, &e->where);
12959 for (; c ; c = c->next)
12961 if (c->ts.type == BT_DERIVED
12962 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12965 /* Shall not be an object of sequence derived type containing a pointer
12966 in the structure. */
12967 if (c->attr.pointer)
12969 gfc_error ("Derived type variable '%s' at %L with pointer "
12970 "component(s) cannot be an EQUIVALENCE object",
12971 sym->name, &e->where);
12979 /* Resolve equivalence object.
12980 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12981 an allocatable array, an object of nonsequence derived type, an object of
12982 sequence derived type containing a pointer at any level of component
12983 selection, an automatic object, a function name, an entry name, a result
12984 name, a named constant, a structure component, or a subobject of any of
12985 the preceding objects. A substring shall not have length zero. A
12986 derived type shall not have components with default initialization nor
12987 shall two objects of an equivalence group be initialized.
12988 Either all or none of the objects shall have an protected attribute.
12989 The simple constraints are done in symbol.c(check_conflict) and the rest
12990 are implemented here. */
12993 resolve_equivalence (gfc_equiv *eq)
12996 gfc_symbol *first_sym;
12999 locus *last_where = NULL;
13000 seq_type eq_type, last_eq_type;
13001 gfc_typespec *last_ts;
13002 int object, cnt_protected;
13005 last_ts = &eq->expr->symtree->n.sym->ts;
13007 first_sym = eq->expr->symtree->n.sym;
13011 for (object = 1; eq; eq = eq->eq, object++)
13015 e->ts = e->symtree->n.sym->ts;
13016 /* match_varspec might not know yet if it is seeing
13017 array reference or substring reference, as it doesn't
13019 if (e->ref && e->ref->type == REF_ARRAY)
13021 gfc_ref *ref = e->ref;
13022 sym = e->symtree->n.sym;
13024 if (sym->attr.dimension)
13026 ref->u.ar.as = sym->as;
13030 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13031 if (e->ts.type == BT_CHARACTER
13033 && ref->type == REF_ARRAY
13034 && ref->u.ar.dimen == 1
13035 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13036 && ref->u.ar.stride[0] == NULL)
13038 gfc_expr *start = ref->u.ar.start[0];
13039 gfc_expr *end = ref->u.ar.end[0];
13042 /* Optimize away the (:) reference. */
13043 if (start == NULL && end == NULL)
13046 e->ref = ref->next;
13048 e->ref->next = ref->next;
13053 ref->type = REF_SUBSTRING;
13055 start = gfc_get_int_expr (gfc_default_integer_kind,
13057 ref->u.ss.start = start;
13058 if (end == NULL && e->ts.u.cl)
13059 end = gfc_copy_expr (e->ts.u.cl->length);
13060 ref->u.ss.end = end;
13061 ref->u.ss.length = e->ts.u.cl;
13068 /* Any further ref is an error. */
13071 gcc_assert (ref->type == REF_ARRAY);
13072 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13078 if (gfc_resolve_expr (e) == FAILURE)
13081 sym = e->symtree->n.sym;
13083 if (sym->attr.is_protected)
13085 if (cnt_protected > 0 && cnt_protected != object)
13087 gfc_error ("Either all or none of the objects in the "
13088 "EQUIVALENCE set at %L shall have the "
13089 "PROTECTED attribute",
13094 /* Shall not equivalence common block variables in a PURE procedure. */
13095 if (sym->ns->proc_name
13096 && sym->ns->proc_name->attr.pure
13097 && sym->attr.in_common)
13099 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13100 "object in the pure procedure '%s'",
13101 sym->name, &e->where, sym->ns->proc_name->name);
13105 /* Shall not be a named constant. */
13106 if (e->expr_type == EXPR_CONSTANT)
13108 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13109 "object", sym->name, &e->where);
13113 if (e->ts.type == BT_DERIVED
13114 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13117 /* Check that the types correspond correctly:
13119 A numeric sequence structure may be equivalenced to another sequence
13120 structure, an object of default integer type, default real type, double
13121 precision real type, default logical type such that components of the
13122 structure ultimately only become associated to objects of the same
13123 kind. A character sequence structure may be equivalenced to an object
13124 of default character kind or another character sequence structure.
13125 Other objects may be equivalenced only to objects of the same type and
13126 kind parameters. */
13128 /* Identical types are unconditionally OK. */
13129 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13130 goto identical_types;
13132 last_eq_type = sequence_type (*last_ts);
13133 eq_type = sequence_type (sym->ts);
13135 /* Since the pair of objects is not of the same type, mixed or
13136 non-default sequences can be rejected. */
13138 msg = "Sequence %s with mixed components in EQUIVALENCE "
13139 "statement at %L with different type objects";
13141 && last_eq_type == SEQ_MIXED
13142 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13144 || (eq_type == SEQ_MIXED
13145 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13146 &e->where) == FAILURE))
13149 msg = "Non-default type object or sequence %s in EQUIVALENCE "
13150 "statement at %L with objects of different type";
13152 && last_eq_type == SEQ_NONDEFAULT
13153 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13154 last_where) == FAILURE)
13155 || (eq_type == SEQ_NONDEFAULT
13156 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13157 &e->where) == FAILURE))
13160 msg ="Non-CHARACTER object '%s' in default CHARACTER "
13161 "EQUIVALENCE statement at %L";
13162 if (last_eq_type == SEQ_CHARACTER
13163 && eq_type != SEQ_CHARACTER
13164 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13165 &e->where) == FAILURE)
13168 msg ="Non-NUMERIC object '%s' in default NUMERIC "
13169 "EQUIVALENCE statement at %L";
13170 if (last_eq_type == SEQ_NUMERIC
13171 && eq_type != SEQ_NUMERIC
13172 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13173 &e->where) == FAILURE)
13178 last_where = &e->where;
13183 /* Shall not be an automatic array. */
13184 if (e->ref->type == REF_ARRAY
13185 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13187 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13188 "an EQUIVALENCE object", sym->name, &e->where);
13195 /* Shall not be a structure component. */
13196 if (r->type == REF_COMPONENT)
13198 gfc_error ("Structure component '%s' at %L cannot be an "
13199 "EQUIVALENCE object",
13200 r->u.c.component->name, &e->where);
13204 /* A substring shall not have length zero. */
13205 if (r->type == REF_SUBSTRING)
13207 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13209 gfc_error ("Substring at %L has length zero",
13210 &r->u.ss.start->where);
13220 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13223 resolve_fntype (gfc_namespace *ns)
13225 gfc_entry_list *el;
13228 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13231 /* If there are any entries, ns->proc_name is the entry master
13232 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13234 sym = ns->entries->sym;
13236 sym = ns->proc_name;
13237 if (sym->result == sym
13238 && sym->ts.type == BT_UNKNOWN
13239 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13240 && !sym->attr.untyped)
13242 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13243 sym->name, &sym->declared_at);
13244 sym->attr.untyped = 1;
13247 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13248 && !sym->attr.contained
13249 && !gfc_check_access (sym->ts.u.derived->attr.access,
13250 sym->ts.u.derived->ns->default_access)
13251 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13253 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13254 "%L of PRIVATE type '%s'", sym->name,
13255 &sym->declared_at, sym->ts.u.derived->name);
13259 for (el = ns->entries->next; el; el = el->next)
13261 if (el->sym->result == el->sym
13262 && el->sym->ts.type == BT_UNKNOWN
13263 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13264 && !el->sym->attr.untyped)
13266 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13267 el->sym->name, &el->sym->declared_at);
13268 el->sym->attr.untyped = 1;
13274 /* 12.3.2.1.1 Defined operators. */
13277 check_uop_procedure (gfc_symbol *sym, locus where)
13279 gfc_formal_arglist *formal;
13281 if (!sym->attr.function)
13283 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13284 sym->name, &where);
13288 if (sym->ts.type == BT_CHARACTER
13289 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13290 && !(sym->result && sym->result->ts.u.cl
13291 && sym->result->ts.u.cl->length))
13293 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13294 "character length", sym->name, &where);
13298 formal = sym->formal;
13299 if (!formal || !formal->sym)
13301 gfc_error ("User operator procedure '%s' at %L must have at least "
13302 "one argument", sym->name, &where);
13306 if (formal->sym->attr.intent != INTENT_IN)
13308 gfc_error ("First argument of operator interface at %L must be "
13309 "INTENT(IN)", &where);
13313 if (formal->sym->attr.optional)
13315 gfc_error ("First argument of operator interface at %L cannot be "
13316 "optional", &where);
13320 formal = formal->next;
13321 if (!formal || !formal->sym)
13324 if (formal->sym->attr.intent != INTENT_IN)
13326 gfc_error ("Second argument of operator interface at %L must be "
13327 "INTENT(IN)", &where);
13331 if (formal->sym->attr.optional)
13333 gfc_error ("Second argument of operator interface at %L cannot be "
13334 "optional", &where);
13340 gfc_error ("Operator interface at %L must have, at most, two "
13341 "arguments", &where);
13349 gfc_resolve_uops (gfc_symtree *symtree)
13351 gfc_interface *itr;
13353 if (symtree == NULL)
13356 gfc_resolve_uops (symtree->left);
13357 gfc_resolve_uops (symtree->right);
13359 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13360 check_uop_procedure (itr->sym, itr->sym->declared_at);
13364 /* Examine all of the expressions associated with a program unit,
13365 assign types to all intermediate expressions, make sure that all
13366 assignments are to compatible types and figure out which names
13367 refer to which functions or subroutines. It doesn't check code
13368 block, which is handled by resolve_code. */
13371 resolve_types (gfc_namespace *ns)
13377 gfc_namespace* old_ns = gfc_current_ns;
13379 /* Check that all IMPLICIT types are ok. */
13380 if (!ns->seen_implicit_none)
13383 for (letter = 0; letter != GFC_LETTERS; ++letter)
13384 if (ns->set_flag[letter]
13385 && resolve_typespec_used (&ns->default_type[letter],
13386 &ns->implicit_loc[letter],
13391 gfc_current_ns = ns;
13393 resolve_entries (ns);
13395 resolve_common_vars (ns->blank_common.head, false);
13396 resolve_common_blocks (ns->common_root);
13398 resolve_contained_functions (ns);
13400 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13402 for (cl = ns->cl_list; cl; cl = cl->next)
13403 resolve_charlen (cl);
13405 gfc_traverse_ns (ns, resolve_symbol);
13407 resolve_fntype (ns);
13409 for (n = ns->contained; n; n = n->sibling)
13411 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13412 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13413 "also be PURE", n->proc_name->name,
13414 &n->proc_name->declared_at);
13420 gfc_check_interfaces (ns);
13422 gfc_traverse_ns (ns, resolve_values);
13428 for (d = ns->data; d; d = d->next)
13432 gfc_traverse_ns (ns, gfc_formalize_init_value);
13434 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13436 if (ns->common_root != NULL)
13437 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13439 for (eq = ns->equiv; eq; eq = eq->next)
13440 resolve_equivalence (eq);
13442 /* Warn about unused labels. */
13443 if (warn_unused_label)
13444 warn_unused_fortran_label (ns->st_labels);
13446 gfc_resolve_uops (ns->uop_root);
13448 gfc_current_ns = old_ns;
13452 /* Call resolve_code recursively. */
13455 resolve_codes (gfc_namespace *ns)
13458 bitmap_obstack old_obstack;
13460 if (ns->resolved == 1)
13463 for (n = ns->contained; n; n = n->sibling)
13466 gfc_current_ns = ns;
13468 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13469 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13472 /* Set to an out of range value. */
13473 current_entry_id = -1;
13475 old_obstack = labels_obstack;
13476 bitmap_obstack_initialize (&labels_obstack);
13478 resolve_code (ns->code, ns);
13480 bitmap_obstack_release (&labels_obstack);
13481 labels_obstack = old_obstack;
13485 /* This function is called after a complete program unit has been compiled.
13486 Its purpose is to examine all of the expressions associated with a program
13487 unit, assign types to all intermediate expressions, make sure that all
13488 assignments are to compatible types and figure out which names refer to
13489 which functions or subroutines. */
13492 gfc_resolve (gfc_namespace *ns)
13494 gfc_namespace *old_ns;
13495 code_stack *old_cs_base;
13501 old_ns = gfc_current_ns;
13502 old_cs_base = cs_base;
13504 resolve_types (ns);
13505 resolve_codes (ns);
13507 gfc_current_ns = old_ns;
13508 cs_base = old_cs_base;
13511 gfc_run_passes (ns);