1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
41 /* Stack to keep track of the nesting of blocks as we move through the
42 code. See resolve_branch() and resolve_code(). */
44 typedef struct code_stack
46 struct gfc_code *head, *current, *tail;
47 struct code_stack *prev;
49 /* This bitmap keeps track of the targets valid for a branch from
51 bitmap reachable_labels;
55 static code_stack *cs_base = NULL;
58 /* Nonzero if we're inside a FORALL block. */
60 static int forall_flag;
62 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
64 static int omp_workshare_flag;
66 /* Nonzero if we are processing a formal arglist. The corresponding function
67 resets the flag each time that it is read. */
68 static int formal_arg_flag = 0;
70 /* True if we are resolving a specification expression. */
71 static int specification_expr = 0;
73 /* The id of the last entry seen. */
74 static int current_entry_id;
76 /* We use bitmaps to determine if a branch target is valid. */
77 static bitmap_obstack labels_obstack;
80 gfc_is_formal_arg (void)
82 return formal_arg_flag;
86 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
87 an ABSTRACT derived-type. If where is not NULL, an error message with that
88 locus is printed, optionally using name. */
91 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
93 if (ts->type == BT_DERIVED && ts->derived->attr.abstract)
98 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
99 name, where, ts->derived->name);
101 gfc_error ("ABSTRACT type '%s' used at %L",
102 ts->derived->name, where);
112 /* Resolve types of formal argument lists. These have to be done early so that
113 the formal argument lists of module procedures can be copied to the
114 containing module before the individual procedures are resolved
115 individually. We also resolve argument lists of procedures in interface
116 blocks because they are self-contained scoping units.
118 Since a dummy argument cannot be a non-dummy procedure, the only
119 resort left for untyped names are the IMPLICIT types. */
122 resolve_formal_arglist (gfc_symbol *proc)
124 gfc_formal_arglist *f;
128 if (proc->result != NULL)
133 if (gfc_elemental (proc)
134 || sym->attr.pointer || sym->attr.allocatable
135 || (sym->as && sym->as->rank > 0))
137 proc->attr.always_explicit = 1;
138 sym->attr.always_explicit = 1;
143 for (f = proc->formal; f; f = f->next)
149 /* Alternate return placeholder. */
150 if (gfc_elemental (proc))
151 gfc_error ("Alternate return specifier in elemental subroutine "
152 "'%s' at %L is not allowed", proc->name,
154 if (proc->attr.function)
155 gfc_error ("Alternate return specifier in function "
156 "'%s' at %L is not allowed", proc->name,
161 if (sym->attr.if_source != IFSRC_UNKNOWN)
162 resolve_formal_arglist (sym);
164 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
166 if (gfc_pure (proc) && !gfc_pure (sym))
168 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
169 "also be PURE", sym->name, &sym->declared_at);
173 if (gfc_elemental (proc))
175 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
176 "procedure", &sym->declared_at);
180 if (sym->attr.function
181 && sym->ts.type == BT_UNKNOWN
182 && sym->attr.intrinsic)
184 gfc_intrinsic_sym *isym;
185 isym = gfc_find_function (sym->name);
186 if (isym == NULL || !isym->specific)
188 gfc_error ("Unable to find a specific INTRINSIC procedure "
189 "for the reference '%s' at %L", sym->name,
198 if (sym->ts.type == BT_UNKNOWN)
200 if (!sym->attr.function || sym->result == sym)
201 gfc_set_default_type (sym, 1, sym->ns);
204 gfc_resolve_array_spec (sym->as, 0);
206 /* We can't tell if an array with dimension (:) is assumed or deferred
207 shape until we know if it has the pointer or allocatable attributes.
209 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
210 && !(sym->attr.pointer || sym->attr.allocatable))
212 sym->as->type = AS_ASSUMED_SHAPE;
213 for (i = 0; i < sym->as->rank; i++)
214 sym->as->lower[i] = gfc_int_expr (1);
217 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
218 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
219 || sym->attr.optional)
221 proc->attr.always_explicit = 1;
223 proc->result->attr.always_explicit = 1;
226 /* If the flavor is unknown at this point, it has to be a variable.
227 A procedure specification would have already set the type. */
229 if (sym->attr.flavor == FL_UNKNOWN)
230 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
232 if (gfc_pure (proc) && !sym->attr.pointer
233 && sym->attr.flavor != FL_PROCEDURE)
235 if (proc->attr.function && sym->attr.intent != INTENT_IN)
236 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
237 "INTENT(IN)", sym->name, proc->name,
240 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
241 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
242 "have its INTENT specified", sym->name, proc->name,
246 if (gfc_elemental (proc))
250 gfc_error ("Argument '%s' of elemental procedure at %L must "
251 "be scalar", sym->name, &sym->declared_at);
255 if (sym->attr.pointer)
257 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
258 "have the POINTER attribute", sym->name,
263 if (sym->attr.flavor == FL_PROCEDURE)
265 gfc_error ("Dummy procedure '%s' not allowed in elemental "
266 "procedure '%s' at %L", sym->name, proc->name,
272 /* Each dummy shall be specified to be scalar. */
273 if (proc->attr.proc == PROC_ST_FUNCTION)
277 gfc_error ("Argument '%s' of statement function at %L must "
278 "be scalar", sym->name, &sym->declared_at);
282 if (sym->ts.type == BT_CHARACTER)
284 gfc_charlen *cl = sym->ts.cl;
285 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
287 gfc_error ("Character-valued argument '%s' of statement "
288 "function at %L must have constant length",
289 sym->name, &sym->declared_at);
299 /* Work function called when searching for symbols that have argument lists
300 associated with them. */
303 find_arglists (gfc_symbol *sym)
305 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
308 resolve_formal_arglist (sym);
312 /* Given a namespace, resolve all formal argument lists within the namespace.
316 resolve_formal_arglists (gfc_namespace *ns)
321 gfc_traverse_ns (ns, find_arglists);
326 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
330 /* If this namespace is not a function or an entry master function,
332 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
333 || sym->attr.entry_master)
336 /* Try to find out of what the return type is. */
337 if (sym->result->ts.type == BT_UNKNOWN)
339 t = gfc_set_default_type (sym->result, 0, ns);
341 if (t == FAILURE && !sym->result->attr.untyped)
343 if (sym->result == sym)
344 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
345 sym->name, &sym->declared_at);
347 gfc_error ("Result '%s' of contained function '%s' at %L has "
348 "no IMPLICIT type", sym->result->name, sym->name,
349 &sym->result->declared_at);
350 sym->result->attr.untyped = 1;
354 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
355 type, lists the only ways a character length value of * can be used:
356 dummy arguments of procedures, named constants, and function results
357 in external functions. Internal function results are not on that list;
358 ergo, not permitted. */
360 if (sym->result->ts.type == BT_CHARACTER)
362 gfc_charlen *cl = sym->result->ts.cl;
363 if (!cl || !cl->length)
364 gfc_error ("Character-valued internal function '%s' at %L must "
365 "not be assumed length", sym->name, &sym->declared_at);
370 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
371 introduce duplicates. */
374 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
376 gfc_formal_arglist *f, *new_arglist;
379 for (; new_args != NULL; new_args = new_args->next)
381 new_sym = new_args->sym;
382 /* See if this arg is already in the formal argument list. */
383 for (f = proc->formal; f; f = f->next)
385 if (new_sym == f->sym)
392 /* Add a new argument. Argument order is not important. */
393 new_arglist = gfc_get_formal_arglist ();
394 new_arglist->sym = new_sym;
395 new_arglist->next = proc->formal;
396 proc->formal = new_arglist;
401 /* Flag the arguments that are not present in all entries. */
404 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
406 gfc_formal_arglist *f, *head;
409 for (f = proc->formal; f; f = f->next)
414 for (new_args = head; new_args; new_args = new_args->next)
416 if (new_args->sym == f->sym)
423 f->sym->attr.not_always_present = 1;
428 /* Resolve alternate entry points. If a symbol has multiple entry points we
429 create a new master symbol for the main routine, and turn the existing
430 symbol into an entry point. */
433 resolve_entries (gfc_namespace *ns)
435 gfc_namespace *old_ns;
439 char name[GFC_MAX_SYMBOL_LEN + 1];
440 static int master_count = 0;
442 if (ns->proc_name == NULL)
445 /* No need to do anything if this procedure doesn't have alternate entry
450 /* We may already have resolved alternate entry points. */
451 if (ns->proc_name->attr.entry_master)
454 /* If this isn't a procedure something has gone horribly wrong. */
455 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
457 /* Remember the current namespace. */
458 old_ns = gfc_current_ns;
462 /* Add the main entry point to the list of entry points. */
463 el = gfc_get_entry_list ();
464 el->sym = ns->proc_name;
466 el->next = ns->entries;
468 ns->proc_name->attr.entry = 1;
470 /* If it is a module function, it needs to be in the right namespace
471 so that gfc_get_fake_result_decl can gather up the results. The
472 need for this arose in get_proc_name, where these beasts were
473 left in their own namespace, to keep prior references linked to
474 the entry declaration.*/
475 if (ns->proc_name->attr.function
476 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
479 /* Do the same for entries where the master is not a module
480 procedure. These are retained in the module namespace because
481 of the module procedure declaration. */
482 for (el = el->next; el; el = el->next)
483 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
484 && el->sym->attr.mod_proc)
488 /* Add an entry statement for it. */
495 /* Create a new symbol for the master function. */
496 /* Give the internal function a unique name (within this file).
497 Also include the function name so the user has some hope of figuring
498 out what is going on. */
499 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
500 master_count++, ns->proc_name->name);
501 gfc_get_ha_symbol (name, &proc);
502 gcc_assert (proc != NULL);
504 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
505 if (ns->proc_name->attr.subroutine)
506 gfc_add_subroutine (&proc->attr, proc->name, NULL);
510 gfc_typespec *ts, *fts;
511 gfc_array_spec *as, *fas;
512 gfc_add_function (&proc->attr, proc->name, NULL);
514 fas = ns->entries->sym->as;
515 fas = fas ? fas : ns->entries->sym->result->as;
516 fts = &ns->entries->sym->result->ts;
517 if (fts->type == BT_UNKNOWN)
518 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
519 for (el = ns->entries->next; el; el = el->next)
521 ts = &el->sym->result->ts;
523 as = as ? as : el->sym->result->as;
524 if (ts->type == BT_UNKNOWN)
525 ts = gfc_get_default_type (el->sym->result, NULL);
527 if (! gfc_compare_types (ts, fts)
528 || (el->sym->result->attr.dimension
529 != ns->entries->sym->result->attr.dimension)
530 || (el->sym->result->attr.pointer
531 != ns->entries->sym->result->attr.pointer))
533 else if (as && fas && ns->entries->sym->result != el->sym->result
534 && gfc_compare_array_spec (as, fas) == 0)
535 gfc_error ("Function %s at %L has entries with mismatched "
536 "array specifications", ns->entries->sym->name,
537 &ns->entries->sym->declared_at);
538 /* The characteristics need to match and thus both need to have
539 the same string length, i.e. both len=*, or both len=4.
540 Having both len=<variable> is also possible, but difficult to
541 check at compile time. */
542 else if (ts->type == BT_CHARACTER && ts->cl && fts->cl
543 && (((ts->cl->length && !fts->cl->length)
544 ||(!ts->cl->length && fts->cl->length))
546 && ts->cl->length->expr_type
547 != fts->cl->length->expr_type)
549 && ts->cl->length->expr_type == EXPR_CONSTANT
550 && mpz_cmp (ts->cl->length->value.integer,
551 fts->cl->length->value.integer) != 0)))
552 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
553 "entries returning variables of different "
554 "string lengths", ns->entries->sym->name,
555 &ns->entries->sym->declared_at);
560 sym = ns->entries->sym->result;
561 /* All result types the same. */
563 if (sym->attr.dimension)
564 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
565 if (sym->attr.pointer)
566 gfc_add_pointer (&proc->attr, NULL);
570 /* Otherwise the result will be passed through a union by
572 proc->attr.mixed_entry_master = 1;
573 for (el = ns->entries; el; el = el->next)
575 sym = el->sym->result;
576 if (sym->attr.dimension)
578 if (el == ns->entries)
579 gfc_error ("FUNCTION result %s can't be an array in "
580 "FUNCTION %s at %L", sym->name,
581 ns->entries->sym->name, &sym->declared_at);
583 gfc_error ("ENTRY result %s can't be an array in "
584 "FUNCTION %s at %L", sym->name,
585 ns->entries->sym->name, &sym->declared_at);
587 else if (sym->attr.pointer)
589 if (el == ns->entries)
590 gfc_error ("FUNCTION result %s can't be a POINTER in "
591 "FUNCTION %s at %L", sym->name,
592 ns->entries->sym->name, &sym->declared_at);
594 gfc_error ("ENTRY result %s can't be a POINTER in "
595 "FUNCTION %s at %L", sym->name,
596 ns->entries->sym->name, &sym->declared_at);
601 if (ts->type == BT_UNKNOWN)
602 ts = gfc_get_default_type (sym, NULL);
606 if (ts->kind == gfc_default_integer_kind)
610 if (ts->kind == gfc_default_real_kind
611 || ts->kind == gfc_default_double_kind)
615 if (ts->kind == gfc_default_complex_kind)
619 if (ts->kind == gfc_default_logical_kind)
623 /* We will issue error elsewhere. */
631 if (el == ns->entries)
632 gfc_error ("FUNCTION result %s can't be of type %s "
633 "in FUNCTION %s at %L", sym->name,
634 gfc_typename (ts), ns->entries->sym->name,
637 gfc_error ("ENTRY result %s can't be of type %s "
638 "in FUNCTION %s at %L", sym->name,
639 gfc_typename (ts), ns->entries->sym->name,
646 proc->attr.access = ACCESS_PRIVATE;
647 proc->attr.entry_master = 1;
649 /* Merge all the entry point arguments. */
650 for (el = ns->entries; el; el = el->next)
651 merge_argument_lists (proc, el->sym->formal);
653 /* Check the master formal arguments for any that are not
654 present in all entry points. */
655 for (el = ns->entries; el; el = el->next)
656 check_argument_lists (proc, el->sym->formal);
658 /* Use the master function for the function body. */
659 ns->proc_name = proc;
661 /* Finalize the new symbols. */
662 gfc_commit_symbols ();
664 /* Restore the original namespace. */
665 gfc_current_ns = old_ns;
670 has_default_initializer (gfc_symbol *der)
674 gcc_assert (der->attr.flavor == FL_DERIVED);
675 for (c = der->components; c; c = c->next)
676 if ((c->ts.type != BT_DERIVED && c->initializer)
677 || (c->ts.type == BT_DERIVED
678 && (!c->attr.pointer && has_default_initializer (c->ts.derived))))
684 /* Resolve common variables. */
686 resolve_common_vars (gfc_symbol *sym, bool named_common)
688 gfc_symbol *csym = sym;
690 for (; csym; csym = csym->common_next)
692 if (csym->value || csym->attr.data)
694 if (!csym->ns->is_block_data)
695 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
696 "but only in BLOCK DATA initialization is "
697 "allowed", csym->name, &csym->declared_at);
698 else if (!named_common)
699 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
700 "in a blank COMMON but initialization is only "
701 "allowed in named common blocks", csym->name,
705 if (csym->ts.type != BT_DERIVED)
708 if (!(csym->ts.derived->attr.sequence
709 || csym->ts.derived->attr.is_bind_c))
710 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
711 "has neither the SEQUENCE nor the BIND(C) "
712 "attribute", csym->name, &csym->declared_at);
713 if (csym->ts.derived->attr.alloc_comp)
714 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
715 "has an ultimate component that is "
716 "allocatable", csym->name, &csym->declared_at);
717 if (has_default_initializer (csym->ts.derived))
718 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
719 "may not have default initializer", csym->name,
724 /* Resolve common blocks. */
726 resolve_common_blocks (gfc_symtree *common_root)
730 if (common_root == NULL)
733 if (common_root->left)
734 resolve_common_blocks (common_root->left);
735 if (common_root->right)
736 resolve_common_blocks (common_root->right);
738 resolve_common_vars (common_root->n.common->head, true);
740 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
744 if (sym->attr.flavor == FL_PARAMETER)
745 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
746 sym->name, &common_root->n.common->where, &sym->declared_at);
748 if (sym->attr.intrinsic)
749 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
750 sym->name, &common_root->n.common->where);
751 else if (sym->attr.result
752 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
753 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
754 "that is also a function result", sym->name,
755 &common_root->n.common->where);
756 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
757 && sym->attr.proc != PROC_ST_FUNCTION)
758 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
759 "that is also a global procedure", sym->name,
760 &common_root->n.common->where);
764 /* Resolve contained function types. Because contained functions can call one
765 another, they have to be worked out before any of the contained procedures
768 The good news is that if a function doesn't already have a type, the only
769 way it can get one is through an IMPLICIT type or a RESULT variable, because
770 by definition contained functions are contained namespace they're contained
771 in, not in a sibling or parent namespace. */
774 resolve_contained_functions (gfc_namespace *ns)
776 gfc_namespace *child;
779 resolve_formal_arglists (ns);
781 for (child = ns->contained; child; child = child->sibling)
783 /* Resolve alternate entry points first. */
784 resolve_entries (child);
786 /* Then check function return types. */
787 resolve_contained_fntype (child->proc_name, child);
788 for (el = child->entries; el; el = el->next)
789 resolve_contained_fntype (el->sym, child);
794 /* Resolve all of the elements of a structure constructor and make sure that
795 the types are correct. */
798 resolve_structure_cons (gfc_expr *expr)
800 gfc_constructor *cons;
806 cons = expr->value.constructor;
807 /* A constructor may have references if it is the result of substituting a
808 parameter variable. In this case we just pull out the component we
811 comp = expr->ref->u.c.sym->components;
813 comp = expr->ts.derived->components;
815 /* See if the user is trying to invoke a structure constructor for one of
816 the iso_c_binding derived types. */
817 if (expr->ts.derived && expr->ts.derived->ts.is_iso_c && cons
818 && cons->expr != NULL)
820 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
821 expr->ts.derived->name, &(expr->where));
825 for (; comp; comp = comp->next, cons = cons->next)
832 if (gfc_resolve_expr (cons->expr) == FAILURE)
838 rank = comp->as ? comp->as->rank : 0;
839 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
840 && (comp->attr.allocatable || cons->expr->rank))
842 gfc_error ("The rank of the element in the derived type "
843 "constructor at %L does not match that of the "
844 "component (%d/%d)", &cons->expr->where,
845 cons->expr->rank, rank);
849 /* If we don't have the right type, try to convert it. */
851 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
854 if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
855 gfc_error ("The element in the derived type constructor at %L, "
856 "for pointer component '%s', is %s but should be %s",
857 &cons->expr->where, comp->name,
858 gfc_basic_typename (cons->expr->ts.type),
859 gfc_basic_typename (comp->ts.type));
861 t = gfc_convert_type (cons->expr, &comp->ts, 1);
864 if (cons->expr->expr_type == EXPR_NULL
865 && !(comp->attr.pointer || comp->attr.allocatable))
868 gfc_error ("The NULL in the derived type constructor at %L is "
869 "being applied to component '%s', which is neither "
870 "a POINTER nor ALLOCATABLE", &cons->expr->where,
874 if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
877 a = gfc_expr_attr (cons->expr);
879 if (!a.pointer && !a.target)
882 gfc_error ("The element in the derived type constructor at %L, "
883 "for pointer component '%s' should be a POINTER or "
884 "a TARGET", &cons->expr->where, comp->name);
892 /****************** Expression name resolution ******************/
894 /* Returns 0 if a symbol was not declared with a type or
895 attribute declaration statement, nonzero otherwise. */
898 was_declared (gfc_symbol *sym)
904 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
907 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
908 || a.optional || a.pointer || a.save || a.target || a.volatile_
909 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
916 /* Determine if a symbol is generic or not. */
919 generic_sym (gfc_symbol *sym)
923 if (sym->attr.generic ||
924 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
927 if (was_declared (sym) || sym->ns->parent == NULL)
930 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
937 return generic_sym (s);
944 /* Determine if a symbol is specific or not. */
947 specific_sym (gfc_symbol *sym)
951 if (sym->attr.if_source == IFSRC_IFBODY
952 || sym->attr.proc == PROC_MODULE
953 || sym->attr.proc == PROC_INTERNAL
954 || sym->attr.proc == PROC_ST_FUNCTION
955 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
956 || sym->attr.external)
959 if (was_declared (sym) || sym->ns->parent == NULL)
962 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
964 return (s == NULL) ? 0 : specific_sym (s);
968 /* Figure out if the procedure is specific, generic or unknown. */
971 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
975 procedure_kind (gfc_symbol *sym)
977 if (generic_sym (sym))
978 return PTYPE_GENERIC;
980 if (specific_sym (sym))
981 return PTYPE_SPECIFIC;
983 return PTYPE_UNKNOWN;
986 /* Check references to assumed size arrays. The flag need_full_assumed_size
987 is nonzero when matching actual arguments. */
989 static int need_full_assumed_size = 0;
992 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
994 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
997 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
998 What should it be? */
999 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1000 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1001 && (e->ref->u.ar.type == AR_FULL))
1003 gfc_error ("The upper bound in the last dimension must "
1004 "appear in the reference to the assumed size "
1005 "array '%s' at %L", sym->name, &e->where);
1012 /* Look for bad assumed size array references in argument expressions
1013 of elemental and array valued intrinsic procedures. Since this is
1014 called from procedure resolution functions, it only recurses at
1018 resolve_assumed_size_actual (gfc_expr *e)
1023 switch (e->expr_type)
1026 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1031 if (resolve_assumed_size_actual (e->value.op.op1)
1032 || resolve_assumed_size_actual (e->value.op.op2))
1043 /* Check a generic procedure, passed as an actual argument, to see if
1044 there is a matching specific name. If none, it is an error, and if
1045 more than one, the reference is ambiguous. */
1047 count_specific_procs (gfc_expr *e)
1054 sym = e->symtree->n.sym;
1056 for (p = sym->generic; p; p = p->next)
1057 if (strcmp (sym->name, p->sym->name) == 0)
1059 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1065 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1069 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1070 "argument at %L", sym->name, &e->where);
1076 /* See if a call to sym could possibly be a not allowed RECURSION because of
1077 a missing RECURIVE declaration. This means that either sym is the current
1078 context itself, or sym is the parent of a contained procedure calling its
1079 non-RECURSIVE containing procedure.
1080 This also works if sym is an ENTRY. */
1083 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1085 gfc_symbol* proc_sym;
1086 gfc_symbol* context_proc;
1088 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1090 /* If we've got an ENTRY, find real procedure. */
1091 if (sym->attr.entry && sym->ns->entries)
1092 proc_sym = sym->ns->entries->sym;
1096 /* If sym is RECURSIVE, all is well of course. */
1097 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1100 /* Find the context procdure's "real" symbol if it has entries. */
1101 context_proc = (context->entries ? context->entries->sym
1102 : context->proc_name);
1106 /* A call from sym's body to itself is recursion, of course. */
1107 if (context_proc == proc_sym)
1110 /* The same is true if context is a contained procedure and sym the
1112 if (context_proc->attr.contained)
1114 gfc_symbol* parent_proc;
1116 gcc_assert (context->parent);
1117 parent_proc = (context->parent->entries ? context->parent->entries->sym
1118 : context->parent->proc_name);
1120 if (parent_proc == proc_sym)
1128 /* Resolve a procedure expression, like passing it to a called procedure or as
1129 RHS for a procedure pointer assignment. */
1132 resolve_procedure_expression (gfc_expr* expr)
1136 if (expr->expr_type != EXPR_VARIABLE)
1138 gcc_assert (expr->symtree);
1140 sym = expr->symtree->n.sym;
1141 if (sym->attr.flavor != FL_PROCEDURE
1142 || (sym->attr.function && sym->result == sym))
1145 /* A non-RECURSIVE procedure that is used as procedure expression within its
1146 own body is in danger of being called recursively. */
1147 if (is_illegal_recursion (sym, gfc_current_ns))
1148 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1149 " itself recursively. Declare it RECURSIVE or use"
1150 " -frecursive", sym->name, &expr->where);
1156 /* Resolve an actual argument list. Most of the time, this is just
1157 resolving the expressions in the list.
1158 The exception is that we sometimes have to decide whether arguments
1159 that look like procedure arguments are really simple variable
1163 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1164 bool no_formal_args)
1167 gfc_symtree *parent_st;
1169 int save_need_full_assumed_size;
1171 for (; arg; arg = arg->next)
1176 /* Check the label is a valid branching target. */
1179 if (arg->label->defined == ST_LABEL_UNKNOWN)
1181 gfc_error ("Label %d referenced at %L is never defined",
1182 arg->label->value, &arg->label->where);
1189 if (e->expr_type == EXPR_VARIABLE
1190 && e->symtree->n.sym->attr.generic
1192 && count_specific_procs (e) != 1)
1195 if (e->ts.type != BT_PROCEDURE)
1197 save_need_full_assumed_size = need_full_assumed_size;
1198 if (e->expr_type != EXPR_VARIABLE)
1199 need_full_assumed_size = 0;
1200 if (gfc_resolve_expr (e) != SUCCESS)
1202 need_full_assumed_size = save_need_full_assumed_size;
1206 /* See if the expression node should really be a variable reference. */
1208 sym = e->symtree->n.sym;
1210 if (sym->attr.flavor == FL_PROCEDURE
1211 || sym->attr.intrinsic
1212 || sym->attr.external)
1216 /* If a procedure is not already determined to be something else
1217 check if it is intrinsic. */
1218 if (!sym->attr.intrinsic
1219 && !(sym->attr.external || sym->attr.use_assoc
1220 || sym->attr.if_source == IFSRC_IFBODY)
1221 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1222 sym->attr.intrinsic = 1;
1224 if (sym->attr.proc == PROC_ST_FUNCTION)
1226 gfc_error ("Statement function '%s' at %L is not allowed as an "
1227 "actual argument", sym->name, &e->where);
1230 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1231 sym->attr.subroutine);
1232 if (sym->attr.intrinsic && actual_ok == 0)
1234 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1235 "actual argument", sym->name, &e->where);
1238 if (sym->attr.contained && !sym->attr.use_assoc
1239 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1241 gfc_error ("Internal procedure '%s' is not allowed as an "
1242 "actual argument at %L", sym->name, &e->where);
1245 if (sym->attr.elemental && !sym->attr.intrinsic)
1247 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1248 "allowed as an actual argument at %L", sym->name,
1252 /* Check if a generic interface has a specific procedure
1253 with the same name before emitting an error. */
1254 if (sym->attr.generic && count_specific_procs (e) != 1)
1257 /* Just in case a specific was found for the expression. */
1258 sym = e->symtree->n.sym;
1260 /* If the symbol is the function that names the current (or
1261 parent) scope, then we really have a variable reference. */
1263 if (sym->attr.function && sym->result == sym
1264 && (sym->ns->proc_name == sym
1265 || (sym->ns->parent != NULL
1266 && sym->ns->parent->proc_name == sym)))
1269 /* If all else fails, see if we have a specific intrinsic. */
1270 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1272 gfc_intrinsic_sym *isym;
1274 isym = gfc_find_function (sym->name);
1275 if (isym == NULL || !isym->specific)
1277 gfc_error ("Unable to find a specific INTRINSIC procedure "
1278 "for the reference '%s' at %L", sym->name,
1283 sym->attr.intrinsic = 1;
1284 sym->attr.function = 1;
1287 if (gfc_resolve_expr (e) == FAILURE)
1292 /* See if the name is a module procedure in a parent unit. */
1294 if (was_declared (sym) || sym->ns->parent == NULL)
1297 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1299 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1303 if (parent_st == NULL)
1306 sym = parent_st->n.sym;
1307 e->symtree = parent_st; /* Point to the right thing. */
1309 if (sym->attr.flavor == FL_PROCEDURE
1310 || sym->attr.intrinsic
1311 || sym->attr.external)
1313 if (gfc_resolve_expr (e) == FAILURE)
1319 e->expr_type = EXPR_VARIABLE;
1321 if (sym->as != NULL)
1323 e->rank = sym->as->rank;
1324 e->ref = gfc_get_ref ();
1325 e->ref->type = REF_ARRAY;
1326 e->ref->u.ar.type = AR_FULL;
1327 e->ref->u.ar.as = sym->as;
1330 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1331 primary.c (match_actual_arg). If above code determines that it
1332 is a variable instead, it needs to be resolved as it was not
1333 done at the beginning of this function. */
1334 save_need_full_assumed_size = need_full_assumed_size;
1335 if (e->expr_type != EXPR_VARIABLE)
1336 need_full_assumed_size = 0;
1337 if (gfc_resolve_expr (e) != SUCCESS)
1339 need_full_assumed_size = save_need_full_assumed_size;
1342 /* Check argument list functions %VAL, %LOC and %REF. There is
1343 nothing to do for %REF. */
1344 if (arg->name && arg->name[0] == '%')
1346 if (strncmp ("%VAL", arg->name, 4) == 0)
1348 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1350 gfc_error ("By-value argument at %L is not of numeric "
1357 gfc_error ("By-value argument at %L cannot be an array or "
1358 "an array section", &e->where);
1362 /* Intrinsics are still PROC_UNKNOWN here. However,
1363 since same file external procedures are not resolvable
1364 in gfortran, it is a good deal easier to leave them to
1366 if (ptype != PROC_UNKNOWN
1367 && ptype != PROC_DUMMY
1368 && ptype != PROC_EXTERNAL
1369 && ptype != PROC_MODULE)
1371 gfc_error ("By-value argument at %L is not allowed "
1372 "in this context", &e->where);
1377 /* Statement functions have already been excluded above. */
1378 else if (strncmp ("%LOC", arg->name, 4) == 0
1379 && e->ts.type == BT_PROCEDURE)
1381 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1383 gfc_error ("Passing internal procedure at %L by location "
1384 "not allowed", &e->where);
1395 /* Do the checks of the actual argument list that are specific to elemental
1396 procedures. If called with c == NULL, we have a function, otherwise if
1397 expr == NULL, we have a subroutine. */
1400 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1402 gfc_actual_arglist *arg0;
1403 gfc_actual_arglist *arg;
1404 gfc_symbol *esym = NULL;
1405 gfc_intrinsic_sym *isym = NULL;
1407 gfc_intrinsic_arg *iformal = NULL;
1408 gfc_formal_arglist *eformal = NULL;
1409 bool formal_optional = false;
1410 bool set_by_optional = false;
1414 /* Is this an elemental procedure? */
1415 if (expr && expr->value.function.actual != NULL)
1417 if (expr->value.function.esym != NULL
1418 && expr->value.function.esym->attr.elemental)
1420 arg0 = expr->value.function.actual;
1421 esym = expr->value.function.esym;
1423 else if (expr->value.function.isym != NULL
1424 && expr->value.function.isym->elemental)
1426 arg0 = expr->value.function.actual;
1427 isym = expr->value.function.isym;
1432 else if (c && c->ext.actual != NULL)
1434 arg0 = c->ext.actual;
1436 if (c->resolved_sym)
1437 esym = c->resolved_sym;
1439 esym = c->symtree->n.sym;
1442 if (!esym->attr.elemental)
1448 /* The rank of an elemental is the rank of its array argument(s). */
1449 for (arg = arg0; arg; arg = arg->next)
1451 if (arg->expr != NULL && arg->expr->rank > 0)
1453 rank = arg->expr->rank;
1454 if (arg->expr->expr_type == EXPR_VARIABLE
1455 && arg->expr->symtree->n.sym->attr.optional)
1456 set_by_optional = true;
1458 /* Function specific; set the result rank and shape. */
1462 if (!expr->shape && arg->expr->shape)
1464 expr->shape = gfc_get_shape (rank);
1465 for (i = 0; i < rank; i++)
1466 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1473 /* If it is an array, it shall not be supplied as an actual argument
1474 to an elemental procedure unless an array of the same rank is supplied
1475 as an actual argument corresponding to a nonoptional dummy argument of
1476 that elemental procedure(12.4.1.5). */
1477 formal_optional = false;
1479 iformal = isym->formal;
1481 eformal = esym->formal;
1483 for (arg = arg0; arg; arg = arg->next)
1487 if (eformal->sym && eformal->sym->attr.optional)
1488 formal_optional = true;
1489 eformal = eformal->next;
1491 else if (isym && iformal)
1493 if (iformal->optional)
1494 formal_optional = true;
1495 iformal = iformal->next;
1498 formal_optional = true;
1500 if (pedantic && arg->expr != NULL
1501 && arg->expr->expr_type == EXPR_VARIABLE
1502 && arg->expr->symtree->n.sym->attr.optional
1505 && (set_by_optional || arg->expr->rank != rank)
1506 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1508 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1509 "MISSING, it cannot be the actual argument of an "
1510 "ELEMENTAL procedure unless there is a non-optional "
1511 "argument with the same rank (12.4.1.5)",
1512 arg->expr->symtree->n.sym->name, &arg->expr->where);
1517 for (arg = arg0; arg; arg = arg->next)
1519 if (arg->expr == NULL || arg->expr->rank == 0)
1522 /* Being elemental, the last upper bound of an assumed size array
1523 argument must be present. */
1524 if (resolve_assumed_size_actual (arg->expr))
1527 /* Elemental procedure's array actual arguments must conform. */
1530 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1538 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1539 is an array, the intent inout/out variable needs to be also an array. */
1540 if (rank > 0 && esym && expr == NULL)
1541 for (eformal = esym->formal, arg = arg0; arg && eformal;
1542 arg = arg->next, eformal = eformal->next)
1543 if ((eformal->sym->attr.intent == INTENT_OUT
1544 || eformal->sym->attr.intent == INTENT_INOUT)
1545 && arg->expr && arg->expr->rank == 0)
1547 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1548 "ELEMENTAL subroutine '%s' is a scalar, but another "
1549 "actual argument is an array", &arg->expr->where,
1550 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1551 : "INOUT", eformal->sym->name, esym->name);
1558 /* Go through each actual argument in ACTUAL and see if it can be
1559 implemented as an inlined, non-copying intrinsic. FNSYM is the
1560 function being called, or NULL if not known. */
1563 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1565 gfc_actual_arglist *ap;
1568 for (ap = actual; ap; ap = ap->next)
1570 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1571 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1573 ap->expr->inline_noncopying_intrinsic = 1;
1577 /* This function does the checking of references to global procedures
1578 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1579 77 and 95 standards. It checks for a gsymbol for the name, making
1580 one if it does not already exist. If it already exists, then the
1581 reference being resolved must correspond to the type of gsymbol.
1582 Otherwise, the new symbol is equipped with the attributes of the
1583 reference. The corresponding code that is called in creating
1584 global entities is parse.c. */
1587 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1592 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1594 gsym = gfc_get_gsymbol (sym->name);
1596 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1597 gfc_global_used (gsym, where);
1599 if (gsym->type == GSYM_UNKNOWN)
1602 gsym->where = *where;
1609 /************* Function resolution *************/
1611 /* Resolve a function call known to be generic.
1612 Section 14.1.2.4.1. */
1615 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1619 if (sym->attr.generic)
1621 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1624 expr->value.function.name = s->name;
1625 expr->value.function.esym = s;
1627 if (s->ts.type != BT_UNKNOWN)
1629 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1630 expr->ts = s->result->ts;
1633 expr->rank = s->as->rank;
1634 else if (s->result != NULL && s->result->as != NULL)
1635 expr->rank = s->result->as->rank;
1637 gfc_set_sym_referenced (expr->value.function.esym);
1642 /* TODO: Need to search for elemental references in generic
1646 if (sym->attr.intrinsic)
1647 return gfc_intrinsic_func_interface (expr, 0);
1654 resolve_generic_f (gfc_expr *expr)
1659 sym = expr->symtree->n.sym;
1663 m = resolve_generic_f0 (expr, sym);
1666 else if (m == MATCH_ERROR)
1670 if (sym->ns->parent == NULL)
1672 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1676 if (!generic_sym (sym))
1680 /* Last ditch attempt. See if the reference is to an intrinsic
1681 that possesses a matching interface. 14.1.2.4 */
1682 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1684 gfc_error ("There is no specific function for the generic '%s' at %L",
1685 expr->symtree->n.sym->name, &expr->where);
1689 m = gfc_intrinsic_func_interface (expr, 0);
1693 gfc_error ("Generic function '%s' at %L is not consistent with a "
1694 "specific intrinsic interface", expr->symtree->n.sym->name,
1701 /* Resolve a function call known to be specific. */
1704 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1708 /* See if we have an intrinsic interface. */
1710 if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
1712 gfc_intrinsic_sym *isym;
1713 isym = gfc_find_function (sym->ts.interface->name);
1715 /* Existence of isym should be checked already. */
1718 sym->ts.type = isym->ts.type;
1719 sym->ts.kind = isym->ts.kind;
1720 sym->attr.function = 1;
1721 sym->attr.proc = PROC_EXTERNAL;
1725 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1727 if (sym->attr.dummy)
1729 sym->attr.proc = PROC_DUMMY;
1733 sym->attr.proc = PROC_EXTERNAL;
1737 if (sym->attr.proc == PROC_MODULE
1738 || sym->attr.proc == PROC_ST_FUNCTION
1739 || sym->attr.proc == PROC_INTERNAL)
1742 if (sym->attr.intrinsic)
1744 m = gfc_intrinsic_func_interface (expr, 1);
1748 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1749 "with an intrinsic", sym->name, &expr->where);
1757 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1760 expr->value.function.name = sym->name;
1761 expr->value.function.esym = sym;
1762 if (sym->as != NULL)
1763 expr->rank = sym->as->rank;
1770 resolve_specific_f (gfc_expr *expr)
1775 sym = expr->symtree->n.sym;
1779 m = resolve_specific_f0 (sym, expr);
1782 if (m == MATCH_ERROR)
1785 if (sym->ns->parent == NULL)
1788 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1794 gfc_error ("Unable to resolve the specific function '%s' at %L",
1795 expr->symtree->n.sym->name, &expr->where);
1801 /* Resolve a procedure call not known to be generic nor specific. */
1804 resolve_unknown_f (gfc_expr *expr)
1809 sym = expr->symtree->n.sym;
1811 if (sym->attr.dummy)
1813 sym->attr.proc = PROC_DUMMY;
1814 expr->value.function.name = sym->name;
1818 /* See if we have an intrinsic function reference. */
1820 if (gfc_is_intrinsic (sym, 0, expr->where))
1822 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1827 /* The reference is to an external name. */
1829 sym->attr.proc = PROC_EXTERNAL;
1830 expr->value.function.name = sym->name;
1831 expr->value.function.esym = expr->symtree->n.sym;
1833 if (sym->as != NULL)
1834 expr->rank = sym->as->rank;
1836 /* Type of the expression is either the type of the symbol or the
1837 default type of the symbol. */
1840 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1842 if (sym->ts.type != BT_UNKNOWN)
1846 ts = gfc_get_default_type (sym, sym->ns);
1848 if (ts->type == BT_UNKNOWN)
1850 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1851 sym->name, &expr->where);
1862 /* Return true, if the symbol is an external procedure. */
1864 is_external_proc (gfc_symbol *sym)
1866 if (!sym->attr.dummy && !sym->attr.contained
1867 && !(sym->attr.intrinsic
1868 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
1869 && sym->attr.proc != PROC_ST_FUNCTION
1870 && !sym->attr.use_assoc
1878 /* Figure out if a function reference is pure or not. Also set the name
1879 of the function for a potential error message. Return nonzero if the
1880 function is PURE, zero if not. */
1882 pure_stmt_function (gfc_expr *, gfc_symbol *);
1885 pure_function (gfc_expr *e, const char **name)
1891 if (e->symtree != NULL
1892 && e->symtree->n.sym != NULL
1893 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1894 return pure_stmt_function (e, e->symtree->n.sym);
1896 if (e->value.function.esym)
1898 pure = gfc_pure (e->value.function.esym);
1899 *name = e->value.function.esym->name;
1901 else if (e->value.function.isym)
1903 pure = e->value.function.isym->pure
1904 || e->value.function.isym->elemental;
1905 *name = e->value.function.isym->name;
1909 /* Implicit functions are not pure. */
1911 *name = e->value.function.name;
1919 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
1920 int *f ATTRIBUTE_UNUSED)
1924 /* Don't bother recursing into other statement functions
1925 since they will be checked individually for purity. */
1926 if (e->expr_type != EXPR_FUNCTION
1928 || e->symtree->n.sym == sym
1929 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1932 return pure_function (e, &name) ? false : true;
1937 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
1939 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
1944 is_scalar_expr_ptr (gfc_expr *expr)
1946 gfc_try retval = SUCCESS;
1951 /* See if we have a gfc_ref, which means we have a substring, array
1952 reference, or a component. */
1953 if (expr->ref != NULL)
1956 while (ref->next != NULL)
1962 if (ref->u.ss.length != NULL
1963 && ref->u.ss.length->length != NULL
1965 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1967 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1969 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1970 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1971 if (end - start + 1 != 1)
1978 if (ref->u.ar.type == AR_ELEMENT)
1980 else if (ref->u.ar.type == AR_FULL)
1982 /* The user can give a full array if the array is of size 1. */
1983 if (ref->u.ar.as != NULL
1984 && ref->u.ar.as->rank == 1
1985 && ref->u.ar.as->type == AS_EXPLICIT
1986 && ref->u.ar.as->lower[0] != NULL
1987 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1988 && ref->u.ar.as->upper[0] != NULL
1989 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1991 /* If we have a character string, we need to check if
1992 its length is one. */
1993 if (expr->ts.type == BT_CHARACTER)
1995 if (expr->ts.cl == NULL
1996 || expr->ts.cl->length == NULL
1997 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
2003 /* We have constant lower and upper bounds. If the
2004 difference between is 1, it can be considered a
2006 start = (int) mpz_get_si
2007 (ref->u.ar.as->lower[0]->value.integer);
2008 end = (int) mpz_get_si
2009 (ref->u.ar.as->upper[0]->value.integer);
2010 if (end - start + 1 != 1)
2025 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2027 /* Character string. Make sure it's of length 1. */
2028 if (expr->ts.cl == NULL
2029 || expr->ts.cl->length == NULL
2030 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
2033 else if (expr->rank != 0)
2040 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2041 and, in the case of c_associated, set the binding label based on
2045 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2046 gfc_symbol **new_sym)
2048 char name[GFC_MAX_SYMBOL_LEN + 1];
2049 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2050 int optional_arg = 0, is_pointer = 0;
2051 gfc_try retval = SUCCESS;
2052 gfc_symbol *args_sym;
2053 gfc_typespec *arg_ts;
2055 if (args->expr->expr_type == EXPR_CONSTANT
2056 || args->expr->expr_type == EXPR_OP
2057 || args->expr->expr_type == EXPR_NULL)
2059 gfc_error ("Argument to '%s' at %L is not a variable",
2060 sym->name, &(args->expr->where));
2064 args_sym = args->expr->symtree->n.sym;
2066 /* The typespec for the actual arg should be that stored in the expr
2067 and not necessarily that of the expr symbol (args_sym), because
2068 the actual expression could be a part-ref of the expr symbol. */
2069 arg_ts = &(args->expr->ts);
2071 is_pointer = gfc_is_data_pointer (args->expr);
2073 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2075 /* If the user gave two args then they are providing something for
2076 the optional arg (the second cptr). Therefore, set the name and
2077 binding label to the c_associated for two cptrs. Otherwise,
2078 set c_associated to expect one cptr. */
2082 sprintf (name, "%s_2", sym->name);
2083 sprintf (binding_label, "%s_2", sym->binding_label);
2089 sprintf (name, "%s_1", sym->name);
2090 sprintf (binding_label, "%s_1", sym->binding_label);
2094 /* Get a new symbol for the version of c_associated that
2096 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2098 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2099 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2101 sprintf (name, "%s", sym->name);
2102 sprintf (binding_label, "%s", sym->binding_label);
2104 /* Error check the call. */
2105 if (args->next != NULL)
2107 gfc_error_now ("More actual than formal arguments in '%s' "
2108 "call at %L", name, &(args->expr->where));
2111 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2113 /* Make sure we have either the target or pointer attribute. */
2114 if (!args_sym->attr.target && !is_pointer)
2116 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2117 "a TARGET or an associated pointer",
2119 sym->name, &(args->expr->where));
2123 /* See if we have interoperable type and type param. */
2124 if (verify_c_interop (arg_ts) == SUCCESS
2125 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2127 if (args_sym->attr.target == 1)
2129 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2130 has the target attribute and is interoperable. */
2131 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2132 allocatable variable that has the TARGET attribute and
2133 is not an array of zero size. */
2134 if (args_sym->attr.allocatable == 1)
2136 if (args_sym->attr.dimension != 0
2137 && (args_sym->as && args_sym->as->rank == 0))
2139 gfc_error_now ("Allocatable variable '%s' used as a "
2140 "parameter to '%s' at %L must not be "
2141 "an array of zero size",
2142 args_sym->name, sym->name,
2143 &(args->expr->where));
2149 /* A non-allocatable target variable with C
2150 interoperable type and type parameters must be
2152 if (args_sym && args_sym->attr.dimension)
2154 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2156 gfc_error ("Assumed-shape array '%s' at %L "
2157 "cannot be an argument to the "
2158 "procedure '%s' because "
2159 "it is not C interoperable",
2161 &(args->expr->where), sym->name);
2164 else if (args_sym->as->type == AS_DEFERRED)
2166 gfc_error ("Deferred-shape array '%s' at %L "
2167 "cannot be an argument to the "
2168 "procedure '%s' because "
2169 "it is not C interoperable",
2171 &(args->expr->where), sym->name);
2176 /* Make sure it's not a character string. Arrays of
2177 any type should be ok if the variable is of a C
2178 interoperable type. */
2179 if (arg_ts->type == BT_CHARACTER)
2180 if (arg_ts->cl != NULL
2181 && (arg_ts->cl->length == NULL
2182 || arg_ts->cl->length->expr_type
2185 (arg_ts->cl->length->value.integer, 1)
2187 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2189 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2190 "at %L must have a length of 1",
2191 args_sym->name, sym->name,
2192 &(args->expr->where));
2198 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2200 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2202 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2203 "associated scalar POINTER", args_sym->name,
2204 sym->name, &(args->expr->where));
2210 /* The parameter is not required to be C interoperable. If it
2211 is not C interoperable, it must be a nonpolymorphic scalar
2212 with no length type parameters. It still must have either
2213 the pointer or target attribute, and it can be
2214 allocatable (but must be allocated when c_loc is called). */
2215 if (args->expr->rank != 0
2216 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2218 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2219 "scalar", args_sym->name, sym->name,
2220 &(args->expr->where));
2223 else if (arg_ts->type == BT_CHARACTER
2224 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2226 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2227 "%L must have a length of 1",
2228 args_sym->name, sym->name,
2229 &(args->expr->where));
2234 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2236 if (args_sym->attr.flavor != FL_PROCEDURE)
2238 /* TODO: Update this error message to allow for procedure
2239 pointers once they are implemented. */
2240 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2242 args_sym->name, sym->name,
2243 &(args->expr->where));
2246 else if (args_sym->attr.is_bind_c != 1)
2248 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2250 args_sym->name, sym->name,
2251 &(args->expr->where));
2256 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2261 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2262 "iso_c_binding function: '%s'!\n", sym->name);
2269 /* Resolve a function call, which means resolving the arguments, then figuring
2270 out which entity the name refers to. */
2271 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2272 to INTENT(OUT) or INTENT(INOUT). */
2275 resolve_function (gfc_expr *expr)
2277 gfc_actual_arglist *arg;
2282 procedure_type p = PROC_INTRINSIC;
2283 bool no_formal_args;
2287 sym = expr->symtree->n.sym;
2289 if (sym && sym->attr.intrinsic
2290 && !gfc_find_function (sym->name)
2291 && gfc_find_subroutine (sym->name)
2292 && sym->attr.function)
2294 gfc_error ("Intrinsic subroutine '%s' used as "
2295 "a function at %L", sym->name, &expr->where);
2299 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2301 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2305 if (sym && sym->attr.abstract)
2307 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2308 sym->name, &expr->where);
2312 /* If the procedure is external, check for usage. */
2313 if (sym && is_external_proc (sym))
2314 resolve_global_procedure (sym, &expr->where, 0);
2316 /* Switch off assumed size checking and do this again for certain kinds
2317 of procedure, once the procedure itself is resolved. */
2318 need_full_assumed_size++;
2320 if (expr->symtree && expr->symtree->n.sym)
2321 p = expr->symtree->n.sym->attr.proc;
2323 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2324 if (resolve_actual_arglist (expr->value.function.actual,
2325 p, no_formal_args) == FAILURE)
2328 /* Need to setup the call to the correct c_associated, depending on
2329 the number of cptrs to user gives to compare. */
2330 if (sym && sym->attr.is_iso_c == 1)
2332 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2336 /* Get the symtree for the new symbol (resolved func).
2337 the old one will be freed later, when it's no longer used. */
2338 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2341 /* Resume assumed_size checking. */
2342 need_full_assumed_size--;
2344 if (sym && sym->ts.type == BT_CHARACTER
2346 && sym->ts.cl->length == NULL
2348 && expr->value.function.esym == NULL
2349 && !sym->attr.contained)
2351 /* Internal procedures are taken care of in resolve_contained_fntype. */
2352 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2353 "be used at %L since it is not a dummy argument",
2354 sym->name, &expr->where);
2358 /* See if function is already resolved. */
2360 if (expr->value.function.name != NULL)
2362 if (expr->ts.type == BT_UNKNOWN)
2368 /* Apply the rules of section 14.1.2. */
2370 switch (procedure_kind (sym))
2373 t = resolve_generic_f (expr);
2376 case PTYPE_SPECIFIC:
2377 t = resolve_specific_f (expr);
2381 t = resolve_unknown_f (expr);
2385 gfc_internal_error ("resolve_function(): bad function type");
2389 /* If the expression is still a function (it might have simplified),
2390 then we check to see if we are calling an elemental function. */
2392 if (expr->expr_type != EXPR_FUNCTION)
2395 temp = need_full_assumed_size;
2396 need_full_assumed_size = 0;
2398 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2401 if (omp_workshare_flag
2402 && expr->value.function.esym
2403 && ! gfc_elemental (expr->value.function.esym))
2405 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2406 "in WORKSHARE construct", expr->value.function.esym->name,
2411 #define GENERIC_ID expr->value.function.isym->id
2412 else if (expr->value.function.actual != NULL
2413 && expr->value.function.isym != NULL
2414 && GENERIC_ID != GFC_ISYM_LBOUND
2415 && GENERIC_ID != GFC_ISYM_LEN
2416 && GENERIC_ID != GFC_ISYM_LOC
2417 && GENERIC_ID != GFC_ISYM_PRESENT)
2419 /* Array intrinsics must also have the last upper bound of an
2420 assumed size array argument. UBOUND and SIZE have to be
2421 excluded from the check if the second argument is anything
2424 for (arg = expr->value.function.actual; arg; arg = arg->next)
2426 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2427 && arg->next != NULL && arg->next->expr)
2429 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2432 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2435 if ((int)mpz_get_si (arg->next->expr->value.integer)
2440 if (arg->expr != NULL
2441 && arg->expr->rank > 0
2442 && resolve_assumed_size_actual (arg->expr))
2448 need_full_assumed_size = temp;
2451 if (!pure_function (expr, &name) && name)
2455 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2456 "FORALL %s", name, &expr->where,
2457 forall_flag == 2 ? "mask" : "block");
2460 else if (gfc_pure (NULL))
2462 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2463 "procedure within a PURE procedure", name, &expr->where);
2468 /* Functions without the RECURSIVE attribution are not allowed to
2469 * call themselves. */
2470 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2473 esym = expr->value.function.esym;
2475 if (is_illegal_recursion (esym, gfc_current_ns))
2477 if (esym->attr.entry && esym->ns->entries)
2478 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2479 " function '%s' is not RECURSIVE",
2480 esym->name, &expr->where, esym->ns->entries->sym->name);
2482 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
2483 " is not RECURSIVE", esym->name, &expr->where);
2489 /* Character lengths of use associated functions may contains references to
2490 symbols not referenced from the current program unit otherwise. Make sure
2491 those symbols are marked as referenced. */
2493 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2494 && expr->value.function.esym->attr.use_assoc)
2496 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2500 && !((expr->value.function.esym
2501 && expr->value.function.esym->attr.elemental)
2503 (expr->value.function.isym
2504 && expr->value.function.isym->elemental)))
2505 find_noncopying_intrinsics (expr->value.function.esym,
2506 expr->value.function.actual);
2508 /* Make sure that the expression has a typespec that works. */
2509 if (expr->ts.type == BT_UNKNOWN)
2511 if (expr->symtree->n.sym->result
2512 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2513 expr->ts = expr->symtree->n.sym->result->ts;
2520 /************* Subroutine resolution *************/
2523 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2529 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2530 sym->name, &c->loc);
2531 else if (gfc_pure (NULL))
2532 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2538 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2542 if (sym->attr.generic)
2544 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2547 c->resolved_sym = s;
2548 pure_subroutine (c, s);
2552 /* TODO: Need to search for elemental references in generic interface. */
2555 if (sym->attr.intrinsic)
2556 return gfc_intrinsic_sub_interface (c, 0);
2563 resolve_generic_s (gfc_code *c)
2568 sym = c->symtree->n.sym;
2572 m = resolve_generic_s0 (c, sym);
2575 else if (m == MATCH_ERROR)
2579 if (sym->ns->parent == NULL)
2581 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2585 if (!generic_sym (sym))
2589 /* Last ditch attempt. See if the reference is to an intrinsic
2590 that possesses a matching interface. 14.1.2.4 */
2591 sym = c->symtree->n.sym;
2593 if (!gfc_is_intrinsic (sym, 1, c->loc))
2595 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2596 sym->name, &c->loc);
2600 m = gfc_intrinsic_sub_interface (c, 0);
2604 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2605 "intrinsic subroutine interface", sym->name, &c->loc);
2611 /* Set the name and binding label of the subroutine symbol in the call
2612 expression represented by 'c' to include the type and kind of the
2613 second parameter. This function is for resolving the appropriate
2614 version of c_f_pointer() and c_f_procpointer(). For example, a
2615 call to c_f_pointer() for a default integer pointer could have a
2616 name of c_f_pointer_i4. If no second arg exists, which is an error
2617 for these two functions, it defaults to the generic symbol's name
2618 and binding label. */
2621 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2622 char *name, char *binding_label)
2624 gfc_expr *arg = NULL;
2628 /* The second arg of c_f_pointer and c_f_procpointer determines
2629 the type and kind for the procedure name. */
2630 arg = c->ext.actual->next->expr;
2634 /* Set up the name to have the given symbol's name,
2635 plus the type and kind. */
2636 /* a derived type is marked with the type letter 'u' */
2637 if (arg->ts.type == BT_DERIVED)
2640 kind = 0; /* set the kind as 0 for now */
2644 type = gfc_type_letter (arg->ts.type);
2645 kind = arg->ts.kind;
2648 if (arg->ts.type == BT_CHARACTER)
2649 /* Kind info for character strings not needed. */
2652 sprintf (name, "%s_%c%d", sym->name, type, kind);
2653 /* Set up the binding label as the given symbol's label plus
2654 the type and kind. */
2655 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2659 /* If the second arg is missing, set the name and label as
2660 was, cause it should at least be found, and the missing
2661 arg error will be caught by compare_parameters(). */
2662 sprintf (name, "%s", sym->name);
2663 sprintf (binding_label, "%s", sym->binding_label);
2670 /* Resolve a generic version of the iso_c_binding procedure given
2671 (sym) to the specific one based on the type and kind of the
2672 argument(s). Currently, this function resolves c_f_pointer() and
2673 c_f_procpointer based on the type and kind of the second argument
2674 (FPTR). Other iso_c_binding procedures aren't specially handled.
2675 Upon successfully exiting, c->resolved_sym will hold the resolved
2676 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2680 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2682 gfc_symbol *new_sym;
2683 /* this is fine, since we know the names won't use the max */
2684 char name[GFC_MAX_SYMBOL_LEN + 1];
2685 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2686 /* default to success; will override if find error */
2687 match m = MATCH_YES;
2689 /* Make sure the actual arguments are in the necessary order (based on the
2690 formal args) before resolving. */
2691 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2693 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2694 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2696 set_name_and_label (c, sym, name, binding_label);
2698 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2700 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2702 /* Make sure we got a third arg if the second arg has non-zero
2703 rank. We must also check that the type and rank are
2704 correct since we short-circuit this check in
2705 gfc_procedure_use() (called above to sort actual args). */
2706 if (c->ext.actual->next->expr->rank != 0)
2708 if(c->ext.actual->next->next == NULL
2709 || c->ext.actual->next->next->expr == NULL)
2712 gfc_error ("Missing SHAPE parameter for call to %s "
2713 "at %L", sym->name, &(c->loc));
2715 else if (c->ext.actual->next->next->expr->ts.type
2717 || c->ext.actual->next->next->expr->rank != 1)
2720 gfc_error ("SHAPE parameter for call to %s at %L must "
2721 "be a rank 1 INTEGER array", sym->name,
2728 if (m != MATCH_ERROR)
2730 /* the 1 means to add the optional arg to formal list */
2731 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2733 /* for error reporting, say it's declared where the original was */
2734 new_sym->declared_at = sym->declared_at;
2739 /* no differences for c_loc or c_funloc */
2743 /* set the resolved symbol */
2744 if (m != MATCH_ERROR)
2745 c->resolved_sym = new_sym;
2747 c->resolved_sym = sym;
2753 /* Resolve a subroutine call known to be specific. */
2756 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2760 /* See if we have an intrinsic interface. */
2761 if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
2762 && !sym->ts.interface->attr.subroutine
2763 && sym->ts.interface->attr.intrinsic)
2765 gfc_intrinsic_sym *isym;
2767 isym = gfc_find_function (sym->ts.interface->name);
2769 /* Existence of isym should be checked already. */
2772 sym->ts.type = isym->ts.type;
2773 sym->ts.kind = isym->ts.kind;
2774 sym->attr.subroutine = 1;
2778 if(sym->attr.is_iso_c)
2780 m = gfc_iso_c_sub_interface (c,sym);
2784 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2786 if (sym->attr.dummy)
2788 sym->attr.proc = PROC_DUMMY;
2792 sym->attr.proc = PROC_EXTERNAL;
2796 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2799 if (sym->attr.intrinsic)
2801 m = gfc_intrinsic_sub_interface (c, 1);
2805 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2806 "with an intrinsic", sym->name, &c->loc);
2814 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2816 c->resolved_sym = sym;
2817 pure_subroutine (c, sym);
2824 resolve_specific_s (gfc_code *c)
2829 sym = c->symtree->n.sym;
2833 m = resolve_specific_s0 (c, sym);
2836 if (m == MATCH_ERROR)
2839 if (sym->ns->parent == NULL)
2842 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2848 sym = c->symtree->n.sym;
2849 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2850 sym->name, &c->loc);
2856 /* Resolve a subroutine call not known to be generic nor specific. */
2859 resolve_unknown_s (gfc_code *c)
2863 sym = c->symtree->n.sym;
2865 if (sym->attr.dummy)
2867 sym->attr.proc = PROC_DUMMY;
2871 /* See if we have an intrinsic function reference. */
2873 if (gfc_is_intrinsic (sym, 1, c->loc))
2875 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2880 /* The reference is to an external name. */
2883 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2885 c->resolved_sym = sym;
2887 pure_subroutine (c, sym);
2893 /* Resolve a subroutine call. Although it was tempting to use the same code
2894 for functions, subroutines and functions are stored differently and this
2895 makes things awkward. */
2898 resolve_call (gfc_code *c)
2901 procedure_type ptype = PROC_INTRINSIC;
2902 gfc_symbol *csym, *sym;
2903 bool no_formal_args;
2905 csym = c->symtree ? c->symtree->n.sym : NULL;
2907 if (csym && csym->ts.type != BT_UNKNOWN)
2909 gfc_error ("'%s' at %L has a type, which is not consistent with "
2910 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
2914 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
2917 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
2918 sym = st ? st->n.sym : NULL;
2919 if (sym && csym != sym
2920 && sym->ns == gfc_current_ns
2921 && sym->attr.flavor == FL_PROCEDURE
2922 && sym->attr.contained)
2925 if (csym->attr.generic)
2926 c->symtree->n.sym = sym;
2929 csym = c->symtree->n.sym;
2933 /* If external, check for usage. */
2934 if (csym && is_external_proc (csym))
2935 resolve_global_procedure (csym, &c->loc, 1);
2937 /* Subroutines without the RECURSIVE attribution are not allowed to
2938 * call themselves. */
2939 if (csym && is_illegal_recursion (csym, gfc_current_ns))
2941 if (csym->attr.entry && csym->ns->entries)
2942 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2943 " subroutine '%s' is not RECURSIVE",
2944 csym->name, &c->loc, csym->ns->entries->sym->name);
2946 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
2947 " is not RECURSIVE", csym->name, &c->loc);
2952 /* Switch off assumed size checking and do this again for certain kinds
2953 of procedure, once the procedure itself is resolved. */
2954 need_full_assumed_size++;
2957 ptype = csym->attr.proc;
2959 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
2960 if (resolve_actual_arglist (c->ext.actual, ptype,
2961 no_formal_args) == FAILURE)
2964 /* Resume assumed_size checking. */
2965 need_full_assumed_size--;
2968 if (c->resolved_sym == NULL)
2970 c->resolved_isym = NULL;
2971 switch (procedure_kind (csym))
2974 t = resolve_generic_s (c);
2977 case PTYPE_SPECIFIC:
2978 t = resolve_specific_s (c);
2982 t = resolve_unknown_s (c);
2986 gfc_internal_error ("resolve_subroutine(): bad function type");
2990 /* Some checks of elemental subroutine actual arguments. */
2991 if (resolve_elemental_actual (NULL, c) == FAILURE)
2994 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
2995 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3000 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3001 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3002 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3003 if their shapes do not match. If either op1->shape or op2->shape is
3004 NULL, return SUCCESS. */
3007 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3014 if (op1->shape != NULL && op2->shape != NULL)
3016 for (i = 0; i < op1->rank; i++)
3018 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3020 gfc_error ("Shapes for operands at %L and %L are not conformable",
3021 &op1->where, &op2->where);
3032 /* Resolve an operator expression node. This can involve replacing the
3033 operation with a user defined function call. */
3036 resolve_operator (gfc_expr *e)
3038 gfc_expr *op1, *op2;
3040 bool dual_locus_error;
3043 /* Resolve all subnodes-- give them types. */
3045 switch (e->value.op.op)
3048 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3051 /* Fall through... */
3054 case INTRINSIC_UPLUS:
3055 case INTRINSIC_UMINUS:
3056 case INTRINSIC_PARENTHESES:
3057 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3062 /* Typecheck the new node. */
3064 op1 = e->value.op.op1;
3065 op2 = e->value.op.op2;
3066 dual_locus_error = false;
3068 if ((op1 && op1->expr_type == EXPR_NULL)
3069 || (op2 && op2->expr_type == EXPR_NULL))
3071 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3075 switch (e->value.op.op)
3077 case INTRINSIC_UPLUS:
3078 case INTRINSIC_UMINUS:
3079 if (op1->ts.type == BT_INTEGER
3080 || op1->ts.type == BT_REAL
3081 || op1->ts.type == BT_COMPLEX)
3087 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3088 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3091 case INTRINSIC_PLUS:
3092 case INTRINSIC_MINUS:
3093 case INTRINSIC_TIMES:
3094 case INTRINSIC_DIVIDE:
3095 case INTRINSIC_POWER:
3096 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3098 gfc_type_convert_binary (e);
3103 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3104 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3105 gfc_typename (&op2->ts));
3108 case INTRINSIC_CONCAT:
3109 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3110 && op1->ts.kind == op2->ts.kind)
3112 e->ts.type = BT_CHARACTER;
3113 e->ts.kind = op1->ts.kind;
3118 _("Operands of string concatenation operator at %%L are %s/%s"),
3119 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3125 case INTRINSIC_NEQV:
3126 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3128 e->ts.type = BT_LOGICAL;
3129 e->ts.kind = gfc_kind_max (op1, op2);
3130 if (op1->ts.kind < e->ts.kind)
3131 gfc_convert_type (op1, &e->ts, 2);
3132 else if (op2->ts.kind < e->ts.kind)
3133 gfc_convert_type (op2, &e->ts, 2);
3137 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3138 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3139 gfc_typename (&op2->ts));
3144 if (op1->ts.type == BT_LOGICAL)
3146 e->ts.type = BT_LOGICAL;
3147 e->ts.kind = op1->ts.kind;
3151 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3152 gfc_typename (&op1->ts));
3156 case INTRINSIC_GT_OS:
3158 case INTRINSIC_GE_OS:
3160 case INTRINSIC_LT_OS:
3162 case INTRINSIC_LE_OS:
3163 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3165 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3169 /* Fall through... */
3172 case INTRINSIC_EQ_OS:
3174 case INTRINSIC_NE_OS:
3175 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3176 && op1->ts.kind == op2->ts.kind)
3178 e->ts.type = BT_LOGICAL;
3179 e->ts.kind = gfc_default_logical_kind;
3183 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3185 gfc_type_convert_binary (e);
3187 e->ts.type = BT_LOGICAL;
3188 e->ts.kind = gfc_default_logical_kind;
3192 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3194 _("Logicals at %%L must be compared with %s instead of %s"),
3195 (e->value.op.op == INTRINSIC_EQ
3196 || e->value.op.op == INTRINSIC_EQ_OS)
3197 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3200 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3201 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3202 gfc_typename (&op2->ts));
3206 case INTRINSIC_USER:
3207 if (e->value.op.uop->op == NULL)
3208 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3209 else if (op2 == NULL)
3210 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3211 e->value.op.uop->name, gfc_typename (&op1->ts));
3213 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3214 e->value.op.uop->name, gfc_typename (&op1->ts),
3215 gfc_typename (&op2->ts));
3219 case INTRINSIC_PARENTHESES:
3221 if (e->ts.type == BT_CHARACTER)
3222 e->ts.cl = op1->ts.cl;
3226 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3229 /* Deal with arrayness of an operand through an operator. */
3233 switch (e->value.op.op)
3235 case INTRINSIC_PLUS:
3236 case INTRINSIC_MINUS:
3237 case INTRINSIC_TIMES:
3238 case INTRINSIC_DIVIDE:
3239 case INTRINSIC_POWER:
3240 case INTRINSIC_CONCAT:
3244 case INTRINSIC_NEQV:
3246 case INTRINSIC_EQ_OS:
3248 case INTRINSIC_NE_OS:
3250 case INTRINSIC_GT_OS:
3252 case INTRINSIC_GE_OS:
3254 case INTRINSIC_LT_OS:
3256 case INTRINSIC_LE_OS:
3258 if (op1->rank == 0 && op2->rank == 0)
3261 if (op1->rank == 0 && op2->rank != 0)
3263 e->rank = op2->rank;
3265 if (e->shape == NULL)
3266 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3269 if (op1->rank != 0 && op2->rank == 0)
3271 e->rank = op1->rank;
3273 if (e->shape == NULL)
3274 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3277 if (op1->rank != 0 && op2->rank != 0)
3279 if (op1->rank == op2->rank)
3281 e->rank = op1->rank;
3282 if (e->shape == NULL)
3284 t = compare_shapes(op1, op2);
3288 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3293 /* Allow higher level expressions to work. */
3296 /* Try user-defined operators, and otherwise throw an error. */
3297 dual_locus_error = true;
3299 _("Inconsistent ranks for operator at %%L and %%L"));
3306 case INTRINSIC_PARENTHESES:
3308 case INTRINSIC_UPLUS:
3309 case INTRINSIC_UMINUS:
3310 /* Simply copy arrayness attribute */
3311 e->rank = op1->rank;
3313 if (e->shape == NULL)
3314 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3322 /* Attempt to simplify the expression. */
3325 t = gfc_simplify_expr (e, 0);
3326 /* Some calls do not succeed in simplification and return FAILURE
3327 even though there is no error; e.g. variable references to
3328 PARAMETER arrays. */
3329 if (!gfc_is_constant_expr (e))
3336 if (gfc_extend_expr (e) == SUCCESS)
3339 if (dual_locus_error)
3340 gfc_error (msg, &op1->where, &op2->where);
3342 gfc_error (msg, &e->where);
3348 /************** Array resolution subroutines **************/
3351 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3354 /* Compare two integer expressions. */
3357 compare_bound (gfc_expr *a, gfc_expr *b)
3361 if (a == NULL || a->expr_type != EXPR_CONSTANT
3362 || b == NULL || b->expr_type != EXPR_CONSTANT)
3365 /* If either of the types isn't INTEGER, we must have
3366 raised an error earlier. */
3368 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3371 i = mpz_cmp (a->value.integer, b->value.integer);
3381 /* Compare an integer expression with an integer. */
3384 compare_bound_int (gfc_expr *a, int b)
3388 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3391 if (a->ts.type != BT_INTEGER)
3392 gfc_internal_error ("compare_bound_int(): Bad expression");
3394 i = mpz_cmp_si (a->value.integer, b);
3404 /* Compare an integer expression with a mpz_t. */
3407 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3411 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3414 if (a->ts.type != BT_INTEGER)
3415 gfc_internal_error ("compare_bound_int(): Bad expression");
3417 i = mpz_cmp (a->value.integer, b);
3427 /* Compute the last value of a sequence given by a triplet.
3428 Return 0 if it wasn't able to compute the last value, or if the
3429 sequence if empty, and 1 otherwise. */
3432 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3433 gfc_expr *stride, mpz_t last)
3437 if (start == NULL || start->expr_type != EXPR_CONSTANT
3438 || end == NULL || end->expr_type != EXPR_CONSTANT
3439 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3442 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3443 || (stride != NULL && stride->ts.type != BT_INTEGER))
3446 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3448 if (compare_bound (start, end) == CMP_GT)
3450 mpz_set (last, end->value.integer);
3454 if (compare_bound_int (stride, 0) == CMP_GT)
3456 /* Stride is positive */
3457 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3462 /* Stride is negative */
3463 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3468 mpz_sub (rem, end->value.integer, start->value.integer);
3469 mpz_tdiv_r (rem, rem, stride->value.integer);
3470 mpz_sub (last, end->value.integer, rem);
3477 /* Compare a single dimension of an array reference to the array
3481 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3485 /* Given start, end and stride values, calculate the minimum and
3486 maximum referenced indexes. */
3488 switch (ar->dimen_type[i])
3494 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3496 gfc_warning ("Array reference at %L is out of bounds "
3497 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3498 mpz_get_si (ar->start[i]->value.integer),
3499 mpz_get_si (as->lower[i]->value.integer), i+1);
3502 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3504 gfc_warning ("Array reference at %L is out of bounds "
3505 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3506 mpz_get_si (ar->start[i]->value.integer),
3507 mpz_get_si (as->upper[i]->value.integer), i+1);
3515 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3516 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3518 comparison comp_start_end = compare_bound (AR_START, AR_END);
3520 /* Check for zero stride, which is not allowed. */
3521 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3523 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3527 /* if start == len || (stride > 0 && start < len)
3528 || (stride < 0 && start > len),
3529 then the array section contains at least one element. In this
3530 case, there is an out-of-bounds access if
3531 (start < lower || start > upper). */
3532 if (compare_bound (AR_START, AR_END) == CMP_EQ
3533 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3534 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3535 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3536 && comp_start_end == CMP_GT))
3538 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3540 gfc_warning ("Lower array reference at %L is out of bounds "
3541 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3542 mpz_get_si (AR_START->value.integer),
3543 mpz_get_si (as->lower[i]->value.integer), i+1);
3546 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3548 gfc_warning ("Lower array reference at %L is out of bounds "
3549 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3550 mpz_get_si (AR_START->value.integer),
3551 mpz_get_si (as->upper[i]->value.integer), i+1);
3556 /* If we can compute the highest index of the array section,
3557 then it also has to be between lower and upper. */
3558 mpz_init (last_value);
3559 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3562 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3564 gfc_warning ("Upper array reference at %L is out of bounds "
3565 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3566 mpz_get_si (last_value),
3567 mpz_get_si (as->lower[i]->value.integer), i+1);
3568 mpz_clear (last_value);
3571 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3573 gfc_warning ("Upper array reference at %L is out of bounds "
3574 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3575 mpz_get_si (last_value),
3576 mpz_get_si (as->upper[i]->value.integer), i+1);
3577 mpz_clear (last_value);
3581 mpz_clear (last_value);
3589 gfc_internal_error ("check_dimension(): Bad array reference");
3596 /* Compare an array reference with an array specification. */
3599 compare_spec_to_ref (gfc_array_ref *ar)
3606 /* TODO: Full array sections are only allowed as actual parameters. */
3607 if (as->type == AS_ASSUMED_SIZE
3608 && (/*ar->type == AR_FULL
3609 ||*/ (ar->type == AR_SECTION
3610 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3612 gfc_error ("Rightmost upper bound of assumed size array section "
3613 "not specified at %L", &ar->where);
3617 if (ar->type == AR_FULL)
3620 if (as->rank != ar->dimen)
3622 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3623 &ar->where, ar->dimen, as->rank);
3627 for (i = 0; i < as->rank; i++)
3628 if (check_dimension (i, ar, as) == FAILURE)
3635 /* Resolve one part of an array index. */
3638 gfc_resolve_index (gfc_expr *index, int check_scalar)
3645 if (gfc_resolve_expr (index) == FAILURE)
3648 if (check_scalar && index->rank != 0)
3650 gfc_error ("Array index at %L must be scalar", &index->where);
3654 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3656 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3657 &index->where, gfc_basic_typename (index->ts.type));
3661 if (index->ts.type == BT_REAL)
3662 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3663 &index->where) == FAILURE)
3666 if (index->ts.kind != gfc_index_integer_kind
3667 || index->ts.type != BT_INTEGER)
3670 ts.type = BT_INTEGER;
3671 ts.kind = gfc_index_integer_kind;
3673 gfc_convert_type_warn (index, &ts, 2, 0);
3679 /* Resolve a dim argument to an intrinsic function. */
3682 gfc_resolve_dim_arg (gfc_expr *dim)
3687 if (gfc_resolve_expr (dim) == FAILURE)
3692 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3697 if (dim->ts.type != BT_INTEGER)
3699 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3703 if (dim->ts.kind != gfc_index_integer_kind)
3707 ts.type = BT_INTEGER;
3708 ts.kind = gfc_index_integer_kind;
3710 gfc_convert_type_warn (dim, &ts, 2, 0);
3716 /* Given an expression that contains array references, update those array
3717 references to point to the right array specifications. While this is
3718 filled in during matching, this information is difficult to save and load
3719 in a module, so we take care of it here.
3721 The idea here is that the original array reference comes from the
3722 base symbol. We traverse the list of reference structures, setting
3723 the stored reference to references. Component references can
3724 provide an additional array specification. */
3727 find_array_spec (gfc_expr *e)
3731 gfc_symbol *derived;
3734 as = e->symtree->n.sym->as;
3737 for (ref = e->ref; ref; ref = ref->next)
3742 gfc_internal_error ("find_array_spec(): Missing spec");
3749 if (derived == NULL)
3750 derived = e->symtree->n.sym->ts.derived;
3752 c = derived->components;
3754 for (; c; c = c->next)
3755 if (c == ref->u.c.component)
3757 /* Track the sequence of component references. */
3758 if (c->ts.type == BT_DERIVED)
3759 derived = c->ts.derived;
3764 gfc_internal_error ("find_array_spec(): Component not found");
3766 if (c->attr.dimension)
3769 gfc_internal_error ("find_array_spec(): unused as(1)");
3780 gfc_internal_error ("find_array_spec(): unused as(2)");
3784 /* Resolve an array reference. */
3787 resolve_array_ref (gfc_array_ref *ar)
3789 int i, check_scalar;
3792 for (i = 0; i < ar->dimen; i++)
3794 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3796 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3798 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3800 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3805 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3809 ar->dimen_type[i] = DIMEN_ELEMENT;
3813 ar->dimen_type[i] = DIMEN_VECTOR;
3814 if (e->expr_type == EXPR_VARIABLE
3815 && e->symtree->n.sym->ts.type == BT_DERIVED)
3816 ar->start[i] = gfc_get_parentheses (e);
3820 gfc_error ("Array index at %L is an array of rank %d",
3821 &ar->c_where[i], e->rank);
3826 /* If the reference type is unknown, figure out what kind it is. */
3828 if (ar->type == AR_UNKNOWN)
3830 ar->type = AR_ELEMENT;
3831 for (i = 0; i < ar->dimen; i++)
3832 if (ar->dimen_type[i] == DIMEN_RANGE
3833 || ar->dimen_type[i] == DIMEN_VECTOR)
3835 ar->type = AR_SECTION;
3840 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3848 resolve_substring (gfc_ref *ref)
3850 if (ref->u.ss.start != NULL)
3852 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3855 if (ref->u.ss.start->ts.type != BT_INTEGER)
3857 gfc_error ("Substring start index at %L must be of type INTEGER",
3858 &ref->u.ss.start->where);
3862 if (ref->u.ss.start->rank != 0)
3864 gfc_error ("Substring start index at %L must be scalar",
3865 &ref->u.ss.start->where);
3869 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3870 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3871 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3873 gfc_error ("Substring start index at %L is less than one",
3874 &ref->u.ss.start->where);
3879 if (ref->u.ss.end != NULL)
3881 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3884 if (ref->u.ss.end->ts.type != BT_INTEGER)
3886 gfc_error ("Substring end index at %L must be of type INTEGER",
3887 &ref->u.ss.end->where);
3891 if (ref->u.ss.end->rank != 0)
3893 gfc_error ("Substring end index at %L must be scalar",
3894 &ref->u.ss.end->where);
3898 if (ref->u.ss.length != NULL
3899 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3900 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3901 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3903 gfc_error ("Substring end index at %L exceeds the string length",
3904 &ref->u.ss.start->where);
3913 /* This function supplies missing substring charlens. */
3916 gfc_resolve_substring_charlen (gfc_expr *e)
3919 gfc_expr *start, *end;
3921 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3922 if (char_ref->type == REF_SUBSTRING)
3928 gcc_assert (char_ref->next == NULL);
3932 if (e->ts.cl->length)
3933 gfc_free_expr (e->ts.cl->length);
3934 else if (e->expr_type == EXPR_VARIABLE
3935 && e->symtree->n.sym->attr.dummy)
3939 e->ts.type = BT_CHARACTER;
3940 e->ts.kind = gfc_default_character_kind;
3944 e->ts.cl = gfc_get_charlen ();
3945 e->ts.cl->next = gfc_current_ns->cl_list;
3946 gfc_current_ns->cl_list = e->ts.cl;
3949 if (char_ref->u.ss.start)
3950 start = gfc_copy_expr (char_ref->u.ss.start);
3952 start = gfc_int_expr (1);
3954 if (char_ref->u.ss.end)
3955 end = gfc_copy_expr (char_ref->u.ss.end);
3956 else if (e->expr_type == EXPR_VARIABLE)
3957 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3964 /* Length = (end - start +1). */
3965 e->ts.cl->length = gfc_subtract (end, start);
3966 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3968 e->ts.cl->length->ts.type = BT_INTEGER;
3969 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3971 /* Make sure that the length is simplified. */
3972 gfc_simplify_expr (e->ts.cl->length, 1);
3973 gfc_resolve_expr (e->ts.cl->length);
3977 /* Resolve subtype references. */
3980 resolve_ref (gfc_expr *expr)
3982 int current_part_dimension, n_components, seen_part_dimension;
3985 for (ref = expr->ref; ref; ref = ref->next)
3986 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3988 find_array_spec (expr);
3992 for (ref = expr->ref; ref; ref = ref->next)
3996 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4004 resolve_substring (ref);
4008 /* Check constraints on part references. */
4010 current_part_dimension = 0;
4011 seen_part_dimension = 0;
4014 for (ref = expr->ref; ref; ref = ref->next)
4019 switch (ref->u.ar.type)
4023 current_part_dimension = 1;
4027 current_part_dimension = 0;
4031 gfc_internal_error ("resolve_ref(): Bad array reference");
4037 if (current_part_dimension || seen_part_dimension)
4039 if (ref->u.c.component->attr.pointer)
4041 gfc_error ("Component to the right of a part reference "
4042 "with nonzero rank must not have the POINTER "
4043 "attribute at %L", &expr->where);
4046 else if (ref->u.c.component->attr.allocatable)
4048 gfc_error ("Component to the right of a part reference "
4049 "with nonzero rank must not have the ALLOCATABLE "
4050 "attribute at %L", &expr->where);
4062 if (((ref->type == REF_COMPONENT && n_components > 1)
4063 || ref->next == NULL)
4064 && current_part_dimension
4065 && seen_part_dimension)
4067 gfc_error ("Two or more part references with nonzero rank must "
4068 "not be specified at %L", &expr->where);
4072 if (ref->type == REF_COMPONENT)
4074 if (current_part_dimension)
4075 seen_part_dimension = 1;
4077 /* reset to make sure */
4078 current_part_dimension = 0;
4086 /* Given an expression, determine its shape. This is easier than it sounds.
4087 Leaves the shape array NULL if it is not possible to determine the shape. */
4090 expression_shape (gfc_expr *e)
4092 mpz_t array[GFC_MAX_DIMENSIONS];
4095 if (e->rank == 0 || e->shape != NULL)
4098 for (i = 0; i < e->rank; i++)
4099 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4102 e->shape = gfc_get_shape (e->rank);
4104 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4109 for (i--; i >= 0; i--)
4110 mpz_clear (array[i]);
4114 /* Given a variable expression node, compute the rank of the expression by
4115 examining the base symbol and any reference structures it may have. */
4118 expression_rank (gfc_expr *e)
4123 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4124 could lead to serious confusion... */
4125 gcc_assert (e->expr_type != EXPR_COMPCALL);
4129 if (e->expr_type == EXPR_ARRAY)
4131 /* Constructors can have a rank different from one via RESHAPE(). */
4133 if (e->symtree == NULL)
4139 e->rank = (e->symtree->n.sym->as == NULL)
4140 ? 0 : e->symtree->n.sym->as->rank;
4146 for (ref = e->ref; ref; ref = ref->next)
4148 if (ref->type != REF_ARRAY)
4151 if (ref->u.ar.type == AR_FULL)
4153 rank = ref->u.ar.as->rank;
4157 if (ref->u.ar.type == AR_SECTION)
4159 /* Figure out the rank of the section. */
4161 gfc_internal_error ("expression_rank(): Two array specs");
4163 for (i = 0; i < ref->u.ar.dimen; i++)
4164 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4165 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4175 expression_shape (e);
4179 /* Resolve a variable expression. */
4182 resolve_variable (gfc_expr *e)
4189 if (e->symtree == NULL)
4192 if (e->ref && resolve_ref (e) == FAILURE)
4195 sym = e->symtree->n.sym;
4196 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
4198 e->ts.type = BT_PROCEDURE;
4199 goto resolve_procedure;
4202 if (sym->ts.type != BT_UNKNOWN)
4203 gfc_variable_attr (e, &e->ts);
4206 /* Must be a simple variable reference. */
4207 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4212 if (check_assumed_size_reference (sym, e))
4215 /* Deal with forward references to entries during resolve_code, to
4216 satisfy, at least partially, 12.5.2.5. */
4217 if (gfc_current_ns->entries
4218 && current_entry_id == sym->entry_id
4221 && cs_base->current->op != EXEC_ENTRY)
4223 gfc_entry_list *entry;
4224 gfc_formal_arglist *formal;
4228 /* If the symbol is a dummy... */
4229 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4231 entry = gfc_current_ns->entries;
4234 /* ...test if the symbol is a parameter of previous entries. */
4235 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4236 for (formal = entry->sym->formal; formal; formal = formal->next)
4238 if (formal->sym && sym->name == formal->sym->name)
4242 /* If it has not been seen as a dummy, this is an error. */
4245 if (specification_expr)
4246 gfc_error ("Variable '%s', used in a specification expression"
4247 ", is referenced at %L before the ENTRY statement "
4248 "in which it is a parameter",
4249 sym->name, &cs_base->current->loc);
4251 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4252 "statement in which it is a parameter",
4253 sym->name, &cs_base->current->loc);
4258 /* Now do the same check on the specification expressions. */
4259 specification_expr = 1;
4260 if (sym->ts.type == BT_CHARACTER
4261 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
4265 for (n = 0; n < sym->as->rank; n++)
4267 specification_expr = 1;
4268 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4270 specification_expr = 1;
4271 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4274 specification_expr = 0;
4277 /* Update the symbol's entry level. */
4278 sym->entry_id = current_entry_id + 1;
4282 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
4289 /* Checks to see that the correct symbol has been host associated.
4290 The only situation where this arises is that in which a twice
4291 contained function is parsed after the host association is made.
4292 Therefore, on detecting this, change the symbol in the expression
4293 and convert the array reference into an actual arglist if the old
4294 symbol is a variable. */
4296 check_host_association (gfc_expr *e)
4298 gfc_symbol *sym, *old_sym;
4302 gfc_actual_arglist *arg, *tail;
4303 bool retval = e->expr_type == EXPR_FUNCTION;
4305 /* If the expression is the result of substitution in
4306 interface.c(gfc_extend_expr) because there is no way in
4307 which the host association can be wrong. */
4308 if (e->symtree == NULL
4309 || e->symtree->n.sym == NULL
4310 || e->user_operator)
4313 old_sym = e->symtree->n.sym;
4315 if (gfc_current_ns->parent
4316 && old_sym->ns != gfc_current_ns)
4318 /* Use the 'USE' name so that renamed module symbols are
4319 correctly handled. */
4320 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
4322 if (sym && old_sym != sym
4323 && sym->ts.type == old_sym->ts.type
4324 && sym->attr.flavor == FL_PROCEDURE
4325 && sym->attr.contained)
4327 /* Clear the shape, since it might not be valid. */
4328 if (e->shape != NULL)
4330 for (n = 0; n < e->rank; n++)
4331 mpz_clear (e->shape[n]);
4333 gfc_free (e->shape);
4336 /* Give the symbol a symtree in the right place! */
4337 gfc_get_sym_tree (sym->name, gfc_current_ns, &st);
4340 if (old_sym->attr.flavor == FL_PROCEDURE)
4342 /* Original was function so point to the new symbol, since
4343 the actual argument list is already attached to the
4345 e->value.function.esym = NULL;
4350 /* Original was variable so convert array references into
4351 an actual arglist. This does not need any checking now
4352 since gfc_resolve_function will take care of it. */
4353 e->value.function.actual = NULL;
4354 e->expr_type = EXPR_FUNCTION;
4357 /* Ambiguity will not arise if the array reference is not
4358 the last reference. */
4359 for (ref = e->ref; ref; ref = ref->next)
4360 if (ref->type == REF_ARRAY && ref->next == NULL)
4363 gcc_assert (ref->type == REF_ARRAY);
4365 /* Grab the start expressions from the array ref and
4366 copy them into actual arguments. */
4367 for (n = 0; n < ref->u.ar.dimen; n++)
4369 arg = gfc_get_actual_arglist ();
4370 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
4371 if (e->value.function.actual == NULL)
4372 tail = e->value.function.actual = arg;
4380 /* Dump the reference list and set the rank. */
4381 gfc_free_ref_list (e->ref);
4383 e->rank = sym->as ? sym->as->rank : 0;
4386 gfc_resolve_expr (e);
4390 /* This might have changed! */
4391 return e->expr_type == EXPR_FUNCTION;
4396 gfc_resolve_character_operator (gfc_expr *e)
4398 gfc_expr *op1 = e->value.op.op1;
4399 gfc_expr *op2 = e->value.op.op2;
4400 gfc_expr *e1 = NULL;
4401 gfc_expr *e2 = NULL;
4403 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
4405 if (op1->ts.cl && op1->ts.cl->length)
4406 e1 = gfc_copy_expr (op1->ts.cl->length);
4407 else if (op1->expr_type == EXPR_CONSTANT)
4408 e1 = gfc_int_expr (op1->value.character.length);
4410 if (op2->ts.cl && op2->ts.cl->length)
4411 e2 = gfc_copy_expr (op2->ts.cl->length);
4412 else if (op2->expr_type == EXPR_CONSTANT)
4413 e2 = gfc_int_expr (op2->value.character.length);
4415 e->ts.cl = gfc_get_charlen ();
4416 e->ts.cl->next = gfc_current_ns->cl_list;
4417 gfc_current_ns->cl_list = e->ts.cl;
4422 e->ts.cl->length = gfc_add (e1, e2);
4423 e->ts.cl->length->ts.type = BT_INTEGER;
4424 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4425 gfc_simplify_expr (e->ts.cl->length, 0);
4426 gfc_resolve_expr (e->ts.cl->length);
4432 /* Ensure that an character expression has a charlen and, if possible, a
4433 length expression. */
4436 fixup_charlen (gfc_expr *e)
4438 /* The cases fall through so that changes in expression type and the need
4439 for multiple fixes are picked up. In all circumstances, a charlen should
4440 be available for the middle end to hang a backend_decl on. */
4441 switch (e->expr_type)
4444 gfc_resolve_character_operator (e);
4447 if (e->expr_type == EXPR_ARRAY)
4448 gfc_resolve_character_array_constructor (e);
4450 case EXPR_SUBSTRING:
4451 if (!e->ts.cl && e->ref)
4452 gfc_resolve_substring_charlen (e);
4457 e->ts.cl = gfc_get_charlen ();
4458 e->ts.cl->next = gfc_current_ns->cl_list;
4459 gfc_current_ns->cl_list = e->ts.cl;
4467 /* Update an actual argument to include the passed-object for type-bound
4468 procedures at the right position. */
4470 static gfc_actual_arglist*
4471 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
4473 gcc_assert (argpos > 0);
4477 gfc_actual_arglist* result;
4479 result = gfc_get_actual_arglist ();
4487 gcc_assert (argpos > 1);
4489 lst->next = update_arglist_pass (lst->next, po, argpos - 1);
4494 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4497 extract_compcall_passed_object (gfc_expr* e)
4501 gcc_assert (e->expr_type == EXPR_COMPCALL);
4503 po = gfc_get_expr ();
4504 po->expr_type = EXPR_VARIABLE;
4505 po->symtree = e->symtree;
4506 po->ref = gfc_copy_ref (e->ref);
4508 if (gfc_resolve_expr (po) == FAILURE)
4515 /* Update the arglist of an EXPR_COMPCALL expression to include the
4519 update_compcall_arglist (gfc_expr* e)
4522 gfc_typebound_proc* tbp;
4524 tbp = e->value.compcall.tbp;
4529 po = extract_compcall_passed_object (e);
4535 gfc_error ("Passed-object at %L must be scalar", &e->where);
4545 gcc_assert (tbp->pass_arg_num > 0);
4546 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4553 /* Resolve a call to a type-bound procedure, either function or subroutine,
4554 statically from the data in an EXPR_COMPCALL expression. The adapted
4555 arglist and the target-procedure symtree are returned. */
4558 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
4559 gfc_actual_arglist** actual)
4561 gcc_assert (e->expr_type == EXPR_COMPCALL);
4562 gcc_assert (!e->value.compcall.tbp->is_generic);
4564 /* Update the actual arglist for PASS. */
4565 if (update_compcall_arglist (e) == FAILURE)
4568 *actual = e->value.compcall.actual;
4569 *target = e->value.compcall.tbp->u.specific;
4571 gfc_free_ref_list (e->ref);
4573 e->value.compcall.actual = NULL;
4579 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4580 which of the specific bindings (if any) matches the arglist and transform
4581 the expression into a call of that binding. */
4584 resolve_typebound_generic_call (gfc_expr* e)
4586 gfc_typebound_proc* genproc;
4587 const char* genname;
4589 gcc_assert (e->expr_type == EXPR_COMPCALL);
4590 genname = e->value.compcall.name;
4591 genproc = e->value.compcall.tbp;
4593 if (!genproc->is_generic)
4596 /* Try the bindings on this type and in the inheritance hierarchy. */
4597 for (; genproc; genproc = genproc->overridden)
4601 gcc_assert (genproc->is_generic);
4602 for (g = genproc->u.generic; g; g = g->next)
4605 gfc_actual_arglist* args;
4608 gcc_assert (g->specific);
4610 if (g->specific->error)
4613 target = g->specific->u.specific->n.sym;
4615 /* Get the right arglist by handling PASS/NOPASS. */
4616 args = gfc_copy_actual_arglist (e->value.compcall.actual);
4617 if (!g->specific->nopass)
4620 po = extract_compcall_passed_object (e);
4624 gcc_assert (g->specific->pass_arg_num > 0);
4625 gcc_assert (!g->specific->error);
4626 args = update_arglist_pass (args, po, g->specific->pass_arg_num);
4628 resolve_actual_arglist (args, target->attr.proc,
4629 is_external_proc (target) && !target->formal);
4631 /* Check if this arglist matches the formal. */
4632 matches = gfc_arglist_matches_symbol (&args, target);
4634 /* Clean up and break out of the loop if we've found it. */
4635 gfc_free_actual_arglist (args);
4638 e->value.compcall.tbp = g->specific;
4644 /* Nothing matching found! */
4645 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4646 " '%s' at %L", genname, &e->where);
4654 /* Resolve a call to a type-bound subroutine. */
4657 resolve_typebound_call (gfc_code* c)
4659 gfc_actual_arglist* newactual;
4660 gfc_symtree* target;
4662 /* Check that's really a SUBROUTINE. */
4663 if (!c->expr->value.compcall.tbp->subroutine)
4665 gfc_error ("'%s' at %L should be a SUBROUTINE",
4666 c->expr->value.compcall.name, &c->loc);
4670 if (resolve_typebound_generic_call (c->expr) == FAILURE)
4673 /* Transform into an ordinary EXEC_CALL for now. */
4675 if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
4678 c->ext.actual = newactual;
4679 c->symtree = target;
4682 gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
4683 gfc_free_expr (c->expr);
4686 return resolve_call (c);
4690 /* Resolve a component-call expression. */
4693 resolve_compcall (gfc_expr* e)
4695 gfc_actual_arglist* newactual;
4696 gfc_symtree* target;
4698 /* Check that's really a FUNCTION. */
4699 if (!e->value.compcall.tbp->function)
4701 gfc_error ("'%s' at %L should be a FUNCTION",
4702 e->value.compcall.name, &e->where);
4706 if (resolve_typebound_generic_call (e) == FAILURE)
4708 gcc_assert (!e->value.compcall.tbp->is_generic);
4710 /* Take the rank from the function's symbol. */
4711 if (e->value.compcall.tbp->u.specific->n.sym->as)
4712 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
4714 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4715 arglist to the TBP's binding target. */
4717 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
4720 e->value.function.actual = newactual;
4721 e->value.function.name = e->value.compcall.name;
4722 e->value.function.isym = NULL;
4723 e->value.function.esym = NULL;
4724 e->symtree = target;
4725 e->ts = target->n.sym->ts;
4726 e->expr_type = EXPR_FUNCTION;
4728 return gfc_resolve_expr (e);
4732 /* Resolve an expression. That is, make sure that types of operands agree
4733 with their operators, intrinsic operators are converted to function calls
4734 for overloaded types and unresolved function references are resolved. */
4737 gfc_resolve_expr (gfc_expr *e)
4744 switch (e->expr_type)
4747 t = resolve_operator (e);
4753 if (check_host_association (e))
4754 t = resolve_function (e);
4757 t = resolve_variable (e);
4759 expression_rank (e);
4762 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4763 && e->ref->type != REF_SUBSTRING)
4764 gfc_resolve_substring_charlen (e);
4769 t = resolve_compcall (e);
4772 case EXPR_SUBSTRING:
4773 t = resolve_ref (e);
4783 if (resolve_ref (e) == FAILURE)
4786 t = gfc_resolve_array_constructor (e);
4787 /* Also try to expand a constructor. */
4790 expression_rank (e);
4791 gfc_expand_constructor (e);
4794 /* This provides the opportunity for the length of constructors with
4795 character valued function elements to propagate the string length
4796 to the expression. */
4797 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
4798 t = gfc_resolve_character_array_constructor (e);
4802 case EXPR_STRUCTURE:
4803 t = resolve_ref (e);
4807 t = resolve_structure_cons (e);
4811 t = gfc_simplify_expr (e, 0);
4815 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4818 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4825 /* Resolve an expression from an iterator. They must be scalar and have
4826 INTEGER or (optionally) REAL type. */
4829 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4830 const char *name_msgid)
4832 if (gfc_resolve_expr (expr) == FAILURE)
4835 if (expr->rank != 0)
4837 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4841 if (expr->ts.type != BT_INTEGER)
4843 if (expr->ts.type == BT_REAL)
4846 return gfc_notify_std (GFC_STD_F95_DEL,
4847 "Deleted feature: %s at %L must be integer",
4848 _(name_msgid), &expr->where);
4851 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4858 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4866 /* Resolve the expressions in an iterator structure. If REAL_OK is
4867 false allow only INTEGER type iterators, otherwise allow REAL types. */
4870 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4872 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4876 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4878 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4883 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4884 "Start expression in DO loop") == FAILURE)
4887 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4888 "End expression in DO loop") == FAILURE)
4891 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4892 "Step expression in DO loop") == FAILURE)
4895 if (iter->step->expr_type == EXPR_CONSTANT)
4897 if ((iter->step->ts.type == BT_INTEGER
4898 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4899 || (iter->step->ts.type == BT_REAL
4900 && mpfr_sgn (iter->step->value.real) == 0))
4902 gfc_error ("Step expression in DO loop at %L cannot be zero",
4903 &iter->step->where);
4908 /* Convert start, end, and step to the same type as var. */
4909 if (iter->start->ts.kind != iter->var->ts.kind
4910 || iter->start->ts.type != iter->var->ts.type)
4911 gfc_convert_type (iter->start, &iter->var->ts, 2);
4913 if (iter->end->ts.kind != iter->var->ts.kind
4914 || iter->end->ts.type != iter->var->ts.type)
4915 gfc_convert_type (iter->end, &iter->var->ts, 2);
4917 if (iter->step->ts.kind != iter->var->ts.kind
4918 || iter->step->ts.type != iter->var->ts.type)
4919 gfc_convert_type (iter->step, &iter->var->ts, 2);
4925 /* Traversal function for find_forall_index. f == 2 signals that
4926 that variable itself is not to be checked - only the references. */
4929 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
4931 if (expr->expr_type != EXPR_VARIABLE)
4934 /* A scalar assignment */
4935 if (!expr->ref || *f == 1)
4937 if (expr->symtree->n.sym == sym)
4949 /* Check whether the FORALL index appears in the expression or not.
4950 Returns SUCCESS if SYM is found in EXPR. */
4953 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
4955 if (gfc_traverse_expr (expr, sym, forall_index, f))
4962 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4963 to be a scalar INTEGER variable. The subscripts and stride are scalar
4964 INTEGERs, and if stride is a constant it must be nonzero.
4965 Furthermore "A subscript or stride in a forall-triplet-spec shall
4966 not contain a reference to any index-name in the
4967 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4970 resolve_forall_iterators (gfc_forall_iterator *it)
4972 gfc_forall_iterator *iter, *iter2;
4974 for (iter = it; iter; iter = iter->next)
4976 if (gfc_resolve_expr (iter->var) == SUCCESS
4977 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4978 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4981 if (gfc_resolve_expr (iter->start) == SUCCESS
4982 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4983 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4984 &iter->start->where);
4985 if (iter->var->ts.kind != iter->start->ts.kind)
4986 gfc_convert_type (iter->start, &iter->var->ts, 2);
4988 if (gfc_resolve_expr (iter->end) == SUCCESS
4989 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4990 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4992 if (iter->var->ts.kind != iter->end->ts.kind)
4993 gfc_convert_type (iter->end, &iter->var->ts, 2);
4995 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4997 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4998 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4999 &iter->stride->where, "INTEGER");
5001 if (iter->stride->expr_type == EXPR_CONSTANT
5002 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
5003 gfc_error ("FORALL stride expression at %L cannot be zero",
5004 &iter->stride->where);
5006 if (iter->var->ts.kind != iter->stride->ts.kind)
5007 gfc_convert_type (iter->stride, &iter->var->ts, 2);
5010 for (iter = it; iter; iter = iter->next)
5011 for (iter2 = iter; iter2; iter2 = iter2->next)
5013 if (find_forall_index (iter2->start,
5014 iter->var->symtree->n.sym, 0) == SUCCESS
5015 || find_forall_index (iter2->end,
5016 iter->var->symtree->n.sym, 0) == SUCCESS
5017 || find_forall_index (iter2->stride,
5018 iter->var->symtree->n.sym, 0) == SUCCESS)
5019 gfc_error ("FORALL index '%s' may not appear in triplet "
5020 "specification at %L", iter->var->symtree->name,
5021 &iter2->start->where);
5026 /* Given a pointer to a symbol that is a derived type, see if it's
5027 inaccessible, i.e. if it's defined in another module and the components are
5028 PRIVATE. The search is recursive if necessary. Returns zero if no
5029 inaccessible components are found, nonzero otherwise. */
5032 derived_inaccessible (gfc_symbol *sym)
5036 if (sym->attr.use_assoc && sym->attr.private_comp)
5039 for (c = sym->components; c; c = c->next)
5041 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
5049 /* Resolve the argument of a deallocate expression. The expression must be
5050 a pointer or a full array. */
5053 resolve_deallocate_expr (gfc_expr *e)
5055 symbol_attribute attr;
5056 int allocatable, pointer, check_intent_in;
5059 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5060 check_intent_in = 1;
5062 if (gfc_resolve_expr (e) == FAILURE)
5065 if (e->expr_type != EXPR_VARIABLE)
5068 allocatable = e->symtree->n.sym->attr.allocatable;
5069 pointer = e->symtree->n.sym->attr.pointer;
5070 for (ref = e->ref; ref; ref = ref->next)
5073 check_intent_in = 0;
5078 if (ref->u.ar.type != AR_FULL)
5083 allocatable = (ref->u.c.component->as != NULL
5084 && ref->u.c.component->as->type == AS_DEFERRED);
5085 pointer = ref->u.c.component->attr.pointer;
5094 attr = gfc_expr_attr (e);
5096 if (allocatable == 0 && attr.pointer == 0)
5099 gfc_error ("Expression in DEALLOCATE statement at %L must be "
5100 "ALLOCATABLE or a POINTER", &e->where);
5104 && e->symtree->n.sym->attr.intent == INTENT_IN)
5106 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5107 e->symtree->n.sym->name, &e->where);
5115 /* Returns true if the expression e contains a reference to the symbol sym. */
5117 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5119 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
5126 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
5128 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
5132 /* Given the expression node e for an allocatable/pointer of derived type to be
5133 allocated, get the expression node to be initialized afterwards (needed for
5134 derived types with default initializers, and derived types with allocatable
5135 components that need nullification.) */
5138 expr_to_initialize (gfc_expr *e)
5144 result = gfc_copy_expr (e);
5146 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5147 for (ref = result->ref; ref; ref = ref->next)
5148 if (ref->type == REF_ARRAY && ref->next == NULL)
5150 ref->u.ar.type = AR_FULL;
5152 for (i = 0; i < ref->u.ar.dimen; i++)
5153 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
5155 result->rank = ref->u.ar.dimen;
5163 /* Resolve the expression in an ALLOCATE statement, doing the additional
5164 checks to see whether the expression is OK or not. The expression must
5165 have a trailing array reference that gives the size of the array. */
5168 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
5170 int i, pointer, allocatable, dimension, check_intent_in;
5171 symbol_attribute attr;
5172 gfc_ref *ref, *ref2;
5179 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5180 check_intent_in = 1;
5182 if (gfc_resolve_expr (e) == FAILURE)
5185 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
5186 sym = code->expr->symtree->n.sym;
5190 /* Make sure the expression is allocatable or a pointer. If it is
5191 pointer, the next-to-last reference must be a pointer. */
5195 if (e->expr_type != EXPR_VARIABLE)
5198 attr = gfc_expr_attr (e);
5199 pointer = attr.pointer;
5200 dimension = attr.dimension;
5204 allocatable = e->symtree->n.sym->attr.allocatable;
5205 pointer = e->symtree->n.sym->attr.pointer;
5206 dimension = e->symtree->n.sym->attr.dimension;
5208 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
5210 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
5211 "not be allocated in the same statement at %L",
5212 sym->name, &e->where);
5216 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
5219 check_intent_in = 0;
5224 if (ref->next != NULL)
5229 allocatable = (ref->u.c.component->as != NULL
5230 && ref->u.c.component->as->type == AS_DEFERRED);
5232 pointer = ref->u.c.component->attr.pointer;
5233 dimension = ref->u.c.component->attr.dimension;
5244 if (allocatable == 0 && pointer == 0)
5246 gfc_error ("Expression in ALLOCATE statement at %L must be "
5247 "ALLOCATABLE or a POINTER", &e->where);
5252 && e->symtree->n.sym->attr.intent == INTENT_IN)
5254 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5255 e->symtree->n.sym->name, &e->where);
5259 /* Add default initializer for those derived types that need them. */
5260 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
5262 init_st = gfc_get_code ();
5263 init_st->loc = code->loc;
5264 init_st->op = EXEC_INIT_ASSIGN;
5265 init_st->expr = expr_to_initialize (e);
5266 init_st->expr2 = init_e;
5267 init_st->next = code->next;
5268 code->next = init_st;
5271 if (pointer && dimension == 0)
5274 /* Make sure the next-to-last reference node is an array specification. */
5276 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
5278 gfc_error ("Array specification required in ALLOCATE statement "
5279 "at %L", &e->where);
5283 /* Make sure that the array section reference makes sense in the
5284 context of an ALLOCATE specification. */
5288 for (i = 0; i < ar->dimen; i++)
5290 if (ref2->u.ar.type == AR_ELEMENT)
5293 switch (ar->dimen_type[i])
5299 if (ar->start[i] != NULL
5300 && ar->end[i] != NULL
5301 && ar->stride[i] == NULL)
5304 /* Fall Through... */
5308 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5315 for (a = code->ext.alloc_list; a; a = a->next)
5317 sym = a->expr->symtree->n.sym;
5319 /* TODO - check derived type components. */
5320 if (sym->ts.type == BT_DERIVED)
5323 if ((ar->start[i] != NULL
5324 && gfc_find_sym_in_expr (sym, ar->start[i]))
5325 || (ar->end[i] != NULL
5326 && gfc_find_sym_in_expr (sym, ar->end[i])))
5328 gfc_error ("'%s' must not appear in the array specification at "
5329 "%L in the same ALLOCATE statement where it is "
5330 "itself allocated", sym->name, &ar->where);
5340 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
5342 gfc_symbol *s = NULL;
5346 s = code->expr->symtree->n.sym;
5350 if (s->attr.intent == INTENT_IN)
5351 gfc_error ("STAT variable '%s' of %s statement at %C cannot "
5352 "be INTENT(IN)", s->name, fcn);
5354 if (gfc_pure (NULL) && gfc_impure_variable (s))
5355 gfc_error ("Illegal STAT variable in %s statement at %C "
5356 "for a PURE procedure", fcn);
5359 if (s && code->expr->ts.type != BT_INTEGER)
5360 gfc_error ("STAT tag in %s statement at %L must be "
5361 "of type INTEGER", fcn, &code->expr->where);
5363 if (strcmp (fcn, "ALLOCATE") == 0)
5365 for (a = code->ext.alloc_list; a; a = a->next)
5366 resolve_allocate_expr (a->expr, code);
5370 for (a = code->ext.alloc_list; a; a = a->next)
5371 resolve_deallocate_expr (a->expr);
5375 /************ SELECT CASE resolution subroutines ************/
5377 /* Callback function for our mergesort variant. Determines interval
5378 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5379 op1 > op2. Assumes we're not dealing with the default case.
5380 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5381 There are nine situations to check. */
5384 compare_cases (const gfc_case *op1, const gfc_case *op2)
5388 if (op1->low == NULL) /* op1 = (:L) */
5390 /* op2 = (:N), so overlap. */
5392 /* op2 = (M:) or (M:N), L < M */
5393 if (op2->low != NULL
5394 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5397 else if (op1->high == NULL) /* op1 = (K:) */
5399 /* op2 = (M:), so overlap. */
5401 /* op2 = (:N) or (M:N), K > N */
5402 if (op2->high != NULL
5403 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5406 else /* op1 = (K:L) */
5408 if (op2->low == NULL) /* op2 = (:N), K > N */
5409 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5411 else if (op2->high == NULL) /* op2 = (M:), L < M */
5412 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5414 else /* op2 = (M:N) */
5418 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5421 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5430 /* Merge-sort a double linked case list, detecting overlap in the
5431 process. LIST is the head of the double linked case list before it
5432 is sorted. Returns the head of the sorted list if we don't see any
5433 overlap, or NULL otherwise. */
5436 check_case_overlap (gfc_case *list)
5438 gfc_case *p, *q, *e, *tail;
5439 int insize, nmerges, psize, qsize, cmp, overlap_seen;
5441 /* If the passed list was empty, return immediately. */
5448 /* Loop unconditionally. The only exit from this loop is a return
5449 statement, when we've finished sorting the case list. */
5456 /* Count the number of merges we do in this pass. */
5459 /* Loop while there exists a merge to be done. */
5464 /* Count this merge. */
5467 /* Cut the list in two pieces by stepping INSIZE places
5468 forward in the list, starting from P. */
5471 for (i = 0; i < insize; i++)
5480 /* Now we have two lists. Merge them! */
5481 while (psize > 0 || (qsize > 0 && q != NULL))
5483 /* See from which the next case to merge comes from. */
5486 /* P is empty so the next case must come from Q. */
5491 else if (qsize == 0 || q == NULL)
5500 cmp = compare_cases (p, q);
5503 /* The whole case range for P is less than the
5511 /* The whole case range for Q is greater than
5512 the case range for P. */
5519 /* The cases overlap, or they are the same
5520 element in the list. Either way, we must
5521 issue an error and get the next case from P. */
5522 /* FIXME: Sort P and Q by line number. */
5523 gfc_error ("CASE label at %L overlaps with CASE "
5524 "label at %L", &p->where, &q->where);
5532 /* Add the next element to the merged list. */
5541 /* P has now stepped INSIZE places along, and so has Q. So
5542 they're the same. */
5547 /* If we have done only one merge or none at all, we've
5548 finished sorting the cases. */
5557 /* Otherwise repeat, merging lists twice the size. */
5563 /* Check to see if an expression is suitable for use in a CASE statement.
5564 Makes sure that all case expressions are scalar constants of the same
5565 type. Return FAILURE if anything is wrong. */
5568 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5570 if (e == NULL) return SUCCESS;
5572 if (e->ts.type != case_expr->ts.type)
5574 gfc_error ("Expression in CASE statement at %L must be of type %s",
5575 &e->where, gfc_basic_typename (case_expr->ts.type));
5579 /* C805 (R808) For a given case-construct, each case-value shall be of
5580 the same type as case-expr. For character type, length differences
5581 are allowed, but the kind type parameters shall be the same. */
5583 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5585 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5586 &e->where, case_expr->ts.kind);
5590 /* Convert the case value kind to that of case expression kind, if needed.
5591 FIXME: Should a warning be issued? */
5592 if (e->ts.kind != case_expr->ts.kind)
5593 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5597 gfc_error ("Expression in CASE statement at %L must be scalar",
5606 /* Given a completely parsed select statement, we:
5608 - Validate all expressions and code within the SELECT.
5609 - Make sure that the selection expression is not of the wrong type.
5610 - Make sure that no case ranges overlap.
5611 - Eliminate unreachable cases and unreachable code resulting from
5612 removing case labels.
5614 The standard does allow unreachable cases, e.g. CASE (5:3). But
5615 they are a hassle for code generation, and to prevent that, we just
5616 cut them out here. This is not necessary for overlapping cases
5617 because they are illegal and we never even try to generate code.
5619 We have the additional caveat that a SELECT construct could have
5620 been a computed GOTO in the source code. Fortunately we can fairly
5621 easily work around that here: The case_expr for a "real" SELECT CASE
5622 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5623 we have to do is make sure that the case_expr is a scalar integer
5627 resolve_select (gfc_code *code)
5630 gfc_expr *case_expr;
5631 gfc_case *cp, *default_case, *tail, *head;
5632 int seen_unreachable;
5638 if (code->expr == NULL)
5640 /* This was actually a computed GOTO statement. */
5641 case_expr = code->expr2;
5642 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5643 gfc_error ("Selection expression in computed GOTO statement "
5644 "at %L must be a scalar integer expression",
5647 /* Further checking is not necessary because this SELECT was built
5648 by the compiler, so it should always be OK. Just move the
5649 case_expr from expr2 to expr so that we can handle computed
5650 GOTOs as normal SELECTs from here on. */
5651 code->expr = code->expr2;
5656 case_expr = code->expr;
5658 type = case_expr->ts.type;
5659 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5661 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5662 &case_expr->where, gfc_typename (&case_expr->ts));
5664 /* Punt. Going on here just produce more garbage error messages. */
5668 if (case_expr->rank != 0)
5670 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5671 "expression", &case_expr->where);
5677 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5678 of the SELECT CASE expression and its CASE values. Walk the lists
5679 of case values, and if we find a mismatch, promote case_expr to
5680 the appropriate kind. */
5682 if (type == BT_LOGICAL || type == BT_INTEGER)
5684 for (body = code->block; body; body = body->block)
5686 /* Walk the case label list. */
5687 for (cp = body->ext.case_list; cp; cp = cp->next)
5689 /* Intercept the DEFAULT case. It does not have a kind. */
5690 if (cp->low == NULL && cp->high == NULL)
5693 /* Unreachable case ranges are discarded, so ignore. */
5694 if (cp->low != NULL && cp->high != NULL
5695 && cp->low != cp->high
5696 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5699 /* FIXME: Should a warning be issued? */
5701 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5702 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5704 if (cp->high != NULL
5705 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5706 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5711 /* Assume there is no DEFAULT case. */
5712 default_case = NULL;
5717 for (body = code->block; body; body = body->block)
5719 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5721 seen_unreachable = 0;
5723 /* Walk the case label list, making sure that all case labels
5725 for (cp = body->ext.case_list; cp; cp = cp->next)
5727 /* Count the number of cases in the whole construct. */
5730 /* Intercept the DEFAULT case. */
5731 if (cp->low == NULL && cp->high == NULL)
5733 if (default_case != NULL)
5735 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5736 "by a second DEFAULT CASE at %L",
5737 &default_case->where, &cp->where);
5748 /* Deal with single value cases and case ranges. Errors are
5749 issued from the validation function. */
5750 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5751 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5757 if (type == BT_LOGICAL
5758 && ((cp->low == NULL || cp->high == NULL)
5759 || cp->low != cp->high))
5761 gfc_error ("Logical range in CASE statement at %L is not "
5762 "allowed", &cp->low->where);
5767 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5770 value = cp->low->value.logical == 0 ? 2 : 1;
5771 if (value & seen_logical)
5773 gfc_error ("constant logical value in CASE statement "
5774 "is repeated at %L",
5779 seen_logical |= value;
5782 if (cp->low != NULL && cp->high != NULL
5783 && cp->low != cp->high
5784 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5786 if (gfc_option.warn_surprising)
5787 gfc_warning ("Range specification at %L can never "
5788 "be matched", &cp->where);
5790 cp->unreachable = 1;
5791 seen_unreachable = 1;
5795 /* If the case range can be matched, it can also overlap with
5796 other cases. To make sure it does not, we put it in a
5797 double linked list here. We sort that with a merge sort
5798 later on to detect any overlapping cases. */
5802 head->right = head->left = NULL;
5807 tail->right->left = tail;
5814 /* It there was a failure in the previous case label, give up
5815 for this case label list. Continue with the next block. */
5819 /* See if any case labels that are unreachable have been seen.
5820 If so, we eliminate them. This is a bit of a kludge because
5821 the case lists for a single case statement (label) is a
5822 single forward linked lists. */
5823 if (seen_unreachable)
5825 /* Advance until the first case in the list is reachable. */
5826 while (body->ext.case_list != NULL
5827 && body->ext.case_list->unreachable)
5829 gfc_case *n = body->ext.case_list;
5830 body->ext.case_list = body->ext.case_list->next;
5832 gfc_free_case_list (n);
5835 /* Strip all other unreachable cases. */
5836 if (body->ext.case_list)
5838 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5840 if (cp->next->unreachable)
5842 gfc_case *n = cp->next;
5843 cp->next = cp->next->next;
5845 gfc_free_case_list (n);
5852 /* See if there were overlapping cases. If the check returns NULL,
5853 there was overlap. In that case we don't do anything. If head
5854 is non-NULL, we prepend the DEFAULT case. The sorted list can
5855 then used during code generation for SELECT CASE constructs with
5856 a case expression of a CHARACTER type. */
5859 head = check_case_overlap (head);
5861 /* Prepend the default_case if it is there. */
5862 if (head != NULL && default_case)
5864 default_case->left = NULL;
5865 default_case->right = head;
5866 head->left = default_case;
5870 /* Eliminate dead blocks that may be the result if we've seen
5871 unreachable case labels for a block. */
5872 for (body = code; body && body->block; body = body->block)
5874 if (body->block->ext.case_list == NULL)
5876 /* Cut the unreachable block from the code chain. */
5877 gfc_code *c = body->block;
5878 body->block = c->block;
5880 /* Kill the dead block, but not the blocks below it. */
5882 gfc_free_statements (c);
5886 /* More than two cases is legal but insane for logical selects.
5887 Issue a warning for it. */
5888 if (gfc_option.warn_surprising && type == BT_LOGICAL
5890 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5895 /* Resolve a transfer statement. This is making sure that:
5896 -- a derived type being transferred has only non-pointer components
5897 -- a derived type being transferred doesn't have private components, unless
5898 it's being transferred from the module where the type was defined
5899 -- we're not trying to transfer a whole assumed size array. */
5902 resolve_transfer (gfc_code *code)
5911 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5914 sym = exp->symtree->n.sym;
5917 /* Go to actual component transferred. */
5918 for (ref = code->expr->ref; ref; ref = ref->next)
5919 if (ref->type == REF_COMPONENT)
5920 ts = &ref->u.c.component->ts;
5922 if (ts->type == BT_DERIVED)
5924 /* Check that transferred derived type doesn't contain POINTER
5926 if (ts->derived->attr.pointer_comp)
5928 gfc_error ("Data transfer element at %L cannot have "
5929 "POINTER components", &code->loc);
5933 if (ts->derived->attr.alloc_comp)
5935 gfc_error ("Data transfer element at %L cannot have "
5936 "ALLOCATABLE components", &code->loc);
5940 if (derived_inaccessible (ts->derived))
5942 gfc_error ("Data transfer element at %L cannot have "
5943 "PRIVATE components",&code->loc);
5948 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5949 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5951 gfc_error ("Data transfer element at %L cannot be a full reference to "
5952 "an assumed-size array", &code->loc);
5958 /*********** Toplevel code resolution subroutines ***********/
5960 /* Find the set of labels that are reachable from this block. We also
5961 record the last statement in each block so that we don't have to do
5962 a linear search to find the END DO statements of the blocks. */
5965 reachable_labels (gfc_code *block)
5972 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5974 /* Collect labels in this block. */
5975 for (c = block; c; c = c->next)
5978 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5980 if (!c->next && cs_base->prev)
5981 cs_base->prev->tail = c;
5984 /* Merge with labels from parent block. */
5987 gcc_assert (cs_base->prev->reachable_labels);
5988 bitmap_ior_into (cs_base->reachable_labels,
5989 cs_base->prev->reachable_labels);
5993 /* Given a branch to a label and a namespace, if the branch is conforming.
5994 The code node describes where the branch is located. */
5997 resolve_branch (gfc_st_label *label, gfc_code *code)
6004 /* Step one: is this a valid branching target? */
6006 if (label->defined == ST_LABEL_UNKNOWN)
6008 gfc_error ("Label %d referenced at %L is never defined", label->value,
6013 if (label->defined != ST_LABEL_TARGET)
6015 gfc_error ("Statement at %L is not a valid branch target statement "
6016 "for the branch statement at %L", &label->where, &code->loc);
6020 /* Step two: make sure this branch is not a branch to itself ;-) */
6022 if (code->here == label)
6024 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
6028 /* Step three: See if the label is in the same block as the
6029 branching statement. The hard work has been done by setting up
6030 the bitmap reachable_labels. */
6032 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
6034 /* The label is not in an enclosing block, so illegal. This was
6035 allowed in Fortran 66, so we allow it as extension. No
6036 further checks are necessary in this case. */
6037 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
6038 "as the GOTO statement at %L", &label->where,
6043 /* Step four: Make sure that the branching target is legal if
6044 the statement is an END {SELECT,IF}. */
6046 for (stack = cs_base; stack; stack = stack->prev)
6047 if (stack->current->next && stack->current->next->here == label)
6050 if (stack && stack->current->next->op == EXEC_NOP)
6052 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
6053 "END of construct at %L", &code->loc,
6054 &stack->current->next->loc);
6055 return; /* We know this is not an END DO. */
6058 /* Step five: Make sure that we're not jumping to the end of a DO
6059 loop from within the loop. */
6061 for (stack = cs_base; stack; stack = stack->prev)
6062 if ((stack->current->op == EXEC_DO
6063 || stack->current->op == EXEC_DO_WHILE)
6064 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
6066 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
6067 "to END of construct at %L", &code->loc,
6075 /* Check whether EXPR1 has the same shape as EXPR2. */
6078 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
6080 mpz_t shape[GFC_MAX_DIMENSIONS];
6081 mpz_t shape2[GFC_MAX_DIMENSIONS];
6082 gfc_try result = FAILURE;
6085 /* Compare the rank. */
6086 if (expr1->rank != expr2->rank)
6089 /* Compare the size of each dimension. */
6090 for (i=0; i<expr1->rank; i++)
6092 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
6095 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
6098 if (mpz_cmp (shape[i], shape2[i]))
6102 /* When either of the two expression is an assumed size array, we
6103 ignore the comparison of dimension sizes. */
6108 for (i--; i >= 0; i--)
6110 mpz_clear (shape[i]);
6111 mpz_clear (shape2[i]);
6117 /* Check whether a WHERE assignment target or a WHERE mask expression
6118 has the same shape as the outmost WHERE mask expression. */
6121 resolve_where (gfc_code *code, gfc_expr *mask)
6127 cblock = code->block;
6129 /* Store the first WHERE mask-expr of the WHERE statement or construct.
6130 In case of nested WHERE, only the outmost one is stored. */
6131 if (mask == NULL) /* outmost WHERE */
6133 else /* inner WHERE */
6140 /* Check if the mask-expr has a consistent shape with the
6141 outmost WHERE mask-expr. */
6142 if (resolve_where_shape (cblock->expr, e) == FAILURE)
6143 gfc_error ("WHERE mask at %L has inconsistent shape",
6144 &cblock->expr->where);
6147 /* the assignment statement of a WHERE statement, or the first
6148 statement in where-body-construct of a WHERE construct */
6149 cnext = cblock->next;
6154 /* WHERE assignment statement */
6157 /* Check shape consistent for WHERE assignment target. */
6158 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
6159 gfc_error ("WHERE assignment target at %L has "
6160 "inconsistent shape", &cnext->expr->where);
6164 case EXEC_ASSIGN_CALL:
6165 resolve_call (cnext);
6166 if (!cnext->resolved_sym->attr.elemental)
6167 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6168 &cnext->ext.actual->expr->where);
6171 /* WHERE or WHERE construct is part of a where-body-construct */
6173 resolve_where (cnext, e);
6177 gfc_error ("Unsupported statement inside WHERE at %L",
6180 /* the next statement within the same where-body-construct */
6181 cnext = cnext->next;
6183 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6184 cblock = cblock->block;
6189 /* Resolve assignment in FORALL construct.
6190 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6191 FORALL index variables. */
6194 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
6198 for (n = 0; n < nvar; n++)
6200 gfc_symbol *forall_index;
6202 forall_index = var_expr[n]->symtree->n.sym;
6204 /* Check whether the assignment target is one of the FORALL index
6206 if ((code->expr->expr_type == EXPR_VARIABLE)
6207 && (code->expr->symtree->n.sym == forall_index))
6208 gfc_error ("Assignment to a FORALL index variable at %L",
6209 &code->expr->where);
6212 /* If one of the FORALL index variables doesn't appear in the
6213 assignment variable, then there could be a many-to-one
6214 assignment. Emit a warning rather than an error because the
6215 mask could be resolving this problem. */
6216 if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
6217 gfc_warning ("The FORALL with index '%s' is not used on the "
6218 "left side of the assignment at %L and so might "
6219 "cause multiple assignment to this object",
6220 var_expr[n]->symtree->name, &code->expr->where);
6226 /* Resolve WHERE statement in FORALL construct. */
6229 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
6230 gfc_expr **var_expr)
6235 cblock = code->block;
6238 /* the assignment statement of a WHERE statement, or the first
6239 statement in where-body-construct of a WHERE construct */
6240 cnext = cblock->next;
6245 /* WHERE assignment statement */
6247 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
6250 /* WHERE operator assignment statement */
6251 case EXEC_ASSIGN_CALL:
6252 resolve_call (cnext);
6253 if (!cnext->resolved_sym->attr.elemental)
6254 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6255 &cnext->ext.actual->expr->where);
6258 /* WHERE or WHERE construct is part of a where-body-construct */
6260 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
6264 gfc_error ("Unsupported statement inside WHERE at %L",
6267 /* the next statement within the same where-body-construct */
6268 cnext = cnext->next;
6270 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6271 cblock = cblock->block;
6276 /* Traverse the FORALL body to check whether the following errors exist:
6277 1. For assignment, check if a many-to-one assignment happens.
6278 2. For WHERE statement, check the WHERE body to see if there is any
6279 many-to-one assignment. */
6282 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
6286 c = code->block->next;
6292 case EXEC_POINTER_ASSIGN:
6293 gfc_resolve_assign_in_forall (c, nvar, var_expr);
6296 case EXEC_ASSIGN_CALL:
6300 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6301 there is no need to handle it here. */
6305 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
6310 /* The next statement in the FORALL body. */
6316 /* Counts the number of iterators needed inside a forall construct, including
6317 nested forall constructs. This is used to allocate the needed memory
6318 in gfc_resolve_forall. */
6321 gfc_count_forall_iterators (gfc_code *code)
6323 int max_iters, sub_iters, current_iters;
6324 gfc_forall_iterator *fa;
6326 gcc_assert(code->op == EXEC_FORALL);
6330 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6333 code = code->block->next;
6337 if (code->op == EXEC_FORALL)
6339 sub_iters = gfc_count_forall_iterators (code);
6340 if (sub_iters > max_iters)
6341 max_iters = sub_iters;
6346 return current_iters + max_iters;
6350 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6351 gfc_resolve_forall_body to resolve the FORALL body. */
6354 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
6356 static gfc_expr **var_expr;
6357 static int total_var = 0;
6358 static int nvar = 0;
6360 gfc_forall_iterator *fa;
6365 /* Start to resolve a FORALL construct */
6366 if (forall_save == 0)
6368 /* Count the total number of FORALL index in the nested FORALL
6369 construct in order to allocate the VAR_EXPR with proper size. */
6370 total_var = gfc_count_forall_iterators (code);
6372 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6373 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
6376 /* The information about FORALL iterator, including FORALL index start, end
6377 and stride. The FORALL index can not appear in start, end or stride. */
6378 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6380 /* Check if any outer FORALL index name is the same as the current
6382 for (i = 0; i < nvar; i++)
6384 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
6386 gfc_error ("An outer FORALL construct already has an index "
6387 "with this name %L", &fa->var->where);
6391 /* Record the current FORALL index. */
6392 var_expr[nvar] = gfc_copy_expr (fa->var);
6396 /* No memory leak. */
6397 gcc_assert (nvar <= total_var);
6400 /* Resolve the FORALL body. */
6401 gfc_resolve_forall_body (code, nvar, var_expr);
6403 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6404 gfc_resolve_blocks (code->block, ns);
6408 /* Free only the VAR_EXPRs allocated in this frame. */
6409 for (i = nvar; i < tmp; i++)
6410 gfc_free_expr (var_expr[i]);
6414 /* We are in the outermost FORALL construct. */
6415 gcc_assert (forall_save == 0);
6417 /* VAR_EXPR is not needed any more. */
6418 gfc_free (var_expr);
6424 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6427 static void resolve_code (gfc_code *, gfc_namespace *);
6430 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
6434 for (; b; b = b->block)
6436 t = gfc_resolve_expr (b->expr);
6437 if (gfc_resolve_expr (b->expr2) == FAILURE)
6443 if (t == SUCCESS && b->expr != NULL
6444 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
6445 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6452 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
6453 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6458 resolve_branch (b->label, b);
6471 case EXEC_OMP_ATOMIC:
6472 case EXEC_OMP_CRITICAL:
6474 case EXEC_OMP_MASTER:
6475 case EXEC_OMP_ORDERED:
6476 case EXEC_OMP_PARALLEL:
6477 case EXEC_OMP_PARALLEL_DO:
6478 case EXEC_OMP_PARALLEL_SECTIONS:
6479 case EXEC_OMP_PARALLEL_WORKSHARE:
6480 case EXEC_OMP_SECTIONS:
6481 case EXEC_OMP_SINGLE:
6483 case EXEC_OMP_TASKWAIT:
6484 case EXEC_OMP_WORKSHARE:
6488 gfc_internal_error ("resolve_block(): Bad block type");
6491 resolve_code (b->next, ns);
6496 /* Does everything to resolve an ordinary assignment. Returns true
6497 if this is an interface assignment. */
6499 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
6509 if (gfc_extend_assign (code, ns) == SUCCESS)
6511 lhs = code->ext.actual->expr;
6512 rhs = code->ext.actual->next->expr;
6513 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6515 gfc_error ("Subroutine '%s' called instead of assignment at "
6516 "%L must be PURE", code->symtree->n.sym->name,
6521 /* Make a temporary rhs when there is a default initializer
6522 and rhs is the same symbol as the lhs. */
6523 if (rhs->expr_type == EXPR_VARIABLE
6524 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6525 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6526 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6527 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6536 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
6537 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6538 &code->loc) == FAILURE)
6541 /* Handle the case of a BOZ literal on the RHS. */
6542 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
6545 if (gfc_option.warn_surprising)
6546 gfc_warning ("BOZ literal at %L is bitwise transferred "
6547 "non-integer symbol '%s'", &code->loc,
6548 lhs->symtree->n.sym->name);
6550 if (!gfc_convert_boz (rhs, &lhs->ts))
6552 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
6554 if (rc == ARITH_UNDERFLOW)
6555 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6556 ". This check can be disabled with the option "
6557 "-fno-range-check", &rhs->where);
6558 else if (rc == ARITH_OVERFLOW)
6559 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6560 ". This check can be disabled with the option "
6561 "-fno-range-check", &rhs->where);
6562 else if (rc == ARITH_NAN)
6563 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6564 ". This check can be disabled with the option "
6565 "-fno-range-check", &rhs->where);
6571 if (lhs->ts.type == BT_CHARACTER
6572 && gfc_option.warn_character_truncation)
6574 if (lhs->ts.cl != NULL
6575 && lhs->ts.cl->length != NULL
6576 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6577 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
6579 if (rhs->expr_type == EXPR_CONSTANT)
6580 rlen = rhs->value.character.length;
6582 else if (rhs->ts.cl != NULL
6583 && rhs->ts.cl->length != NULL
6584 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6585 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
6587 if (rlen && llen && rlen > llen)
6588 gfc_warning_now ("CHARACTER expression will be truncated "
6589 "in assignment (%d/%d) at %L",
6590 llen, rlen, &code->loc);
6593 /* Ensure that a vector index expression for the lvalue is evaluated
6594 to a temporary if the lvalue symbol is referenced in it. */
6597 for (ref = lhs->ref; ref; ref= ref->next)
6598 if (ref->type == REF_ARRAY)
6600 for (n = 0; n < ref->u.ar.dimen; n++)
6601 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
6602 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
6603 ref->u.ar.start[n]))
6605 = gfc_get_parentheses (ref->u.ar.start[n]);
6609 if (gfc_pure (NULL))
6611 if (gfc_impure_variable (lhs->symtree->n.sym))
6613 gfc_error ("Cannot assign to variable '%s' in PURE "
6615 lhs->symtree->n.sym->name,
6620 if (lhs->ts.type == BT_DERIVED
6621 && lhs->expr_type == EXPR_VARIABLE
6622 && lhs->ts.derived->attr.pointer_comp
6623 && gfc_impure_variable (rhs->symtree->n.sym))
6625 gfc_error ("The impure variable at %L is assigned to "
6626 "a derived type variable with a POINTER "
6627 "component in a PURE procedure (12.6)",
6633 gfc_check_assign (lhs, rhs, 1);
6637 /* Given a block of code, recursively resolve everything pointed to by this
6641 resolve_code (gfc_code *code, gfc_namespace *ns)
6643 int omp_workshare_save;
6648 frame.prev = cs_base;
6652 reachable_labels (code);
6654 for (; code; code = code->next)
6656 frame.current = code;
6657 forall_save = forall_flag;
6659 if (code->op == EXEC_FORALL)
6662 gfc_resolve_forall (code, ns, forall_save);
6665 else if (code->block)
6667 omp_workshare_save = -1;
6670 case EXEC_OMP_PARALLEL_WORKSHARE:
6671 omp_workshare_save = omp_workshare_flag;
6672 omp_workshare_flag = 1;
6673 gfc_resolve_omp_parallel_blocks (code, ns);
6675 case EXEC_OMP_PARALLEL:
6676 case EXEC_OMP_PARALLEL_DO:
6677 case EXEC_OMP_PARALLEL_SECTIONS:
6679 omp_workshare_save = omp_workshare_flag;
6680 omp_workshare_flag = 0;
6681 gfc_resolve_omp_parallel_blocks (code, ns);
6684 gfc_resolve_omp_do_blocks (code, ns);
6686 case EXEC_OMP_WORKSHARE:
6687 omp_workshare_save = omp_workshare_flag;
6688 omp_workshare_flag = 1;
6691 gfc_resolve_blocks (code->block, ns);
6695 if (omp_workshare_save != -1)
6696 omp_workshare_flag = omp_workshare_save;
6700 if (code->op != EXEC_COMPCALL)
6701 t = gfc_resolve_expr (code->expr);
6702 forall_flag = forall_save;
6704 if (gfc_resolve_expr (code->expr2) == FAILURE)
6719 /* Keep track of which entry we are up to. */
6720 current_entry_id = code->ext.entry->id;
6724 resolve_where (code, NULL);
6728 if (code->expr != NULL)
6730 if (code->expr->ts.type != BT_INTEGER)
6731 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6732 "INTEGER variable", &code->expr->where);
6733 else if (code->expr->symtree->n.sym->attr.assign != 1)
6734 gfc_error ("Variable '%s' has not been assigned a target "
6735 "label at %L", code->expr->symtree->n.sym->name,
6736 &code->expr->where);
6739 resolve_branch (code->label, code);
6743 if (code->expr != NULL
6744 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6745 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6746 "INTEGER return specifier", &code->expr->where);
6749 case EXEC_INIT_ASSIGN:
6756 if (resolve_ordinary_assign (code, ns))
6761 case EXEC_LABEL_ASSIGN:
6762 if (code->label->defined == ST_LABEL_UNKNOWN)
6763 gfc_error ("Label %d referenced at %L is never defined",
6764 code->label->value, &code->label->where);
6766 && (code->expr->expr_type != EXPR_VARIABLE
6767 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6768 || code->expr->symtree->n.sym->ts.kind
6769 != gfc_default_integer_kind
6770 || code->expr->symtree->n.sym->as != NULL))
6771 gfc_error ("ASSIGN statement at %L requires a scalar "
6772 "default INTEGER variable", &code->expr->where);
6775 case EXEC_POINTER_ASSIGN:
6779 gfc_check_pointer_assign (code->expr, code->expr2);
6782 case EXEC_ARITHMETIC_IF:
6784 && code->expr->ts.type != BT_INTEGER
6785 && code->expr->ts.type != BT_REAL)
6786 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6787 "expression", &code->expr->where);
6789 resolve_branch (code->label, code);
6790 resolve_branch (code->label2, code);
6791 resolve_branch (code->label3, code);
6795 if (t == SUCCESS && code->expr != NULL
6796 && (code->expr->ts.type != BT_LOGICAL
6797 || code->expr->rank != 0))
6798 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6799 &code->expr->where);
6804 resolve_call (code);
6808 resolve_typebound_call (code);
6812 /* Select is complicated. Also, a SELECT construct could be
6813 a transformed computed GOTO. */
6814 resolve_select (code);
6818 if (code->ext.iterator != NULL)
6820 gfc_iterator *iter = code->ext.iterator;
6821 if (gfc_resolve_iterator (iter, true) != FAILURE)
6822 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6827 if (code->expr == NULL)
6828 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6830 && (code->expr->rank != 0
6831 || code->expr->ts.type != BT_LOGICAL))
6832 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6833 "a scalar LOGICAL expression", &code->expr->where);
6838 resolve_allocate_deallocate (code, "ALLOCATE");
6842 case EXEC_DEALLOCATE:
6844 resolve_allocate_deallocate (code, "DEALLOCATE");
6849 if (gfc_resolve_open (code->ext.open) == FAILURE)
6852 resolve_branch (code->ext.open->err, code);
6856 if (gfc_resolve_close (code->ext.close) == FAILURE)
6859 resolve_branch (code->ext.close->err, code);
6862 case EXEC_BACKSPACE:
6866 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6869 resolve_branch (code->ext.filepos->err, code);
6873 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6876 resolve_branch (code->ext.inquire->err, code);
6880 gcc_assert (code->ext.inquire != NULL);
6881 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6884 resolve_branch (code->ext.inquire->err, code);
6888 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
6891 resolve_branch (code->ext.wait->err, code);
6892 resolve_branch (code->ext.wait->end, code);
6893 resolve_branch (code->ext.wait->eor, code);
6898 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6901 resolve_branch (code->ext.dt->err, code);
6902 resolve_branch (code->ext.dt->end, code);
6903 resolve_branch (code->ext.dt->eor, code);
6907 resolve_transfer (code);
6911 resolve_forall_iterators (code->ext.forall_iterator);
6913 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6914 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6915 "expression", &code->expr->where);
6918 case EXEC_OMP_ATOMIC:
6919 case EXEC_OMP_BARRIER:
6920 case EXEC_OMP_CRITICAL:
6921 case EXEC_OMP_FLUSH:
6923 case EXEC_OMP_MASTER:
6924 case EXEC_OMP_ORDERED:
6925 case EXEC_OMP_SECTIONS:
6926 case EXEC_OMP_SINGLE:
6927 case EXEC_OMP_TASKWAIT:
6928 case EXEC_OMP_WORKSHARE:
6929 gfc_resolve_omp_directive (code, ns);
6932 case EXEC_OMP_PARALLEL:
6933 case EXEC_OMP_PARALLEL_DO:
6934 case EXEC_OMP_PARALLEL_SECTIONS:
6935 case EXEC_OMP_PARALLEL_WORKSHARE:
6937 omp_workshare_save = omp_workshare_flag;
6938 omp_workshare_flag = 0;
6939 gfc_resolve_omp_directive (code, ns);
6940 omp_workshare_flag = omp_workshare_save;
6944 gfc_internal_error ("resolve_code(): Bad statement code");
6948 cs_base = frame.prev;
6952 /* Resolve initial values and make sure they are compatible with
6956 resolve_values (gfc_symbol *sym)
6958 if (sym->value == NULL)
6961 if (gfc_resolve_expr (sym->value) == FAILURE)
6964 gfc_check_assign_symbol (sym, sym->value);
6968 /* Verify the binding labels for common blocks that are BIND(C). The label
6969 for a BIND(C) common block must be identical in all scoping units in which
6970 the common block is declared. Further, the binding label can not collide
6971 with any other global entity in the program. */
6974 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6976 if (comm_block_tree->n.common->is_bind_c == 1)
6978 gfc_gsymbol *binding_label_gsym;
6979 gfc_gsymbol *comm_name_gsym;
6981 /* See if a global symbol exists by the common block's name. It may
6982 be NULL if the common block is use-associated. */
6983 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6984 comm_block_tree->n.common->name);
6985 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6986 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6987 "with the global entity '%s' at %L",
6988 comm_block_tree->n.common->binding_label,
6989 comm_block_tree->n.common->name,
6990 &(comm_block_tree->n.common->where),
6991 comm_name_gsym->name, &(comm_name_gsym->where));
6992 else if (comm_name_gsym != NULL
6993 && strcmp (comm_name_gsym->name,
6994 comm_block_tree->n.common->name) == 0)
6996 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6998 if (comm_name_gsym->binding_label == NULL)
6999 /* No binding label for common block stored yet; save this one. */
7000 comm_name_gsym->binding_label =
7001 comm_block_tree->n.common->binding_label;
7003 if (strcmp (comm_name_gsym->binding_label,
7004 comm_block_tree->n.common->binding_label) != 0)
7006 /* Common block names match but binding labels do not. */
7007 gfc_error ("Binding label '%s' for common block '%s' at %L "
7008 "does not match the binding label '%s' for common "
7010 comm_block_tree->n.common->binding_label,
7011 comm_block_tree->n.common->name,
7012 &(comm_block_tree->n.common->where),
7013 comm_name_gsym->binding_label,
7014 comm_name_gsym->name,
7015 &(comm_name_gsym->where));
7020 /* There is no binding label (NAME="") so we have nothing further to
7021 check and nothing to add as a global symbol for the label. */
7022 if (comm_block_tree->n.common->binding_label[0] == '\0' )
7025 binding_label_gsym =
7026 gfc_find_gsymbol (gfc_gsym_root,
7027 comm_block_tree->n.common->binding_label);
7028 if (binding_label_gsym == NULL)
7030 /* Need to make a global symbol for the binding label to prevent
7031 it from colliding with another. */
7032 binding_label_gsym =
7033 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
7034 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
7035 binding_label_gsym->type = GSYM_COMMON;
7039 /* If comm_name_gsym is NULL, the name common block is use
7040 associated and the name could be colliding. */
7041 if (binding_label_gsym->type != GSYM_COMMON)
7042 gfc_error ("Binding label '%s' for common block '%s' at %L "
7043 "collides with the global entity '%s' at %L",
7044 comm_block_tree->n.common->binding_label,
7045 comm_block_tree->n.common->name,
7046 &(comm_block_tree->n.common->where),
7047 binding_label_gsym->name,
7048 &(binding_label_gsym->where));
7049 else if (comm_name_gsym != NULL
7050 && (strcmp (binding_label_gsym->name,
7051 comm_name_gsym->binding_label) != 0)
7052 && (strcmp (binding_label_gsym->sym_name,
7053 comm_name_gsym->name) != 0))
7054 gfc_error ("Binding label '%s' for common block '%s' at %L "
7055 "collides with global entity '%s' at %L",
7056 binding_label_gsym->name, binding_label_gsym->sym_name,
7057 &(comm_block_tree->n.common->where),
7058 comm_name_gsym->name, &(comm_name_gsym->where));
7066 /* Verify any BIND(C) derived types in the namespace so we can report errors
7067 for them once, rather than for each variable declared of that type. */
7070 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
7072 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
7073 && derived_sym->attr.is_bind_c == 1)
7074 verify_bind_c_derived_type (derived_sym);
7080 /* Verify that any binding labels used in a given namespace do not collide
7081 with the names or binding labels of any global symbols. */
7084 gfc_verify_binding_labels (gfc_symbol *sym)
7088 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
7089 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
7091 gfc_gsymbol *bind_c_sym;
7093 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
7094 if (bind_c_sym != NULL
7095 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
7097 if (sym->attr.if_source == IFSRC_DECL
7098 && (bind_c_sym->type != GSYM_SUBROUTINE
7099 && bind_c_sym->type != GSYM_FUNCTION)
7100 && ((sym->attr.contained == 1
7101 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
7102 || (sym->attr.use_assoc == 1
7103 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
7105 /* Make sure global procedures don't collide with anything. */
7106 gfc_error ("Binding label '%s' at %L collides with the global "
7107 "entity '%s' at %L", sym->binding_label,
7108 &(sym->declared_at), bind_c_sym->name,
7109 &(bind_c_sym->where));
7112 else if (sym->attr.contained == 0
7113 && (sym->attr.if_source == IFSRC_IFBODY
7114 && sym->attr.flavor == FL_PROCEDURE)
7115 && (bind_c_sym->sym_name != NULL
7116 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
7118 /* Make sure procedures in interface bodies don't collide. */
7119 gfc_error ("Binding label '%s' in interface body at %L collides "
7120 "with the global entity '%s' at %L",
7122 &(sym->declared_at), bind_c_sym->name,
7123 &(bind_c_sym->where));
7126 else if (sym->attr.contained == 0
7127 && sym->attr.if_source == IFSRC_UNKNOWN)
7128 if ((sym->attr.use_assoc && bind_c_sym->mod_name
7129 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
7130 || sym->attr.use_assoc == 0)
7132 gfc_error ("Binding label '%s' at %L collides with global "
7133 "entity '%s' at %L", sym->binding_label,
7134 &(sym->declared_at), bind_c_sym->name,
7135 &(bind_c_sym->where));
7140 /* Clear the binding label to prevent checking multiple times. */
7141 sym->binding_label[0] = '\0';
7143 else if (bind_c_sym == NULL)
7145 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
7146 bind_c_sym->where = sym->declared_at;
7147 bind_c_sym->sym_name = sym->name;
7149 if (sym->attr.use_assoc == 1)
7150 bind_c_sym->mod_name = sym->module;
7152 if (sym->ns->proc_name != NULL)
7153 bind_c_sym->mod_name = sym->ns->proc_name->name;
7155 if (sym->attr.contained == 0)
7157 if (sym->attr.subroutine)
7158 bind_c_sym->type = GSYM_SUBROUTINE;
7159 else if (sym->attr.function)
7160 bind_c_sym->type = GSYM_FUNCTION;
7168 /* Resolve an index expression. */
7171 resolve_index_expr (gfc_expr *e)
7173 if (gfc_resolve_expr (e) == FAILURE)
7176 if (gfc_simplify_expr (e, 0) == FAILURE)
7179 if (gfc_specification_expr (e) == FAILURE)
7185 /* Resolve a charlen structure. */
7188 resolve_charlen (gfc_charlen *cl)
7197 specification_expr = 1;
7199 if (resolve_index_expr (cl->length) == FAILURE)
7201 specification_expr = 0;
7205 /* "If the character length parameter value evaluates to a negative
7206 value, the length of character entities declared is zero." */
7207 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
7209 gfc_warning_now ("CHARACTER variable has zero length at %L",
7210 &cl->length->where);
7211 gfc_replace_expr (cl->length, gfc_int_expr (0));
7218 /* Test for non-constant shape arrays. */
7221 is_non_constant_shape_array (gfc_symbol *sym)
7227 not_constant = false;
7228 if (sym->as != NULL)
7230 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7231 has not been simplified; parameter array references. Do the
7232 simplification now. */
7233 for (i = 0; i < sym->as->rank; i++)
7235 e = sym->as->lower[i];
7236 if (e && (resolve_index_expr (e) == FAILURE
7237 || !gfc_is_constant_expr (e)))
7238 not_constant = true;
7240 e = sym->as->upper[i];
7241 if (e && (resolve_index_expr (e) == FAILURE
7242 || !gfc_is_constant_expr (e)))
7243 not_constant = true;
7246 return not_constant;
7249 /* Given a symbol and an initialization expression, add code to initialize
7250 the symbol to the function entry. */
7252 build_init_assign (gfc_symbol *sym, gfc_expr *init)
7256 gfc_namespace *ns = sym->ns;
7258 /* Search for the function namespace if this is a contained
7259 function without an explicit result. */
7260 if (sym->attr.function && sym == sym->result
7261 && sym->name != sym->ns->proc_name->name)
7264 for (;ns; ns = ns->sibling)
7265 if (strcmp (ns->proc_name->name, sym->name) == 0)
7271 gfc_free_expr (init);
7275 /* Build an l-value expression for the result. */
7276 lval = gfc_lval_expr_from_sym (sym);
7278 /* Add the code at scope entry. */
7279 init_st = gfc_get_code ();
7280 init_st->next = ns->code;
7283 /* Assign the default initializer to the l-value. */
7284 init_st->loc = sym->declared_at;
7285 init_st->op = EXEC_INIT_ASSIGN;
7286 init_st->expr = lval;
7287 init_st->expr2 = init;
7290 /* Assign the default initializer to a derived type variable or result. */
7293 apply_default_init (gfc_symbol *sym)
7295 gfc_expr *init = NULL;
7297 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7300 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
7301 init = gfc_default_initializer (&sym->ts);
7306 build_init_assign (sym, init);
7309 /* Build an initializer for a local integer, real, complex, logical, or
7310 character variable, based on the command line flags finit-local-zero,
7311 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7312 null if the symbol should not have a default initialization. */
7314 build_default_init_expr (gfc_symbol *sym)
7317 gfc_expr *init_expr;
7320 /* These symbols should never have a default initialization. */
7321 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
7322 || sym->attr.external
7324 || sym->attr.pointer
7325 || sym->attr.in_equivalence
7326 || sym->attr.in_common
7329 || sym->attr.cray_pointee
7330 || sym->attr.cray_pointer)
7333 /* Now we'll try to build an initializer expression. */
7334 init_expr = gfc_get_expr ();
7335 init_expr->expr_type = EXPR_CONSTANT;
7336 init_expr->ts.type = sym->ts.type;
7337 init_expr->ts.kind = sym->ts.kind;
7338 init_expr->where = sym->declared_at;
7340 /* We will only initialize integers, reals, complex, logicals, and
7341 characters, and only if the corresponding command-line flags
7342 were set. Otherwise, we free init_expr and return null. */
7343 switch (sym->ts.type)
7346 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
7347 mpz_init_set_si (init_expr->value.integer,
7348 gfc_option.flag_init_integer_value);
7351 gfc_free_expr (init_expr);
7357 mpfr_init (init_expr->value.real);
7358 switch (gfc_option.flag_init_real)
7360 case GFC_INIT_REAL_NAN:
7361 mpfr_set_nan (init_expr->value.real);
7364 case GFC_INIT_REAL_INF:
7365 mpfr_set_inf (init_expr->value.real, 1);
7368 case GFC_INIT_REAL_NEG_INF:
7369 mpfr_set_inf (init_expr->value.real, -1);
7372 case GFC_INIT_REAL_ZERO:
7373 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
7377 gfc_free_expr (init_expr);
7384 mpfr_init (init_expr->value.complex.r);
7385 mpfr_init (init_expr->value.complex.i);
7386 switch (gfc_option.flag_init_real)
7388 case GFC_INIT_REAL_NAN:
7389 mpfr_set_nan (init_expr->value.complex.r);
7390 mpfr_set_nan (init_expr->value.complex.i);
7393 case GFC_INIT_REAL_INF:
7394 mpfr_set_inf (init_expr->value.complex.r, 1);
7395 mpfr_set_inf (init_expr->value.complex.i, 1);
7398 case GFC_INIT_REAL_NEG_INF:
7399 mpfr_set_inf (init_expr->value.complex.r, -1);
7400 mpfr_set_inf (init_expr->value.complex.i, -1);
7403 case GFC_INIT_REAL_ZERO:
7404 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
7405 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
7409 gfc_free_expr (init_expr);
7416 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
7417 init_expr->value.logical = 0;
7418 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
7419 init_expr->value.logical = 1;
7422 gfc_free_expr (init_expr);
7428 /* For characters, the length must be constant in order to
7429 create a default initializer. */
7430 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
7431 && sym->ts.cl->length
7432 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
7434 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
7435 init_expr->value.character.length = char_len;
7436 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
7437 for (i = 0; i < char_len; i++)
7438 init_expr->value.character.string[i]
7439 = (unsigned char) gfc_option.flag_init_character_value;
7443 gfc_free_expr (init_expr);
7449 gfc_free_expr (init_expr);
7455 /* Add an initialization expression to a local variable. */
7457 apply_default_init_local (gfc_symbol *sym)
7459 gfc_expr *init = NULL;
7461 /* The symbol should be a variable or a function return value. */
7462 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7463 || (sym->attr.function && sym->result != sym))
7466 /* Try to build the initializer expression. If we can't initialize
7467 this symbol, then init will be NULL. */
7468 init = build_default_init_expr (sym);
7472 /* For saved variables, we don't want to add an initializer at
7473 function entry, so we just add a static initializer. */
7474 if (sym->attr.save || sym->ns->save_all)
7476 /* Don't clobber an existing initializer! */
7477 gcc_assert (sym->value == NULL);
7482 build_init_assign (sym, init);
7485 /* Resolution of common features of flavors variable and procedure. */
7488 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
7490 /* Constraints on deferred shape variable. */
7491 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
7493 if (sym->attr.allocatable)
7495 if (sym->attr.dimension)
7496 gfc_error ("Allocatable array '%s' at %L must have "
7497 "a deferred shape", sym->name, &sym->declared_at);
7499 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7500 sym->name, &sym->declared_at);
7504 if (sym->attr.pointer && sym->attr.dimension)
7506 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7507 sym->name, &sym->declared_at);
7514 if (!mp_flag && !sym->attr.allocatable
7515 && !sym->attr.pointer && !sym->attr.dummy)
7517 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7518 sym->name, &sym->declared_at);
7526 /* Additional checks for symbols with flavor variable and derived
7527 type. To be called from resolve_fl_variable. */
7530 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
7532 gcc_assert (sym->ts.type == BT_DERIVED);
7534 /* Check to see if a derived type is blocked from being host
7535 associated by the presence of another class I symbol in the same
7536 namespace. 14.6.1.3 of the standard and the discussion on
7537 comp.lang.fortran. */
7538 if (sym->ns != sym->ts.derived->ns
7539 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
7542 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
7543 if (s && s->attr.flavor != FL_DERIVED)
7545 gfc_error ("The type '%s' cannot be host associated at %L "
7546 "because it is blocked by an incompatible object "
7547 "of the same name declared at %L",
7548 sym->ts.derived->name, &sym->declared_at,
7554 /* 4th constraint in section 11.3: "If an object of a type for which
7555 component-initialization is specified (R429) appears in the
7556 specification-part of a module and does not have the ALLOCATABLE
7557 or POINTER attribute, the object shall have the SAVE attribute."
7559 The check for initializers is performed with
7560 has_default_initializer because gfc_default_initializer generates
7561 a hidden default for allocatable components. */
7562 if (!(sym->value || no_init_flag) && sym->ns->proc_name
7563 && sym->ns->proc_name->attr.flavor == FL_MODULE
7564 && !sym->ns->save_all && !sym->attr.save
7565 && !sym->attr.pointer && !sym->attr.allocatable
7566 && has_default_initializer (sym->ts.derived))
7568 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7569 "default initialization of a component",
7570 sym->name, &sym->declared_at);
7574 /* Assign default initializer. */
7575 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
7576 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
7578 sym->value = gfc_default_initializer (&sym->ts);
7585 /* Resolve symbols with flavor variable. */
7588 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
7590 int no_init_flag, automatic_flag;
7592 const char *auto_save_msg;
7594 auto_save_msg = "Automatic object '%s' at %L cannot have the "
7597 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7600 /* Set this flag to check that variables are parameters of all entries.
7601 This check is effected by the call to gfc_resolve_expr through
7602 is_non_constant_shape_array. */
7603 specification_expr = 1;
7605 if (sym->ns->proc_name
7606 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7607 || sym->ns->proc_name->attr.is_main_program)
7608 && !sym->attr.use_assoc
7609 && !sym->attr.allocatable
7610 && !sym->attr.pointer
7611 && is_non_constant_shape_array (sym))
7613 /* The shape of a main program or module array needs to be
7615 gfc_error ("The module or main program array '%s' at %L must "
7616 "have constant shape", sym->name, &sym->declared_at);
7617 specification_expr = 0;
7621 if (sym->ts.type == BT_CHARACTER)
7623 /* Make sure that character string variables with assumed length are
7625 e = sym->ts.cl->length;
7626 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
7628 gfc_error ("Entity with assumed character length at %L must be a "
7629 "dummy argument or a PARAMETER", &sym->declared_at);
7633 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7635 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7639 if (!gfc_is_constant_expr (e)
7640 && !(e->expr_type == EXPR_VARIABLE
7641 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7642 && sym->ns->proc_name
7643 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7644 || sym->ns->proc_name->attr.is_main_program)
7645 && !sym->attr.use_assoc)
7647 gfc_error ("'%s' at %L must have constant character length "
7648 "in this context", sym->name, &sym->declared_at);
7653 if (sym->value == NULL && sym->attr.referenced)
7654 apply_default_init_local (sym); /* Try to apply a default initialization. */
7656 /* Determine if the symbol may not have an initializer. */
7657 no_init_flag = automatic_flag = 0;
7658 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7659 || sym->attr.intrinsic || sym->attr.result)
7661 else if (sym->attr.dimension && !sym->attr.pointer
7662 && is_non_constant_shape_array (sym))
7664 no_init_flag = automatic_flag = 1;
7666 /* Also, they must not have the SAVE attribute.
7667 SAVE_IMPLICIT is checked below. */
7668 if (sym->attr.save == SAVE_EXPLICIT)
7670 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7675 /* Ensure that any initializer is simplified. */
7677 gfc_simplify_expr (sym->value, 1);
7679 /* Reject illegal initializers. */
7680 if (!sym->mark && sym->value)
7682 if (sym->attr.allocatable)
7683 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7684 sym->name, &sym->declared_at);
7685 else if (sym->attr.external)
7686 gfc_error ("External '%s' at %L cannot have an initializer",
7687 sym->name, &sym->declared_at);
7688 else if (sym->attr.dummy
7689 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7690 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7691 sym->name, &sym->declared_at);
7692 else if (sym->attr.intrinsic)
7693 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7694 sym->name, &sym->declared_at);
7695 else if (sym->attr.result)
7696 gfc_error ("Function result '%s' at %L cannot have an initializer",
7697 sym->name, &sym->declared_at);
7698 else if (automatic_flag)
7699 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7700 sym->name, &sym->declared_at);
7707 if (sym->ts.type == BT_DERIVED)
7708 return resolve_fl_variable_derived (sym, no_init_flag);
7714 /* Resolve a procedure. */
7717 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7719 gfc_formal_arglist *arg;
7721 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7722 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7723 "interfaces", sym->name, &sym->declared_at);
7725 if (sym->attr.function
7726 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7729 if (sym->ts.type == BT_CHARACTER)
7731 gfc_charlen *cl = sym->ts.cl;
7733 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7734 && resolve_charlen (cl) == FAILURE)
7737 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7739 if (sym->attr.proc == PROC_ST_FUNCTION)
7741 gfc_error ("Character-valued statement function '%s' at %L must "
7742 "have constant length", sym->name, &sym->declared_at);
7746 if (sym->attr.external && sym->formal == NULL
7747 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7749 gfc_error ("Automatic character length function '%s' at %L must "
7750 "have an explicit interface", sym->name,
7757 /* Ensure that derived type for are not of a private type. Internal
7758 module procedures are excluded by 2.2.3.3 - i.e., they are not
7759 externally accessible and can access all the objects accessible in
7761 if (!(sym->ns->parent
7762 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7763 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7765 gfc_interface *iface;
7767 for (arg = sym->formal; arg; arg = arg->next)
7770 && arg->sym->ts.type == BT_DERIVED
7771 && !arg->sym->ts.derived->attr.use_assoc
7772 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7773 arg->sym->ts.derived->ns->default_access)
7774 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7775 "PRIVATE type and cannot be a dummy argument"
7776 " of '%s', which is PUBLIC at %L",
7777 arg->sym->name, sym->name, &sym->declared_at)
7780 /* Stop this message from recurring. */
7781 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7786 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7787 PRIVATE to the containing module. */
7788 for (iface = sym->generic; iface; iface = iface->next)
7790 for (arg = iface->sym->formal; arg; arg = arg->next)
7793 && arg->sym->ts.type == BT_DERIVED
7794 && !arg->sym->ts.derived->attr.use_assoc
7795 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7796 arg->sym->ts.derived->ns->default_access)
7797 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7798 "'%s' in PUBLIC interface '%s' at %L "
7799 "takes dummy arguments of '%s' which is "
7800 "PRIVATE", iface->sym->name, sym->name,
7801 &iface->sym->declared_at,
7802 gfc_typename (&arg->sym->ts)) == FAILURE)
7804 /* Stop this message from recurring. */
7805 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7811 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7812 PRIVATE to the containing module. */
7813 for (iface = sym->generic; iface; iface = iface->next)
7815 for (arg = iface->sym->formal; arg; arg = arg->next)
7818 && arg->sym->ts.type == BT_DERIVED
7819 && !arg->sym->ts.derived->attr.use_assoc
7820 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7821 arg->sym->ts.derived->ns->default_access)
7822 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7823 "'%s' in PUBLIC interface '%s' at %L "
7824 "takes dummy arguments of '%s' which is "
7825 "PRIVATE", iface->sym->name, sym->name,
7826 &iface->sym->declared_at,
7827 gfc_typename (&arg->sym->ts)) == FAILURE)
7829 /* Stop this message from recurring. */
7830 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7837 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
7838 && !sym->attr.proc_pointer)
7840 gfc_error ("Function '%s' at %L cannot have an initializer",
7841 sym->name, &sym->declared_at);
7845 /* An external symbol may not have an initializer because it is taken to be
7846 a procedure. Exception: Procedure Pointers. */
7847 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
7849 gfc_error ("External object '%s' at %L may not have an initializer",
7850 sym->name, &sym->declared_at);
7854 /* An elemental function is required to return a scalar 12.7.1 */
7855 if (sym->attr.elemental && sym->attr.function && sym->as)
7857 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7858 "result", sym->name, &sym->declared_at);
7859 /* Reset so that the error only occurs once. */
7860 sym->attr.elemental = 0;
7864 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7865 char-len-param shall not be array-valued, pointer-valued, recursive
7866 or pure. ....snip... A character value of * may only be used in the
7867 following ways: (i) Dummy arg of procedure - dummy associates with
7868 actual length; (ii) To declare a named constant; or (iii) External
7869 function - but length must be declared in calling scoping unit. */
7870 if (sym->attr.function
7871 && sym->ts.type == BT_CHARACTER
7872 && sym->ts.cl && sym->ts.cl->length == NULL)
7874 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7875 || (sym->attr.recursive) || (sym->attr.pure))
7877 if (sym->as && sym->as->rank)
7878 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7879 "array-valued", sym->name, &sym->declared_at);
7881 if (sym->attr.pointer)
7882 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7883 "pointer-valued", sym->name, &sym->declared_at);
7886 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7887 "pure", sym->name, &sym->declared_at);
7889 if (sym->attr.recursive)
7890 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7891 "recursive", sym->name, &sym->declared_at);
7896 /* Appendix B.2 of the standard. Contained functions give an
7897 error anyway. Fixed-form is likely to be F77/legacy. */
7898 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7899 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7900 "'%s' at %L is obsolescent in fortran 95",
7901 sym->name, &sym->declared_at);
7904 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7906 gfc_formal_arglist *curr_arg;
7907 int has_non_interop_arg = 0;
7909 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7910 sym->common_block) == FAILURE)
7912 /* Clear these to prevent looking at them again if there was an
7914 sym->attr.is_bind_c = 0;
7915 sym->attr.is_c_interop = 0;
7916 sym->ts.is_c_interop = 0;
7920 /* So far, no errors have been found. */
7921 sym->attr.is_c_interop = 1;
7922 sym->ts.is_c_interop = 1;
7925 curr_arg = sym->formal;
7926 while (curr_arg != NULL)
7928 /* Skip implicitly typed dummy args here. */
7929 if (curr_arg->sym->attr.implicit_type == 0)
7930 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7931 /* If something is found to fail, record the fact so we
7932 can mark the symbol for the procedure as not being
7933 BIND(C) to try and prevent multiple errors being
7935 has_non_interop_arg = 1;
7937 curr_arg = curr_arg->next;
7940 /* See if any of the arguments were not interoperable and if so, clear
7941 the procedure symbol to prevent duplicate error messages. */
7942 if (has_non_interop_arg != 0)
7944 sym->attr.is_c_interop = 0;
7945 sym->ts.is_c_interop = 0;
7946 sym->attr.is_bind_c = 0;
7950 if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
7952 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
7953 "in '%s' at %L", sym->name, &sym->declared_at);
7957 if (sym->attr.intent && !sym->attr.proc_pointer)
7959 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
7960 "in '%s' at %L", sym->name, &sym->declared_at);
7968 /* Resolve a list of finalizer procedures. That is, after they have hopefully
7969 been defined and we now know their defined arguments, check that they fulfill
7970 the requirements of the standard for procedures used as finalizers. */
7973 gfc_resolve_finalizers (gfc_symbol* derived)
7975 gfc_finalizer* list;
7976 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
7977 gfc_try result = SUCCESS;
7978 bool seen_scalar = false;
7980 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
7983 /* Walk over the list of finalizer-procedures, check them, and if any one
7984 does not fit in with the standard's definition, print an error and remove
7985 it from the list. */
7986 prev_link = &derived->f2k_derived->finalizers;
7987 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
7993 /* Skip this finalizer if we already resolved it. */
7994 if (list->proc_tree)
7996 prev_link = &(list->next);
8000 /* Check this exists and is a SUBROUTINE. */
8001 if (!list->proc_sym->attr.subroutine)
8003 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
8004 list->proc_sym->name, &list->where);
8008 /* We should have exactly one argument. */
8009 if (!list->proc_sym->formal || list->proc_sym->formal->next)
8011 gfc_error ("FINAL procedure at %L must have exactly one argument",
8015 arg = list->proc_sym->formal->sym;
8017 /* This argument must be of our type. */
8018 if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
8020 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
8021 &arg->declared_at, derived->name);
8025 /* It must neither be a pointer nor allocatable nor optional. */
8026 if (arg->attr.pointer)
8028 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
8032 if (arg->attr.allocatable)
8034 gfc_error ("Argument of FINAL procedure at %L must not be"
8035 " ALLOCATABLE", &arg->declared_at);
8038 if (arg->attr.optional)
8040 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
8045 /* It must not be INTENT(OUT). */
8046 if (arg->attr.intent == INTENT_OUT)
8048 gfc_error ("Argument of FINAL procedure at %L must not be"
8049 " INTENT(OUT)", &arg->declared_at);
8053 /* Warn if the procedure is non-scalar and not assumed shape. */
8054 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
8055 && arg->as->type != AS_ASSUMED_SHAPE)
8056 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
8057 " shape argument", &arg->declared_at);
8059 /* Check that it does not match in kind and rank with a FINAL procedure
8060 defined earlier. To really loop over the *earlier* declarations,
8061 we need to walk the tail of the list as new ones were pushed at the
8063 /* TODO: Handle kind parameters once they are implemented. */
8064 my_rank = (arg->as ? arg->as->rank : 0);
8065 for (i = list->next; i; i = i->next)
8067 /* Argument list might be empty; that is an error signalled earlier,
8068 but we nevertheless continued resolving. */
8069 if (i->proc_sym->formal)
8071 gfc_symbol* i_arg = i->proc_sym->formal->sym;
8072 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
8073 if (i_rank == my_rank)
8075 gfc_error ("FINAL procedure '%s' declared at %L has the same"
8076 " rank (%d) as '%s'",
8077 list->proc_sym->name, &list->where, my_rank,
8084 /* Is this the/a scalar finalizer procedure? */
8085 if (!arg->as || arg->as->rank == 0)
8088 /* Find the symtree for this procedure. */
8089 gcc_assert (!list->proc_tree);
8090 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
8092 prev_link = &list->next;
8095 /* Remove wrong nodes immediately from the list so we don't risk any
8096 troubles in the future when they might fail later expectations. */
8100 *prev_link = list->next;
8101 gfc_free_finalizer (i);
8104 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
8105 were nodes in the list, must have been for arrays. It is surely a good
8106 idea to have a scalar version there if there's something to finalize. */
8107 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
8108 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
8109 " defined at %L, suggest also scalar one",
8110 derived->name, &derived->declared_at);
8112 /* TODO: Remove this error when finalization is finished. */
8113 gfc_error ("Finalization at %L is not yet implemented",
8114 &derived->declared_at);
8120 /* Check that it is ok for the typebound procedure proc to override the
8124 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
8127 const gfc_symbol* proc_target;
8128 const gfc_symbol* old_target;
8129 unsigned proc_pass_arg, old_pass_arg, argpos;
8130 gfc_formal_arglist* proc_formal;
8131 gfc_formal_arglist* old_formal;
8133 /* This procedure should only be called for non-GENERIC proc. */
8134 gcc_assert (!proc->typebound->is_generic);
8136 /* If the overwritten procedure is GENERIC, this is an error. */
8137 if (old->typebound->is_generic)
8139 gfc_error ("Can't overwrite GENERIC '%s' at %L",
8140 old->name, &proc->typebound->where);
8144 where = proc->typebound->where;
8145 proc_target = proc->typebound->u.specific->n.sym;
8146 old_target = old->typebound->u.specific->n.sym;
8148 /* Check that overridden binding is not NON_OVERRIDABLE. */
8149 if (old->typebound->non_overridable)
8151 gfc_error ("'%s' at %L overrides a procedure binding declared"
8152 " NON_OVERRIDABLE", proc->name, &where);
8156 /* If the overridden binding is PURE, the overriding must be, too. */
8157 if (old_target->attr.pure && !proc_target->attr.pure)
8159 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
8160 proc->name, &where);
8164 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
8165 is not, the overriding must not be either. */
8166 if (old_target->attr.elemental && !proc_target->attr.elemental)
8168 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
8169 " ELEMENTAL", proc->name, &where);
8172 if (!old_target->attr.elemental && proc_target->attr.elemental)
8174 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
8175 " be ELEMENTAL, either", proc->name, &where);
8179 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
8181 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
8183 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
8184 " SUBROUTINE", proc->name, &where);
8188 /* If the overridden binding is a FUNCTION, the overriding must also be a
8189 FUNCTION and have the same characteristics. */
8190 if (old_target->attr.function)
8192 if (!proc_target->attr.function)
8194 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
8195 " FUNCTION", proc->name, &where);
8199 /* FIXME: Do more comprehensive checking (including, for instance, the
8200 rank and array-shape). */
8201 gcc_assert (proc_target->result && old_target->result);
8202 if (!gfc_compare_types (&proc_target->result->ts,
8203 &old_target->result->ts))
8205 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
8206 " matching result types", proc->name, &where);
8211 /* If the overridden binding is PUBLIC, the overriding one must not be
8213 if (old->typebound->access == ACCESS_PUBLIC
8214 && proc->typebound->access == ACCESS_PRIVATE)
8216 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
8217 " PRIVATE", proc->name, &where);
8221 /* Compare the formal argument lists of both procedures. This is also abused
8222 to find the position of the passed-object dummy arguments of both
8223 bindings as at least the overridden one might not yet be resolved and we
8224 need those positions in the check below. */
8225 proc_pass_arg = old_pass_arg = 0;
8226 if (!proc->typebound->nopass && !proc->typebound->pass_arg)
8228 if (!old->typebound->nopass && !old->typebound->pass_arg)
8231 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
8232 proc_formal && old_formal;
8233 proc_formal = proc_formal->next, old_formal = old_formal->next)
8235 if (proc->typebound->pass_arg
8236 && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name))
8237 proc_pass_arg = argpos;
8238 if (old->typebound->pass_arg
8239 && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
8240 old_pass_arg = argpos;
8242 /* Check that the names correspond. */
8243 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
8245 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8246 " to match the corresponding argument of the overridden"
8247 " procedure", proc_formal->sym->name, proc->name, &where,
8248 old_formal->sym->name);
8252 /* Check that the types correspond if neither is the passed-object
8254 /* FIXME: Do more comprehensive testing here. */
8255 if (proc_pass_arg != argpos && old_pass_arg != argpos
8256 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
8258 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8259 " in respect to the overridden procedure",
8260 proc_formal->sym->name, proc->name, &where);
8266 if (proc_formal || old_formal)
8268 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8269 " the overridden procedure", proc->name, &where);
8273 /* If the overridden binding is NOPASS, the overriding one must also be
8275 if (old->typebound->nopass && !proc->typebound->nopass)
8277 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8278 " NOPASS", proc->name, &where);
8282 /* If the overridden binding is PASS(x), the overriding one must also be
8283 PASS and the passed-object dummy arguments must correspond. */
8284 if (!old->typebound->nopass)
8286 if (proc->typebound->nopass)
8288 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8289 " PASS", proc->name, &where);
8293 if (proc_pass_arg != old_pass_arg)
8295 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8296 " the same position as the passed-object dummy argument of"
8297 " the overridden procedure", proc->name, &where);
8306 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8309 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
8310 const char* generic_name, locus where)
8315 gcc_assert (t1->specific && t2->specific);
8316 gcc_assert (!t1->specific->is_generic);
8317 gcc_assert (!t2->specific->is_generic);
8319 sym1 = t1->specific->u.specific->n.sym;
8320 sym2 = t2->specific->u.specific->n.sym;
8322 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8323 if (sym1->attr.subroutine != sym2->attr.subroutine
8324 || sym1->attr.function != sym2->attr.function)
8326 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8327 " GENERIC '%s' at %L",
8328 sym1->name, sym2->name, generic_name, &where);
8332 /* Compare the interfaces. */
8333 if (gfc_compare_interfaces (sym1, sym2, 1))
8335 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8336 sym1->name, sym2->name, generic_name, &where);
8344 /* Resolve a GENERIC procedure binding for a derived type. */
8347 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
8349 gfc_tbp_generic* target;
8350 gfc_symtree* first_target;
8351 gfc_symbol* super_type;
8352 gfc_symtree* inherited;
8355 gcc_assert (st->typebound);
8356 gcc_assert (st->typebound->is_generic);
8358 where = st->typebound->where;
8359 super_type = gfc_get_derived_super_type (derived);
8361 /* Find the overridden binding if any. */
8362 st->typebound->overridden = NULL;
8365 gfc_symtree* overridden;
8366 overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
8368 if (overridden && overridden->typebound)
8369 st->typebound->overridden = overridden->typebound;
8372 /* Try to find the specific bindings for the symtrees in our target-list. */
8373 gcc_assert (st->typebound->u.generic);
8374 for (target = st->typebound->u.generic; target; target = target->next)
8375 if (!target->specific)
8377 gfc_typebound_proc* overridden_tbp;
8379 const char* target_name;
8381 target_name = target->specific_st->name;
8383 /* Defined for this type directly. */
8384 if (target->specific_st->typebound)
8386 target->specific = target->specific_st->typebound;
8387 goto specific_found;
8390 /* Look for an inherited specific binding. */
8393 inherited = gfc_find_typebound_proc (super_type, NULL,
8398 gcc_assert (inherited->typebound);
8399 target->specific = inherited->typebound;
8400 goto specific_found;
8404 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8405 " at %L", target_name, st->name, &where);
8408 /* Once we've found the specific binding, check it is not ambiguous with
8409 other specifics already found or inherited for the same GENERIC. */
8411 gcc_assert (target->specific);
8413 /* This must really be a specific binding! */
8414 if (target->specific->is_generic)
8416 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8417 " '%s' is GENERIC, too", st->name, &where, target_name);
8421 /* Check those already resolved on this type directly. */
8422 for (g = st->typebound->u.generic; g; g = g->next)
8423 if (g != target && g->specific
8424 && check_generic_tbp_ambiguity (target, g, st->name, where)
8428 /* Check for ambiguity with inherited specific targets. */
8429 for (overridden_tbp = st->typebound->overridden; overridden_tbp;
8430 overridden_tbp = overridden_tbp->overridden)
8431 if (overridden_tbp->is_generic)
8433 for (g = overridden_tbp->u.generic; g; g = g->next)
8435 gcc_assert (g->specific);
8436 if (check_generic_tbp_ambiguity (target, g,
8437 st->name, where) == FAILURE)
8443 /* If we attempt to "overwrite" a specific binding, this is an error. */
8444 if (st->typebound->overridden && !st->typebound->overridden->is_generic)
8446 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8447 " the same name", st->name, &where);
8451 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8452 all must have the same attributes here. */
8453 first_target = st->typebound->u.generic->specific->u.specific;
8454 st->typebound->subroutine = first_target->n.sym->attr.subroutine;
8455 st->typebound->function = first_target->n.sym->attr.function;
8461 /* Resolve the type-bound procedures for a derived type. */
8463 static gfc_symbol* resolve_bindings_derived;
8464 static gfc_try resolve_bindings_result;
8467 resolve_typebound_procedure (gfc_symtree* stree)
8472 gfc_symbol* super_type;
8473 gfc_component* comp;
8475 /* If this is no type-bound procedure, just return. */
8476 if (!stree->typebound)
8479 /* If this is a GENERIC binding, use that routine. */
8480 if (stree->typebound->is_generic)
8482 if (resolve_typebound_generic (resolve_bindings_derived, stree)
8488 /* Get the target-procedure to check it. */
8489 gcc_assert (!stree->typebound->is_generic);
8490 gcc_assert (stree->typebound->u.specific);
8491 proc = stree->typebound->u.specific->n.sym;
8492 where = stree->typebound->where;
8494 /* Default access should already be resolved from the parser. */
8495 gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
8497 /* It should be a module procedure or an external procedure with explicit
8499 if ((!proc->attr.subroutine && !proc->attr.function)
8500 || (proc->attr.proc != PROC_MODULE
8501 && proc->attr.if_source != IFSRC_IFBODY)
8502 || proc->attr.abstract)
8504 gfc_error ("'%s' must be a module procedure or an external procedure with"
8505 " an explicit interface at %L", proc->name, &where);
8508 stree->typebound->subroutine = proc->attr.subroutine;
8509 stree->typebound->function = proc->attr.function;
8511 /* Find the super-type of the current derived type. We could do this once and
8512 store in a global if speed is needed, but as long as not I believe this is
8513 more readable and clearer. */
8514 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
8516 /* If PASS, resolve and check arguments if not already resolved / loaded
8517 from a .mod file. */
8518 if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
8520 if (stree->typebound->pass_arg)
8522 gfc_formal_arglist* i;
8524 /* If an explicit passing argument name is given, walk the arg-list
8528 stree->typebound->pass_arg_num = 1;
8529 for (i = proc->formal; i; i = i->next)
8531 if (!strcmp (i->sym->name, stree->typebound->pass_arg))
8536 ++stree->typebound->pass_arg_num;
8541 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8543 proc->name, stree->typebound->pass_arg, &where,
8544 stree->typebound->pass_arg);
8550 /* Otherwise, take the first one; there should in fact be at least
8552 stree->typebound->pass_arg_num = 1;
8555 gfc_error ("Procedure '%s' with PASS at %L must have at"
8556 " least one argument", proc->name, &where);
8559 me_arg = proc->formal->sym;
8562 /* Now check that the argument-type matches. */
8563 gcc_assert (me_arg);
8564 if (me_arg->ts.type != BT_DERIVED
8565 || me_arg->ts.derived != resolve_bindings_derived)
8567 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8568 " the derived-type '%s'", me_arg->name, proc->name,
8569 me_arg->name, &where, resolve_bindings_derived->name);
8573 gfc_warning ("Polymorphic entities are not yet implemented,"
8574 " non-polymorphic passed-object dummy argument of '%s'"
8575 " at %L accepted", proc->name, &where);
8578 /* If we are extending some type, check that we don't override a procedure
8579 flagged NON_OVERRIDABLE. */
8580 stree->typebound->overridden = NULL;
8583 gfc_symtree* overridden;
8584 overridden = gfc_find_typebound_proc (super_type, NULL,
8587 if (overridden && overridden->typebound)
8588 stree->typebound->overridden = overridden->typebound;
8590 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
8594 /* See if there's a name collision with a component directly in this type. */
8595 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
8596 if (!strcmp (comp->name, stree->name))
8598 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8600 stree->name, &where, resolve_bindings_derived->name);
8604 /* Try to find a name collision with an inherited component. */
8605 if (super_type && gfc_find_component (super_type, stree->name, true, true))
8607 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8608 " component of '%s'",
8609 stree->name, &where, resolve_bindings_derived->name);
8613 stree->typebound->error = 0;
8617 resolve_bindings_result = FAILURE;
8618 stree->typebound->error = 1;
8622 resolve_typebound_procedures (gfc_symbol* derived)
8624 if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
8627 resolve_bindings_derived = derived;
8628 resolve_bindings_result = SUCCESS;
8629 gfc_traverse_symtree (derived->f2k_derived->sym_root,
8630 &resolve_typebound_procedure);
8632 return resolve_bindings_result;
8636 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8637 to give all identical derived types the same backend_decl. */
8639 add_dt_to_dt_list (gfc_symbol *derived)
8641 gfc_dt_list *dt_list;
8643 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
8644 if (derived == dt_list->derived)
8647 if (dt_list == NULL)
8649 dt_list = gfc_get_dt_list ();
8650 dt_list->next = gfc_derived_types;
8651 dt_list->derived = derived;
8652 gfc_derived_types = dt_list;
8657 /* Resolve the components of a derived type. */
8660 resolve_fl_derived (gfc_symbol *sym)
8662 gfc_symbol* super_type;
8666 super_type = gfc_get_derived_super_type (sym);
8668 /* Ensure the extended type gets resolved before we do. */
8669 if (super_type && resolve_fl_derived (super_type) == FAILURE)
8672 /* An ABSTRACT type must be extensible. */
8673 if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
8675 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
8676 sym->name, &sym->declared_at);
8680 for (c = sym->components; c != NULL; c = c->next)
8682 /* Check type-spec if this is not the parent-type component. */
8683 if ((!sym->attr.extension || c != sym->components)
8684 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
8687 /* If this type is an extension, see if this component has the same name
8688 as an inherited type-bound procedure. */
8690 && gfc_find_typebound_proc (super_type, NULL, c->name, true))
8692 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
8693 " inherited type-bound procedure",
8694 c->name, sym->name, &c->loc);
8698 if (c->ts.type == BT_CHARACTER)
8700 if (c->ts.cl->length == NULL
8701 || (resolve_charlen (c->ts.cl) == FAILURE)
8702 || !gfc_is_constant_expr (c->ts.cl->length))
8704 gfc_error ("Character length of component '%s' needs to "
8705 "be a constant specification expression at %L",
8707 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
8712 if (c->ts.type == BT_DERIVED
8713 && sym->component_access != ACCESS_PRIVATE
8714 && gfc_check_access (sym->attr.access, sym->ns->default_access)
8715 && !c->ts.derived->attr.use_assoc
8716 && !gfc_check_access (c->ts.derived->attr.access,
8717 c->ts.derived->ns->default_access))
8719 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
8720 "a component of '%s', which is PUBLIC at %L",
8721 c->name, sym->name, &sym->declared_at);
8725 if (sym->attr.sequence)
8727 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
8729 gfc_error ("Component %s of SEQUENCE type declared at %L does "
8730 "not have the SEQUENCE attribute",
8731 c->ts.derived->name, &sym->declared_at);
8736 if (c->ts.type == BT_DERIVED && c->attr.pointer
8737 && c->ts.derived->components == NULL
8738 && !c->ts.derived->attr.zero_comp)
8740 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
8741 "that has not been declared", c->name, sym->name,
8746 /* Ensure that all the derived type components are put on the
8747 derived type list; even in formal namespaces, where derived type
8748 pointer components might not have been declared. */
8749 if (c->ts.type == BT_DERIVED
8751 && c->ts.derived->components
8753 && sym != c->ts.derived)
8754 add_dt_to_dt_list (c->ts.derived);
8756 if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
8759 for (i = 0; i < c->as->rank; i++)
8761 if (c->as->lower[i] == NULL
8762 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
8763 || !gfc_is_constant_expr (c->as->lower[i])
8764 || c->as->upper[i] == NULL
8765 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
8766 || !gfc_is_constant_expr (c->as->upper[i]))
8768 gfc_error ("Component '%s' of '%s' at %L must have "
8769 "constant array bounds",
8770 c->name, sym->name, &c->loc);
8776 /* Resolve the type-bound procedures. */
8777 if (resolve_typebound_procedures (sym) == FAILURE)
8780 /* Resolve the finalizer procedures. */
8781 if (gfc_resolve_finalizers (sym) == FAILURE)
8784 /* Add derived type to the derived type list. */
8785 add_dt_to_dt_list (sym);
8792 resolve_fl_namelist (gfc_symbol *sym)
8797 /* Reject PRIVATE objects in a PUBLIC namelist. */
8798 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
8800 for (nl = sym->namelist; nl; nl = nl->next)
8802 if (!nl->sym->attr.use_assoc
8803 && !(sym->ns->parent == nl->sym->ns)
8804 && !(sym->ns->parent
8805 && sym->ns->parent->parent == nl->sym->ns)
8806 && !gfc_check_access(nl->sym->attr.access,
8807 nl->sym->ns->default_access))
8809 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
8810 "cannot be member of PUBLIC namelist '%s' at %L",
8811 nl->sym->name, sym->name, &sym->declared_at);
8815 /* Types with private components that came here by USE-association. */
8816 if (nl->sym->ts.type == BT_DERIVED
8817 && derived_inaccessible (nl->sym->ts.derived))
8819 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
8820 "components and cannot be member of namelist '%s' at %L",
8821 nl->sym->name, sym->name, &sym->declared_at);
8825 /* Types with private components that are defined in the same module. */
8826 if (nl->sym->ts.type == BT_DERIVED
8827 && !(sym->ns->parent == nl->sym->ts.derived->ns)
8828 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
8829 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
8830 nl->sym->ns->default_access))
8832 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
8833 "cannot be a member of PUBLIC namelist '%s' at %L",
8834 nl->sym->name, sym->name, &sym->declared_at);
8840 for (nl = sym->namelist; nl; nl = nl->next)
8842 /* Reject namelist arrays of assumed shape. */
8843 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
8844 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
8845 "must not have assumed shape in namelist "
8846 "'%s' at %L", nl->sym->name, sym->name,
8847 &sym->declared_at) == FAILURE)
8850 /* Reject namelist arrays that are not constant shape. */
8851 if (is_non_constant_shape_array (nl->sym))
8853 gfc_error ("NAMELIST array object '%s' must have constant "
8854 "shape in namelist '%s' at %L", nl->sym->name,
8855 sym->name, &sym->declared_at);
8859 /* Namelist objects cannot have allocatable or pointer components. */
8860 if (nl->sym->ts.type != BT_DERIVED)
8863 if (nl->sym->ts.derived->attr.alloc_comp)
8865 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8866 "have ALLOCATABLE components",
8867 nl->sym->name, sym->name, &sym->declared_at);
8871 if (nl->sym->ts.derived->attr.pointer_comp)
8873 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8874 "have POINTER components",
8875 nl->sym->name, sym->name, &sym->declared_at);
8881 /* 14.1.2 A module or internal procedure represent local entities
8882 of the same type as a namelist member and so are not allowed. */
8883 for (nl = sym->namelist; nl; nl = nl->next)
8885 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
8888 if (nl->sym->attr.function && nl->sym == nl->sym->result)
8889 if ((nl->sym == sym->ns->proc_name)
8891 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
8895 if (nl->sym && nl->sym->name)
8896 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
8897 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
8899 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
8900 "attribute in '%s' at %L", nlsym->name,
8911 resolve_fl_parameter (gfc_symbol *sym)
8913 /* A parameter array's shape needs to be constant. */
8915 && (sym->as->type == AS_DEFERRED
8916 || is_non_constant_shape_array (sym)))
8918 gfc_error ("Parameter array '%s' at %L cannot be automatic "
8919 "or of deferred shape", sym->name, &sym->declared_at);
8923 /* Make sure a parameter that has been implicitly typed still
8924 matches the implicit type, since PARAMETER statements can precede
8925 IMPLICIT statements. */
8926 if (sym->attr.implicit_type
8927 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
8929 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
8930 "later IMPLICIT type", sym->name, &sym->declared_at);
8934 /* Make sure the types of derived parameters are consistent. This
8935 type checking is deferred until resolution because the type may
8936 refer to a derived type from the host. */
8937 if (sym->ts.type == BT_DERIVED
8938 && !gfc_compare_types (&sym->ts, &sym->value->ts))
8940 gfc_error ("Incompatible derived type in PARAMETER at %L",
8941 &sym->value->where);
8948 /* Do anything necessary to resolve a symbol. Right now, we just
8949 assume that an otherwise unknown symbol is a variable. This sort
8950 of thing commonly happens for symbols in module. */
8953 resolve_symbol (gfc_symbol *sym)
8955 int check_constant, mp_flag;
8956 gfc_symtree *symtree;
8957 gfc_symtree *this_symtree;
8961 if (sym->attr.flavor == FL_UNKNOWN)
8964 /* If we find that a flavorless symbol is an interface in one of the
8965 parent namespaces, find its symtree in this namespace, free the
8966 symbol and set the symtree to point to the interface symbol. */
8967 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
8969 symtree = gfc_find_symtree (ns->sym_root, sym->name);
8970 if (symtree && symtree->n.sym->generic)
8972 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
8976 gfc_free_symbol (sym);
8977 symtree->n.sym->refs++;
8978 this_symtree->n.sym = symtree->n.sym;
8983 /* Otherwise give it a flavor according to such attributes as
8985 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
8986 sym->attr.flavor = FL_VARIABLE;
8989 sym->attr.flavor = FL_PROCEDURE;
8990 if (sym->attr.dimension)
8991 sym->attr.function = 1;
8995 if (sym->attr.procedure && sym->ts.interface
8996 && sym->attr.if_source != IFSRC_DECL)
8998 if (sym->ts.interface->attr.procedure)
8999 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
9000 "in a later PROCEDURE statement", sym->ts.interface->name,
9001 sym->name,&sym->declared_at);
9003 /* Get the attributes from the interface (now resolved). */
9004 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
9006 gfc_symbol *ifc = sym->ts.interface;
9008 sym->ts.interface = ifc;
9009 sym->attr.function = ifc->attr.function;
9010 sym->attr.subroutine = ifc->attr.subroutine;
9011 sym->attr.allocatable = ifc->attr.allocatable;
9012 sym->attr.pointer = ifc->attr.pointer;
9013 sym->attr.pure = ifc->attr.pure;
9014 sym->attr.elemental = ifc->attr.elemental;
9015 sym->attr.dimension = ifc->attr.dimension;
9016 sym->attr.recursive = ifc->attr.recursive;
9017 sym->attr.always_explicit = ifc->attr.always_explicit;
9018 copy_formal_args (sym, ifc);
9019 /* Copy array spec. */
9020 sym->as = gfc_copy_array_spec (ifc->as);
9024 for (i = 0; i < sym->as->rank; i++)
9026 gfc_expr_replace_symbols (sym->as->lower[i], sym);
9027 gfc_expr_replace_symbols (sym->as->upper[i], sym);
9030 /* Copy char length. */
9033 sym->ts.cl = gfc_get_charlen();
9034 sym->ts.cl->resolved = ifc->ts.cl->resolved;
9035 sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
9036 gfc_expr_replace_symbols (sym->ts.cl->length, sym);
9037 /* Add charlen to namespace. */
9040 sym->ts.cl->next = sym->formal_ns->cl_list;
9041 sym->formal_ns->cl_list = sym->ts.cl;
9045 else if (sym->ts.interface->name[0] != '\0')
9047 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
9048 sym->ts.interface->name, sym->name, &sym->declared_at);
9053 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
9056 /* Symbols that are module procedures with results (functions) have
9057 the types and array specification copied for type checking in
9058 procedures that call them, as well as for saving to a module
9059 file. These symbols can't stand the scrutiny that their results
9061 mp_flag = (sym->result != NULL && sym->result != sym);
9064 /* Make sure that the intrinsic is consistent with its internal
9065 representation. This needs to be done before assigning a default
9066 type to avoid spurious warnings. */
9067 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
9069 gfc_intrinsic_sym* isym;
9072 /* We already know this one is an intrinsic, so we don't call
9073 gfc_is_intrinsic for full checking but rather use gfc_find_function and
9074 gfc_find_subroutine directly to check whether it is a function or
9077 if ((isym = gfc_find_function (sym->name)))
9079 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
9080 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
9081 " ignored", sym->name, &sym->declared_at);
9083 else if ((isym = gfc_find_subroutine (sym->name)))
9085 if (sym->ts.type != BT_UNKNOWN)
9087 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
9088 " specifier", sym->name, &sym->declared_at);
9094 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
9095 sym->name, &sym->declared_at);
9099 /* Check it is actually available in the standard settings. */
9100 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
9103 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
9104 " available in the current standard settings but %s. Use"
9105 " an appropriate -std=* option or enable -fall-intrinsics"
9106 " in order to use it.",
9107 sym->name, &sym->declared_at, symstd);
9112 /* Assign default type to symbols that need one and don't have one. */
9113 if (sym->ts.type == BT_UNKNOWN)
9115 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
9116 gfc_set_default_type (sym, 1, NULL);
9118 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
9120 /* The specific case of an external procedure should emit an error
9121 in the case that there is no implicit type. */
9123 gfc_set_default_type (sym, sym->attr.external, NULL);
9126 /* Result may be in another namespace. */
9127 resolve_symbol (sym->result);
9129 sym->ts = sym->result->ts;
9130 sym->as = gfc_copy_array_spec (sym->result->as);
9131 sym->attr.dimension = sym->result->attr.dimension;
9132 sym->attr.pointer = sym->result->attr.pointer;
9133 sym->attr.allocatable = sym->result->attr.allocatable;
9138 /* Assumed size arrays and assumed shape arrays must be dummy
9142 && (sym->as->type == AS_ASSUMED_SIZE
9143 || sym->as->type == AS_ASSUMED_SHAPE)
9144 && sym->attr.dummy == 0)
9146 if (sym->as->type == AS_ASSUMED_SIZE)
9147 gfc_error ("Assumed size array at %L must be a dummy argument",
9150 gfc_error ("Assumed shape array at %L must be a dummy argument",
9155 /* Make sure symbols with known intent or optional are really dummy
9156 variable. Because of ENTRY statement, this has to be deferred
9157 until resolution time. */
9159 if (!sym->attr.dummy
9160 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
9162 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
9166 if (sym->attr.value && !sym->attr.dummy)
9168 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
9169 "it is not a dummy argument", sym->name, &sym->declared_at);
9173 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
9175 gfc_charlen *cl = sym->ts.cl;
9176 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9178 gfc_error ("Character dummy variable '%s' at %L with VALUE "
9179 "attribute must have constant length",
9180 sym->name, &sym->declared_at);
9184 if (sym->ts.is_c_interop
9185 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
9187 gfc_error ("C interoperable character dummy variable '%s' at %L "
9188 "with VALUE attribute must have length one",
9189 sym->name, &sym->declared_at);
9194 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
9195 do this for something that was implicitly typed because that is handled
9196 in gfc_set_default_type. Handle dummy arguments and procedure
9197 definitions separately. Also, anything that is use associated is not
9198 handled here but instead is handled in the module it is declared in.
9199 Finally, derived type definitions are allowed to be BIND(C) since that
9200 only implies that they're interoperable, and they are checked fully for
9201 interoperability when a variable is declared of that type. */
9202 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
9203 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
9204 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
9206 gfc_try t = SUCCESS;
9208 /* First, make sure the variable is declared at the
9209 module-level scope (J3/04-007, Section 15.3). */
9210 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
9211 sym->attr.in_common == 0)
9213 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
9214 "is neither a COMMON block nor declared at the "
9215 "module level scope", sym->name, &(sym->declared_at));
9218 else if (sym->common_head != NULL)
9220 t = verify_com_block_vars_c_interop (sym->common_head);
9224 /* If type() declaration, we need to verify that the components
9225 of the given type are all C interoperable, etc. */
9226 if (sym->ts.type == BT_DERIVED &&
9227 sym->ts.derived->attr.is_c_interop != 1)
9229 /* Make sure the user marked the derived type as BIND(C). If
9230 not, call the verify routine. This could print an error
9231 for the derived type more than once if multiple variables
9232 of that type are declared. */
9233 if (sym->ts.derived->attr.is_bind_c != 1)
9234 verify_bind_c_derived_type (sym->ts.derived);
9238 /* Verify the variable itself as C interoperable if it
9239 is BIND(C). It is not possible for this to succeed if
9240 the verify_bind_c_derived_type failed, so don't have to handle
9241 any error returned by verify_bind_c_derived_type. */
9242 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9248 /* clear the is_bind_c flag to prevent reporting errors more than
9249 once if something failed. */
9250 sym->attr.is_bind_c = 0;
9255 /* If a derived type symbol has reached this point, without its
9256 type being declared, we have an error. Notice that most
9257 conditions that produce undefined derived types have already
9258 been dealt with. However, the likes of:
9259 implicit type(t) (t) ..... call foo (t) will get us here if
9260 the type is not declared in the scope of the implicit
9261 statement. Change the type to BT_UNKNOWN, both because it is so
9262 and to prevent an ICE. */
9263 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
9264 && !sym->ts.derived->attr.zero_comp)
9266 gfc_error ("The derived type '%s' at %L is of type '%s', "
9267 "which has not been defined", sym->name,
9268 &sym->declared_at, sym->ts.derived->name);
9269 sym->ts.type = BT_UNKNOWN;
9273 /* Make sure that the derived type has been resolved and that the
9274 derived type is visible in the symbol's namespace, if it is a
9275 module function and is not PRIVATE. */
9276 if (sym->ts.type == BT_DERIVED
9277 && sym->ts.derived->attr.use_assoc
9278 && sym->ns->proc_name
9279 && sym->ns->proc_name->attr.flavor == FL_MODULE)
9283 if (resolve_fl_derived (sym->ts.derived) == FAILURE)
9286 gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
9287 if (!ds && sym->attr.function
9288 && gfc_check_access (sym->attr.access, sym->ns->default_access))
9290 symtree = gfc_new_symtree (&sym->ns->sym_root,
9291 sym->ts.derived->name);
9292 symtree->n.sym = sym->ts.derived;
9293 sym->ts.derived->refs++;
9297 /* Unless the derived-type declaration is use associated, Fortran 95
9298 does not allow public entries of private derived types.
9299 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9301 if (sym->ts.type == BT_DERIVED
9302 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
9303 && !sym->ts.derived->attr.use_assoc
9304 && gfc_check_access (sym->attr.access, sym->ns->default_access)
9305 && !gfc_check_access (sym->ts.derived->attr.access,
9306 sym->ts.derived->ns->default_access)
9307 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
9308 "of PRIVATE derived type '%s'",
9309 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
9310 : "variable", sym->name, &sym->declared_at,
9311 sym->ts.derived->name) == FAILURE)
9314 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9315 default initialization is defined (5.1.2.4.4). */
9316 if (sym->ts.type == BT_DERIVED
9318 && sym->attr.intent == INTENT_OUT
9320 && sym->as->type == AS_ASSUMED_SIZE)
9322 for (c = sym->ts.derived->components; c; c = c->next)
9326 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9327 "ASSUMED SIZE and so cannot have a default initializer",
9328 sym->name, &sym->declared_at);
9334 switch (sym->attr.flavor)
9337 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
9342 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
9347 if (resolve_fl_namelist (sym) == FAILURE)
9352 if (resolve_fl_parameter (sym) == FAILURE)
9360 /* Resolve array specifier. Check as well some constraints
9361 on COMMON blocks. */
9363 check_constant = sym->attr.in_common && !sym->attr.pointer;
9365 /* Set the formal_arg_flag so that check_conflict will not throw
9366 an error for host associated variables in the specification
9367 expression for an array_valued function. */
9368 if (sym->attr.function && sym->as)
9369 formal_arg_flag = 1;
9371 gfc_resolve_array_spec (sym->as, check_constant);
9373 formal_arg_flag = 0;
9375 /* Resolve formal namespaces. */
9376 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
9377 gfc_resolve (sym->formal_ns);
9379 /* Check threadprivate restrictions. */
9380 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
9381 && (!sym->attr.in_common
9382 && sym->module == NULL
9383 && (sym->ns->proc_name == NULL
9384 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
9385 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
9387 /* If we have come this far we can apply default-initializers, as
9388 described in 14.7.5, to those variables that have not already
9389 been assigned one. */
9390 if (sym->ts.type == BT_DERIVED
9391 && sym->attr.referenced
9392 && sym->ns == gfc_current_ns
9394 && !sym->attr.allocatable
9395 && !sym->attr.alloc_comp)
9397 symbol_attribute *a = &sym->attr;
9399 if ((!a->save && !a->dummy && !a->pointer
9400 && !a->in_common && !a->use_assoc
9401 && !(a->function && sym != sym->result))
9402 || (a->dummy && a->intent == INTENT_OUT))
9403 apply_default_init (sym);
9406 /* If this symbol has a type-spec, check it. */
9407 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
9408 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
9409 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
9415 /************* Resolve DATA statements *************/
9419 gfc_data_value *vnode;
9425 /* Advance the values structure to point to the next value in the data list. */
9428 next_data_value (void)
9431 while (mpz_cmp_ui (values.left, 0) == 0)
9433 if (values.vnode->next == NULL)
9436 values.vnode = values.vnode->next;
9437 mpz_set (values.left, values.vnode->repeat);
9445 check_data_variable (gfc_data_variable *var, locus *where)
9451 ar_type mark = AR_UNKNOWN;
9453 mpz_t section_index[GFC_MAX_DIMENSIONS];
9457 if (gfc_resolve_expr (var->expr) == FAILURE)
9461 mpz_init_set_si (offset, 0);
9464 if (e->expr_type != EXPR_VARIABLE)
9465 gfc_internal_error ("check_data_variable(): Bad expression");
9467 if (e->symtree->n.sym->ns->is_block_data
9468 && !e->symtree->n.sym->attr.in_common)
9470 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9471 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
9474 if (e->ref == NULL && e->symtree->n.sym->as)
9476 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9477 " declaration", e->symtree->n.sym->name, where);
9483 mpz_init_set_ui (size, 1);
9490 /* Find the array section reference. */
9491 for (ref = e->ref; ref; ref = ref->next)
9493 if (ref->type != REF_ARRAY)
9495 if (ref->u.ar.type == AR_ELEMENT)
9501 /* Set marks according to the reference pattern. */
9502 switch (ref->u.ar.type)
9510 /* Get the start position of array section. */
9511 gfc_get_section_index (ar, section_index, &offset);
9519 if (gfc_array_size (e, &size) == FAILURE)
9521 gfc_error ("Nonconstant array section at %L in DATA statement",
9530 while (mpz_cmp_ui (size, 0) > 0)
9532 if (next_data_value () == FAILURE)
9534 gfc_error ("DATA statement at %L has more variables than values",
9540 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
9544 /* If we have more than one element left in the repeat count,
9545 and we have more than one element left in the target variable,
9546 then create a range assignment. */
9547 /* FIXME: Only done for full arrays for now, since array sections
9549 if (mark == AR_FULL && ref && ref->next == NULL
9550 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
9554 if (mpz_cmp (size, values.left) >= 0)
9556 mpz_init_set (range, values.left);
9557 mpz_sub (size, size, values.left);
9558 mpz_set_ui (values.left, 0);
9562 mpz_init_set (range, size);
9563 mpz_sub (values.left, values.left, size);
9564 mpz_set_ui (size, 0);
9567 gfc_assign_data_value_range (var->expr, values.vnode->expr,
9570 mpz_add (offset, offset, range);
9574 /* Assign initial value to symbol. */
9577 mpz_sub_ui (values.left, values.left, 1);
9578 mpz_sub_ui (size, size, 1);
9580 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
9584 if (mark == AR_FULL)
9585 mpz_add_ui (offset, offset, 1);
9587 /* Modify the array section indexes and recalculate the offset
9588 for next element. */
9589 else if (mark == AR_SECTION)
9590 gfc_advance_section (section_index, ar, &offset);
9594 if (mark == AR_SECTION)
9596 for (i = 0; i < ar->dimen; i++)
9597 mpz_clear (section_index[i]);
9607 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
9609 /* Iterate over a list of elements in a DATA statement. */
9612 traverse_data_list (gfc_data_variable *var, locus *where)
9615 iterator_stack frame;
9616 gfc_expr *e, *start, *end, *step;
9617 gfc_try retval = SUCCESS;
9619 mpz_init (frame.value);
9621 start = gfc_copy_expr (var->iter.start);
9622 end = gfc_copy_expr (var->iter.end);
9623 step = gfc_copy_expr (var->iter.step);
9625 if (gfc_simplify_expr (start, 1) == FAILURE
9626 || start->expr_type != EXPR_CONSTANT)
9628 gfc_error ("iterator start at %L does not simplify", &start->where);
9632 if (gfc_simplify_expr (end, 1) == FAILURE
9633 || end->expr_type != EXPR_CONSTANT)
9635 gfc_error ("iterator end at %L does not simplify", &end->where);
9639 if (gfc_simplify_expr (step, 1) == FAILURE
9640 || step->expr_type != EXPR_CONSTANT)
9642 gfc_error ("iterator step at %L does not simplify", &step->where);
9647 mpz_init_set (trip, end->value.integer);
9648 mpz_sub (trip, trip, start->value.integer);
9649 mpz_add (trip, trip, step->value.integer);
9651 mpz_div (trip, trip, step->value.integer);
9653 mpz_set (frame.value, start->value.integer);
9655 frame.prev = iter_stack;
9656 frame.variable = var->iter.var->symtree;
9657 iter_stack = &frame;
9659 while (mpz_cmp_ui (trip, 0) > 0)
9661 if (traverse_data_var (var->list, where) == FAILURE)
9668 e = gfc_copy_expr (var->expr);
9669 if (gfc_simplify_expr (e, 1) == FAILURE)
9677 mpz_add (frame.value, frame.value, step->value.integer);
9679 mpz_sub_ui (trip, trip, 1);
9684 mpz_clear (frame.value);
9686 gfc_free_expr (start);
9687 gfc_free_expr (end);
9688 gfc_free_expr (step);
9690 iter_stack = frame.prev;
9695 /* Type resolve variables in the variable list of a DATA statement. */
9698 traverse_data_var (gfc_data_variable *var, locus *where)
9702 for (; var; var = var->next)
9704 if (var->expr == NULL)
9705 t = traverse_data_list (var, where);
9707 t = check_data_variable (var, where);
9717 /* Resolve the expressions and iterators associated with a data statement.
9718 This is separate from the assignment checking because data lists should
9719 only be resolved once. */
9722 resolve_data_variables (gfc_data_variable *d)
9724 for (; d; d = d->next)
9726 if (d->list == NULL)
9728 if (gfc_resolve_expr (d->expr) == FAILURE)
9733 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
9736 if (resolve_data_variables (d->list) == FAILURE)
9745 /* Resolve a single DATA statement. We implement this by storing a pointer to
9746 the value list into static variables, and then recursively traversing the
9747 variables list, expanding iterators and such. */
9750 resolve_data (gfc_data *d)
9753 if (resolve_data_variables (d->var) == FAILURE)
9756 values.vnode = d->value;
9757 if (d->value == NULL)
9758 mpz_set_ui (values.left, 0);
9760 mpz_set (values.left, d->value->repeat);
9762 if (traverse_data_var (d->var, &d->where) == FAILURE)
9765 /* At this point, we better not have any values left. */
9767 if (next_data_value () == SUCCESS)
9768 gfc_error ("DATA statement at %L has more values than variables",
9773 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
9774 accessed by host or use association, is a dummy argument to a pure function,
9775 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
9776 is storage associated with any such variable, shall not be used in the
9777 following contexts: (clients of this function). */
9779 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
9780 procedure. Returns zero if assignment is OK, nonzero if there is a
9783 gfc_impure_variable (gfc_symbol *sym)
9787 if (sym->attr.use_assoc || sym->attr.in_common)
9790 if (sym->ns != gfc_current_ns)
9791 return !sym->attr.function;
9793 proc = sym->ns->proc_name;
9794 if (sym->attr.dummy && gfc_pure (proc)
9795 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
9797 proc->attr.function))
9800 /* TODO: Sort out what can be storage associated, if anything, and include
9801 it here. In principle equivalences should be scanned but it does not
9802 seem to be possible to storage associate an impure variable this way. */
9807 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
9808 symbol of the current procedure. */
9811 gfc_pure (gfc_symbol *sym)
9813 symbol_attribute attr;
9816 sym = gfc_current_ns->proc_name;
9822 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
9826 /* Test whether the current procedure is elemental or not. */
9829 gfc_elemental (gfc_symbol *sym)
9831 symbol_attribute attr;
9834 sym = gfc_current_ns->proc_name;
9839 return attr.flavor == FL_PROCEDURE && attr.elemental;
9843 /* Warn about unused labels. */
9846 warn_unused_fortran_label (gfc_st_label *label)
9851 warn_unused_fortran_label (label->left);
9853 if (label->defined == ST_LABEL_UNKNOWN)
9856 switch (label->referenced)
9858 case ST_LABEL_UNKNOWN:
9859 gfc_warning ("Label %d at %L defined but not used", label->value,
9863 case ST_LABEL_BAD_TARGET:
9864 gfc_warning ("Label %d at %L defined but cannot be used",
9865 label->value, &label->where);
9872 warn_unused_fortran_label (label->right);
9876 /* Returns the sequence type of a symbol or sequence. */
9879 sequence_type (gfc_typespec ts)
9888 if (ts.derived->components == NULL)
9889 return SEQ_NONDEFAULT;
9891 result = sequence_type (ts.derived->components->ts);
9892 for (c = ts.derived->components->next; c; c = c->next)
9893 if (sequence_type (c->ts) != result)
9899 if (ts.kind != gfc_default_character_kind)
9900 return SEQ_NONDEFAULT;
9902 return SEQ_CHARACTER;
9905 if (ts.kind != gfc_default_integer_kind)
9906 return SEQ_NONDEFAULT;
9911 if (!(ts.kind == gfc_default_real_kind
9912 || ts.kind == gfc_default_double_kind))
9913 return SEQ_NONDEFAULT;
9918 if (ts.kind != gfc_default_complex_kind)
9919 return SEQ_NONDEFAULT;
9924 if (ts.kind != gfc_default_logical_kind)
9925 return SEQ_NONDEFAULT;
9930 return SEQ_NONDEFAULT;
9935 /* Resolve derived type EQUIVALENCE object. */
9938 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
9941 gfc_component *c = derived->components;
9946 /* Shall not be an object of nonsequence derived type. */
9947 if (!derived->attr.sequence)
9949 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
9950 "attribute to be an EQUIVALENCE object", sym->name,
9955 /* Shall not have allocatable components. */
9956 if (derived->attr.alloc_comp)
9958 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
9959 "components to be an EQUIVALENCE object",sym->name,
9964 if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
9966 gfc_error ("Derived type variable '%s' at %L with default "
9967 "initialization cannot be in EQUIVALENCE with a variable "
9968 "in COMMON", sym->name, &e->where);
9972 for (; c ; c = c->next)
9976 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
9979 /* Shall not be an object of sequence derived type containing a pointer
9980 in the structure. */
9981 if (c->attr.pointer)
9983 gfc_error ("Derived type variable '%s' at %L with pointer "
9984 "component(s) cannot be an EQUIVALENCE object",
9985 sym->name, &e->where);
9993 /* Resolve equivalence object.
9994 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
9995 an allocatable array, an object of nonsequence derived type, an object of
9996 sequence derived type containing a pointer at any level of component
9997 selection, an automatic object, a function name, an entry name, a result
9998 name, a named constant, a structure component, or a subobject of any of
9999 the preceding objects. A substring shall not have length zero. A
10000 derived type shall not have components with default initialization nor
10001 shall two objects of an equivalence group be initialized.
10002 Either all or none of the objects shall have an protected attribute.
10003 The simple constraints are done in symbol.c(check_conflict) and the rest
10004 are implemented here. */
10007 resolve_equivalence (gfc_equiv *eq)
10010 gfc_symbol *derived;
10011 gfc_symbol *first_sym;
10014 locus *last_where = NULL;
10015 seq_type eq_type, last_eq_type;
10016 gfc_typespec *last_ts;
10017 int object, cnt_protected;
10018 const char *value_name;
10022 last_ts = &eq->expr->symtree->n.sym->ts;
10024 first_sym = eq->expr->symtree->n.sym;
10028 for (object = 1; eq; eq = eq->eq, object++)
10032 e->ts = e->symtree->n.sym->ts;
10033 /* match_varspec might not know yet if it is seeing
10034 array reference or substring reference, as it doesn't
10036 if (e->ref && e->ref->type == REF_ARRAY)
10038 gfc_ref *ref = e->ref;
10039 sym = e->symtree->n.sym;
10041 if (sym->attr.dimension)
10043 ref->u.ar.as = sym->as;
10047 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
10048 if (e->ts.type == BT_CHARACTER
10050 && ref->type == REF_ARRAY
10051 && ref->u.ar.dimen == 1
10052 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
10053 && ref->u.ar.stride[0] == NULL)
10055 gfc_expr *start = ref->u.ar.start[0];
10056 gfc_expr *end = ref->u.ar.end[0];
10059 /* Optimize away the (:) reference. */
10060 if (start == NULL && end == NULL)
10063 e->ref = ref->next;
10065 e->ref->next = ref->next;
10070 ref->type = REF_SUBSTRING;
10072 start = gfc_int_expr (1);
10073 ref->u.ss.start = start;
10074 if (end == NULL && e->ts.cl)
10075 end = gfc_copy_expr (e->ts.cl->length);
10076 ref->u.ss.end = end;
10077 ref->u.ss.length = e->ts.cl;
10084 /* Any further ref is an error. */
10087 gcc_assert (ref->type == REF_ARRAY);
10088 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
10094 if (gfc_resolve_expr (e) == FAILURE)
10097 sym = e->symtree->n.sym;
10099 if (sym->attr.is_protected)
10101 if (cnt_protected > 0 && cnt_protected != object)
10103 gfc_error ("Either all or none of the objects in the "
10104 "EQUIVALENCE set at %L shall have the "
10105 "PROTECTED attribute",
10110 /* Shall not equivalence common block variables in a PURE procedure. */
10111 if (sym->ns->proc_name
10112 && sym->ns->proc_name->attr.pure
10113 && sym->attr.in_common)
10115 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
10116 "object in the pure procedure '%s'",
10117 sym->name, &e->where, sym->ns->proc_name->name);
10121 /* Shall not be a named constant. */
10122 if (e->expr_type == EXPR_CONSTANT)
10124 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
10125 "object", sym->name, &e->where);
10129 derived = e->ts.derived;
10130 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
10133 /* Check that the types correspond correctly:
10135 A numeric sequence structure may be equivalenced to another sequence
10136 structure, an object of default integer type, default real type, double
10137 precision real type, default logical type such that components of the
10138 structure ultimately only become associated to objects of the same
10139 kind. A character sequence structure may be equivalenced to an object
10140 of default character kind or another character sequence structure.
10141 Other objects may be equivalenced only to objects of the same type and
10142 kind parameters. */
10144 /* Identical types are unconditionally OK. */
10145 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
10146 goto identical_types;
10148 last_eq_type = sequence_type (*last_ts);
10149 eq_type = sequence_type (sym->ts);
10151 /* Since the pair of objects is not of the same type, mixed or
10152 non-default sequences can be rejected. */
10154 msg = "Sequence %s with mixed components in EQUIVALENCE "
10155 "statement at %L with different type objects";
10157 && last_eq_type == SEQ_MIXED
10158 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
10160 || (eq_type == SEQ_MIXED
10161 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10162 &e->where) == FAILURE))
10165 msg = "Non-default type object or sequence %s in EQUIVALENCE "
10166 "statement at %L with objects of different type";
10168 && last_eq_type == SEQ_NONDEFAULT
10169 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
10170 last_where) == FAILURE)
10171 || (eq_type == SEQ_NONDEFAULT
10172 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10173 &e->where) == FAILURE))
10176 msg ="Non-CHARACTER object '%s' in default CHARACTER "
10177 "EQUIVALENCE statement at %L";
10178 if (last_eq_type == SEQ_CHARACTER
10179 && eq_type != SEQ_CHARACTER
10180 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10181 &e->where) == FAILURE)
10184 msg ="Non-NUMERIC object '%s' in default NUMERIC "
10185 "EQUIVALENCE statement at %L";
10186 if (last_eq_type == SEQ_NUMERIC
10187 && eq_type != SEQ_NUMERIC
10188 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10189 &e->where) == FAILURE)
10194 last_where = &e->where;
10199 /* Shall not be an automatic array. */
10200 if (e->ref->type == REF_ARRAY
10201 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
10203 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
10204 "an EQUIVALENCE object", sym->name, &e->where);
10211 /* Shall not be a structure component. */
10212 if (r->type == REF_COMPONENT)
10214 gfc_error ("Structure component '%s' at %L cannot be an "
10215 "EQUIVALENCE object",
10216 r->u.c.component->name, &e->where);
10220 /* A substring shall not have length zero. */
10221 if (r->type == REF_SUBSTRING)
10223 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
10225 gfc_error ("Substring at %L has length zero",
10226 &r->u.ss.start->where);
10236 /* Resolve function and ENTRY types, issue diagnostics if needed. */
10239 resolve_fntype (gfc_namespace *ns)
10241 gfc_entry_list *el;
10244 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
10247 /* If there are any entries, ns->proc_name is the entry master
10248 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10250 sym = ns->entries->sym;
10252 sym = ns->proc_name;
10253 if (sym->result == sym
10254 && sym->ts.type == BT_UNKNOWN
10255 && gfc_set_default_type (sym, 0, NULL) == FAILURE
10256 && !sym->attr.untyped)
10258 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10259 sym->name, &sym->declared_at);
10260 sym->attr.untyped = 1;
10263 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
10264 && !sym->attr.contained
10265 && !gfc_check_access (sym->ts.derived->attr.access,
10266 sym->ts.derived->ns->default_access)
10267 && gfc_check_access (sym->attr.access, sym->ns->default_access))
10269 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
10270 "%L of PRIVATE type '%s'", sym->name,
10271 &sym->declared_at, sym->ts.derived->name);
10275 for (el = ns->entries->next; el; el = el->next)
10277 if (el->sym->result == el->sym
10278 && el->sym->ts.type == BT_UNKNOWN
10279 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
10280 && !el->sym->attr.untyped)
10282 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10283 el->sym->name, &el->sym->declared_at);
10284 el->sym->attr.untyped = 1;
10289 /* 12.3.2.1.1 Defined operators. */
10292 gfc_resolve_uops (gfc_symtree *symtree)
10294 gfc_interface *itr;
10296 gfc_formal_arglist *formal;
10298 if (symtree == NULL)
10301 gfc_resolve_uops (symtree->left);
10302 gfc_resolve_uops (symtree->right);
10304 for (itr = symtree->n.uop->op; itr; itr = itr->next)
10307 if (!sym->attr.function)
10308 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10309 sym->name, &sym->declared_at);
10311 if (sym->ts.type == BT_CHARACTER
10312 && !(sym->ts.cl && sym->ts.cl->length)
10313 && !(sym->result && sym->result->ts.cl
10314 && sym->result->ts.cl->length))
10315 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10316 "character length", sym->name, &sym->declared_at);
10318 formal = sym->formal;
10319 if (!formal || !formal->sym)
10321 gfc_error ("User operator procedure '%s' at %L must have at least "
10322 "one argument", sym->name, &sym->declared_at);
10326 if (formal->sym->attr.intent != INTENT_IN)
10327 gfc_error ("First argument of operator interface at %L must be "
10328 "INTENT(IN)", &sym->declared_at);
10330 if (formal->sym->attr.optional)
10331 gfc_error ("First argument of operator interface at %L cannot be "
10332 "optional", &sym->declared_at);
10334 formal = formal->next;
10335 if (!formal || !formal->sym)
10338 if (formal->sym->attr.intent != INTENT_IN)
10339 gfc_error ("Second argument of operator interface at %L must be "
10340 "INTENT(IN)", &sym->declared_at);
10342 if (formal->sym->attr.optional)
10343 gfc_error ("Second argument of operator interface at %L cannot be "
10344 "optional", &sym->declared_at);
10347 gfc_error ("Operator interface at %L must have, at most, two "
10348 "arguments", &sym->declared_at);
10353 /* Examine all of the expressions associated with a program unit,
10354 assign types to all intermediate expressions, make sure that all
10355 assignments are to compatible types and figure out which names
10356 refer to which functions or subroutines. It doesn't check code
10357 block, which is handled by resolve_code. */
10360 resolve_types (gfc_namespace *ns)
10366 gfc_namespace* old_ns = gfc_current_ns;
10368 /* Check that all IMPLICIT types are ok. */
10369 if (!ns->seen_implicit_none)
10372 for (letter = 0; letter != GFC_LETTERS; ++letter)
10373 if (ns->set_flag[letter]
10374 && resolve_typespec_used (&ns->default_type[letter],
10375 &ns->implicit_loc[letter],
10380 gfc_current_ns = ns;
10382 resolve_entries (ns);
10384 resolve_common_vars (ns->blank_common.head, false);
10385 resolve_common_blocks (ns->common_root);
10387 resolve_contained_functions (ns);
10389 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
10391 for (cl = ns->cl_list; cl; cl = cl->next)
10392 resolve_charlen (cl);
10394 gfc_traverse_ns (ns, resolve_symbol);
10396 resolve_fntype (ns);
10398 for (n = ns->contained; n; n = n->sibling)
10400 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
10401 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10402 "also be PURE", n->proc_name->name,
10403 &n->proc_name->declared_at);
10409 gfc_check_interfaces (ns);
10411 gfc_traverse_ns (ns, resolve_values);
10417 for (d = ns->data; d; d = d->next)
10421 gfc_traverse_ns (ns, gfc_formalize_init_value);
10423 gfc_traverse_ns (ns, gfc_verify_binding_labels);
10425 if (ns->common_root != NULL)
10426 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
10428 for (eq = ns->equiv; eq; eq = eq->next)
10429 resolve_equivalence (eq);
10431 /* Warn about unused labels. */
10432 if (warn_unused_label)
10433 warn_unused_fortran_label (ns->st_labels);
10435 gfc_resolve_uops (ns->uop_root);
10437 gfc_current_ns = old_ns;
10441 /* Call resolve_code recursively. */
10444 resolve_codes (gfc_namespace *ns)
10448 for (n = ns->contained; n; n = n->sibling)
10451 gfc_current_ns = ns;
10453 /* Set to an out of range value. */
10454 current_entry_id = -1;
10456 bitmap_obstack_initialize (&labels_obstack);
10457 resolve_code (ns->code, ns);
10458 bitmap_obstack_release (&labels_obstack);
10462 /* This function is called after a complete program unit has been compiled.
10463 Its purpose is to examine all of the expressions associated with a program
10464 unit, assign types to all intermediate expressions, make sure that all
10465 assignments are to compatible types and figure out which names refer to
10466 which functions or subroutines. */
10469 gfc_resolve (gfc_namespace *ns)
10471 gfc_namespace *old_ns;
10473 old_ns = gfc_current_ns;
10475 resolve_types (ns);
10476 resolve_codes (ns);
10478 gfc_current_ns = old_ns;