1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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);
1075 /* Resolve an actual argument list. Most of the time, this is just
1076 resolving the expressions in the list.
1077 The exception is that we sometimes have to decide whether arguments
1078 that look like procedure arguments are really simple variable
1082 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1083 bool no_formal_args)
1086 gfc_symtree *parent_st;
1088 int save_need_full_assumed_size;
1090 for (; arg; arg = arg->next)
1095 /* Check the label is a valid branching target. */
1098 if (arg->label->defined == ST_LABEL_UNKNOWN)
1100 gfc_error ("Label %d referenced at %L is never defined",
1101 arg->label->value, &arg->label->where);
1108 if (e->expr_type == EXPR_VARIABLE
1109 && e->symtree->n.sym->attr.generic
1111 && count_specific_procs (e) != 1)
1114 if (e->ts.type != BT_PROCEDURE)
1116 save_need_full_assumed_size = need_full_assumed_size;
1117 if (e->expr_type != EXPR_VARIABLE)
1118 need_full_assumed_size = 0;
1119 if (gfc_resolve_expr (e) != SUCCESS)
1121 need_full_assumed_size = save_need_full_assumed_size;
1125 /* See if the expression node should really be a variable reference. */
1127 sym = e->symtree->n.sym;
1129 if (sym->attr.flavor == FL_PROCEDURE
1130 || sym->attr.intrinsic
1131 || sym->attr.external)
1135 /* If a procedure is not already determined to be something else
1136 check if it is intrinsic. */
1137 if (!sym->attr.intrinsic
1138 && !(sym->attr.external || sym->attr.use_assoc
1139 || sym->attr.if_source == IFSRC_IFBODY)
1140 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1141 sym->attr.intrinsic = 1;
1143 if (sym->attr.proc == PROC_ST_FUNCTION)
1145 gfc_error ("Statement function '%s' at %L is not allowed as an "
1146 "actual argument", sym->name, &e->where);
1149 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1150 sym->attr.subroutine);
1151 if (sym->attr.intrinsic && actual_ok == 0)
1153 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1154 "actual argument", sym->name, &e->where);
1157 if (sym->attr.contained && !sym->attr.use_assoc
1158 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1160 gfc_error ("Internal procedure '%s' is not allowed as an "
1161 "actual argument at %L", sym->name, &e->where);
1164 if (sym->attr.elemental && !sym->attr.intrinsic)
1166 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1167 "allowed as an actual argument at %L", sym->name,
1171 /* Check if a generic interface has a specific procedure
1172 with the same name before emitting an error. */
1173 if (sym->attr.generic && count_specific_procs (e) != 1)
1176 /* Just in case a specific was found for the expression. */
1177 sym = e->symtree->n.sym;
1179 if (sym->attr.entry && sym->ns->entries
1180 && sym->ns == gfc_current_ns
1181 && !sym->ns->entries->sym->attr.recursive)
1183 gfc_error ("Reference to ENTRY '%s' at %L is recursive, but procedure "
1184 "'%s' is not declared as RECURSIVE",
1185 sym->name, &e->where, sym->ns->entries->sym->name);
1188 /* If the symbol is the function that names the current (or
1189 parent) scope, then we really have a variable reference. */
1191 if (sym->attr.function && sym->result == sym
1192 && (sym->ns->proc_name == sym
1193 || (sym->ns->parent != NULL
1194 && sym->ns->parent->proc_name == sym)))
1197 /* If all else fails, see if we have a specific intrinsic. */
1198 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1200 gfc_intrinsic_sym *isym;
1202 isym = gfc_find_function (sym->name);
1203 if (isym == NULL || !isym->specific)
1205 gfc_error ("Unable to find a specific INTRINSIC procedure "
1206 "for the reference '%s' at %L", sym->name,
1211 sym->attr.intrinsic = 1;
1212 sym->attr.function = 1;
1217 /* See if the name is a module procedure in a parent unit. */
1219 if (was_declared (sym) || sym->ns->parent == NULL)
1222 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1224 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1228 if (parent_st == NULL)
1231 sym = parent_st->n.sym;
1232 e->symtree = parent_st; /* Point to the right thing. */
1234 if (sym->attr.flavor == FL_PROCEDURE
1235 || sym->attr.intrinsic
1236 || sym->attr.external)
1242 e->expr_type = EXPR_VARIABLE;
1244 if (sym->as != NULL)
1246 e->rank = sym->as->rank;
1247 e->ref = gfc_get_ref ();
1248 e->ref->type = REF_ARRAY;
1249 e->ref->u.ar.type = AR_FULL;
1250 e->ref->u.ar.as = sym->as;
1253 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1254 primary.c (match_actual_arg). If above code determines that it
1255 is a variable instead, it needs to be resolved as it was not
1256 done at the beginning of this function. */
1257 save_need_full_assumed_size = need_full_assumed_size;
1258 if (e->expr_type != EXPR_VARIABLE)
1259 need_full_assumed_size = 0;
1260 if (gfc_resolve_expr (e) != SUCCESS)
1262 need_full_assumed_size = save_need_full_assumed_size;
1265 /* Check argument list functions %VAL, %LOC and %REF. There is
1266 nothing to do for %REF. */
1267 if (arg->name && arg->name[0] == '%')
1269 if (strncmp ("%VAL", arg->name, 4) == 0)
1271 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1273 gfc_error ("By-value argument at %L is not of numeric "
1280 gfc_error ("By-value argument at %L cannot be an array or "
1281 "an array section", &e->where);
1285 /* Intrinsics are still PROC_UNKNOWN here. However,
1286 since same file external procedures are not resolvable
1287 in gfortran, it is a good deal easier to leave them to
1289 if (ptype != PROC_UNKNOWN
1290 && ptype != PROC_DUMMY
1291 && ptype != PROC_EXTERNAL
1292 && ptype != PROC_MODULE)
1294 gfc_error ("By-value argument at %L is not allowed "
1295 "in this context", &e->where);
1300 /* Statement functions have already been excluded above. */
1301 else if (strncmp ("%LOC", arg->name, 4) == 0
1302 && e->ts.type == BT_PROCEDURE)
1304 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1306 gfc_error ("Passing internal procedure at %L by location "
1307 "not allowed", &e->where);
1318 /* Do the checks of the actual argument list that are specific to elemental
1319 procedures. If called with c == NULL, we have a function, otherwise if
1320 expr == NULL, we have a subroutine. */
1323 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1325 gfc_actual_arglist *arg0;
1326 gfc_actual_arglist *arg;
1327 gfc_symbol *esym = NULL;
1328 gfc_intrinsic_sym *isym = NULL;
1330 gfc_intrinsic_arg *iformal = NULL;
1331 gfc_formal_arglist *eformal = NULL;
1332 bool formal_optional = false;
1333 bool set_by_optional = false;
1337 /* Is this an elemental procedure? */
1338 if (expr && expr->value.function.actual != NULL)
1340 if (expr->value.function.esym != NULL
1341 && expr->value.function.esym->attr.elemental)
1343 arg0 = expr->value.function.actual;
1344 esym = expr->value.function.esym;
1346 else if (expr->value.function.isym != NULL
1347 && expr->value.function.isym->elemental)
1349 arg0 = expr->value.function.actual;
1350 isym = expr->value.function.isym;
1355 else if (c && c->ext.actual != NULL)
1357 arg0 = c->ext.actual;
1359 if (c->resolved_sym)
1360 esym = c->resolved_sym;
1362 esym = c->symtree->n.sym;
1365 if (!esym->attr.elemental)
1371 /* The rank of an elemental is the rank of its array argument(s). */
1372 for (arg = arg0; arg; arg = arg->next)
1374 if (arg->expr != NULL && arg->expr->rank > 0)
1376 rank = arg->expr->rank;
1377 if (arg->expr->expr_type == EXPR_VARIABLE
1378 && arg->expr->symtree->n.sym->attr.optional)
1379 set_by_optional = true;
1381 /* Function specific; set the result rank and shape. */
1385 if (!expr->shape && arg->expr->shape)
1387 expr->shape = gfc_get_shape (rank);
1388 for (i = 0; i < rank; i++)
1389 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1396 /* If it is an array, it shall not be supplied as an actual argument
1397 to an elemental procedure unless an array of the same rank is supplied
1398 as an actual argument corresponding to a nonoptional dummy argument of
1399 that elemental procedure(12.4.1.5). */
1400 formal_optional = false;
1402 iformal = isym->formal;
1404 eformal = esym->formal;
1406 for (arg = arg0; arg; arg = arg->next)
1410 if (eformal->sym && eformal->sym->attr.optional)
1411 formal_optional = true;
1412 eformal = eformal->next;
1414 else if (isym && iformal)
1416 if (iformal->optional)
1417 formal_optional = true;
1418 iformal = iformal->next;
1421 formal_optional = true;
1423 if (pedantic && arg->expr != NULL
1424 && arg->expr->expr_type == EXPR_VARIABLE
1425 && arg->expr->symtree->n.sym->attr.optional
1428 && (set_by_optional || arg->expr->rank != rank)
1429 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1431 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1432 "MISSING, it cannot be the actual argument of an "
1433 "ELEMENTAL procedure unless there is a non-optional "
1434 "argument with the same rank (12.4.1.5)",
1435 arg->expr->symtree->n.sym->name, &arg->expr->where);
1440 for (arg = arg0; arg; arg = arg->next)
1442 if (arg->expr == NULL || arg->expr->rank == 0)
1445 /* Being elemental, the last upper bound of an assumed size array
1446 argument must be present. */
1447 if (resolve_assumed_size_actual (arg->expr))
1450 /* Elemental procedure's array actual arguments must conform. */
1453 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1461 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1462 is an array, the intent inout/out variable needs to be also an array. */
1463 if (rank > 0 && esym && expr == NULL)
1464 for (eformal = esym->formal, arg = arg0; arg && eformal;
1465 arg = arg->next, eformal = eformal->next)
1466 if ((eformal->sym->attr.intent == INTENT_OUT
1467 || eformal->sym->attr.intent == INTENT_INOUT)
1468 && arg->expr && arg->expr->rank == 0)
1470 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1471 "ELEMENTAL subroutine '%s' is a scalar, but another "
1472 "actual argument is an array", &arg->expr->where,
1473 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1474 : "INOUT", eformal->sym->name, esym->name);
1481 /* Go through each actual argument in ACTUAL and see if it can be
1482 implemented as an inlined, non-copying intrinsic. FNSYM is the
1483 function being called, or NULL if not known. */
1486 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1488 gfc_actual_arglist *ap;
1491 for (ap = actual; ap; ap = ap->next)
1493 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1494 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1495 ap->expr->inline_noncopying_intrinsic = 1;
1499 /* This function does the checking of references to global procedures
1500 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1501 77 and 95 standards. It checks for a gsymbol for the name, making
1502 one if it does not already exist. If it already exists, then the
1503 reference being resolved must correspond to the type of gsymbol.
1504 Otherwise, the new symbol is equipped with the attributes of the
1505 reference. The corresponding code that is called in creating
1506 global entities is parse.c. */
1509 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1514 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1516 gsym = gfc_get_gsymbol (sym->name);
1518 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1519 gfc_global_used (gsym, where);
1521 if (gsym->type == GSYM_UNKNOWN)
1524 gsym->where = *where;
1531 /************* Function resolution *************/
1533 /* Resolve a function call known to be generic.
1534 Section 14.1.2.4.1. */
1537 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1541 if (sym->attr.generic)
1543 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1546 expr->value.function.name = s->name;
1547 expr->value.function.esym = s;
1549 if (s->ts.type != BT_UNKNOWN)
1551 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1552 expr->ts = s->result->ts;
1555 expr->rank = s->as->rank;
1556 else if (s->result != NULL && s->result->as != NULL)
1557 expr->rank = s->result->as->rank;
1559 gfc_set_sym_referenced (expr->value.function.esym);
1564 /* TODO: Need to search for elemental references in generic
1568 if (sym->attr.intrinsic)
1569 return gfc_intrinsic_func_interface (expr, 0);
1576 resolve_generic_f (gfc_expr *expr)
1581 sym = expr->symtree->n.sym;
1585 m = resolve_generic_f0 (expr, sym);
1588 else if (m == MATCH_ERROR)
1592 if (sym->ns->parent == NULL)
1594 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1598 if (!generic_sym (sym))
1602 /* Last ditch attempt. See if the reference is to an intrinsic
1603 that possesses a matching interface. 14.1.2.4 */
1604 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1606 gfc_error ("There is no specific function for the generic '%s' at %L",
1607 expr->symtree->n.sym->name, &expr->where);
1611 m = gfc_intrinsic_func_interface (expr, 0);
1615 gfc_error ("Generic function '%s' at %L is not consistent with a "
1616 "specific intrinsic interface", expr->symtree->n.sym->name,
1623 /* Resolve a function call known to be specific. */
1626 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1630 /* See if we have an intrinsic interface. */
1632 if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
1634 gfc_intrinsic_sym *isym;
1635 isym = gfc_find_function (sym->ts.interface->name);
1637 /* Existence of isym should be checked already. */
1640 sym->ts.type = isym->ts.type;
1641 sym->ts.kind = isym->ts.kind;
1642 sym->attr.function = 1;
1643 sym->attr.proc = PROC_EXTERNAL;
1647 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1649 if (sym->attr.dummy)
1651 sym->attr.proc = PROC_DUMMY;
1655 sym->attr.proc = PROC_EXTERNAL;
1659 if (sym->attr.proc == PROC_MODULE
1660 || sym->attr.proc == PROC_ST_FUNCTION
1661 || sym->attr.proc == PROC_INTERNAL)
1664 if (sym->attr.intrinsic)
1666 m = gfc_intrinsic_func_interface (expr, 1);
1670 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1671 "with an intrinsic", sym->name, &expr->where);
1679 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1682 expr->value.function.name = sym->name;
1683 expr->value.function.esym = sym;
1684 if (sym->as != NULL)
1685 expr->rank = sym->as->rank;
1692 resolve_specific_f (gfc_expr *expr)
1697 sym = expr->symtree->n.sym;
1701 m = resolve_specific_f0 (sym, expr);
1704 if (m == MATCH_ERROR)
1707 if (sym->ns->parent == NULL)
1710 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1716 gfc_error ("Unable to resolve the specific function '%s' at %L",
1717 expr->symtree->n.sym->name, &expr->where);
1723 /* Resolve a procedure call not known to be generic nor specific. */
1726 resolve_unknown_f (gfc_expr *expr)
1731 sym = expr->symtree->n.sym;
1733 if (sym->attr.dummy)
1735 sym->attr.proc = PROC_DUMMY;
1736 expr->value.function.name = sym->name;
1740 /* See if we have an intrinsic function reference. */
1742 if (gfc_is_intrinsic (sym, 0, expr->where))
1744 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1749 /* The reference is to an external name. */
1751 sym->attr.proc = PROC_EXTERNAL;
1752 expr->value.function.name = sym->name;
1753 expr->value.function.esym = expr->symtree->n.sym;
1755 if (sym->as != NULL)
1756 expr->rank = sym->as->rank;
1758 /* Type of the expression is either the type of the symbol or the
1759 default type of the symbol. */
1762 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1764 if (sym->ts.type != BT_UNKNOWN)
1768 ts = gfc_get_default_type (sym, sym->ns);
1770 if (ts->type == BT_UNKNOWN)
1772 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1773 sym->name, &expr->where);
1784 /* Return true, if the symbol is an external procedure. */
1786 is_external_proc (gfc_symbol *sym)
1788 if (!sym->attr.dummy && !sym->attr.contained
1789 && !(sym->attr.intrinsic
1790 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
1791 && sym->attr.proc != PROC_ST_FUNCTION
1792 && !sym->attr.use_assoc
1800 /* Figure out if a function reference is pure or not. Also set the name
1801 of the function for a potential error message. Return nonzero if the
1802 function is PURE, zero if not. */
1804 pure_stmt_function (gfc_expr *, gfc_symbol *);
1807 pure_function (gfc_expr *e, const char **name)
1813 if (e->symtree != NULL
1814 && e->symtree->n.sym != NULL
1815 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1816 return pure_stmt_function (e, e->symtree->n.sym);
1818 if (e->value.function.esym)
1820 pure = gfc_pure (e->value.function.esym);
1821 *name = e->value.function.esym->name;
1823 else if (e->value.function.isym)
1825 pure = e->value.function.isym->pure
1826 || e->value.function.isym->elemental;
1827 *name = e->value.function.isym->name;
1831 /* Implicit functions are not pure. */
1833 *name = e->value.function.name;
1841 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
1842 int *f ATTRIBUTE_UNUSED)
1846 /* Don't bother recursing into other statement functions
1847 since they will be checked individually for purity. */
1848 if (e->expr_type != EXPR_FUNCTION
1850 || e->symtree->n.sym == sym
1851 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1854 return pure_function (e, &name) ? false : true;
1859 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
1861 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
1866 is_scalar_expr_ptr (gfc_expr *expr)
1868 gfc_try retval = SUCCESS;
1873 /* See if we have a gfc_ref, which means we have a substring, array
1874 reference, or a component. */
1875 if (expr->ref != NULL)
1878 while (ref->next != NULL)
1884 if (ref->u.ss.length != NULL
1885 && ref->u.ss.length->length != NULL
1887 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1889 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1891 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1892 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1893 if (end - start + 1 != 1)
1900 if (ref->u.ar.type == AR_ELEMENT)
1902 else if (ref->u.ar.type == AR_FULL)
1904 /* The user can give a full array if the array is of size 1. */
1905 if (ref->u.ar.as != NULL
1906 && ref->u.ar.as->rank == 1
1907 && ref->u.ar.as->type == AS_EXPLICIT
1908 && ref->u.ar.as->lower[0] != NULL
1909 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1910 && ref->u.ar.as->upper[0] != NULL
1911 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1913 /* If we have a character string, we need to check if
1914 its length is one. */
1915 if (expr->ts.type == BT_CHARACTER)
1917 if (expr->ts.cl == NULL
1918 || expr->ts.cl->length == NULL
1919 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1925 /* We have constant lower and upper bounds. If the
1926 difference between is 1, it can be considered a
1928 start = (int) mpz_get_si
1929 (ref->u.ar.as->lower[0]->value.integer);
1930 end = (int) mpz_get_si
1931 (ref->u.ar.as->upper[0]->value.integer);
1932 if (end - start + 1 != 1)
1947 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1949 /* Character string. Make sure it's of length 1. */
1950 if (expr->ts.cl == NULL
1951 || expr->ts.cl->length == NULL
1952 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1955 else if (expr->rank != 0)
1962 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1963 and, in the case of c_associated, set the binding label based on
1967 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1968 gfc_symbol **new_sym)
1970 char name[GFC_MAX_SYMBOL_LEN + 1];
1971 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1972 int optional_arg = 0;
1973 gfc_try retval = SUCCESS;
1974 gfc_symbol *args_sym;
1975 gfc_typespec *arg_ts;
1976 gfc_ref *parent_ref;
1979 if (args->expr->expr_type == EXPR_CONSTANT
1980 || args->expr->expr_type == EXPR_OP
1981 || args->expr->expr_type == EXPR_NULL)
1983 gfc_error ("Argument to '%s' at %L is not a variable",
1984 sym->name, &(args->expr->where));
1988 args_sym = args->expr->symtree->n.sym;
1990 /* The typespec for the actual arg should be that stored in the expr
1991 and not necessarily that of the expr symbol (args_sym), because
1992 the actual expression could be a part-ref of the expr symbol. */
1993 arg_ts = &(args->expr->ts);
1995 /* Get the parent reference (if any) for the expression. This happens for
1996 cases such as a%b%c. */
1997 parent_ref = args->expr->ref;
1999 if (parent_ref != NULL)
2001 curr_ref = parent_ref->next;
2002 while (curr_ref != NULL && curr_ref->next != NULL)
2004 parent_ref = curr_ref;
2005 curr_ref = curr_ref->next;
2009 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
2010 is for a REF_COMPONENT, then we need to use it as the parent_ref for
2011 the name, etc. Otherwise, the current parent_ref should be correct. */
2012 if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
2013 parent_ref = curr_ref;
2015 if (parent_ref == args->expr->ref)
2017 else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
2018 gfc_internal_error ("Unexpected expression reference type in "
2019 "gfc_iso_c_func_interface");
2021 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2023 /* If the user gave two args then they are providing something for
2024 the optional arg (the second cptr). Therefore, set the name and
2025 binding label to the c_associated for two cptrs. Otherwise,
2026 set c_associated to expect one cptr. */
2030 sprintf (name, "%s_2", sym->name);
2031 sprintf (binding_label, "%s_2", sym->binding_label);
2037 sprintf (name, "%s_1", sym->name);
2038 sprintf (binding_label, "%s_1", sym->binding_label);
2042 /* Get a new symbol for the version of c_associated that
2044 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2046 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2047 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2049 sprintf (name, "%s", sym->name);
2050 sprintf (binding_label, "%s", sym->binding_label);
2052 /* Error check the call. */
2053 if (args->next != NULL)
2055 gfc_error_now ("More actual than formal arguments in '%s' "
2056 "call at %L", name, &(args->expr->where));
2059 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2061 /* Make sure we have either the target or pointer attribute. */
2062 if (!(args_sym->attr.target)
2063 && !(args_sym->attr.pointer)
2064 && (parent_ref == NULL ||
2065 !parent_ref->u.c.component->attr.pointer))
2067 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2068 "a TARGET or an associated pointer",
2070 sym->name, &(args->expr->where));
2074 /* See if we have interoperable type and type param. */
2075 if (verify_c_interop (arg_ts,
2076 (parent_ref ? parent_ref->u.c.component->name
2078 &(args->expr->where)) == SUCCESS
2079 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2081 if (args_sym->attr.target == 1)
2083 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2084 has the target attribute and is interoperable. */
2085 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2086 allocatable variable that has the TARGET attribute and
2087 is not an array of zero size. */
2088 if (args_sym->attr.allocatable == 1)
2090 if (args_sym->attr.dimension != 0
2091 && (args_sym->as && args_sym->as->rank == 0))
2093 gfc_error_now ("Allocatable variable '%s' used as a "
2094 "parameter to '%s' at %L must not be "
2095 "an array of zero size",
2096 args_sym->name, sym->name,
2097 &(args->expr->where));
2103 /* A non-allocatable target variable with C
2104 interoperable type and type parameters must be
2106 if (args_sym && args_sym->attr.dimension)
2108 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2110 gfc_error ("Assumed-shape array '%s' at %L "
2111 "cannot be an argument to the "
2112 "procedure '%s' because "
2113 "it is not C interoperable",
2115 &(args->expr->where), sym->name);
2118 else if (args_sym->as->type == AS_DEFERRED)
2120 gfc_error ("Deferred-shape array '%s' at %L "
2121 "cannot be an argument to the "
2122 "procedure '%s' because "
2123 "it is not C interoperable",
2125 &(args->expr->where), sym->name);
2130 /* Make sure it's not a character string. Arrays of
2131 any type should be ok if the variable is of a C
2132 interoperable type. */
2133 if (arg_ts->type == BT_CHARACTER)
2134 if (arg_ts->cl != NULL
2135 && (arg_ts->cl->length == NULL
2136 || arg_ts->cl->length->expr_type
2139 (arg_ts->cl->length->value.integer, 1)
2141 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2143 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2144 "at %L must have a length of 1",
2145 args_sym->name, sym->name,
2146 &(args->expr->where));
2151 else if ((args_sym->attr.pointer == 1 ||
2153 && parent_ref->u.c.component->attr.pointer))
2154 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2156 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2158 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2159 "associated scalar POINTER", args_sym->name,
2160 sym->name, &(args->expr->where));
2166 /* The parameter is not required to be C interoperable. If it
2167 is not C interoperable, it must be a nonpolymorphic scalar
2168 with no length type parameters. It still must have either
2169 the pointer or target attribute, and it can be
2170 allocatable (but must be allocated when c_loc is called). */
2171 if (args->expr->rank != 0
2172 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2174 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2175 "scalar", args_sym->name, sym->name,
2176 &(args->expr->where));
2179 else if (arg_ts->type == BT_CHARACTER
2180 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2182 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2183 "%L must have a length of 1",
2184 args_sym->name, sym->name,
2185 &(args->expr->where));
2190 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2192 if (args_sym->attr.flavor != FL_PROCEDURE)
2194 /* TODO: Update this error message to allow for procedure
2195 pointers once they are implemented. */
2196 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2198 args_sym->name, sym->name,
2199 &(args->expr->where));
2202 else if (args_sym->attr.is_bind_c != 1)
2204 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2206 args_sym->name, sym->name,
2207 &(args->expr->where));
2212 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2217 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2218 "iso_c_binding function: '%s'!\n", sym->name);
2225 /* Resolve a function call, which means resolving the arguments, then figuring
2226 out which entity the name refers to. */
2227 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2228 to INTENT(OUT) or INTENT(INOUT). */
2231 resolve_function (gfc_expr *expr)
2233 gfc_actual_arglist *arg;
2238 procedure_type p = PROC_INTRINSIC;
2239 bool no_formal_args;
2243 sym = expr->symtree->n.sym;
2245 if (sym && sym->attr.intrinsic
2246 && !gfc_find_function (sym->name)
2247 && gfc_find_subroutine (sym->name)
2248 && sym->attr.function)
2250 gfc_error ("Intrinsic subroutine '%s' used as "
2251 "a function at %L", sym->name, &expr->where);
2255 if (sym && sym->attr.flavor == FL_VARIABLE)
2257 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2261 if (sym && sym->attr.abstract)
2263 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2264 sym->name, &expr->where);
2268 /* If the procedure is external, check for usage. */
2269 if (sym && is_external_proc (sym))
2270 resolve_global_procedure (sym, &expr->where, 0);
2272 /* Switch off assumed size checking and do this again for certain kinds
2273 of procedure, once the procedure itself is resolved. */
2274 need_full_assumed_size++;
2276 if (expr->symtree && expr->symtree->n.sym)
2277 p = expr->symtree->n.sym->attr.proc;
2279 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2280 if (resolve_actual_arglist (expr->value.function.actual,
2281 p, no_formal_args) == FAILURE)
2284 /* Need to setup the call to the correct c_associated, depending on
2285 the number of cptrs to user gives to compare. */
2286 if (sym && sym->attr.is_iso_c == 1)
2288 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2292 /* Get the symtree for the new symbol (resolved func).
2293 the old one will be freed later, when it's no longer used. */
2294 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2297 /* Resume assumed_size checking. */
2298 need_full_assumed_size--;
2300 if (sym && sym->ts.type == BT_CHARACTER
2302 && sym->ts.cl->length == NULL
2304 && expr->value.function.esym == NULL
2305 && !sym->attr.contained)
2307 /* Internal procedures are taken care of in resolve_contained_fntype. */
2308 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2309 "be used at %L since it is not a dummy argument",
2310 sym->name, &expr->where);
2314 /* See if function is already resolved. */
2316 if (expr->value.function.name != NULL)
2318 if (expr->ts.type == BT_UNKNOWN)
2324 /* Apply the rules of section 14.1.2. */
2326 switch (procedure_kind (sym))
2329 t = resolve_generic_f (expr);
2332 case PTYPE_SPECIFIC:
2333 t = resolve_specific_f (expr);
2337 t = resolve_unknown_f (expr);
2341 gfc_internal_error ("resolve_function(): bad function type");
2345 /* If the expression is still a function (it might have simplified),
2346 then we check to see if we are calling an elemental function. */
2348 if (expr->expr_type != EXPR_FUNCTION)
2351 temp = need_full_assumed_size;
2352 need_full_assumed_size = 0;
2354 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2357 if (omp_workshare_flag
2358 && expr->value.function.esym
2359 && ! gfc_elemental (expr->value.function.esym))
2361 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2362 "in WORKSHARE construct", expr->value.function.esym->name,
2367 #define GENERIC_ID expr->value.function.isym->id
2368 else if (expr->value.function.actual != NULL
2369 && expr->value.function.isym != NULL
2370 && GENERIC_ID != GFC_ISYM_LBOUND
2371 && GENERIC_ID != GFC_ISYM_LEN
2372 && GENERIC_ID != GFC_ISYM_LOC
2373 && GENERIC_ID != GFC_ISYM_PRESENT)
2375 /* Array intrinsics must also have the last upper bound of an
2376 assumed size array argument. UBOUND and SIZE have to be
2377 excluded from the check if the second argument is anything
2380 for (arg = expr->value.function.actual; arg; arg = arg->next)
2382 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2383 && arg->next != NULL && arg->next->expr)
2385 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2388 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2391 if ((int)mpz_get_si (arg->next->expr->value.integer)
2396 if (arg->expr != NULL
2397 && arg->expr->rank > 0
2398 && resolve_assumed_size_actual (arg->expr))
2404 need_full_assumed_size = temp;
2407 if (!pure_function (expr, &name) && name)
2411 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2412 "FORALL %s", name, &expr->where,
2413 forall_flag == 2 ? "mask" : "block");
2416 else if (gfc_pure (NULL))
2418 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2419 "procedure within a PURE procedure", name, &expr->where);
2424 /* Functions without the RECURSIVE attribution are not allowed to
2425 * call themselves. */
2426 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2428 gfc_symbol *esym, *proc;
2429 esym = expr->value.function.esym;
2430 proc = gfc_current_ns->proc_name;
2433 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2434 "RECURSIVE", name, &expr->where);
2438 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2439 && esym->ns->entries->sym == proc->ns->entries->sym)
2441 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2442 "'%s' is not declared as RECURSIVE",
2443 esym->name, &expr->where, esym->ns->entries->sym->name);
2448 /* Character lengths of use associated functions may contains references to
2449 symbols not referenced from the current program unit otherwise. Make sure
2450 those symbols are marked as referenced. */
2452 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2453 && expr->value.function.esym->attr.use_assoc)
2455 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2459 && !((expr->value.function.esym
2460 && expr->value.function.esym->attr.elemental)
2462 (expr->value.function.isym
2463 && expr->value.function.isym->elemental)))
2464 find_noncopying_intrinsics (expr->value.function.esym,
2465 expr->value.function.actual);
2467 /* Make sure that the expression has a typespec that works. */
2468 if (expr->ts.type == BT_UNKNOWN)
2470 if (expr->symtree->n.sym->result
2471 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2472 expr->ts = expr->symtree->n.sym->result->ts;
2479 /************* Subroutine resolution *************/
2482 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2488 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2489 sym->name, &c->loc);
2490 else if (gfc_pure (NULL))
2491 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2497 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2501 if (sym->attr.generic)
2503 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2506 c->resolved_sym = s;
2507 pure_subroutine (c, s);
2511 /* TODO: Need to search for elemental references in generic interface. */
2514 if (sym->attr.intrinsic)
2515 return gfc_intrinsic_sub_interface (c, 0);
2522 resolve_generic_s (gfc_code *c)
2527 sym = c->symtree->n.sym;
2531 m = resolve_generic_s0 (c, sym);
2534 else if (m == MATCH_ERROR)
2538 if (sym->ns->parent == NULL)
2540 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2544 if (!generic_sym (sym))
2548 /* Last ditch attempt. See if the reference is to an intrinsic
2549 that possesses a matching interface. 14.1.2.4 */
2550 sym = c->symtree->n.sym;
2552 if (!gfc_is_intrinsic (sym, 1, c->loc))
2554 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2555 sym->name, &c->loc);
2559 m = gfc_intrinsic_sub_interface (c, 0);
2563 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2564 "intrinsic subroutine interface", sym->name, &c->loc);
2570 /* Set the name and binding label of the subroutine symbol in the call
2571 expression represented by 'c' to include the type and kind of the
2572 second parameter. This function is for resolving the appropriate
2573 version of c_f_pointer() and c_f_procpointer(). For example, a
2574 call to c_f_pointer() for a default integer pointer could have a
2575 name of c_f_pointer_i4. If no second arg exists, which is an error
2576 for these two functions, it defaults to the generic symbol's name
2577 and binding label. */
2580 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2581 char *name, char *binding_label)
2583 gfc_expr *arg = NULL;
2587 /* The second arg of c_f_pointer and c_f_procpointer determines
2588 the type and kind for the procedure name. */
2589 arg = c->ext.actual->next->expr;
2593 /* Set up the name to have the given symbol's name,
2594 plus the type and kind. */
2595 /* a derived type is marked with the type letter 'u' */
2596 if (arg->ts.type == BT_DERIVED)
2599 kind = 0; /* set the kind as 0 for now */
2603 type = gfc_type_letter (arg->ts.type);
2604 kind = arg->ts.kind;
2607 if (arg->ts.type == BT_CHARACTER)
2608 /* Kind info for character strings not needed. */
2611 sprintf (name, "%s_%c%d", sym->name, type, kind);
2612 /* Set up the binding label as the given symbol's label plus
2613 the type and kind. */
2614 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2618 /* If the second arg is missing, set the name and label as
2619 was, cause it should at least be found, and the missing
2620 arg error will be caught by compare_parameters(). */
2621 sprintf (name, "%s", sym->name);
2622 sprintf (binding_label, "%s", sym->binding_label);
2629 /* Resolve a generic version of the iso_c_binding procedure given
2630 (sym) to the specific one based on the type and kind of the
2631 argument(s). Currently, this function resolves c_f_pointer() and
2632 c_f_procpointer based on the type and kind of the second argument
2633 (FPTR). Other iso_c_binding procedures aren't specially handled.
2634 Upon successfully exiting, c->resolved_sym will hold the resolved
2635 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2639 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2641 gfc_symbol *new_sym;
2642 /* this is fine, since we know the names won't use the max */
2643 char name[GFC_MAX_SYMBOL_LEN + 1];
2644 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2645 /* default to success; will override if find error */
2646 match m = MATCH_YES;
2648 /* Make sure the actual arguments are in the necessary order (based on the
2649 formal args) before resolving. */
2650 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2652 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2653 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2655 set_name_and_label (c, sym, name, binding_label);
2657 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2659 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2661 /* Make sure we got a third arg if the second arg has non-zero
2662 rank. We must also check that the type and rank are
2663 correct since we short-circuit this check in
2664 gfc_procedure_use() (called above to sort actual args). */
2665 if (c->ext.actual->next->expr->rank != 0)
2667 if(c->ext.actual->next->next == NULL
2668 || c->ext.actual->next->next->expr == NULL)
2671 gfc_error ("Missing SHAPE parameter for call to %s "
2672 "at %L", sym->name, &(c->loc));
2674 else if (c->ext.actual->next->next->expr->ts.type
2676 || c->ext.actual->next->next->expr->rank != 1)
2679 gfc_error ("SHAPE parameter for call to %s at %L must "
2680 "be a rank 1 INTEGER array", sym->name,
2687 if (m != MATCH_ERROR)
2689 /* the 1 means to add the optional arg to formal list */
2690 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2692 /* for error reporting, say it's declared where the original was */
2693 new_sym->declared_at = sym->declared_at;
2698 /* no differences for c_loc or c_funloc */
2702 /* set the resolved symbol */
2703 if (m != MATCH_ERROR)
2704 c->resolved_sym = new_sym;
2706 c->resolved_sym = sym;
2712 /* Resolve a subroutine call known to be specific. */
2715 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2719 /* See if we have an intrinsic interface. */
2720 if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
2721 && !sym->ts.interface->attr.subroutine)
2723 gfc_intrinsic_sym *isym;
2725 isym = gfc_find_function (sym->ts.interface->name);
2727 /* Existence of isym should be checked already. */
2730 sym->ts.type = isym->ts.type;
2731 sym->ts.kind = isym->ts.kind;
2732 sym->attr.subroutine = 1;
2736 if(sym->attr.is_iso_c)
2738 m = gfc_iso_c_sub_interface (c,sym);
2742 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2744 if (sym->attr.dummy)
2746 sym->attr.proc = PROC_DUMMY;
2750 sym->attr.proc = PROC_EXTERNAL;
2754 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2757 if (sym->attr.intrinsic)
2759 m = gfc_intrinsic_sub_interface (c, 1);
2763 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2764 "with an intrinsic", sym->name, &c->loc);
2772 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2774 c->resolved_sym = sym;
2775 pure_subroutine (c, sym);
2782 resolve_specific_s (gfc_code *c)
2787 sym = c->symtree->n.sym;
2791 m = resolve_specific_s0 (c, sym);
2794 if (m == MATCH_ERROR)
2797 if (sym->ns->parent == NULL)
2800 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2806 sym = c->symtree->n.sym;
2807 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2808 sym->name, &c->loc);
2814 /* Resolve a subroutine call not known to be generic nor specific. */
2817 resolve_unknown_s (gfc_code *c)
2821 sym = c->symtree->n.sym;
2823 if (sym->attr.dummy)
2825 sym->attr.proc = PROC_DUMMY;
2829 /* See if we have an intrinsic function reference. */
2831 if (gfc_is_intrinsic (sym, 1, c->loc))
2833 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2838 /* The reference is to an external name. */
2841 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2843 c->resolved_sym = sym;
2845 pure_subroutine (c, sym);
2851 /* Resolve a subroutine call. Although it was tempting to use the same code
2852 for functions, subroutines and functions are stored differently and this
2853 makes things awkward. */
2856 resolve_call (gfc_code *c)
2859 procedure_type ptype = PROC_INTRINSIC;
2860 gfc_symbol *csym, *sym;
2861 bool no_formal_args;
2863 csym = c->symtree ? c->symtree->n.sym : NULL;
2865 if (csym && csym->ts.type != BT_UNKNOWN)
2867 gfc_error ("'%s' at %L has a type, which is not consistent with "
2868 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
2872 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
2874 gfc_find_symbol (csym->name, gfc_current_ns, 1, &sym);
2875 if (sym && csym != sym
2876 && sym->ns == gfc_current_ns
2877 && sym->attr.flavor == FL_PROCEDURE
2878 && sym->attr.contained)
2882 c->symtree->n.sym = sym;
2886 /* If external, check for usage. */
2887 if (csym && is_external_proc (csym))
2888 resolve_global_procedure (csym, &c->loc, 1);
2890 /* Subroutines without the RECURSIVE attribution are not allowed to
2891 * call themselves. */
2892 if (csym && !csym->attr.recursive)
2895 proc = gfc_current_ns->proc_name;
2898 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2899 "RECURSIVE", csym->name, &c->loc);
2903 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2904 && csym->ns->entries->sym == proc->ns->entries->sym)
2906 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2907 "'%s' is not declared as RECURSIVE",
2908 csym->name, &c->loc, csym->ns->entries->sym->name);
2913 /* Switch off assumed size checking and do this again for certain kinds
2914 of procedure, once the procedure itself is resolved. */
2915 need_full_assumed_size++;
2918 ptype = csym->attr.proc;
2920 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
2921 if (resolve_actual_arglist (c->ext.actual, ptype,
2922 no_formal_args) == FAILURE)
2925 /* Resume assumed_size checking. */
2926 need_full_assumed_size--;
2929 if (c->resolved_sym == NULL)
2931 c->resolved_isym = NULL;
2932 switch (procedure_kind (csym))
2935 t = resolve_generic_s (c);
2938 case PTYPE_SPECIFIC:
2939 t = resolve_specific_s (c);
2943 t = resolve_unknown_s (c);
2947 gfc_internal_error ("resolve_subroutine(): bad function type");
2951 /* Some checks of elemental subroutine actual arguments. */
2952 if (resolve_elemental_actual (NULL, c) == FAILURE)
2955 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
2956 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2961 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2962 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2963 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2964 if their shapes do not match. If either op1->shape or op2->shape is
2965 NULL, return SUCCESS. */
2968 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2975 if (op1->shape != NULL && op2->shape != NULL)
2977 for (i = 0; i < op1->rank; i++)
2979 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2981 gfc_error ("Shapes for operands at %L and %L are not conformable",
2982 &op1->where, &op2->where);
2993 /* Resolve an operator expression node. This can involve replacing the
2994 operation with a user defined function call. */
2997 resolve_operator (gfc_expr *e)
2999 gfc_expr *op1, *op2;
3001 bool dual_locus_error;
3004 /* Resolve all subnodes-- give them types. */
3006 switch (e->value.op.op)
3009 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3012 /* Fall through... */
3015 case INTRINSIC_UPLUS:
3016 case INTRINSIC_UMINUS:
3017 case INTRINSIC_PARENTHESES:
3018 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3023 /* Typecheck the new node. */
3025 op1 = e->value.op.op1;
3026 op2 = e->value.op.op2;
3027 dual_locus_error = false;
3029 if ((op1 && op1->expr_type == EXPR_NULL)
3030 || (op2 && op2->expr_type == EXPR_NULL))
3032 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3036 switch (e->value.op.op)
3038 case INTRINSIC_UPLUS:
3039 case INTRINSIC_UMINUS:
3040 if (op1->ts.type == BT_INTEGER
3041 || op1->ts.type == BT_REAL
3042 || op1->ts.type == BT_COMPLEX)
3048 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3049 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3052 case INTRINSIC_PLUS:
3053 case INTRINSIC_MINUS:
3054 case INTRINSIC_TIMES:
3055 case INTRINSIC_DIVIDE:
3056 case INTRINSIC_POWER:
3057 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3059 gfc_type_convert_binary (e);
3064 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3065 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3066 gfc_typename (&op2->ts));
3069 case INTRINSIC_CONCAT:
3070 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3071 && op1->ts.kind == op2->ts.kind)
3073 e->ts.type = BT_CHARACTER;
3074 e->ts.kind = op1->ts.kind;
3079 _("Operands of string concatenation operator at %%L are %s/%s"),
3080 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3086 case INTRINSIC_NEQV:
3087 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3089 e->ts.type = BT_LOGICAL;
3090 e->ts.kind = gfc_kind_max (op1, op2);
3091 if (op1->ts.kind < e->ts.kind)
3092 gfc_convert_type (op1, &e->ts, 2);
3093 else if (op2->ts.kind < e->ts.kind)
3094 gfc_convert_type (op2, &e->ts, 2);
3098 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3099 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3100 gfc_typename (&op2->ts));
3105 if (op1->ts.type == BT_LOGICAL)
3107 e->ts.type = BT_LOGICAL;
3108 e->ts.kind = op1->ts.kind;
3112 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3113 gfc_typename (&op1->ts));
3117 case INTRINSIC_GT_OS:
3119 case INTRINSIC_GE_OS:
3121 case INTRINSIC_LT_OS:
3123 case INTRINSIC_LE_OS:
3124 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3126 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3130 /* Fall through... */
3133 case INTRINSIC_EQ_OS:
3135 case INTRINSIC_NE_OS:
3136 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3137 && op1->ts.kind == op2->ts.kind)
3139 e->ts.type = BT_LOGICAL;
3140 e->ts.kind = gfc_default_logical_kind;
3144 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3146 gfc_type_convert_binary (e);
3148 e->ts.type = BT_LOGICAL;
3149 e->ts.kind = gfc_default_logical_kind;
3153 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3155 _("Logicals at %%L must be compared with %s instead of %s"),
3156 (e->value.op.op == INTRINSIC_EQ
3157 || e->value.op.op == INTRINSIC_EQ_OS)
3158 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3161 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3162 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3163 gfc_typename (&op2->ts));
3167 case INTRINSIC_USER:
3168 if (e->value.op.uop->op == NULL)
3169 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3170 else if (op2 == NULL)
3171 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3172 e->value.op.uop->name, gfc_typename (&op1->ts));
3174 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3175 e->value.op.uop->name, gfc_typename (&op1->ts),
3176 gfc_typename (&op2->ts));
3180 case INTRINSIC_PARENTHESES:
3182 if (e->ts.type == BT_CHARACTER)
3183 e->ts.cl = op1->ts.cl;
3187 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3190 /* Deal with arrayness of an operand through an operator. */
3194 switch (e->value.op.op)
3196 case INTRINSIC_PLUS:
3197 case INTRINSIC_MINUS:
3198 case INTRINSIC_TIMES:
3199 case INTRINSIC_DIVIDE:
3200 case INTRINSIC_POWER:
3201 case INTRINSIC_CONCAT:
3205 case INTRINSIC_NEQV:
3207 case INTRINSIC_EQ_OS:
3209 case INTRINSIC_NE_OS:
3211 case INTRINSIC_GT_OS:
3213 case INTRINSIC_GE_OS:
3215 case INTRINSIC_LT_OS:
3217 case INTRINSIC_LE_OS:
3219 if (op1->rank == 0 && op2->rank == 0)
3222 if (op1->rank == 0 && op2->rank != 0)
3224 e->rank = op2->rank;
3226 if (e->shape == NULL)
3227 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3230 if (op1->rank != 0 && op2->rank == 0)
3232 e->rank = op1->rank;
3234 if (e->shape == NULL)
3235 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3238 if (op1->rank != 0 && op2->rank != 0)
3240 if (op1->rank == op2->rank)
3242 e->rank = op1->rank;
3243 if (e->shape == NULL)
3245 t = compare_shapes(op1, op2);
3249 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3254 /* Allow higher level expressions to work. */
3257 /* Try user-defined operators, and otherwise throw an error. */
3258 dual_locus_error = true;
3260 _("Inconsistent ranks for operator at %%L and %%L"));
3267 case INTRINSIC_PARENTHESES:
3269 case INTRINSIC_UPLUS:
3270 case INTRINSIC_UMINUS:
3271 /* Simply copy arrayness attribute */
3272 e->rank = op1->rank;
3274 if (e->shape == NULL)
3275 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3283 /* Attempt to simplify the expression. */
3286 t = gfc_simplify_expr (e, 0);
3287 /* Some calls do not succeed in simplification and return FAILURE
3288 even though there is no error; e.g. variable references to
3289 PARAMETER arrays. */
3290 if (!gfc_is_constant_expr (e))
3297 if (gfc_extend_expr (e) == SUCCESS)
3300 if (dual_locus_error)
3301 gfc_error (msg, &op1->where, &op2->where);
3303 gfc_error (msg, &e->where);
3309 /************** Array resolution subroutines **************/
3312 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3315 /* Compare two integer expressions. */
3318 compare_bound (gfc_expr *a, gfc_expr *b)
3322 if (a == NULL || a->expr_type != EXPR_CONSTANT
3323 || b == NULL || b->expr_type != EXPR_CONSTANT)
3326 /* If either of the types isn't INTEGER, we must have
3327 raised an error earlier. */
3329 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3332 i = mpz_cmp (a->value.integer, b->value.integer);
3342 /* Compare an integer expression with an integer. */
3345 compare_bound_int (gfc_expr *a, int b)
3349 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3352 if (a->ts.type != BT_INTEGER)
3353 gfc_internal_error ("compare_bound_int(): Bad expression");
3355 i = mpz_cmp_si (a->value.integer, b);
3365 /* Compare an integer expression with a mpz_t. */
3368 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3372 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3375 if (a->ts.type != BT_INTEGER)
3376 gfc_internal_error ("compare_bound_int(): Bad expression");
3378 i = mpz_cmp (a->value.integer, b);
3388 /* Compute the last value of a sequence given by a triplet.
3389 Return 0 if it wasn't able to compute the last value, or if the
3390 sequence if empty, and 1 otherwise. */
3393 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3394 gfc_expr *stride, mpz_t last)
3398 if (start == NULL || start->expr_type != EXPR_CONSTANT
3399 || end == NULL || end->expr_type != EXPR_CONSTANT
3400 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3403 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3404 || (stride != NULL && stride->ts.type != BT_INTEGER))
3407 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3409 if (compare_bound (start, end) == CMP_GT)
3411 mpz_set (last, end->value.integer);
3415 if (compare_bound_int (stride, 0) == CMP_GT)
3417 /* Stride is positive */
3418 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3423 /* Stride is negative */
3424 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3429 mpz_sub (rem, end->value.integer, start->value.integer);
3430 mpz_tdiv_r (rem, rem, stride->value.integer);
3431 mpz_sub (last, end->value.integer, rem);
3438 /* Compare a single dimension of an array reference to the array
3442 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3446 /* Given start, end and stride values, calculate the minimum and
3447 maximum referenced indexes. */
3449 switch (ar->dimen_type[i])
3455 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3457 gfc_warning ("Array reference at %L is out of bounds "
3458 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3459 mpz_get_si (ar->start[i]->value.integer),
3460 mpz_get_si (as->lower[i]->value.integer), i+1);
3463 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3465 gfc_warning ("Array reference at %L is out of bounds "
3466 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3467 mpz_get_si (ar->start[i]->value.integer),
3468 mpz_get_si (as->upper[i]->value.integer), i+1);
3476 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3477 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3479 comparison comp_start_end = compare_bound (AR_START, AR_END);
3481 /* Check for zero stride, which is not allowed. */
3482 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3484 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3488 /* if start == len || (stride > 0 && start < len)
3489 || (stride < 0 && start > len),
3490 then the array section contains at least one element. In this
3491 case, there is an out-of-bounds access if
3492 (start < lower || start > upper). */
3493 if (compare_bound (AR_START, AR_END) == CMP_EQ
3494 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3495 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3496 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3497 && comp_start_end == CMP_GT))
3499 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3501 gfc_warning ("Lower array reference at %L is out of bounds "
3502 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3503 mpz_get_si (AR_START->value.integer),
3504 mpz_get_si (as->lower[i]->value.integer), i+1);
3507 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3509 gfc_warning ("Lower array reference at %L is out of bounds "
3510 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3511 mpz_get_si (AR_START->value.integer),
3512 mpz_get_si (as->upper[i]->value.integer), i+1);
3517 /* If we can compute the highest index of the array section,
3518 then it also has to be between lower and upper. */
3519 mpz_init (last_value);
3520 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3523 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3525 gfc_warning ("Upper array reference at %L is out of bounds "
3526 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3527 mpz_get_si (last_value),
3528 mpz_get_si (as->lower[i]->value.integer), i+1);
3529 mpz_clear (last_value);
3532 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3534 gfc_warning ("Upper array reference at %L is out of bounds "
3535 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3536 mpz_get_si (last_value),
3537 mpz_get_si (as->upper[i]->value.integer), i+1);
3538 mpz_clear (last_value);
3542 mpz_clear (last_value);
3550 gfc_internal_error ("check_dimension(): Bad array reference");
3557 /* Compare an array reference with an array specification. */
3560 compare_spec_to_ref (gfc_array_ref *ar)
3567 /* TODO: Full array sections are only allowed as actual parameters. */
3568 if (as->type == AS_ASSUMED_SIZE
3569 && (/*ar->type == AR_FULL
3570 ||*/ (ar->type == AR_SECTION
3571 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3573 gfc_error ("Rightmost upper bound of assumed size array section "
3574 "not specified at %L", &ar->where);
3578 if (ar->type == AR_FULL)
3581 if (as->rank != ar->dimen)
3583 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3584 &ar->where, ar->dimen, as->rank);
3588 for (i = 0; i < as->rank; i++)
3589 if (check_dimension (i, ar, as) == FAILURE)
3596 /* Resolve one part of an array index. */
3599 gfc_resolve_index (gfc_expr *index, int check_scalar)
3606 if (gfc_resolve_expr (index) == FAILURE)
3609 if (check_scalar && index->rank != 0)
3611 gfc_error ("Array index at %L must be scalar", &index->where);
3615 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3617 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3618 &index->where, gfc_basic_typename (index->ts.type));
3622 if (index->ts.type == BT_REAL)
3623 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3624 &index->where) == FAILURE)
3627 if (index->ts.kind != gfc_index_integer_kind
3628 || index->ts.type != BT_INTEGER)
3631 ts.type = BT_INTEGER;
3632 ts.kind = gfc_index_integer_kind;
3634 gfc_convert_type_warn (index, &ts, 2, 0);
3640 /* Resolve a dim argument to an intrinsic function. */
3643 gfc_resolve_dim_arg (gfc_expr *dim)
3648 if (gfc_resolve_expr (dim) == FAILURE)
3653 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3658 if (dim->ts.type != BT_INTEGER)
3660 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3664 if (dim->ts.kind != gfc_index_integer_kind)
3668 ts.type = BT_INTEGER;
3669 ts.kind = gfc_index_integer_kind;
3671 gfc_convert_type_warn (dim, &ts, 2, 0);
3677 /* Given an expression that contains array references, update those array
3678 references to point to the right array specifications. While this is
3679 filled in during matching, this information is difficult to save and load
3680 in a module, so we take care of it here.
3682 The idea here is that the original array reference comes from the
3683 base symbol. We traverse the list of reference structures, setting
3684 the stored reference to references. Component references can
3685 provide an additional array specification. */
3688 find_array_spec (gfc_expr *e)
3692 gfc_symbol *derived;
3695 as = e->symtree->n.sym->as;
3698 for (ref = e->ref; ref; ref = ref->next)
3703 gfc_internal_error ("find_array_spec(): Missing spec");
3710 if (derived == NULL)
3711 derived = e->symtree->n.sym->ts.derived;
3713 c = derived->components;
3715 for (; c; c = c->next)
3716 if (c == ref->u.c.component)
3718 /* Track the sequence of component references. */
3719 if (c->ts.type == BT_DERIVED)
3720 derived = c->ts.derived;
3725 gfc_internal_error ("find_array_spec(): Component not found");
3727 if (c->attr.dimension)
3730 gfc_internal_error ("find_array_spec(): unused as(1)");
3741 gfc_internal_error ("find_array_spec(): unused as(2)");
3745 /* Resolve an array reference. */
3748 resolve_array_ref (gfc_array_ref *ar)
3750 int i, check_scalar;
3753 for (i = 0; i < ar->dimen; i++)
3755 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3757 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3759 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3761 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3766 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3770 ar->dimen_type[i] = DIMEN_ELEMENT;
3774 ar->dimen_type[i] = DIMEN_VECTOR;
3775 if (e->expr_type == EXPR_VARIABLE
3776 && e->symtree->n.sym->ts.type == BT_DERIVED)
3777 ar->start[i] = gfc_get_parentheses (e);
3781 gfc_error ("Array index at %L is an array of rank %d",
3782 &ar->c_where[i], e->rank);
3787 /* If the reference type is unknown, figure out what kind it is. */
3789 if (ar->type == AR_UNKNOWN)
3791 ar->type = AR_ELEMENT;
3792 for (i = 0; i < ar->dimen; i++)
3793 if (ar->dimen_type[i] == DIMEN_RANGE
3794 || ar->dimen_type[i] == DIMEN_VECTOR)
3796 ar->type = AR_SECTION;
3801 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3809 resolve_substring (gfc_ref *ref)
3811 if (ref->u.ss.start != NULL)
3813 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3816 if (ref->u.ss.start->ts.type != BT_INTEGER)
3818 gfc_error ("Substring start index at %L must be of type INTEGER",
3819 &ref->u.ss.start->where);
3823 if (ref->u.ss.start->rank != 0)
3825 gfc_error ("Substring start index at %L must be scalar",
3826 &ref->u.ss.start->where);
3830 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3831 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3832 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3834 gfc_error ("Substring start index at %L is less than one",
3835 &ref->u.ss.start->where);
3840 if (ref->u.ss.end != NULL)
3842 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3845 if (ref->u.ss.end->ts.type != BT_INTEGER)
3847 gfc_error ("Substring end index at %L must be of type INTEGER",
3848 &ref->u.ss.end->where);
3852 if (ref->u.ss.end->rank != 0)
3854 gfc_error ("Substring end index at %L must be scalar",
3855 &ref->u.ss.end->where);
3859 if (ref->u.ss.length != NULL
3860 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3861 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3862 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3864 gfc_error ("Substring end index at %L exceeds the string length",
3865 &ref->u.ss.start->where);
3874 /* This function supplies missing substring charlens. */
3877 gfc_resolve_substring_charlen (gfc_expr *e)
3880 gfc_expr *start, *end;
3882 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3883 if (char_ref->type == REF_SUBSTRING)
3889 gcc_assert (char_ref->next == NULL);
3893 if (e->ts.cl->length)
3894 gfc_free_expr (e->ts.cl->length);
3895 else if (e->expr_type == EXPR_VARIABLE
3896 && e->symtree->n.sym->attr.dummy)
3900 e->ts.type = BT_CHARACTER;
3901 e->ts.kind = gfc_default_character_kind;
3905 e->ts.cl = gfc_get_charlen ();
3906 e->ts.cl->next = gfc_current_ns->cl_list;
3907 gfc_current_ns->cl_list = e->ts.cl;
3910 if (char_ref->u.ss.start)
3911 start = gfc_copy_expr (char_ref->u.ss.start);
3913 start = gfc_int_expr (1);
3915 if (char_ref->u.ss.end)
3916 end = gfc_copy_expr (char_ref->u.ss.end);
3917 else if (e->expr_type == EXPR_VARIABLE)
3918 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3925 /* Length = (end - start +1). */
3926 e->ts.cl->length = gfc_subtract (end, start);
3927 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3929 e->ts.cl->length->ts.type = BT_INTEGER;
3930 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3932 /* Make sure that the length is simplified. */
3933 gfc_simplify_expr (e->ts.cl->length, 1);
3934 gfc_resolve_expr (e->ts.cl->length);
3938 /* Resolve subtype references. */
3941 resolve_ref (gfc_expr *expr)
3943 int current_part_dimension, n_components, seen_part_dimension;
3946 for (ref = expr->ref; ref; ref = ref->next)
3947 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3949 find_array_spec (expr);
3953 for (ref = expr->ref; ref; ref = ref->next)
3957 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3965 resolve_substring (ref);
3969 /* Check constraints on part references. */
3971 current_part_dimension = 0;
3972 seen_part_dimension = 0;
3975 for (ref = expr->ref; ref; ref = ref->next)
3980 switch (ref->u.ar.type)
3984 current_part_dimension = 1;
3988 current_part_dimension = 0;
3992 gfc_internal_error ("resolve_ref(): Bad array reference");
3998 if (current_part_dimension || seen_part_dimension)
4000 if (ref->u.c.component->attr.pointer)
4002 gfc_error ("Component to the right of a part reference "
4003 "with nonzero rank must not have the POINTER "
4004 "attribute at %L", &expr->where);
4007 else if (ref->u.c.component->attr.allocatable)
4009 gfc_error ("Component to the right of a part reference "
4010 "with nonzero rank must not have the ALLOCATABLE "
4011 "attribute at %L", &expr->where);
4023 if (((ref->type == REF_COMPONENT && n_components > 1)
4024 || ref->next == NULL)
4025 && current_part_dimension
4026 && seen_part_dimension)
4028 gfc_error ("Two or more part references with nonzero rank must "
4029 "not be specified at %L", &expr->where);
4033 if (ref->type == REF_COMPONENT)
4035 if (current_part_dimension)
4036 seen_part_dimension = 1;
4038 /* reset to make sure */
4039 current_part_dimension = 0;
4047 /* Given an expression, determine its shape. This is easier than it sounds.
4048 Leaves the shape array NULL if it is not possible to determine the shape. */
4051 expression_shape (gfc_expr *e)
4053 mpz_t array[GFC_MAX_DIMENSIONS];
4056 if (e->rank == 0 || e->shape != NULL)
4059 for (i = 0; i < e->rank; i++)
4060 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4063 e->shape = gfc_get_shape (e->rank);
4065 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4070 for (i--; i >= 0; i--)
4071 mpz_clear (array[i]);
4075 /* Given a variable expression node, compute the rank of the expression by
4076 examining the base symbol and any reference structures it may have. */
4079 expression_rank (gfc_expr *e)
4084 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4085 could lead to serious confusion... */
4086 gcc_assert (e->expr_type != EXPR_COMPCALL);
4090 if (e->expr_type == EXPR_ARRAY)
4092 /* Constructors can have a rank different from one via RESHAPE(). */
4094 if (e->symtree == NULL)
4100 e->rank = (e->symtree->n.sym->as == NULL)
4101 ? 0 : e->symtree->n.sym->as->rank;
4107 for (ref = e->ref; ref; ref = ref->next)
4109 if (ref->type != REF_ARRAY)
4112 if (ref->u.ar.type == AR_FULL)
4114 rank = ref->u.ar.as->rank;
4118 if (ref->u.ar.type == AR_SECTION)
4120 /* Figure out the rank of the section. */
4122 gfc_internal_error ("expression_rank(): Two array specs");
4124 for (i = 0; i < ref->u.ar.dimen; i++)
4125 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4126 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4136 expression_shape (e);
4140 /* Resolve a variable expression. */
4143 resolve_variable (gfc_expr *e)
4150 if (e->symtree == NULL)
4153 if (e->ref && resolve_ref (e) == FAILURE)
4156 sym = e->symtree->n.sym;
4157 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
4159 e->ts.type = BT_PROCEDURE;
4163 if (sym->ts.type != BT_UNKNOWN)
4164 gfc_variable_attr (e, &e->ts);
4167 /* Must be a simple variable reference. */
4168 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4173 if (check_assumed_size_reference (sym, e))
4176 /* Deal with forward references to entries during resolve_code, to
4177 satisfy, at least partially, 12.5.2.5. */
4178 if (gfc_current_ns->entries
4179 && current_entry_id == sym->entry_id
4182 && cs_base->current->op != EXEC_ENTRY)
4184 gfc_entry_list *entry;
4185 gfc_formal_arglist *formal;
4189 /* If the symbol is a dummy... */
4190 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4192 entry = gfc_current_ns->entries;
4195 /* ...test if the symbol is a parameter of previous entries. */
4196 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4197 for (formal = entry->sym->formal; formal; formal = formal->next)
4199 if (formal->sym && sym->name == formal->sym->name)
4203 /* If it has not been seen as a dummy, this is an error. */
4206 if (specification_expr)
4207 gfc_error ("Variable '%s', used in a specification expression"
4208 ", is referenced at %L before the ENTRY statement "
4209 "in which it is a parameter",
4210 sym->name, &cs_base->current->loc);
4212 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4213 "statement in which it is a parameter",
4214 sym->name, &cs_base->current->loc);
4219 /* Now do the same check on the specification expressions. */
4220 specification_expr = 1;
4221 if (sym->ts.type == BT_CHARACTER
4222 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
4226 for (n = 0; n < sym->as->rank; n++)
4228 specification_expr = 1;
4229 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4231 specification_expr = 1;
4232 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4235 specification_expr = 0;
4238 /* Update the symbol's entry level. */
4239 sym->entry_id = current_entry_id + 1;
4246 /* Checks to see that the correct symbol has been host associated.
4247 The only situation where this arises is that in which a twice
4248 contained function is parsed after the host association is made.
4249 Therefore, on detecting this, the line is rematched, having got
4250 rid of the existing references and actual_arg_list. */
4252 check_host_association (gfc_expr *e)
4254 gfc_symbol *sym, *old_sym;
4258 bool retval = e->expr_type == EXPR_FUNCTION;
4260 if (e->symtree == NULL || e->symtree->n.sym == NULL)
4263 old_sym = e->symtree->n.sym;
4265 if (gfc_current_ns->parent
4266 && old_sym->ns != gfc_current_ns)
4268 gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym);
4269 if (sym && old_sym != sym
4270 && sym->ts.type == old_sym->ts.type
4271 && sym->attr.flavor == FL_PROCEDURE
4272 && sym->attr.contained)
4274 temp_locus = gfc_current_locus;
4275 gfc_current_locus = e->where;
4277 gfc_buffer_error (1);
4279 gfc_free_ref_list (e->ref);
4284 gfc_free_actual_arglist (e->value.function.actual);
4285 e->value.function.actual = NULL;
4288 if (e->shape != NULL)
4290 for (n = 0; n < e->rank; n++)
4291 mpz_clear (e->shape[n]);
4293 gfc_free (e->shape);
4296 gfc_match_rvalue (&expr);
4298 gfc_buffer_error (0);
4300 gcc_assert (expr && sym == expr->symtree->n.sym);
4306 gfc_current_locus = temp_locus;
4309 /* This might have changed! */
4310 return e->expr_type == EXPR_FUNCTION;
4315 gfc_resolve_character_operator (gfc_expr *e)
4317 gfc_expr *op1 = e->value.op.op1;
4318 gfc_expr *op2 = e->value.op.op2;
4319 gfc_expr *e1 = NULL;
4320 gfc_expr *e2 = NULL;
4322 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
4324 if (op1->ts.cl && op1->ts.cl->length)
4325 e1 = gfc_copy_expr (op1->ts.cl->length);
4326 else if (op1->expr_type == EXPR_CONSTANT)
4327 e1 = gfc_int_expr (op1->value.character.length);
4329 if (op2->ts.cl && op2->ts.cl->length)
4330 e2 = gfc_copy_expr (op2->ts.cl->length);
4331 else if (op2->expr_type == EXPR_CONSTANT)
4332 e2 = gfc_int_expr (op2->value.character.length);
4334 e->ts.cl = gfc_get_charlen ();
4335 e->ts.cl->next = gfc_current_ns->cl_list;
4336 gfc_current_ns->cl_list = e->ts.cl;
4341 e->ts.cl->length = gfc_add (e1, e2);
4342 e->ts.cl->length->ts.type = BT_INTEGER;
4343 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4344 gfc_simplify_expr (e->ts.cl->length, 0);
4345 gfc_resolve_expr (e->ts.cl->length);
4351 /* Ensure that an character expression has a charlen and, if possible, a
4352 length expression. */
4355 fixup_charlen (gfc_expr *e)
4357 /* The cases fall through so that changes in expression type and the need
4358 for multiple fixes are picked up. In all circumstances, a charlen should
4359 be available for the middle end to hang a backend_decl on. */
4360 switch (e->expr_type)
4363 gfc_resolve_character_operator (e);
4366 if (e->expr_type == EXPR_ARRAY)
4367 gfc_resolve_character_array_constructor (e);
4369 case EXPR_SUBSTRING:
4370 if (!e->ts.cl && e->ref)
4371 gfc_resolve_substring_charlen (e);
4376 e->ts.cl = gfc_get_charlen ();
4377 e->ts.cl->next = gfc_current_ns->cl_list;
4378 gfc_current_ns->cl_list = e->ts.cl;
4386 /* Update an actual argument to include the passed-object for type-bound
4387 procedures at the right position. */
4389 static gfc_actual_arglist*
4390 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
4392 gcc_assert (argpos > 0);
4396 gfc_actual_arglist* result;
4398 result = gfc_get_actual_arglist ();
4406 gcc_assert (argpos > 1);
4408 lst->next = update_arglist_pass (lst->next, po, argpos - 1);
4413 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4416 extract_compcall_passed_object (gfc_expr* e)
4420 gcc_assert (e->expr_type == EXPR_COMPCALL);
4422 po = gfc_get_expr ();
4423 po->expr_type = EXPR_VARIABLE;
4424 po->symtree = e->symtree;
4425 po->ref = gfc_copy_ref (e->ref);
4427 if (gfc_resolve_expr (po) == FAILURE)
4434 /* Update the arglist of an EXPR_COMPCALL expression to include the
4438 update_compcall_arglist (gfc_expr* e)
4441 gfc_typebound_proc* tbp;
4443 tbp = e->value.compcall.tbp;
4448 po = extract_compcall_passed_object (e);
4454 gfc_error ("Passed-object at %L must be scalar", &e->where);
4464 gcc_assert (tbp->pass_arg_num > 0);
4465 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4472 /* Resolve a call to a type-bound procedure, either function or subroutine,
4473 statically from the data in an EXPR_COMPCALL expression. The adapted
4474 arglist and the target-procedure symtree are returned. */
4477 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
4478 gfc_actual_arglist** actual)
4480 gcc_assert (e->expr_type == EXPR_COMPCALL);
4481 gcc_assert (!e->value.compcall.tbp->is_generic);
4483 /* Update the actual arglist for PASS. */
4484 if (update_compcall_arglist (e) == FAILURE)
4487 *actual = e->value.compcall.actual;
4488 *target = e->value.compcall.tbp->u.specific;
4490 gfc_free_ref_list (e->ref);
4492 e->value.compcall.actual = NULL;
4498 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4499 which of the specific bindings (if any) matches the arglist and transform
4500 the expression into a call of that binding. */
4503 resolve_typebound_generic_call (gfc_expr* e)
4505 gfc_typebound_proc* genproc;
4506 const char* genname;
4508 gcc_assert (e->expr_type == EXPR_COMPCALL);
4509 genname = e->value.compcall.name;
4510 genproc = e->value.compcall.tbp;
4512 if (!genproc->is_generic)
4515 /* Try the bindings on this type and in the inheritance hierarchy. */
4516 for (; genproc; genproc = genproc->overridden)
4520 gcc_assert (genproc->is_generic);
4521 for (g = genproc->u.generic; g; g = g->next)
4524 gfc_actual_arglist* args;
4527 gcc_assert (g->specific);
4529 if (g->specific->error)
4532 target = g->specific->u.specific->n.sym;
4534 /* Get the right arglist by handling PASS/NOPASS. */
4535 args = gfc_copy_actual_arglist (e->value.compcall.actual);
4536 if (!g->specific->nopass)
4539 po = extract_compcall_passed_object (e);
4543 gcc_assert (g->specific->pass_arg_num > 0);
4544 gcc_assert (!g->specific->error);
4545 args = update_arglist_pass (args, po, g->specific->pass_arg_num);
4547 resolve_actual_arglist (args, target->attr.proc,
4548 is_external_proc (target) && !target->formal);
4550 /* Check if this arglist matches the formal. */
4551 matches = gfc_arglist_matches_symbol (&args, target);
4553 /* Clean up and break out of the loop if we've found it. */
4554 gfc_free_actual_arglist (args);
4557 e->value.compcall.tbp = g->specific;
4563 /* Nothing matching found! */
4564 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4565 " '%s' at %L", genname, &e->where);
4573 /* Resolve a call to a type-bound subroutine. */
4576 resolve_typebound_call (gfc_code* c)
4578 gfc_actual_arglist* newactual;
4579 gfc_symtree* target;
4581 /* Check that's really a SUBROUTINE. */
4582 if (!c->expr->value.compcall.tbp->subroutine)
4584 gfc_error ("'%s' at %L should be a SUBROUTINE",
4585 c->expr->value.compcall.name, &c->loc);
4589 if (resolve_typebound_generic_call (c->expr) == FAILURE)
4592 /* Transform into an ordinary EXEC_CALL for now. */
4594 if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
4597 c->ext.actual = newactual;
4598 c->symtree = target;
4601 gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
4602 gfc_free_expr (c->expr);
4605 return resolve_call (c);
4609 /* Resolve a component-call expression. */
4612 resolve_compcall (gfc_expr* e)
4614 gfc_actual_arglist* newactual;
4615 gfc_symtree* target;
4617 /* Check that's really a FUNCTION. */
4618 if (!e->value.compcall.tbp->function)
4620 gfc_error ("'%s' at %L should be a FUNCTION",
4621 e->value.compcall.name, &e->where);
4625 if (resolve_typebound_generic_call (e) == FAILURE)
4627 gcc_assert (!e->value.compcall.tbp->is_generic);
4629 /* Take the rank from the function's symbol. */
4630 if (e->value.compcall.tbp->u.specific->n.sym->as)
4631 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
4633 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4634 arglist to the TBP's binding target. */
4636 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
4639 e->value.function.actual = newactual;
4640 e->value.function.name = e->value.compcall.name;
4641 e->value.function.isym = NULL;
4642 e->value.function.esym = NULL;
4643 e->symtree = target;
4644 e->ts = target->n.sym->ts;
4645 e->expr_type = EXPR_FUNCTION;
4647 return gfc_resolve_expr (e);
4651 /* Resolve an expression. That is, make sure that types of operands agree
4652 with their operators, intrinsic operators are converted to function calls
4653 for overloaded types and unresolved function references are resolved. */
4656 gfc_resolve_expr (gfc_expr *e)
4663 switch (e->expr_type)
4666 t = resolve_operator (e);
4672 if (check_host_association (e))
4673 t = resolve_function (e);
4676 t = resolve_variable (e);
4678 expression_rank (e);
4681 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4682 && e->ref->type != REF_SUBSTRING)
4683 gfc_resolve_substring_charlen (e);
4688 t = resolve_compcall (e);
4691 case EXPR_SUBSTRING:
4692 t = resolve_ref (e);
4702 if (resolve_ref (e) == FAILURE)
4705 t = gfc_resolve_array_constructor (e);
4706 /* Also try to expand a constructor. */
4709 expression_rank (e);
4710 gfc_expand_constructor (e);
4713 /* This provides the opportunity for the length of constructors with
4714 character valued function elements to propagate the string length
4715 to the expression. */
4716 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
4717 t = gfc_resolve_character_array_constructor (e);
4721 case EXPR_STRUCTURE:
4722 t = resolve_ref (e);
4726 t = resolve_structure_cons (e);
4730 t = gfc_simplify_expr (e, 0);
4734 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4737 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4744 /* Resolve an expression from an iterator. They must be scalar and have
4745 INTEGER or (optionally) REAL type. */
4748 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4749 const char *name_msgid)
4751 if (gfc_resolve_expr (expr) == FAILURE)
4754 if (expr->rank != 0)
4756 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4760 if (expr->ts.type != BT_INTEGER)
4762 if (expr->ts.type == BT_REAL)
4765 return gfc_notify_std (GFC_STD_F95_DEL,
4766 "Deleted feature: %s at %L must be integer",
4767 _(name_msgid), &expr->where);
4770 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4777 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4785 /* Resolve the expressions in an iterator structure. If REAL_OK is
4786 false allow only INTEGER type iterators, otherwise allow REAL types. */
4789 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4791 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4795 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4797 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4802 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4803 "Start expression in DO loop") == FAILURE)
4806 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4807 "End expression in DO loop") == FAILURE)
4810 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4811 "Step expression in DO loop") == FAILURE)
4814 if (iter->step->expr_type == EXPR_CONSTANT)
4816 if ((iter->step->ts.type == BT_INTEGER
4817 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4818 || (iter->step->ts.type == BT_REAL
4819 && mpfr_sgn (iter->step->value.real) == 0))
4821 gfc_error ("Step expression in DO loop at %L cannot be zero",
4822 &iter->step->where);
4827 /* Convert start, end, and step to the same type as var. */
4828 if (iter->start->ts.kind != iter->var->ts.kind
4829 || iter->start->ts.type != iter->var->ts.type)
4830 gfc_convert_type (iter->start, &iter->var->ts, 2);
4832 if (iter->end->ts.kind != iter->var->ts.kind
4833 || iter->end->ts.type != iter->var->ts.type)
4834 gfc_convert_type (iter->end, &iter->var->ts, 2);
4836 if (iter->step->ts.kind != iter->var->ts.kind
4837 || iter->step->ts.type != iter->var->ts.type)
4838 gfc_convert_type (iter->step, &iter->var->ts, 2);
4844 /* Traversal function for find_forall_index. f == 2 signals that
4845 that variable itself is not to be checked - only the references. */
4848 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
4850 if (expr->expr_type != EXPR_VARIABLE)
4853 /* A scalar assignment */
4854 if (!expr->ref || *f == 1)
4856 if (expr->symtree->n.sym == sym)
4868 /* Check whether the FORALL index appears in the expression or not.
4869 Returns SUCCESS if SYM is found in EXPR. */
4872 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
4874 if (gfc_traverse_expr (expr, sym, forall_index, f))
4881 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4882 to be a scalar INTEGER variable. The subscripts and stride are scalar
4883 INTEGERs, and if stride is a constant it must be nonzero.
4884 Furthermore "A subscript or stride in a forall-triplet-spec shall
4885 not contain a reference to any index-name in the
4886 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4889 resolve_forall_iterators (gfc_forall_iterator *it)
4891 gfc_forall_iterator *iter, *iter2;
4893 for (iter = it; iter; iter = iter->next)
4895 if (gfc_resolve_expr (iter->var) == SUCCESS
4896 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4897 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4900 if (gfc_resolve_expr (iter->start) == SUCCESS
4901 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4902 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4903 &iter->start->where);
4904 if (iter->var->ts.kind != iter->start->ts.kind)
4905 gfc_convert_type (iter->start, &iter->var->ts, 2);
4907 if (gfc_resolve_expr (iter->end) == SUCCESS
4908 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4909 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4911 if (iter->var->ts.kind != iter->end->ts.kind)
4912 gfc_convert_type (iter->end, &iter->var->ts, 2);
4914 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4916 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4917 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4918 &iter->stride->where, "INTEGER");
4920 if (iter->stride->expr_type == EXPR_CONSTANT
4921 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4922 gfc_error ("FORALL stride expression at %L cannot be zero",
4923 &iter->stride->where);
4925 if (iter->var->ts.kind != iter->stride->ts.kind)
4926 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4929 for (iter = it; iter; iter = iter->next)
4930 for (iter2 = iter; iter2; iter2 = iter2->next)
4932 if (find_forall_index (iter2->start,
4933 iter->var->symtree->n.sym, 0) == SUCCESS
4934 || find_forall_index (iter2->end,
4935 iter->var->symtree->n.sym, 0) == SUCCESS
4936 || find_forall_index (iter2->stride,
4937 iter->var->symtree->n.sym, 0) == SUCCESS)
4938 gfc_error ("FORALL index '%s' may not appear in triplet "
4939 "specification at %L", iter->var->symtree->name,
4940 &iter2->start->where);
4945 /* Given a pointer to a symbol that is a derived type, see if it's
4946 inaccessible, i.e. if it's defined in another module and the components are
4947 PRIVATE. The search is recursive if necessary. Returns zero if no
4948 inaccessible components are found, nonzero otherwise. */
4951 derived_inaccessible (gfc_symbol *sym)
4955 if (sym->attr.use_assoc && sym->attr.private_comp)
4958 for (c = sym->components; c; c = c->next)
4960 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4968 /* Resolve the argument of a deallocate expression. The expression must be
4969 a pointer or a full array. */
4972 resolve_deallocate_expr (gfc_expr *e)
4974 symbol_attribute attr;
4975 int allocatable, pointer, check_intent_in;
4978 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4979 check_intent_in = 1;
4981 if (gfc_resolve_expr (e) == FAILURE)
4984 if (e->expr_type != EXPR_VARIABLE)
4987 allocatable = e->symtree->n.sym->attr.allocatable;
4988 pointer = e->symtree->n.sym->attr.pointer;
4989 for (ref = e->ref; ref; ref = ref->next)
4992 check_intent_in = 0;
4997 if (ref->u.ar.type != AR_FULL)
5002 allocatable = (ref->u.c.component->as != NULL
5003 && ref->u.c.component->as->type == AS_DEFERRED);
5004 pointer = ref->u.c.component->attr.pointer;
5013 attr = gfc_expr_attr (e);
5015 if (allocatable == 0 && attr.pointer == 0)
5018 gfc_error ("Expression in DEALLOCATE statement at %L must be "
5019 "ALLOCATABLE or a POINTER", &e->where);
5023 && e->symtree->n.sym->attr.intent == INTENT_IN)
5025 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5026 e->symtree->n.sym->name, &e->where);
5034 /* Returns true if the expression e contains a reference to the symbol sym. */
5036 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5038 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
5045 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
5047 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
5051 /* Given the expression node e for an allocatable/pointer of derived type to be
5052 allocated, get the expression node to be initialized afterwards (needed for
5053 derived types with default initializers, and derived types with allocatable
5054 components that need nullification.) */
5057 expr_to_initialize (gfc_expr *e)
5063 result = gfc_copy_expr (e);
5065 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5066 for (ref = result->ref; ref; ref = ref->next)
5067 if (ref->type == REF_ARRAY && ref->next == NULL)
5069 ref->u.ar.type = AR_FULL;
5071 for (i = 0; i < ref->u.ar.dimen; i++)
5072 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
5074 result->rank = ref->u.ar.dimen;
5082 /* Resolve the expression in an ALLOCATE statement, doing the additional
5083 checks to see whether the expression is OK or not. The expression must
5084 have a trailing array reference that gives the size of the array. */
5087 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
5089 int i, pointer, allocatable, dimension, check_intent_in;
5090 symbol_attribute attr;
5091 gfc_ref *ref, *ref2;
5098 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5099 check_intent_in = 1;
5101 if (gfc_resolve_expr (e) == FAILURE)
5104 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
5105 sym = code->expr->symtree->n.sym;
5109 /* Make sure the expression is allocatable or a pointer. If it is
5110 pointer, the next-to-last reference must be a pointer. */
5114 if (e->expr_type != EXPR_VARIABLE)
5117 attr = gfc_expr_attr (e);
5118 pointer = attr.pointer;
5119 dimension = attr.dimension;
5123 allocatable = e->symtree->n.sym->attr.allocatable;
5124 pointer = e->symtree->n.sym->attr.pointer;
5125 dimension = e->symtree->n.sym->attr.dimension;
5127 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
5129 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
5130 "not be allocated in the same statement at %L",
5131 sym->name, &e->where);
5135 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
5138 check_intent_in = 0;
5143 if (ref->next != NULL)
5148 allocatable = (ref->u.c.component->as != NULL
5149 && ref->u.c.component->as->type == AS_DEFERRED);
5151 pointer = ref->u.c.component->attr.pointer;
5152 dimension = ref->u.c.component->attr.dimension;
5163 if (allocatable == 0 && pointer == 0)
5165 gfc_error ("Expression in ALLOCATE statement at %L must be "
5166 "ALLOCATABLE or a POINTER", &e->where);
5171 && e->symtree->n.sym->attr.intent == INTENT_IN)
5173 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5174 e->symtree->n.sym->name, &e->where);
5178 /* Add default initializer for those derived types that need them. */
5179 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
5181 init_st = gfc_get_code ();
5182 init_st->loc = code->loc;
5183 init_st->op = EXEC_INIT_ASSIGN;
5184 init_st->expr = expr_to_initialize (e);
5185 init_st->expr2 = init_e;
5186 init_st->next = code->next;
5187 code->next = init_st;
5190 if (pointer && dimension == 0)
5193 /* Make sure the next-to-last reference node is an array specification. */
5195 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
5197 gfc_error ("Array specification required in ALLOCATE statement "
5198 "at %L", &e->where);
5202 /* Make sure that the array section reference makes sense in the
5203 context of an ALLOCATE specification. */
5207 for (i = 0; i < ar->dimen; i++)
5209 if (ref2->u.ar.type == AR_ELEMENT)
5212 switch (ar->dimen_type[i])
5218 if (ar->start[i] != NULL
5219 && ar->end[i] != NULL
5220 && ar->stride[i] == NULL)
5223 /* Fall Through... */
5227 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5234 for (a = code->ext.alloc_list; a; a = a->next)
5236 sym = a->expr->symtree->n.sym;
5238 /* TODO - check derived type components. */
5239 if (sym->ts.type == BT_DERIVED)
5242 if ((ar->start[i] != NULL
5243 && gfc_find_sym_in_expr (sym, ar->start[i]))
5244 || (ar->end[i] != NULL
5245 && gfc_find_sym_in_expr (sym, ar->end[i])))
5247 gfc_error ("'%s' must not appear in the array specification at "
5248 "%L in the same ALLOCATE statement where it is "
5249 "itself allocated", sym->name, &ar->where);
5259 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
5261 gfc_symbol *s = NULL;
5265 s = code->expr->symtree->n.sym;
5269 if (s->attr.intent == INTENT_IN)
5270 gfc_error ("STAT variable '%s' of %s statement at %C cannot "
5271 "be INTENT(IN)", s->name, fcn);
5273 if (gfc_pure (NULL) && gfc_impure_variable (s))
5274 gfc_error ("Illegal STAT variable in %s statement at %C "
5275 "for a PURE procedure", fcn);
5278 if (s && code->expr->ts.type != BT_INTEGER)
5279 gfc_error ("STAT tag in %s statement at %L must be "
5280 "of type INTEGER", fcn, &code->expr->where);
5282 if (strcmp (fcn, "ALLOCATE") == 0)
5284 for (a = code->ext.alloc_list; a; a = a->next)
5285 resolve_allocate_expr (a->expr, code);
5289 for (a = code->ext.alloc_list; a; a = a->next)
5290 resolve_deallocate_expr (a->expr);
5294 /************ SELECT CASE resolution subroutines ************/
5296 /* Callback function for our mergesort variant. Determines interval
5297 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5298 op1 > op2. Assumes we're not dealing with the default case.
5299 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5300 There are nine situations to check. */
5303 compare_cases (const gfc_case *op1, const gfc_case *op2)
5307 if (op1->low == NULL) /* op1 = (:L) */
5309 /* op2 = (:N), so overlap. */
5311 /* op2 = (M:) or (M:N), L < M */
5312 if (op2->low != NULL
5313 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5316 else if (op1->high == NULL) /* op1 = (K:) */
5318 /* op2 = (M:), so overlap. */
5320 /* op2 = (:N) or (M:N), K > N */
5321 if (op2->high != NULL
5322 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5325 else /* op1 = (K:L) */
5327 if (op2->low == NULL) /* op2 = (:N), K > N */
5328 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5330 else if (op2->high == NULL) /* op2 = (M:), L < M */
5331 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5333 else /* op2 = (M:N) */
5337 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5340 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5349 /* Merge-sort a double linked case list, detecting overlap in the
5350 process. LIST is the head of the double linked case list before it
5351 is sorted. Returns the head of the sorted list if we don't see any
5352 overlap, or NULL otherwise. */
5355 check_case_overlap (gfc_case *list)
5357 gfc_case *p, *q, *e, *tail;
5358 int insize, nmerges, psize, qsize, cmp, overlap_seen;
5360 /* If the passed list was empty, return immediately. */
5367 /* Loop unconditionally. The only exit from this loop is a return
5368 statement, when we've finished sorting the case list. */
5375 /* Count the number of merges we do in this pass. */
5378 /* Loop while there exists a merge to be done. */
5383 /* Count this merge. */
5386 /* Cut the list in two pieces by stepping INSIZE places
5387 forward in the list, starting from P. */
5390 for (i = 0; i < insize; i++)
5399 /* Now we have two lists. Merge them! */
5400 while (psize > 0 || (qsize > 0 && q != NULL))
5402 /* See from which the next case to merge comes from. */
5405 /* P is empty so the next case must come from Q. */
5410 else if (qsize == 0 || q == NULL)
5419 cmp = compare_cases (p, q);
5422 /* The whole case range for P is less than the
5430 /* The whole case range for Q is greater than
5431 the case range for P. */
5438 /* The cases overlap, or they are the same
5439 element in the list. Either way, we must
5440 issue an error and get the next case from P. */
5441 /* FIXME: Sort P and Q by line number. */
5442 gfc_error ("CASE label at %L overlaps with CASE "
5443 "label at %L", &p->where, &q->where);
5451 /* Add the next element to the merged list. */
5460 /* P has now stepped INSIZE places along, and so has Q. So
5461 they're the same. */
5466 /* If we have done only one merge or none at all, we've
5467 finished sorting the cases. */
5476 /* Otherwise repeat, merging lists twice the size. */
5482 /* Check to see if an expression is suitable for use in a CASE statement.
5483 Makes sure that all case expressions are scalar constants of the same
5484 type. Return FAILURE if anything is wrong. */
5487 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5489 if (e == NULL) return SUCCESS;
5491 if (e->ts.type != case_expr->ts.type)
5493 gfc_error ("Expression in CASE statement at %L must be of type %s",
5494 &e->where, gfc_basic_typename (case_expr->ts.type));
5498 /* C805 (R808) For a given case-construct, each case-value shall be of
5499 the same type as case-expr. For character type, length differences
5500 are allowed, but the kind type parameters shall be the same. */
5502 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5504 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5505 &e->where, case_expr->ts.kind);
5509 /* Convert the case value kind to that of case expression kind, if needed.
5510 FIXME: Should a warning be issued? */
5511 if (e->ts.kind != case_expr->ts.kind)
5512 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5516 gfc_error ("Expression in CASE statement at %L must be scalar",
5525 /* Given a completely parsed select statement, we:
5527 - Validate all expressions and code within the SELECT.
5528 - Make sure that the selection expression is not of the wrong type.
5529 - Make sure that no case ranges overlap.
5530 - Eliminate unreachable cases and unreachable code resulting from
5531 removing case labels.
5533 The standard does allow unreachable cases, e.g. CASE (5:3). But
5534 they are a hassle for code generation, and to prevent that, we just
5535 cut them out here. This is not necessary for overlapping cases
5536 because they are illegal and we never even try to generate code.
5538 We have the additional caveat that a SELECT construct could have
5539 been a computed GOTO in the source code. Fortunately we can fairly
5540 easily work around that here: The case_expr for a "real" SELECT CASE
5541 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5542 we have to do is make sure that the case_expr is a scalar integer
5546 resolve_select (gfc_code *code)
5549 gfc_expr *case_expr;
5550 gfc_case *cp, *default_case, *tail, *head;
5551 int seen_unreachable;
5557 if (code->expr == NULL)
5559 /* This was actually a computed GOTO statement. */
5560 case_expr = code->expr2;
5561 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5562 gfc_error ("Selection expression in computed GOTO statement "
5563 "at %L must be a scalar integer expression",
5566 /* Further checking is not necessary because this SELECT was built
5567 by the compiler, so it should always be OK. Just move the
5568 case_expr from expr2 to expr so that we can handle computed
5569 GOTOs as normal SELECTs from here on. */
5570 code->expr = code->expr2;
5575 case_expr = code->expr;
5577 type = case_expr->ts.type;
5578 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5580 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5581 &case_expr->where, gfc_typename (&case_expr->ts));
5583 /* Punt. Going on here just produce more garbage error messages. */
5587 if (case_expr->rank != 0)
5589 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5590 "expression", &case_expr->where);
5596 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5597 of the SELECT CASE expression and its CASE values. Walk the lists
5598 of case values, and if we find a mismatch, promote case_expr to
5599 the appropriate kind. */
5601 if (type == BT_LOGICAL || type == BT_INTEGER)
5603 for (body = code->block; body; body = body->block)
5605 /* Walk the case label list. */
5606 for (cp = body->ext.case_list; cp; cp = cp->next)
5608 /* Intercept the DEFAULT case. It does not have a kind. */
5609 if (cp->low == NULL && cp->high == NULL)
5612 /* Unreachable case ranges are discarded, so ignore. */
5613 if (cp->low != NULL && cp->high != NULL
5614 && cp->low != cp->high
5615 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5618 /* FIXME: Should a warning be issued? */
5620 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5621 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5623 if (cp->high != NULL
5624 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5625 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5630 /* Assume there is no DEFAULT case. */
5631 default_case = NULL;
5636 for (body = code->block; body; body = body->block)
5638 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5640 seen_unreachable = 0;
5642 /* Walk the case label list, making sure that all case labels
5644 for (cp = body->ext.case_list; cp; cp = cp->next)
5646 /* Count the number of cases in the whole construct. */
5649 /* Intercept the DEFAULT case. */
5650 if (cp->low == NULL && cp->high == NULL)
5652 if (default_case != NULL)
5654 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5655 "by a second DEFAULT CASE at %L",
5656 &default_case->where, &cp->where);
5667 /* Deal with single value cases and case ranges. Errors are
5668 issued from the validation function. */
5669 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5670 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5676 if (type == BT_LOGICAL
5677 && ((cp->low == NULL || cp->high == NULL)
5678 || cp->low != cp->high))
5680 gfc_error ("Logical range in CASE statement at %L is not "
5681 "allowed", &cp->low->where);
5686 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5689 value = cp->low->value.logical == 0 ? 2 : 1;
5690 if (value & seen_logical)
5692 gfc_error ("constant logical value in CASE statement "
5693 "is repeated at %L",
5698 seen_logical |= value;
5701 if (cp->low != NULL && cp->high != NULL
5702 && cp->low != cp->high
5703 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5705 if (gfc_option.warn_surprising)
5706 gfc_warning ("Range specification at %L can never "
5707 "be matched", &cp->where);
5709 cp->unreachable = 1;
5710 seen_unreachable = 1;
5714 /* If the case range can be matched, it can also overlap with
5715 other cases. To make sure it does not, we put it in a
5716 double linked list here. We sort that with a merge sort
5717 later on to detect any overlapping cases. */
5721 head->right = head->left = NULL;
5726 tail->right->left = tail;
5733 /* It there was a failure in the previous case label, give up
5734 for this case label list. Continue with the next block. */
5738 /* See if any case labels that are unreachable have been seen.
5739 If so, we eliminate them. This is a bit of a kludge because
5740 the case lists for a single case statement (label) is a
5741 single forward linked lists. */
5742 if (seen_unreachable)
5744 /* Advance until the first case in the list is reachable. */
5745 while (body->ext.case_list != NULL
5746 && body->ext.case_list->unreachable)
5748 gfc_case *n = body->ext.case_list;
5749 body->ext.case_list = body->ext.case_list->next;
5751 gfc_free_case_list (n);
5754 /* Strip all other unreachable cases. */
5755 if (body->ext.case_list)
5757 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5759 if (cp->next->unreachable)
5761 gfc_case *n = cp->next;
5762 cp->next = cp->next->next;
5764 gfc_free_case_list (n);
5771 /* See if there were overlapping cases. If the check returns NULL,
5772 there was overlap. In that case we don't do anything. If head
5773 is non-NULL, we prepend the DEFAULT case. The sorted list can
5774 then used during code generation for SELECT CASE constructs with
5775 a case expression of a CHARACTER type. */
5778 head = check_case_overlap (head);
5780 /* Prepend the default_case if it is there. */
5781 if (head != NULL && default_case)
5783 default_case->left = NULL;
5784 default_case->right = head;
5785 head->left = default_case;
5789 /* Eliminate dead blocks that may be the result if we've seen
5790 unreachable case labels for a block. */
5791 for (body = code; body && body->block; body = body->block)
5793 if (body->block->ext.case_list == NULL)
5795 /* Cut the unreachable block from the code chain. */
5796 gfc_code *c = body->block;
5797 body->block = c->block;
5799 /* Kill the dead block, but not the blocks below it. */
5801 gfc_free_statements (c);
5805 /* More than two cases is legal but insane for logical selects.
5806 Issue a warning for it. */
5807 if (gfc_option.warn_surprising && type == BT_LOGICAL
5809 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5814 /* Resolve a transfer statement. This is making sure that:
5815 -- a derived type being transferred has only non-pointer components
5816 -- a derived type being transferred doesn't have private components, unless
5817 it's being transferred from the module where the type was defined
5818 -- we're not trying to transfer a whole assumed size array. */
5821 resolve_transfer (gfc_code *code)
5830 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5833 sym = exp->symtree->n.sym;
5836 /* Go to actual component transferred. */
5837 for (ref = code->expr->ref; ref; ref = ref->next)
5838 if (ref->type == REF_COMPONENT)
5839 ts = &ref->u.c.component->ts;
5841 if (ts->type == BT_DERIVED)
5843 /* Check that transferred derived type doesn't contain POINTER
5845 if (ts->derived->attr.pointer_comp)
5847 gfc_error ("Data transfer element at %L cannot have "
5848 "POINTER components", &code->loc);
5852 if (ts->derived->attr.alloc_comp)
5854 gfc_error ("Data transfer element at %L cannot have "
5855 "ALLOCATABLE components", &code->loc);
5859 if (derived_inaccessible (ts->derived))
5861 gfc_error ("Data transfer element at %L cannot have "
5862 "PRIVATE components",&code->loc);
5867 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5868 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5870 gfc_error ("Data transfer element at %L cannot be a full reference to "
5871 "an assumed-size array", &code->loc);
5877 /*********** Toplevel code resolution subroutines ***********/
5879 /* Find the set of labels that are reachable from this block. We also
5880 record the last statement in each block so that we don't have to do
5881 a linear search to find the END DO statements of the blocks. */
5884 reachable_labels (gfc_code *block)
5891 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5893 /* Collect labels in this block. */
5894 for (c = block; c; c = c->next)
5897 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5899 if (!c->next && cs_base->prev)
5900 cs_base->prev->tail = c;
5903 /* Merge with labels from parent block. */
5906 gcc_assert (cs_base->prev->reachable_labels);
5907 bitmap_ior_into (cs_base->reachable_labels,
5908 cs_base->prev->reachable_labels);
5912 /* Given a branch to a label and a namespace, if the branch is conforming.
5913 The code node describes where the branch is located. */
5916 resolve_branch (gfc_st_label *label, gfc_code *code)
5923 /* Step one: is this a valid branching target? */
5925 if (label->defined == ST_LABEL_UNKNOWN)
5927 gfc_error ("Label %d referenced at %L is never defined", label->value,
5932 if (label->defined != ST_LABEL_TARGET)
5934 gfc_error ("Statement at %L is not a valid branch target statement "
5935 "for the branch statement at %L", &label->where, &code->loc);
5939 /* Step two: make sure this branch is not a branch to itself ;-) */
5941 if (code->here == label)
5943 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
5947 /* Step three: See if the label is in the same block as the
5948 branching statement. The hard work has been done by setting up
5949 the bitmap reachable_labels. */
5951 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5953 /* The label is not in an enclosing block, so illegal. This was
5954 allowed in Fortran 66, so we allow it as extension. No
5955 further checks are necessary in this case. */
5956 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5957 "as the GOTO statement at %L", &label->where,
5962 /* Step four: Make sure that the branching target is legal if
5963 the statement is an END {SELECT,IF}. */
5965 for (stack = cs_base; stack; stack = stack->prev)
5966 if (stack->current->next && stack->current->next->here == label)
5969 if (stack && stack->current->next->op == EXEC_NOP)
5971 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5972 "END of construct at %L", &code->loc,
5973 &stack->current->next->loc);
5974 return; /* We know this is not an END DO. */
5977 /* Step five: Make sure that we're not jumping to the end of a DO
5978 loop from within the loop. */
5980 for (stack = cs_base; stack; stack = stack->prev)
5981 if ((stack->current->op == EXEC_DO
5982 || stack->current->op == EXEC_DO_WHILE)
5983 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5985 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5986 "to END of construct at %L", &code->loc,
5994 /* Check whether EXPR1 has the same shape as EXPR2. */
5997 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5999 mpz_t shape[GFC_MAX_DIMENSIONS];
6000 mpz_t shape2[GFC_MAX_DIMENSIONS];
6001 gfc_try result = FAILURE;
6004 /* Compare the rank. */
6005 if (expr1->rank != expr2->rank)
6008 /* Compare the size of each dimension. */
6009 for (i=0; i<expr1->rank; i++)
6011 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
6014 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
6017 if (mpz_cmp (shape[i], shape2[i]))
6021 /* When either of the two expression is an assumed size array, we
6022 ignore the comparison of dimension sizes. */
6027 for (i--; i >= 0; i--)
6029 mpz_clear (shape[i]);
6030 mpz_clear (shape2[i]);
6036 /* Check whether a WHERE assignment target or a WHERE mask expression
6037 has the same shape as the outmost WHERE mask expression. */
6040 resolve_where (gfc_code *code, gfc_expr *mask)
6046 cblock = code->block;
6048 /* Store the first WHERE mask-expr of the WHERE statement or construct.
6049 In case of nested WHERE, only the outmost one is stored. */
6050 if (mask == NULL) /* outmost WHERE */
6052 else /* inner WHERE */
6059 /* Check if the mask-expr has a consistent shape with the
6060 outmost WHERE mask-expr. */
6061 if (resolve_where_shape (cblock->expr, e) == FAILURE)
6062 gfc_error ("WHERE mask at %L has inconsistent shape",
6063 &cblock->expr->where);
6066 /* the assignment statement of a WHERE statement, or the first
6067 statement in where-body-construct of a WHERE construct */
6068 cnext = cblock->next;
6073 /* WHERE assignment statement */
6076 /* Check shape consistent for WHERE assignment target. */
6077 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
6078 gfc_error ("WHERE assignment target at %L has "
6079 "inconsistent shape", &cnext->expr->where);
6083 case EXEC_ASSIGN_CALL:
6084 resolve_call (cnext);
6085 if (!cnext->resolved_sym->attr.elemental)
6086 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6087 &cnext->ext.actual->expr->where);
6090 /* WHERE or WHERE construct is part of a where-body-construct */
6092 resolve_where (cnext, e);
6096 gfc_error ("Unsupported statement inside WHERE at %L",
6099 /* the next statement within the same where-body-construct */
6100 cnext = cnext->next;
6102 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6103 cblock = cblock->block;
6108 /* Resolve assignment in FORALL construct.
6109 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6110 FORALL index variables. */
6113 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
6117 for (n = 0; n < nvar; n++)
6119 gfc_symbol *forall_index;
6121 forall_index = var_expr[n]->symtree->n.sym;
6123 /* Check whether the assignment target is one of the FORALL index
6125 if ((code->expr->expr_type == EXPR_VARIABLE)
6126 && (code->expr->symtree->n.sym == forall_index))
6127 gfc_error ("Assignment to a FORALL index variable at %L",
6128 &code->expr->where);
6131 /* If one of the FORALL index variables doesn't appear in the
6132 assignment variable, then there could be a many-to-one
6133 assignment. Emit a warning rather than an error because the
6134 mask could be resolving this problem. */
6135 if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
6136 gfc_warning ("The FORALL with index '%s' is not used on the "
6137 "left side of the assignment at %L and so might "
6138 "cause multiple assignment to this object",
6139 var_expr[n]->symtree->name, &code->expr->where);
6145 /* Resolve WHERE statement in FORALL construct. */
6148 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
6149 gfc_expr **var_expr)
6154 cblock = code->block;
6157 /* the assignment statement of a WHERE statement, or the first
6158 statement in where-body-construct of a WHERE construct */
6159 cnext = cblock->next;
6164 /* WHERE assignment statement */
6166 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
6169 /* WHERE operator assignment statement */
6170 case EXEC_ASSIGN_CALL:
6171 resolve_call (cnext);
6172 if (!cnext->resolved_sym->attr.elemental)
6173 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6174 &cnext->ext.actual->expr->where);
6177 /* WHERE or WHERE construct is part of a where-body-construct */
6179 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
6183 gfc_error ("Unsupported statement inside WHERE at %L",
6186 /* the next statement within the same where-body-construct */
6187 cnext = cnext->next;
6189 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6190 cblock = cblock->block;
6195 /* Traverse the FORALL body to check whether the following errors exist:
6196 1. For assignment, check if a many-to-one assignment happens.
6197 2. For WHERE statement, check the WHERE body to see if there is any
6198 many-to-one assignment. */
6201 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
6205 c = code->block->next;
6211 case EXEC_POINTER_ASSIGN:
6212 gfc_resolve_assign_in_forall (c, nvar, var_expr);
6215 case EXEC_ASSIGN_CALL:
6219 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6220 there is no need to handle it here. */
6224 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
6229 /* The next statement in the FORALL body. */
6235 /* Counts the number of iterators needed inside a forall construct, including
6236 nested forall constructs. This is used to allocate the needed memory
6237 in gfc_resolve_forall. */
6240 gfc_count_forall_iterators (gfc_code *code)
6242 int max_iters, sub_iters, current_iters;
6243 gfc_forall_iterator *fa;
6245 gcc_assert(code->op == EXEC_FORALL);
6249 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6252 code = code->block->next;
6256 if (code->op == EXEC_FORALL)
6258 sub_iters = gfc_count_forall_iterators (code);
6259 if (sub_iters > max_iters)
6260 max_iters = sub_iters;
6265 return current_iters + max_iters;
6269 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6270 gfc_resolve_forall_body to resolve the FORALL body. */
6273 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
6275 static gfc_expr **var_expr;
6276 static int total_var = 0;
6277 static int nvar = 0;
6279 gfc_forall_iterator *fa;
6284 /* Start to resolve a FORALL construct */
6285 if (forall_save == 0)
6287 /* Count the total number of FORALL index in the nested FORALL
6288 construct in order to allocate the VAR_EXPR with proper size. */
6289 total_var = gfc_count_forall_iterators (code);
6291 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6292 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
6295 /* The information about FORALL iterator, including FORALL index start, end
6296 and stride. The FORALL index can not appear in start, end or stride. */
6297 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6299 /* Check if any outer FORALL index name is the same as the current
6301 for (i = 0; i < nvar; i++)
6303 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
6305 gfc_error ("An outer FORALL construct already has an index "
6306 "with this name %L", &fa->var->where);
6310 /* Record the current FORALL index. */
6311 var_expr[nvar] = gfc_copy_expr (fa->var);
6315 /* No memory leak. */
6316 gcc_assert (nvar <= total_var);
6319 /* Resolve the FORALL body. */
6320 gfc_resolve_forall_body (code, nvar, var_expr);
6322 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6323 gfc_resolve_blocks (code->block, ns);
6327 /* Free only the VAR_EXPRs allocated in this frame. */
6328 for (i = nvar; i < tmp; i++)
6329 gfc_free_expr (var_expr[i]);
6333 /* We are in the outermost FORALL construct. */
6334 gcc_assert (forall_save == 0);
6336 /* VAR_EXPR is not needed any more. */
6337 gfc_free (var_expr);
6343 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6346 static void resolve_code (gfc_code *, gfc_namespace *);
6349 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
6353 for (; b; b = b->block)
6355 t = gfc_resolve_expr (b->expr);
6356 if (gfc_resolve_expr (b->expr2) == FAILURE)
6362 if (t == SUCCESS && b->expr != NULL
6363 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
6364 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6371 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
6372 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6377 resolve_branch (b->label, b);
6390 case EXEC_OMP_ATOMIC:
6391 case EXEC_OMP_CRITICAL:
6393 case EXEC_OMP_MASTER:
6394 case EXEC_OMP_ORDERED:
6395 case EXEC_OMP_PARALLEL:
6396 case EXEC_OMP_PARALLEL_DO:
6397 case EXEC_OMP_PARALLEL_SECTIONS:
6398 case EXEC_OMP_PARALLEL_WORKSHARE:
6399 case EXEC_OMP_SECTIONS:
6400 case EXEC_OMP_SINGLE:
6402 case EXEC_OMP_TASKWAIT:
6403 case EXEC_OMP_WORKSHARE:
6407 gfc_internal_error ("resolve_block(): Bad block type");
6410 resolve_code (b->next, ns);
6415 /* Does everything to resolve an ordinary assignment. Returns true
6416 if this is an interface assignment. */
6418 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
6428 if (gfc_extend_assign (code, ns) == SUCCESS)
6430 lhs = code->ext.actual->expr;
6431 rhs = code->ext.actual->next->expr;
6432 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6434 gfc_error ("Subroutine '%s' called instead of assignment at "
6435 "%L must be PURE", code->symtree->n.sym->name,
6440 /* Make a temporary rhs when there is a default initializer
6441 and rhs is the same symbol as the lhs. */
6442 if (rhs->expr_type == EXPR_VARIABLE
6443 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6444 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6445 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6446 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6455 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
6456 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6457 &code->loc) == FAILURE)
6460 /* Handle the case of a BOZ literal on the RHS. */
6461 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
6464 if (gfc_option.warn_surprising)
6465 gfc_warning ("BOZ literal at %L is bitwise transferred "
6466 "non-integer symbol '%s'", &code->loc,
6467 lhs->symtree->n.sym->name);
6469 if (!gfc_convert_boz (rhs, &lhs->ts))
6471 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
6473 if (rc == ARITH_UNDERFLOW)
6474 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6475 ". This check can be disabled with the option "
6476 "-fno-range-check", &rhs->where);
6477 else if (rc == ARITH_OVERFLOW)
6478 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6479 ". This check can be disabled with the option "
6480 "-fno-range-check", &rhs->where);
6481 else if (rc == ARITH_NAN)
6482 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6483 ". This check can be disabled with the option "
6484 "-fno-range-check", &rhs->where);
6490 if (lhs->ts.type == BT_CHARACTER
6491 && gfc_option.warn_character_truncation)
6493 if (lhs->ts.cl != NULL
6494 && lhs->ts.cl->length != NULL
6495 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6496 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
6498 if (rhs->expr_type == EXPR_CONSTANT)
6499 rlen = rhs->value.character.length;
6501 else if (rhs->ts.cl != NULL
6502 && rhs->ts.cl->length != NULL
6503 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6504 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
6506 if (rlen && llen && rlen > llen)
6507 gfc_warning_now ("CHARACTER expression will be truncated "
6508 "in assignment (%d/%d) at %L",
6509 llen, rlen, &code->loc);
6512 /* Ensure that a vector index expression for the lvalue is evaluated
6513 to a temporary if the lvalue symbol is referenced in it. */
6516 for (ref = lhs->ref; ref; ref= ref->next)
6517 if (ref->type == REF_ARRAY)
6519 for (n = 0; n < ref->u.ar.dimen; n++)
6520 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
6521 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
6522 ref->u.ar.start[n]))
6524 = gfc_get_parentheses (ref->u.ar.start[n]);
6528 if (gfc_pure (NULL))
6530 if (gfc_impure_variable (lhs->symtree->n.sym))
6532 gfc_error ("Cannot assign to variable '%s' in PURE "
6534 lhs->symtree->n.sym->name,
6539 if (lhs->ts.type == BT_DERIVED
6540 && lhs->expr_type == EXPR_VARIABLE
6541 && lhs->ts.derived->attr.pointer_comp
6542 && gfc_impure_variable (rhs->symtree->n.sym))
6544 gfc_error ("The impure variable at %L is assigned to "
6545 "a derived type variable with a POINTER "
6546 "component in a PURE procedure (12.6)",
6552 gfc_check_assign (lhs, rhs, 1);
6556 /* Given a block of code, recursively resolve everything pointed to by this
6560 resolve_code (gfc_code *code, gfc_namespace *ns)
6562 int omp_workshare_save;
6567 frame.prev = cs_base;
6571 reachable_labels (code);
6573 for (; code; code = code->next)
6575 frame.current = code;
6576 forall_save = forall_flag;
6578 if (code->op == EXEC_FORALL)
6581 gfc_resolve_forall (code, ns, forall_save);
6584 else if (code->block)
6586 omp_workshare_save = -1;
6589 case EXEC_OMP_PARALLEL_WORKSHARE:
6590 omp_workshare_save = omp_workshare_flag;
6591 omp_workshare_flag = 1;
6592 gfc_resolve_omp_parallel_blocks (code, ns);
6594 case EXEC_OMP_PARALLEL:
6595 case EXEC_OMP_PARALLEL_DO:
6596 case EXEC_OMP_PARALLEL_SECTIONS:
6598 omp_workshare_save = omp_workshare_flag;
6599 omp_workshare_flag = 0;
6600 gfc_resolve_omp_parallel_blocks (code, ns);
6603 gfc_resolve_omp_do_blocks (code, ns);
6605 case EXEC_OMP_WORKSHARE:
6606 omp_workshare_save = omp_workshare_flag;
6607 omp_workshare_flag = 1;
6610 gfc_resolve_blocks (code->block, ns);
6614 if (omp_workshare_save != -1)
6615 omp_workshare_flag = omp_workshare_save;
6619 if (code->op != EXEC_COMPCALL)
6620 t = gfc_resolve_expr (code->expr);
6621 forall_flag = forall_save;
6623 if (gfc_resolve_expr (code->expr2) == FAILURE)
6638 /* Keep track of which entry we are up to. */
6639 current_entry_id = code->ext.entry->id;
6643 resolve_where (code, NULL);
6647 if (code->expr != NULL)
6649 if (code->expr->ts.type != BT_INTEGER)
6650 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6651 "INTEGER variable", &code->expr->where);
6652 else if (code->expr->symtree->n.sym->attr.assign != 1)
6653 gfc_error ("Variable '%s' has not been assigned a target "
6654 "label at %L", code->expr->symtree->n.sym->name,
6655 &code->expr->where);
6658 resolve_branch (code->label, code);
6662 if (code->expr != NULL
6663 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6664 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6665 "INTEGER return specifier", &code->expr->where);
6668 case EXEC_INIT_ASSIGN:
6675 if (resolve_ordinary_assign (code, ns))
6680 case EXEC_LABEL_ASSIGN:
6681 if (code->label->defined == ST_LABEL_UNKNOWN)
6682 gfc_error ("Label %d referenced at %L is never defined",
6683 code->label->value, &code->label->where);
6685 && (code->expr->expr_type != EXPR_VARIABLE
6686 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6687 || code->expr->symtree->n.sym->ts.kind
6688 != gfc_default_integer_kind
6689 || code->expr->symtree->n.sym->as != NULL))
6690 gfc_error ("ASSIGN statement at %L requires a scalar "
6691 "default INTEGER variable", &code->expr->where);
6694 case EXEC_POINTER_ASSIGN:
6698 gfc_check_pointer_assign (code->expr, code->expr2);
6701 case EXEC_ARITHMETIC_IF:
6703 && code->expr->ts.type != BT_INTEGER
6704 && code->expr->ts.type != BT_REAL)
6705 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6706 "expression", &code->expr->where);
6708 resolve_branch (code->label, code);
6709 resolve_branch (code->label2, code);
6710 resolve_branch (code->label3, code);
6714 if (t == SUCCESS && code->expr != NULL
6715 && (code->expr->ts.type != BT_LOGICAL
6716 || code->expr->rank != 0))
6717 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6718 &code->expr->where);
6723 resolve_call (code);
6727 resolve_typebound_call (code);
6731 /* Select is complicated. Also, a SELECT construct could be
6732 a transformed computed GOTO. */
6733 resolve_select (code);
6737 if (code->ext.iterator != NULL)
6739 gfc_iterator *iter = code->ext.iterator;
6740 if (gfc_resolve_iterator (iter, true) != FAILURE)
6741 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6746 if (code->expr == NULL)
6747 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6749 && (code->expr->rank != 0
6750 || code->expr->ts.type != BT_LOGICAL))
6751 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6752 "a scalar LOGICAL expression", &code->expr->where);
6757 resolve_allocate_deallocate (code, "ALLOCATE");
6761 case EXEC_DEALLOCATE:
6763 resolve_allocate_deallocate (code, "DEALLOCATE");
6768 if (gfc_resolve_open (code->ext.open) == FAILURE)
6771 resolve_branch (code->ext.open->err, code);
6775 if (gfc_resolve_close (code->ext.close) == FAILURE)
6778 resolve_branch (code->ext.close->err, code);
6781 case EXEC_BACKSPACE:
6785 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6788 resolve_branch (code->ext.filepos->err, code);
6792 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6795 resolve_branch (code->ext.inquire->err, code);
6799 gcc_assert (code->ext.inquire != NULL);
6800 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6803 resolve_branch (code->ext.inquire->err, code);
6807 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
6810 resolve_branch (code->ext.wait->err, code);
6811 resolve_branch (code->ext.wait->end, code);
6812 resolve_branch (code->ext.wait->eor, code);
6817 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6820 resolve_branch (code->ext.dt->err, code);
6821 resolve_branch (code->ext.dt->end, code);
6822 resolve_branch (code->ext.dt->eor, code);
6826 resolve_transfer (code);
6830 resolve_forall_iterators (code->ext.forall_iterator);
6832 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6833 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6834 "expression", &code->expr->where);
6837 case EXEC_OMP_ATOMIC:
6838 case EXEC_OMP_BARRIER:
6839 case EXEC_OMP_CRITICAL:
6840 case EXEC_OMP_FLUSH:
6842 case EXEC_OMP_MASTER:
6843 case EXEC_OMP_ORDERED:
6844 case EXEC_OMP_SECTIONS:
6845 case EXEC_OMP_SINGLE:
6846 case EXEC_OMP_TASKWAIT:
6847 case EXEC_OMP_WORKSHARE:
6848 gfc_resolve_omp_directive (code, ns);
6851 case EXEC_OMP_PARALLEL:
6852 case EXEC_OMP_PARALLEL_DO:
6853 case EXEC_OMP_PARALLEL_SECTIONS:
6854 case EXEC_OMP_PARALLEL_WORKSHARE:
6856 omp_workshare_save = omp_workshare_flag;
6857 omp_workshare_flag = 0;
6858 gfc_resolve_omp_directive (code, ns);
6859 omp_workshare_flag = omp_workshare_save;
6863 gfc_internal_error ("resolve_code(): Bad statement code");
6867 cs_base = frame.prev;
6871 /* Resolve initial values and make sure they are compatible with
6875 resolve_values (gfc_symbol *sym)
6877 if (sym->value == NULL)
6880 if (gfc_resolve_expr (sym->value) == FAILURE)
6883 gfc_check_assign_symbol (sym, sym->value);
6887 /* Verify the binding labels for common blocks that are BIND(C). The label
6888 for a BIND(C) common block must be identical in all scoping units in which
6889 the common block is declared. Further, the binding label can not collide
6890 with any other global entity in the program. */
6893 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6895 if (comm_block_tree->n.common->is_bind_c == 1)
6897 gfc_gsymbol *binding_label_gsym;
6898 gfc_gsymbol *comm_name_gsym;
6900 /* See if a global symbol exists by the common block's name. It may
6901 be NULL if the common block is use-associated. */
6902 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6903 comm_block_tree->n.common->name);
6904 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6905 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6906 "with the global entity '%s' at %L",
6907 comm_block_tree->n.common->binding_label,
6908 comm_block_tree->n.common->name,
6909 &(comm_block_tree->n.common->where),
6910 comm_name_gsym->name, &(comm_name_gsym->where));
6911 else if (comm_name_gsym != NULL
6912 && strcmp (comm_name_gsym->name,
6913 comm_block_tree->n.common->name) == 0)
6915 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6917 if (comm_name_gsym->binding_label == NULL)
6918 /* No binding label for common block stored yet; save this one. */
6919 comm_name_gsym->binding_label =
6920 comm_block_tree->n.common->binding_label;
6922 if (strcmp (comm_name_gsym->binding_label,
6923 comm_block_tree->n.common->binding_label) != 0)
6925 /* Common block names match but binding labels do not. */
6926 gfc_error ("Binding label '%s' for common block '%s' at %L "
6927 "does not match the binding label '%s' for common "
6929 comm_block_tree->n.common->binding_label,
6930 comm_block_tree->n.common->name,
6931 &(comm_block_tree->n.common->where),
6932 comm_name_gsym->binding_label,
6933 comm_name_gsym->name,
6934 &(comm_name_gsym->where));
6939 /* There is no binding label (NAME="") so we have nothing further to
6940 check and nothing to add as a global symbol for the label. */
6941 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6944 binding_label_gsym =
6945 gfc_find_gsymbol (gfc_gsym_root,
6946 comm_block_tree->n.common->binding_label);
6947 if (binding_label_gsym == NULL)
6949 /* Need to make a global symbol for the binding label to prevent
6950 it from colliding with another. */
6951 binding_label_gsym =
6952 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6953 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6954 binding_label_gsym->type = GSYM_COMMON;
6958 /* If comm_name_gsym is NULL, the name common block is use
6959 associated and the name could be colliding. */
6960 if (binding_label_gsym->type != GSYM_COMMON)
6961 gfc_error ("Binding label '%s' for common block '%s' at %L "
6962 "collides with the global entity '%s' at %L",
6963 comm_block_tree->n.common->binding_label,
6964 comm_block_tree->n.common->name,
6965 &(comm_block_tree->n.common->where),
6966 binding_label_gsym->name,
6967 &(binding_label_gsym->where));
6968 else if (comm_name_gsym != NULL
6969 && (strcmp (binding_label_gsym->name,
6970 comm_name_gsym->binding_label) != 0)
6971 && (strcmp (binding_label_gsym->sym_name,
6972 comm_name_gsym->name) != 0))
6973 gfc_error ("Binding label '%s' for common block '%s' at %L "
6974 "collides with global entity '%s' at %L",
6975 binding_label_gsym->name, binding_label_gsym->sym_name,
6976 &(comm_block_tree->n.common->where),
6977 comm_name_gsym->name, &(comm_name_gsym->where));
6985 /* Verify any BIND(C) derived types in the namespace so we can report errors
6986 for them once, rather than for each variable declared of that type. */
6989 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6991 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6992 && derived_sym->attr.is_bind_c == 1)
6993 verify_bind_c_derived_type (derived_sym);
6999 /* Verify that any binding labels used in a given namespace do not collide
7000 with the names or binding labels of any global symbols. */
7003 gfc_verify_binding_labels (gfc_symbol *sym)
7007 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
7008 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
7010 gfc_gsymbol *bind_c_sym;
7012 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
7013 if (bind_c_sym != NULL
7014 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
7016 if (sym->attr.if_source == IFSRC_DECL
7017 && (bind_c_sym->type != GSYM_SUBROUTINE
7018 && bind_c_sym->type != GSYM_FUNCTION)
7019 && ((sym->attr.contained == 1
7020 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
7021 || (sym->attr.use_assoc == 1
7022 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
7024 /* Make sure global procedures don't collide with anything. */
7025 gfc_error ("Binding label '%s' at %L collides with the global "
7026 "entity '%s' at %L", sym->binding_label,
7027 &(sym->declared_at), bind_c_sym->name,
7028 &(bind_c_sym->where));
7031 else if (sym->attr.contained == 0
7032 && (sym->attr.if_source == IFSRC_IFBODY
7033 && sym->attr.flavor == FL_PROCEDURE)
7034 && (bind_c_sym->sym_name != NULL
7035 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
7037 /* Make sure procedures in interface bodies don't collide. */
7038 gfc_error ("Binding label '%s' in interface body at %L collides "
7039 "with the global entity '%s' at %L",
7041 &(sym->declared_at), bind_c_sym->name,
7042 &(bind_c_sym->where));
7045 else if (sym->attr.contained == 0
7046 && sym->attr.if_source == IFSRC_UNKNOWN)
7047 if ((sym->attr.use_assoc && bind_c_sym->mod_name
7048 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
7049 || sym->attr.use_assoc == 0)
7051 gfc_error ("Binding label '%s' at %L collides with global "
7052 "entity '%s' at %L", sym->binding_label,
7053 &(sym->declared_at), bind_c_sym->name,
7054 &(bind_c_sym->where));
7059 /* Clear the binding label to prevent checking multiple times. */
7060 sym->binding_label[0] = '\0';
7062 else if (bind_c_sym == NULL)
7064 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
7065 bind_c_sym->where = sym->declared_at;
7066 bind_c_sym->sym_name = sym->name;
7068 if (sym->attr.use_assoc == 1)
7069 bind_c_sym->mod_name = sym->module;
7071 if (sym->ns->proc_name != NULL)
7072 bind_c_sym->mod_name = sym->ns->proc_name->name;
7074 if (sym->attr.contained == 0)
7076 if (sym->attr.subroutine)
7077 bind_c_sym->type = GSYM_SUBROUTINE;
7078 else if (sym->attr.function)
7079 bind_c_sym->type = GSYM_FUNCTION;
7087 /* Resolve an index expression. */
7090 resolve_index_expr (gfc_expr *e)
7092 if (gfc_resolve_expr (e) == FAILURE)
7095 if (gfc_simplify_expr (e, 0) == FAILURE)
7098 if (gfc_specification_expr (e) == FAILURE)
7104 /* Resolve a charlen structure. */
7107 resolve_charlen (gfc_charlen *cl)
7116 specification_expr = 1;
7118 if (resolve_index_expr (cl->length) == FAILURE)
7120 specification_expr = 0;
7124 /* "If the character length parameter value evaluates to a negative
7125 value, the length of character entities declared is zero." */
7126 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
7128 gfc_warning_now ("CHARACTER variable has zero length at %L",
7129 &cl->length->where);
7130 gfc_replace_expr (cl->length, gfc_int_expr (0));
7137 /* Test for non-constant shape arrays. */
7140 is_non_constant_shape_array (gfc_symbol *sym)
7146 not_constant = false;
7147 if (sym->as != NULL)
7149 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7150 has not been simplified; parameter array references. Do the
7151 simplification now. */
7152 for (i = 0; i < sym->as->rank; i++)
7154 e = sym->as->lower[i];
7155 if (e && (resolve_index_expr (e) == FAILURE
7156 || !gfc_is_constant_expr (e)))
7157 not_constant = true;
7159 e = sym->as->upper[i];
7160 if (e && (resolve_index_expr (e) == FAILURE
7161 || !gfc_is_constant_expr (e)))
7162 not_constant = true;
7165 return not_constant;
7168 /* Given a symbol and an initialization expression, add code to initialize
7169 the symbol to the function entry. */
7171 build_init_assign (gfc_symbol *sym, gfc_expr *init)
7175 gfc_namespace *ns = sym->ns;
7177 /* Search for the function namespace if this is a contained
7178 function without an explicit result. */
7179 if (sym->attr.function && sym == sym->result
7180 && sym->name != sym->ns->proc_name->name)
7183 for (;ns; ns = ns->sibling)
7184 if (strcmp (ns->proc_name->name, sym->name) == 0)
7190 gfc_free_expr (init);
7194 /* Build an l-value expression for the result. */
7195 lval = gfc_lval_expr_from_sym (sym);
7197 /* Add the code at scope entry. */
7198 init_st = gfc_get_code ();
7199 init_st->next = ns->code;
7202 /* Assign the default initializer to the l-value. */
7203 init_st->loc = sym->declared_at;
7204 init_st->op = EXEC_INIT_ASSIGN;
7205 init_st->expr = lval;
7206 init_st->expr2 = init;
7209 /* Assign the default initializer to a derived type variable or result. */
7212 apply_default_init (gfc_symbol *sym)
7214 gfc_expr *init = NULL;
7216 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7219 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
7220 init = gfc_default_initializer (&sym->ts);
7225 build_init_assign (sym, init);
7228 /* Build an initializer for a local integer, real, complex, logical, or
7229 character variable, based on the command line flags finit-local-zero,
7230 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7231 null if the symbol should not have a default initialization. */
7233 build_default_init_expr (gfc_symbol *sym)
7236 gfc_expr *init_expr;
7239 /* These symbols should never have a default initialization. */
7240 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
7241 || sym->attr.external
7243 || sym->attr.pointer
7244 || sym->attr.in_equivalence
7245 || sym->attr.in_common
7248 || sym->attr.cray_pointee
7249 || sym->attr.cray_pointer)
7252 /* Now we'll try to build an initializer expression. */
7253 init_expr = gfc_get_expr ();
7254 init_expr->expr_type = EXPR_CONSTANT;
7255 init_expr->ts.type = sym->ts.type;
7256 init_expr->ts.kind = sym->ts.kind;
7257 init_expr->where = sym->declared_at;
7259 /* We will only initialize integers, reals, complex, logicals, and
7260 characters, and only if the corresponding command-line flags
7261 were set. Otherwise, we free init_expr and return null. */
7262 switch (sym->ts.type)
7265 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
7266 mpz_init_set_si (init_expr->value.integer,
7267 gfc_option.flag_init_integer_value);
7270 gfc_free_expr (init_expr);
7276 mpfr_init (init_expr->value.real);
7277 switch (gfc_option.flag_init_real)
7279 case GFC_INIT_REAL_NAN:
7280 mpfr_set_nan (init_expr->value.real);
7283 case GFC_INIT_REAL_INF:
7284 mpfr_set_inf (init_expr->value.real, 1);
7287 case GFC_INIT_REAL_NEG_INF:
7288 mpfr_set_inf (init_expr->value.real, -1);
7291 case GFC_INIT_REAL_ZERO:
7292 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
7296 gfc_free_expr (init_expr);
7303 mpfr_init (init_expr->value.complex.r);
7304 mpfr_init (init_expr->value.complex.i);
7305 switch (gfc_option.flag_init_real)
7307 case GFC_INIT_REAL_NAN:
7308 mpfr_set_nan (init_expr->value.complex.r);
7309 mpfr_set_nan (init_expr->value.complex.i);
7312 case GFC_INIT_REAL_INF:
7313 mpfr_set_inf (init_expr->value.complex.r, 1);
7314 mpfr_set_inf (init_expr->value.complex.i, 1);
7317 case GFC_INIT_REAL_NEG_INF:
7318 mpfr_set_inf (init_expr->value.complex.r, -1);
7319 mpfr_set_inf (init_expr->value.complex.i, -1);
7322 case GFC_INIT_REAL_ZERO:
7323 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
7324 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
7328 gfc_free_expr (init_expr);
7335 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
7336 init_expr->value.logical = 0;
7337 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
7338 init_expr->value.logical = 1;
7341 gfc_free_expr (init_expr);
7347 /* For characters, the length must be constant in order to
7348 create a default initializer. */
7349 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
7350 && sym->ts.cl->length
7351 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
7353 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
7354 init_expr->value.character.length = char_len;
7355 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
7356 for (i = 0; i < char_len; i++)
7357 init_expr->value.character.string[i]
7358 = (unsigned char) gfc_option.flag_init_character_value;
7362 gfc_free_expr (init_expr);
7368 gfc_free_expr (init_expr);
7374 /* Add an initialization expression to a local variable. */
7376 apply_default_init_local (gfc_symbol *sym)
7378 gfc_expr *init = NULL;
7380 /* The symbol should be a variable or a function return value. */
7381 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7382 || (sym->attr.function && sym->result != sym))
7385 /* Try to build the initializer expression. If we can't initialize
7386 this symbol, then init will be NULL. */
7387 init = build_default_init_expr (sym);
7391 /* For saved variables, we don't want to add an initializer at
7392 function entry, so we just add a static initializer. */
7393 if (sym->attr.save || sym->ns->save_all)
7395 /* Don't clobber an existing initializer! */
7396 gcc_assert (sym->value == NULL);
7401 build_init_assign (sym, init);
7404 /* Resolution of common features of flavors variable and procedure. */
7407 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
7409 /* Constraints on deferred shape variable. */
7410 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
7412 if (sym->attr.allocatable)
7414 if (sym->attr.dimension)
7415 gfc_error ("Allocatable array '%s' at %L must have "
7416 "a deferred shape", sym->name, &sym->declared_at);
7418 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7419 sym->name, &sym->declared_at);
7423 if (sym->attr.pointer && sym->attr.dimension)
7425 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7426 sym->name, &sym->declared_at);
7433 if (!mp_flag && !sym->attr.allocatable
7434 && !sym->attr.pointer && !sym->attr.dummy)
7436 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7437 sym->name, &sym->declared_at);
7445 /* Additional checks for symbols with flavor variable and derived
7446 type. To be called from resolve_fl_variable. */
7449 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
7451 gcc_assert (sym->ts.type == BT_DERIVED);
7453 /* Check to see if a derived type is blocked from being host
7454 associated by the presence of another class I symbol in the same
7455 namespace. 14.6.1.3 of the standard and the discussion on
7456 comp.lang.fortran. */
7457 if (sym->ns != sym->ts.derived->ns
7458 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
7461 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
7462 if (s && s->attr.flavor != FL_DERIVED)
7464 gfc_error ("The type '%s' cannot be host associated at %L "
7465 "because it is blocked by an incompatible object "
7466 "of the same name declared at %L",
7467 sym->ts.derived->name, &sym->declared_at,
7473 /* 4th constraint in section 11.3: "If an object of a type for which
7474 component-initialization is specified (R429) appears in the
7475 specification-part of a module and does not have the ALLOCATABLE
7476 or POINTER attribute, the object shall have the SAVE attribute."
7478 The check for initializers is performed with
7479 has_default_initializer because gfc_default_initializer generates
7480 a hidden default for allocatable components. */
7481 if (!(sym->value || no_init_flag) && sym->ns->proc_name
7482 && sym->ns->proc_name->attr.flavor == FL_MODULE
7483 && !sym->ns->save_all && !sym->attr.save
7484 && !sym->attr.pointer && !sym->attr.allocatable
7485 && has_default_initializer (sym->ts.derived))
7487 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7488 "default initialization of a component",
7489 sym->name, &sym->declared_at);
7493 /* Assign default initializer. */
7494 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
7495 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
7497 sym->value = gfc_default_initializer (&sym->ts);
7504 /* Resolve symbols with flavor variable. */
7507 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
7509 int no_init_flag, automatic_flag;
7511 const char *auto_save_msg;
7513 auto_save_msg = "Automatic object '%s' at %L cannot have the "
7516 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7519 /* Set this flag to check that variables are parameters of all entries.
7520 This check is effected by the call to gfc_resolve_expr through
7521 is_non_constant_shape_array. */
7522 specification_expr = 1;
7524 if (sym->ns->proc_name
7525 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7526 || sym->ns->proc_name->attr.is_main_program)
7527 && !sym->attr.use_assoc
7528 && !sym->attr.allocatable
7529 && !sym->attr.pointer
7530 && is_non_constant_shape_array (sym))
7532 /* The shape of a main program or module array needs to be
7534 gfc_error ("The module or main program array '%s' at %L must "
7535 "have constant shape", sym->name, &sym->declared_at);
7536 specification_expr = 0;
7540 if (sym->ts.type == BT_CHARACTER)
7542 /* Make sure that character string variables with assumed length are
7544 e = sym->ts.cl->length;
7545 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
7547 gfc_error ("Entity with assumed character length at %L must be a "
7548 "dummy argument or a PARAMETER", &sym->declared_at);
7552 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7554 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7558 if (!gfc_is_constant_expr (e)
7559 && !(e->expr_type == EXPR_VARIABLE
7560 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7561 && sym->ns->proc_name
7562 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7563 || sym->ns->proc_name->attr.is_main_program)
7564 && !sym->attr.use_assoc)
7566 gfc_error ("'%s' at %L must have constant character length "
7567 "in this context", sym->name, &sym->declared_at);
7572 if (sym->value == NULL && sym->attr.referenced)
7573 apply_default_init_local (sym); /* Try to apply a default initialization. */
7575 /* Determine if the symbol may not have an initializer. */
7576 no_init_flag = automatic_flag = 0;
7577 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7578 || sym->attr.intrinsic || sym->attr.result)
7580 else if (sym->attr.dimension && !sym->attr.pointer
7581 && is_non_constant_shape_array (sym))
7583 no_init_flag = automatic_flag = 1;
7585 /* Also, they must not have the SAVE attribute.
7586 SAVE_IMPLICIT is checked below. */
7587 if (sym->attr.save == SAVE_EXPLICIT)
7589 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7594 /* Ensure that any initializer is simplified. */
7596 gfc_simplify_expr (sym->value, 1);
7598 /* Reject illegal initializers. */
7599 if (!sym->mark && sym->value)
7601 if (sym->attr.allocatable)
7602 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7603 sym->name, &sym->declared_at);
7604 else if (sym->attr.external)
7605 gfc_error ("External '%s' at %L cannot have an initializer",
7606 sym->name, &sym->declared_at);
7607 else if (sym->attr.dummy
7608 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7609 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7610 sym->name, &sym->declared_at);
7611 else if (sym->attr.intrinsic)
7612 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7613 sym->name, &sym->declared_at);
7614 else if (sym->attr.result)
7615 gfc_error ("Function result '%s' at %L cannot have an initializer",
7616 sym->name, &sym->declared_at);
7617 else if (automatic_flag)
7618 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7619 sym->name, &sym->declared_at);
7626 if (sym->ts.type == BT_DERIVED)
7627 return resolve_fl_variable_derived (sym, no_init_flag);
7633 /* Resolve a procedure. */
7636 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7638 gfc_formal_arglist *arg;
7640 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7641 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7642 "interfaces", sym->name, &sym->declared_at);
7644 if (sym->attr.function
7645 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7648 if (sym->ts.type == BT_CHARACTER)
7650 gfc_charlen *cl = sym->ts.cl;
7652 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7653 && resolve_charlen (cl) == FAILURE)
7656 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7658 if (sym->attr.proc == PROC_ST_FUNCTION)
7660 gfc_error ("Character-valued statement function '%s' at %L must "
7661 "have constant length", sym->name, &sym->declared_at);
7665 if (sym->attr.external && sym->formal == NULL
7666 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7668 gfc_error ("Automatic character length function '%s' at %L must "
7669 "have an explicit interface", sym->name,
7676 /* Ensure that derived type for are not of a private type. Internal
7677 module procedures are excluded by 2.2.3.3 - i.e., they are not
7678 externally accessible and can access all the objects accessible in
7680 if (!(sym->ns->parent
7681 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7682 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7684 gfc_interface *iface;
7686 for (arg = sym->formal; arg; arg = arg->next)
7689 && arg->sym->ts.type == BT_DERIVED
7690 && !arg->sym->ts.derived->attr.use_assoc
7691 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7692 arg->sym->ts.derived->ns->default_access)
7693 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7694 "PRIVATE type and cannot be a dummy argument"
7695 " of '%s', which is PUBLIC at %L",
7696 arg->sym->name, sym->name, &sym->declared_at)
7699 /* Stop this message from recurring. */
7700 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7705 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7706 PRIVATE to the containing module. */
7707 for (iface = sym->generic; iface; iface = iface->next)
7709 for (arg = iface->sym->formal; arg; arg = arg->next)
7712 && arg->sym->ts.type == BT_DERIVED
7713 && !arg->sym->ts.derived->attr.use_assoc
7714 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7715 arg->sym->ts.derived->ns->default_access)
7716 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7717 "'%s' in PUBLIC interface '%s' at %L "
7718 "takes dummy arguments of '%s' which is "
7719 "PRIVATE", iface->sym->name, sym->name,
7720 &iface->sym->declared_at,
7721 gfc_typename (&arg->sym->ts)) == FAILURE)
7723 /* Stop this message from recurring. */
7724 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7730 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7731 PRIVATE to the containing module. */
7732 for (iface = sym->generic; iface; iface = iface->next)
7734 for (arg = iface->sym->formal; arg; arg = arg->next)
7737 && arg->sym->ts.type == BT_DERIVED
7738 && !arg->sym->ts.derived->attr.use_assoc
7739 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7740 arg->sym->ts.derived->ns->default_access)
7741 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7742 "'%s' in PUBLIC interface '%s' at %L "
7743 "takes dummy arguments of '%s' which is "
7744 "PRIVATE", iface->sym->name, sym->name,
7745 &iface->sym->declared_at,
7746 gfc_typename (&arg->sym->ts)) == FAILURE)
7748 /* Stop this message from recurring. */
7749 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7756 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
7757 && !sym->attr.proc_pointer)
7759 gfc_error ("Function '%s' at %L cannot have an initializer",
7760 sym->name, &sym->declared_at);
7764 /* An external symbol may not have an initializer because it is taken to be
7765 a procedure. Exception: Procedure Pointers. */
7766 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
7768 gfc_error ("External object '%s' at %L may not have an initializer",
7769 sym->name, &sym->declared_at);
7773 /* An elemental function is required to return a scalar 12.7.1 */
7774 if (sym->attr.elemental && sym->attr.function && sym->as)
7776 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7777 "result", sym->name, &sym->declared_at);
7778 /* Reset so that the error only occurs once. */
7779 sym->attr.elemental = 0;
7783 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7784 char-len-param shall not be array-valued, pointer-valued, recursive
7785 or pure. ....snip... A character value of * may only be used in the
7786 following ways: (i) Dummy arg of procedure - dummy associates with
7787 actual length; (ii) To declare a named constant; or (iii) External
7788 function - but length must be declared in calling scoping unit. */
7789 if (sym->attr.function
7790 && sym->ts.type == BT_CHARACTER
7791 && sym->ts.cl && sym->ts.cl->length == NULL)
7793 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7794 || (sym->attr.recursive) || (sym->attr.pure))
7796 if (sym->as && sym->as->rank)
7797 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7798 "array-valued", sym->name, &sym->declared_at);
7800 if (sym->attr.pointer)
7801 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7802 "pointer-valued", sym->name, &sym->declared_at);
7805 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7806 "pure", sym->name, &sym->declared_at);
7808 if (sym->attr.recursive)
7809 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7810 "recursive", sym->name, &sym->declared_at);
7815 /* Appendix B.2 of the standard. Contained functions give an
7816 error anyway. Fixed-form is likely to be F77/legacy. */
7817 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7818 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7819 "'%s' at %L is obsolescent in fortran 95",
7820 sym->name, &sym->declared_at);
7823 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7825 gfc_formal_arglist *curr_arg;
7826 int has_non_interop_arg = 0;
7828 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7829 sym->common_block) == FAILURE)
7831 /* Clear these to prevent looking at them again if there was an
7833 sym->attr.is_bind_c = 0;
7834 sym->attr.is_c_interop = 0;
7835 sym->ts.is_c_interop = 0;
7839 /* So far, no errors have been found. */
7840 sym->attr.is_c_interop = 1;
7841 sym->ts.is_c_interop = 1;
7844 curr_arg = sym->formal;
7845 while (curr_arg != NULL)
7847 /* Skip implicitly typed dummy args here. */
7848 if (curr_arg->sym->attr.implicit_type == 0)
7849 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7850 /* If something is found to fail, record the fact so we
7851 can mark the symbol for the procedure as not being
7852 BIND(C) to try and prevent multiple errors being
7854 has_non_interop_arg = 1;
7856 curr_arg = curr_arg->next;
7859 /* See if any of the arguments were not interoperable and if so, clear
7860 the procedure symbol to prevent duplicate error messages. */
7861 if (has_non_interop_arg != 0)
7863 sym->attr.is_c_interop = 0;
7864 sym->ts.is_c_interop = 0;
7865 sym->attr.is_bind_c = 0;
7869 if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
7871 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
7872 "in '%s' at %L", sym->name, &sym->declared_at);
7876 if (sym->attr.intent && !sym->attr.proc_pointer)
7878 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
7879 "in '%s' at %L", sym->name, &sym->declared_at);
7887 /* Resolve a list of finalizer procedures. That is, after they have hopefully
7888 been defined and we now know their defined arguments, check that they fulfill
7889 the requirements of the standard for procedures used as finalizers. */
7892 gfc_resolve_finalizers (gfc_symbol* derived)
7894 gfc_finalizer* list;
7895 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
7896 gfc_try result = SUCCESS;
7897 bool seen_scalar = false;
7899 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
7902 /* Walk over the list of finalizer-procedures, check them, and if any one
7903 does not fit in with the standard's definition, print an error and remove
7904 it from the list. */
7905 prev_link = &derived->f2k_derived->finalizers;
7906 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
7912 /* Skip this finalizer if we already resolved it. */
7913 if (list->proc_tree)
7915 prev_link = &(list->next);
7919 /* Check this exists and is a SUBROUTINE. */
7920 if (!list->proc_sym->attr.subroutine)
7922 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
7923 list->proc_sym->name, &list->where);
7927 /* We should have exactly one argument. */
7928 if (!list->proc_sym->formal || list->proc_sym->formal->next)
7930 gfc_error ("FINAL procedure at %L must have exactly one argument",
7934 arg = list->proc_sym->formal->sym;
7936 /* This argument must be of our type. */
7937 if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
7939 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
7940 &arg->declared_at, derived->name);
7944 /* It must neither be a pointer nor allocatable nor optional. */
7945 if (arg->attr.pointer)
7947 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
7951 if (arg->attr.allocatable)
7953 gfc_error ("Argument of FINAL procedure at %L must not be"
7954 " ALLOCATABLE", &arg->declared_at);
7957 if (arg->attr.optional)
7959 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
7964 /* It must not be INTENT(OUT). */
7965 if (arg->attr.intent == INTENT_OUT)
7967 gfc_error ("Argument of FINAL procedure at %L must not be"
7968 " INTENT(OUT)", &arg->declared_at);
7972 /* Warn if the procedure is non-scalar and not assumed shape. */
7973 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
7974 && arg->as->type != AS_ASSUMED_SHAPE)
7975 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
7976 " shape argument", &arg->declared_at);
7978 /* Check that it does not match in kind and rank with a FINAL procedure
7979 defined earlier. To really loop over the *earlier* declarations,
7980 we need to walk the tail of the list as new ones were pushed at the
7982 /* TODO: Handle kind parameters once they are implemented. */
7983 my_rank = (arg->as ? arg->as->rank : 0);
7984 for (i = list->next; i; i = i->next)
7986 /* Argument list might be empty; that is an error signalled earlier,
7987 but we nevertheless continued resolving. */
7988 if (i->proc_sym->formal)
7990 gfc_symbol* i_arg = i->proc_sym->formal->sym;
7991 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
7992 if (i_rank == my_rank)
7994 gfc_error ("FINAL procedure '%s' declared at %L has the same"
7995 " rank (%d) as '%s'",
7996 list->proc_sym->name, &list->where, my_rank,
8003 /* Is this the/a scalar finalizer procedure? */
8004 if (!arg->as || arg->as->rank == 0)
8007 /* Find the symtree for this procedure. */
8008 gcc_assert (!list->proc_tree);
8009 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
8011 prev_link = &list->next;
8014 /* Remove wrong nodes immediately from the list so we don't risk any
8015 troubles in the future when they might fail later expectations. */
8019 *prev_link = list->next;
8020 gfc_free_finalizer (i);
8023 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
8024 were nodes in the list, must have been for arrays. It is surely a good
8025 idea to have a scalar version there if there's something to finalize. */
8026 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
8027 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
8028 " defined at %L, suggest also scalar one",
8029 derived->name, &derived->declared_at);
8031 /* TODO: Remove this error when finalization is finished. */
8032 gfc_error ("Finalization at %L is not yet implemented",
8033 &derived->declared_at);
8039 /* Check that it is ok for the typebound procedure proc to override the
8043 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
8046 const gfc_symbol* proc_target;
8047 const gfc_symbol* old_target;
8048 unsigned proc_pass_arg, old_pass_arg, argpos;
8049 gfc_formal_arglist* proc_formal;
8050 gfc_formal_arglist* old_formal;
8052 /* This procedure should only be called for non-GENERIC proc. */
8053 gcc_assert (!proc->typebound->is_generic);
8055 /* If the overwritten procedure is GENERIC, this is an error. */
8056 if (old->typebound->is_generic)
8058 gfc_error ("Can't overwrite GENERIC '%s' at %L",
8059 old->name, &proc->typebound->where);
8063 where = proc->typebound->where;
8064 proc_target = proc->typebound->u.specific->n.sym;
8065 old_target = old->typebound->u.specific->n.sym;
8067 /* Check that overridden binding is not NON_OVERRIDABLE. */
8068 if (old->typebound->non_overridable)
8070 gfc_error ("'%s' at %L overrides a procedure binding declared"
8071 " NON_OVERRIDABLE", proc->name, &where);
8075 /* If the overridden binding is PURE, the overriding must be, too. */
8076 if (old_target->attr.pure && !proc_target->attr.pure)
8078 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
8079 proc->name, &where);
8083 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
8084 is not, the overriding must not be either. */
8085 if (old_target->attr.elemental && !proc_target->attr.elemental)
8087 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
8088 " ELEMENTAL", proc->name, &where);
8091 if (!old_target->attr.elemental && proc_target->attr.elemental)
8093 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
8094 " be ELEMENTAL, either", proc->name, &where);
8098 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
8100 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
8102 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
8103 " SUBROUTINE", proc->name, &where);
8107 /* If the overridden binding is a FUNCTION, the overriding must also be a
8108 FUNCTION and have the same characteristics. */
8109 if (old_target->attr.function)
8111 if (!proc_target->attr.function)
8113 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
8114 " FUNCTION", proc->name, &where);
8118 /* FIXME: Do more comprehensive checking (including, for instance, the
8119 rank and array-shape). */
8120 gcc_assert (proc_target->result && old_target->result);
8121 if (!gfc_compare_types (&proc_target->result->ts,
8122 &old_target->result->ts))
8124 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
8125 " matching result types", proc->name, &where);
8130 /* If the overridden binding is PUBLIC, the overriding one must not be
8132 if (old->typebound->access == ACCESS_PUBLIC
8133 && proc->typebound->access == ACCESS_PRIVATE)
8135 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
8136 " PRIVATE", proc->name, &where);
8140 /* Compare the formal argument lists of both procedures. This is also abused
8141 to find the position of the passed-object dummy arguments of both
8142 bindings as at least the overridden one might not yet be resolved and we
8143 need those positions in the check below. */
8144 proc_pass_arg = old_pass_arg = 0;
8145 if (!proc->typebound->nopass && !proc->typebound->pass_arg)
8147 if (!old->typebound->nopass && !old->typebound->pass_arg)
8150 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
8151 proc_formal && old_formal;
8152 proc_formal = proc_formal->next, old_formal = old_formal->next)
8154 if (proc->typebound->pass_arg
8155 && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name))
8156 proc_pass_arg = argpos;
8157 if (old->typebound->pass_arg
8158 && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
8159 old_pass_arg = argpos;
8161 /* Check that the names correspond. */
8162 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
8164 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8165 " to match the corresponding argument of the overridden"
8166 " procedure", proc_formal->sym->name, proc->name, &where,
8167 old_formal->sym->name);
8171 /* Check that the types correspond if neither is the passed-object
8173 /* FIXME: Do more comprehensive testing here. */
8174 if (proc_pass_arg != argpos && old_pass_arg != argpos
8175 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
8177 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8178 " in respect to the overridden procedure",
8179 proc_formal->sym->name, proc->name, &where);
8185 if (proc_formal || old_formal)
8187 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8188 " the overridden procedure", proc->name, &where);
8192 /* If the overridden binding is NOPASS, the overriding one must also be
8194 if (old->typebound->nopass && !proc->typebound->nopass)
8196 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8197 " NOPASS", proc->name, &where);
8201 /* If the overridden binding is PASS(x), the overriding one must also be
8202 PASS and the passed-object dummy arguments must correspond. */
8203 if (!old->typebound->nopass)
8205 if (proc->typebound->nopass)
8207 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8208 " PASS", proc->name, &where);
8212 if (proc_pass_arg != old_pass_arg)
8214 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8215 " the same position as the passed-object dummy argument of"
8216 " the overridden procedure", proc->name, &where);
8225 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8228 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
8229 const char* generic_name, locus where)
8234 gcc_assert (t1->specific && t2->specific);
8235 gcc_assert (!t1->specific->is_generic);
8236 gcc_assert (!t2->specific->is_generic);
8238 sym1 = t1->specific->u.specific->n.sym;
8239 sym2 = t2->specific->u.specific->n.sym;
8241 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8242 if (sym1->attr.subroutine != sym2->attr.subroutine
8243 || sym1->attr.function != sym2->attr.function)
8245 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8246 " GENERIC '%s' at %L",
8247 sym1->name, sym2->name, generic_name, &where);
8251 /* Compare the interfaces. */
8252 if (gfc_compare_interfaces (sym1, sym2, 1))
8254 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8255 sym1->name, sym2->name, generic_name, &where);
8263 /* Resolve a GENERIC procedure binding for a derived type. */
8266 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
8268 gfc_tbp_generic* target;
8269 gfc_symtree* first_target;
8270 gfc_symbol* super_type;
8271 gfc_symtree* inherited;
8274 gcc_assert (st->typebound);
8275 gcc_assert (st->typebound->is_generic);
8277 where = st->typebound->where;
8278 super_type = gfc_get_derived_super_type (derived);
8280 /* Find the overridden binding if any. */
8281 st->typebound->overridden = NULL;
8284 gfc_symtree* overridden;
8285 overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
8287 if (overridden && overridden->typebound)
8288 st->typebound->overridden = overridden->typebound;
8291 /* Try to find the specific bindings for the symtrees in our target-list. */
8292 gcc_assert (st->typebound->u.generic);
8293 for (target = st->typebound->u.generic; target; target = target->next)
8294 if (!target->specific)
8296 gfc_typebound_proc* overridden_tbp;
8298 const char* target_name;
8300 target_name = target->specific_st->name;
8302 /* Defined for this type directly. */
8303 if (target->specific_st->typebound)
8305 target->specific = target->specific_st->typebound;
8306 goto specific_found;
8309 /* Look for an inherited specific binding. */
8312 inherited = gfc_find_typebound_proc (super_type, NULL,
8317 gcc_assert (inherited->typebound);
8318 target->specific = inherited->typebound;
8319 goto specific_found;
8323 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8324 " at %L", target_name, st->name, &where);
8327 /* Once we've found the specific binding, check it is not ambiguous with
8328 other specifics already found or inherited for the same GENERIC. */
8330 gcc_assert (target->specific);
8332 /* This must really be a specific binding! */
8333 if (target->specific->is_generic)
8335 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8336 " '%s' is GENERIC, too", st->name, &where, target_name);
8340 /* Check those already resolved on this type directly. */
8341 for (g = st->typebound->u.generic; g; g = g->next)
8342 if (g != target && g->specific
8343 && check_generic_tbp_ambiguity (target, g, st->name, where)
8347 /* Check for ambiguity with inherited specific targets. */
8348 for (overridden_tbp = st->typebound->overridden; overridden_tbp;
8349 overridden_tbp = overridden_tbp->overridden)
8350 if (overridden_tbp->is_generic)
8352 for (g = overridden_tbp->u.generic; g; g = g->next)
8354 gcc_assert (g->specific);
8355 if (check_generic_tbp_ambiguity (target, g,
8356 st->name, where) == FAILURE)
8362 /* If we attempt to "overwrite" a specific binding, this is an error. */
8363 if (st->typebound->overridden && !st->typebound->overridden->is_generic)
8365 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8366 " the same name", st->name, &where);
8370 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8371 all must have the same attributes here. */
8372 first_target = st->typebound->u.generic->specific->u.specific;
8373 st->typebound->subroutine = first_target->n.sym->attr.subroutine;
8374 st->typebound->function = first_target->n.sym->attr.function;
8380 /* Resolve the type-bound procedures for a derived type. */
8382 static gfc_symbol* resolve_bindings_derived;
8383 static gfc_try resolve_bindings_result;
8386 resolve_typebound_procedure (gfc_symtree* stree)
8391 gfc_symbol* super_type;
8392 gfc_component* comp;
8394 /* If this is no type-bound procedure, just return. */
8395 if (!stree->typebound)
8398 /* If this is a GENERIC binding, use that routine. */
8399 if (stree->typebound->is_generic)
8401 if (resolve_typebound_generic (resolve_bindings_derived, stree)
8407 /* Get the target-procedure to check it. */
8408 gcc_assert (!stree->typebound->is_generic);
8409 gcc_assert (stree->typebound->u.specific);
8410 proc = stree->typebound->u.specific->n.sym;
8411 where = stree->typebound->where;
8413 /* Default access should already be resolved from the parser. */
8414 gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
8416 /* It should be a module procedure or an external procedure with explicit
8418 if ((!proc->attr.subroutine && !proc->attr.function)
8419 || (proc->attr.proc != PROC_MODULE
8420 && proc->attr.if_source != IFSRC_IFBODY)
8421 || proc->attr.abstract)
8423 gfc_error ("'%s' must be a module procedure or an external procedure with"
8424 " an explicit interface at %L", proc->name, &where);
8427 stree->typebound->subroutine = proc->attr.subroutine;
8428 stree->typebound->function = proc->attr.function;
8430 /* Find the super-type of the current derived type. We could do this once and
8431 store in a global if speed is needed, but as long as not I believe this is
8432 more readable and clearer. */
8433 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
8435 /* If PASS, resolve and check arguments if not already resolved / loaded
8436 from a .mod file. */
8437 if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
8439 if (stree->typebound->pass_arg)
8441 gfc_formal_arglist* i;
8443 /* If an explicit passing argument name is given, walk the arg-list
8447 stree->typebound->pass_arg_num = 1;
8448 for (i = proc->formal; i; i = i->next)
8450 if (!strcmp (i->sym->name, stree->typebound->pass_arg))
8455 ++stree->typebound->pass_arg_num;
8460 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8462 proc->name, stree->typebound->pass_arg, &where,
8463 stree->typebound->pass_arg);
8469 /* Otherwise, take the first one; there should in fact be at least
8471 stree->typebound->pass_arg_num = 1;
8474 gfc_error ("Procedure '%s' with PASS at %L must have at"
8475 " least one argument", proc->name, &where);
8478 me_arg = proc->formal->sym;
8481 /* Now check that the argument-type matches. */
8482 gcc_assert (me_arg);
8483 if (me_arg->ts.type != BT_DERIVED
8484 || me_arg->ts.derived != resolve_bindings_derived)
8486 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8487 " the derived-type '%s'", me_arg->name, proc->name,
8488 me_arg->name, &where, resolve_bindings_derived->name);
8492 gfc_warning ("Polymorphic entities are not yet implemented,"
8493 " non-polymorphic passed-object dummy argument of '%s'"
8494 " at %L accepted", proc->name, &where);
8497 /* If we are extending some type, check that we don't override a procedure
8498 flagged NON_OVERRIDABLE. */
8499 stree->typebound->overridden = NULL;
8502 gfc_symtree* overridden;
8503 overridden = gfc_find_typebound_proc (super_type, NULL,
8506 if (overridden && overridden->typebound)
8507 stree->typebound->overridden = overridden->typebound;
8509 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
8513 /* See if there's a name collision with a component directly in this type. */
8514 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
8515 if (!strcmp (comp->name, stree->name))
8517 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8519 stree->name, &where, resolve_bindings_derived->name);
8523 /* Try to find a name collision with an inherited component. */
8524 if (super_type && gfc_find_component (super_type, stree->name, true, true))
8526 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8527 " component of '%s'",
8528 stree->name, &where, resolve_bindings_derived->name);
8532 stree->typebound->error = 0;
8536 resolve_bindings_result = FAILURE;
8537 stree->typebound->error = 1;
8541 resolve_typebound_procedures (gfc_symbol* derived)
8543 if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
8546 resolve_bindings_derived = derived;
8547 resolve_bindings_result = SUCCESS;
8548 gfc_traverse_symtree (derived->f2k_derived->sym_root,
8549 &resolve_typebound_procedure);
8551 return resolve_bindings_result;
8555 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8556 to give all identical derived types the same backend_decl. */
8558 add_dt_to_dt_list (gfc_symbol *derived)
8560 gfc_dt_list *dt_list;
8562 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
8563 if (derived == dt_list->derived)
8566 if (dt_list == NULL)
8568 dt_list = gfc_get_dt_list ();
8569 dt_list->next = gfc_derived_types;
8570 dt_list->derived = derived;
8571 gfc_derived_types = dt_list;
8576 /* Resolve the components of a derived type. */
8579 resolve_fl_derived (gfc_symbol *sym)
8581 gfc_symbol* super_type;
8585 super_type = gfc_get_derived_super_type (sym);
8587 /* Ensure the extended type gets resolved before we do. */
8588 if (super_type && resolve_fl_derived (super_type) == FAILURE)
8591 /* An ABSTRACT type must be extensible. */
8592 if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
8594 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
8595 sym->name, &sym->declared_at);
8599 for (c = sym->components; c != NULL; c = c->next)
8601 /* Check type-spec if this is not the parent-type component. */
8602 if ((!sym->attr.extension || c != sym->components)
8603 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
8606 /* If this type is an extension, see if this component has the same name
8607 as an inherited type-bound procedure. */
8609 && gfc_find_typebound_proc (super_type, NULL, c->name, true))
8611 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
8612 " inherited type-bound procedure",
8613 c->name, sym->name, &c->loc);
8617 if (c->ts.type == BT_CHARACTER)
8619 if (c->ts.cl->length == NULL
8620 || (resolve_charlen (c->ts.cl) == FAILURE)
8621 || !gfc_is_constant_expr (c->ts.cl->length))
8623 gfc_error ("Character length of component '%s' needs to "
8624 "be a constant specification expression at %L",
8626 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
8631 if (c->ts.type == BT_DERIVED
8632 && sym->component_access != ACCESS_PRIVATE
8633 && gfc_check_access (sym->attr.access, sym->ns->default_access)
8634 && !c->ts.derived->attr.use_assoc
8635 && !gfc_check_access (c->ts.derived->attr.access,
8636 c->ts.derived->ns->default_access))
8638 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
8639 "a component of '%s', which is PUBLIC at %L",
8640 c->name, sym->name, &sym->declared_at);
8644 if (sym->attr.sequence)
8646 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
8648 gfc_error ("Component %s of SEQUENCE type declared at %L does "
8649 "not have the SEQUENCE attribute",
8650 c->ts.derived->name, &sym->declared_at);
8655 if (c->ts.type == BT_DERIVED && c->attr.pointer
8656 && c->ts.derived->components == NULL
8657 && !c->ts.derived->attr.zero_comp)
8659 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
8660 "that has not been declared", c->name, sym->name,
8665 /* Ensure that all the derived type components are put on the
8666 derived type list; even in formal namespaces, where derived type
8667 pointer components might not have been declared. */
8668 if (c->ts.type == BT_DERIVED
8670 && c->ts.derived->components
8672 && sym != c->ts.derived)
8673 add_dt_to_dt_list (c->ts.derived);
8675 if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
8678 for (i = 0; i < c->as->rank; i++)
8680 if (c->as->lower[i] == NULL
8681 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
8682 || !gfc_is_constant_expr (c->as->lower[i])
8683 || c->as->upper[i] == NULL
8684 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
8685 || !gfc_is_constant_expr (c->as->upper[i]))
8687 gfc_error ("Component '%s' of '%s' at %L must have "
8688 "constant array bounds",
8689 c->name, sym->name, &c->loc);
8695 /* Resolve the type-bound procedures. */
8696 if (resolve_typebound_procedures (sym) == FAILURE)
8699 /* Resolve the finalizer procedures. */
8700 if (gfc_resolve_finalizers (sym) == FAILURE)
8703 /* Add derived type to the derived type list. */
8704 add_dt_to_dt_list (sym);
8711 resolve_fl_namelist (gfc_symbol *sym)
8716 /* Reject PRIVATE objects in a PUBLIC namelist. */
8717 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
8719 for (nl = sym->namelist; nl; nl = nl->next)
8721 if (!nl->sym->attr.use_assoc
8722 && !(sym->ns->parent == nl->sym->ns)
8723 && !(sym->ns->parent
8724 && sym->ns->parent->parent == nl->sym->ns)
8725 && !gfc_check_access(nl->sym->attr.access,
8726 nl->sym->ns->default_access))
8728 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
8729 "cannot be member of PUBLIC namelist '%s' at %L",
8730 nl->sym->name, sym->name, &sym->declared_at);
8734 /* Types with private components that came here by USE-association. */
8735 if (nl->sym->ts.type == BT_DERIVED
8736 && derived_inaccessible (nl->sym->ts.derived))
8738 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
8739 "components and cannot be member of namelist '%s' at %L",
8740 nl->sym->name, sym->name, &sym->declared_at);
8744 /* Types with private components that are defined in the same module. */
8745 if (nl->sym->ts.type == BT_DERIVED
8746 && !(sym->ns->parent == nl->sym->ts.derived->ns)
8747 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
8748 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
8749 nl->sym->ns->default_access))
8751 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
8752 "cannot be a member of PUBLIC namelist '%s' at %L",
8753 nl->sym->name, sym->name, &sym->declared_at);
8759 for (nl = sym->namelist; nl; nl = nl->next)
8761 /* Reject namelist arrays of assumed shape. */
8762 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
8763 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
8764 "must not have assumed shape in namelist "
8765 "'%s' at %L", nl->sym->name, sym->name,
8766 &sym->declared_at) == FAILURE)
8769 /* Reject namelist arrays that are not constant shape. */
8770 if (is_non_constant_shape_array (nl->sym))
8772 gfc_error ("NAMELIST array object '%s' must have constant "
8773 "shape in namelist '%s' at %L", nl->sym->name,
8774 sym->name, &sym->declared_at);
8778 /* Namelist objects cannot have allocatable or pointer components. */
8779 if (nl->sym->ts.type != BT_DERIVED)
8782 if (nl->sym->ts.derived->attr.alloc_comp)
8784 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8785 "have ALLOCATABLE components",
8786 nl->sym->name, sym->name, &sym->declared_at);
8790 if (nl->sym->ts.derived->attr.pointer_comp)
8792 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8793 "have POINTER components",
8794 nl->sym->name, sym->name, &sym->declared_at);
8800 /* 14.1.2 A module or internal procedure represent local entities
8801 of the same type as a namelist member and so are not allowed. */
8802 for (nl = sym->namelist; nl; nl = nl->next)
8804 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
8807 if (nl->sym->attr.function && nl->sym == nl->sym->result)
8808 if ((nl->sym == sym->ns->proc_name)
8810 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
8814 if (nl->sym && nl->sym->name)
8815 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
8816 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
8818 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
8819 "attribute in '%s' at %L", nlsym->name,
8830 resolve_fl_parameter (gfc_symbol *sym)
8832 /* A parameter array's shape needs to be constant. */
8834 && (sym->as->type == AS_DEFERRED
8835 || is_non_constant_shape_array (sym)))
8837 gfc_error ("Parameter array '%s' at %L cannot be automatic "
8838 "or of deferred shape", sym->name, &sym->declared_at);
8842 /* Make sure a parameter that has been implicitly typed still
8843 matches the implicit type, since PARAMETER statements can precede
8844 IMPLICIT statements. */
8845 if (sym->attr.implicit_type
8846 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
8848 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
8849 "later IMPLICIT type", sym->name, &sym->declared_at);
8853 /* Make sure the types of derived parameters are consistent. This
8854 type checking is deferred until resolution because the type may
8855 refer to a derived type from the host. */
8856 if (sym->ts.type == BT_DERIVED
8857 && !gfc_compare_types (&sym->ts, &sym->value->ts))
8859 gfc_error ("Incompatible derived type in PARAMETER at %L",
8860 &sym->value->where);
8867 /* Do anything necessary to resolve a symbol. Right now, we just
8868 assume that an otherwise unknown symbol is a variable. This sort
8869 of thing commonly happens for symbols in module. */
8872 resolve_symbol (gfc_symbol *sym)
8874 int check_constant, mp_flag;
8875 gfc_symtree *symtree;
8876 gfc_symtree *this_symtree;
8880 if (sym->attr.flavor == FL_UNKNOWN)
8883 /* If we find that a flavorless symbol is an interface in one of the
8884 parent namespaces, find its symtree in this namespace, free the
8885 symbol and set the symtree to point to the interface symbol. */
8886 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
8888 symtree = gfc_find_symtree (ns->sym_root, sym->name);
8889 if (symtree && symtree->n.sym->generic)
8891 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
8895 gfc_free_symbol (sym);
8896 symtree->n.sym->refs++;
8897 this_symtree->n.sym = symtree->n.sym;
8902 /* Otherwise give it a flavor according to such attributes as
8904 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
8905 sym->attr.flavor = FL_VARIABLE;
8908 sym->attr.flavor = FL_PROCEDURE;
8909 if (sym->attr.dimension)
8910 sym->attr.function = 1;
8914 if (sym->attr.procedure && sym->ts.interface
8915 && sym->attr.if_source != IFSRC_DECL)
8917 if (sym->ts.interface->attr.procedure)
8918 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
8919 "in a later PROCEDURE statement", sym->ts.interface->name,
8920 sym->name,&sym->declared_at);
8922 /* Get the attributes from the interface (now resolved). */
8923 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
8925 gfc_symbol *ifc = sym->ts.interface;
8927 sym->ts.interface = ifc;
8928 sym->attr.function = ifc->attr.function;
8929 sym->attr.subroutine = ifc->attr.subroutine;
8930 sym->attr.allocatable = ifc->attr.allocatable;
8931 sym->attr.pointer = ifc->attr.pointer;
8932 sym->attr.pure = ifc->attr.pure;
8933 sym->attr.elemental = ifc->attr.elemental;
8934 sym->attr.dimension = ifc->attr.dimension;
8935 sym->attr.recursive = ifc->attr.recursive;
8936 sym->attr.always_explicit = ifc->attr.always_explicit;
8937 copy_formal_args (sym, ifc);
8938 /* Copy array spec. */
8939 sym->as = gfc_copy_array_spec (ifc->as);
8943 for (i = 0; i < sym->as->rank; i++)
8945 gfc_expr_replace_symbols (sym->as->lower[i], sym);
8946 gfc_expr_replace_symbols (sym->as->upper[i], sym);
8949 /* Copy char length. */
8952 sym->ts.cl = gfc_get_charlen();
8953 sym->ts.cl->resolved = ifc->ts.cl->resolved;
8954 sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
8955 gfc_expr_replace_symbols (sym->ts.cl->length, sym);
8956 /* Add charlen to namespace. */
8959 sym->ts.cl->next = sym->formal_ns->cl_list;
8960 sym->formal_ns->cl_list = sym->ts.cl;
8964 else if (sym->ts.interface->name[0] != '\0')
8966 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
8967 sym->ts.interface->name, sym->name, &sym->declared_at);
8972 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
8975 /* Symbols that are module procedures with results (functions) have
8976 the types and array specification copied for type checking in
8977 procedures that call them, as well as for saving to a module
8978 file. These symbols can't stand the scrutiny that their results
8980 mp_flag = (sym->result != NULL && sym->result != sym);
8983 /* Make sure that the intrinsic is consistent with its internal
8984 representation. This needs to be done before assigning a default
8985 type to avoid spurious warnings. */
8986 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
8988 gfc_intrinsic_sym* isym;
8991 /* We already know this one is an intrinsic, so we don't call
8992 gfc_is_intrinsic for full checking but rather use gfc_find_function and
8993 gfc_find_subroutine directly to check whether it is a function or
8996 if ((isym = gfc_find_function (sym->name)))
8998 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
8999 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
9000 " ignored", sym->name, &sym->declared_at);
9002 else if ((isym = gfc_find_subroutine (sym->name)))
9004 if (sym->ts.type != BT_UNKNOWN)
9006 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
9007 " specifier", sym->name, &sym->declared_at);
9013 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
9014 sym->name, &sym->declared_at);
9018 /* Check it is actually available in the standard settings. */
9019 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
9022 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
9023 " available in the current standard settings but %s. Use"
9024 " an appropriate -std=* option or enable -fall-intrinsics"
9025 " in order to use it.",
9026 sym->name, &sym->declared_at, symstd);
9031 /* Assign default type to symbols that need one and don't have one. */
9032 if (sym->ts.type == BT_UNKNOWN)
9034 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
9035 gfc_set_default_type (sym, 1, NULL);
9037 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
9039 /* The specific case of an external procedure should emit an error
9040 in the case that there is no implicit type. */
9042 gfc_set_default_type (sym, sym->attr.external, NULL);
9045 /* Result may be in another namespace. */
9046 resolve_symbol (sym->result);
9048 sym->ts = sym->result->ts;
9049 sym->as = gfc_copy_array_spec (sym->result->as);
9050 sym->attr.dimension = sym->result->attr.dimension;
9051 sym->attr.pointer = sym->result->attr.pointer;
9052 sym->attr.allocatable = sym->result->attr.allocatable;
9057 /* Assumed size arrays and assumed shape arrays must be dummy
9061 && (sym->as->type == AS_ASSUMED_SIZE
9062 || sym->as->type == AS_ASSUMED_SHAPE)
9063 && sym->attr.dummy == 0)
9065 if (sym->as->type == AS_ASSUMED_SIZE)
9066 gfc_error ("Assumed size array at %L must be a dummy argument",
9069 gfc_error ("Assumed shape array at %L must be a dummy argument",
9074 /* Make sure symbols with known intent or optional are really dummy
9075 variable. Because of ENTRY statement, this has to be deferred
9076 until resolution time. */
9078 if (!sym->attr.dummy
9079 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
9081 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
9085 if (sym->attr.value && !sym->attr.dummy)
9087 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
9088 "it is not a dummy argument", sym->name, &sym->declared_at);
9092 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
9094 gfc_charlen *cl = sym->ts.cl;
9095 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9097 gfc_error ("Character dummy variable '%s' at %L with VALUE "
9098 "attribute must have constant length",
9099 sym->name, &sym->declared_at);
9103 if (sym->ts.is_c_interop
9104 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
9106 gfc_error ("C interoperable character dummy variable '%s' at %L "
9107 "with VALUE attribute must have length one",
9108 sym->name, &sym->declared_at);
9113 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
9114 do this for something that was implicitly typed because that is handled
9115 in gfc_set_default_type. Handle dummy arguments and procedure
9116 definitions separately. Also, anything that is use associated is not
9117 handled here but instead is handled in the module it is declared in.
9118 Finally, derived type definitions are allowed to be BIND(C) since that
9119 only implies that they're interoperable, and they are checked fully for
9120 interoperability when a variable is declared of that type. */
9121 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
9122 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
9123 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
9125 gfc_try t = SUCCESS;
9127 /* First, make sure the variable is declared at the
9128 module-level scope (J3/04-007, Section 15.3). */
9129 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
9130 sym->attr.in_common == 0)
9132 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
9133 "is neither a COMMON block nor declared at the "
9134 "module level scope", sym->name, &(sym->declared_at));
9137 else if (sym->common_head != NULL)
9139 t = verify_com_block_vars_c_interop (sym->common_head);
9143 /* If type() declaration, we need to verify that the components
9144 of the given type are all C interoperable, etc. */
9145 if (sym->ts.type == BT_DERIVED &&
9146 sym->ts.derived->attr.is_c_interop != 1)
9148 /* Make sure the user marked the derived type as BIND(C). If
9149 not, call the verify routine. This could print an error
9150 for the derived type more than once if multiple variables
9151 of that type are declared. */
9152 if (sym->ts.derived->attr.is_bind_c != 1)
9153 verify_bind_c_derived_type (sym->ts.derived);
9157 /* Verify the variable itself as C interoperable if it
9158 is BIND(C). It is not possible for this to succeed if
9159 the verify_bind_c_derived_type failed, so don't have to handle
9160 any error returned by verify_bind_c_derived_type. */
9161 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9167 /* clear the is_bind_c flag to prevent reporting errors more than
9168 once if something failed. */
9169 sym->attr.is_bind_c = 0;
9174 /* If a derived type symbol has reached this point, without its
9175 type being declared, we have an error. Notice that most
9176 conditions that produce undefined derived types have already
9177 been dealt with. However, the likes of:
9178 implicit type(t) (t) ..... call foo (t) will get us here if
9179 the type is not declared in the scope of the implicit
9180 statement. Change the type to BT_UNKNOWN, both because it is so
9181 and to prevent an ICE. */
9182 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
9183 && !sym->ts.derived->attr.zero_comp)
9185 gfc_error ("The derived type '%s' at %L is of type '%s', "
9186 "which has not been defined", sym->name,
9187 &sym->declared_at, sym->ts.derived->name);
9188 sym->ts.type = BT_UNKNOWN;
9192 /* Make sure that the derived type has been resolved and that the
9193 derived type is visible in the symbol's namespace, if it is a
9194 module function and is not PRIVATE. */
9195 if (sym->ts.type == BT_DERIVED
9196 && sym->ts.derived->attr.use_assoc
9197 && sym->ns->proc_name->attr.flavor == FL_MODULE)
9201 if (resolve_fl_derived (sym->ts.derived) == FAILURE)
9204 gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
9205 if (!ds && sym->attr.function
9206 && gfc_check_access (sym->attr.access, sym->ns->default_access))
9208 symtree = gfc_new_symtree (&sym->ns->sym_root,
9209 sym->ts.derived->name);
9210 symtree->n.sym = sym->ts.derived;
9211 sym->ts.derived->refs++;
9215 /* Unless the derived-type declaration is use associated, Fortran 95
9216 does not allow public entries of private derived types.
9217 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9219 if (sym->ts.type == BT_DERIVED
9220 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
9221 && !sym->ts.derived->attr.use_assoc
9222 && gfc_check_access (sym->attr.access, sym->ns->default_access)
9223 && !gfc_check_access (sym->ts.derived->attr.access,
9224 sym->ts.derived->ns->default_access)
9225 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
9226 "of PRIVATE derived type '%s'",
9227 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
9228 : "variable", sym->name, &sym->declared_at,
9229 sym->ts.derived->name) == FAILURE)
9232 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9233 default initialization is defined (5.1.2.4.4). */
9234 if (sym->ts.type == BT_DERIVED
9236 && sym->attr.intent == INTENT_OUT
9238 && sym->as->type == AS_ASSUMED_SIZE)
9240 for (c = sym->ts.derived->components; c; c = c->next)
9244 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9245 "ASSUMED SIZE and so cannot have a default initializer",
9246 sym->name, &sym->declared_at);
9252 switch (sym->attr.flavor)
9255 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
9260 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
9265 if (resolve_fl_namelist (sym) == FAILURE)
9270 if (resolve_fl_parameter (sym) == FAILURE)
9278 /* Resolve array specifier. Check as well some constraints
9279 on COMMON blocks. */
9281 check_constant = sym->attr.in_common && !sym->attr.pointer;
9283 /* Set the formal_arg_flag so that check_conflict will not throw
9284 an error for host associated variables in the specification
9285 expression for an array_valued function. */
9286 if (sym->attr.function && sym->as)
9287 formal_arg_flag = 1;
9289 gfc_resolve_array_spec (sym->as, check_constant);
9291 formal_arg_flag = 0;
9293 /* Resolve formal namespaces. */
9294 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
9295 gfc_resolve (sym->formal_ns);
9297 /* Check threadprivate restrictions. */
9298 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
9299 && (!sym->attr.in_common
9300 && sym->module == NULL
9301 && (sym->ns->proc_name == NULL
9302 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
9303 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
9305 /* If we have come this far we can apply default-initializers, as
9306 described in 14.7.5, to those variables that have not already
9307 been assigned one. */
9308 if (sym->ts.type == BT_DERIVED
9309 && sym->attr.referenced
9310 && sym->ns == gfc_current_ns
9312 && !sym->attr.allocatable
9313 && !sym->attr.alloc_comp)
9315 symbol_attribute *a = &sym->attr;
9317 if ((!a->save && !a->dummy && !a->pointer
9318 && !a->in_common && !a->use_assoc
9319 && !(a->function && sym != sym->result))
9320 || (a->dummy && a->intent == INTENT_OUT))
9321 apply_default_init (sym);
9324 /* If this symbol has a type-spec, check it. */
9325 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
9326 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
9327 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
9333 /************* Resolve DATA statements *************/
9337 gfc_data_value *vnode;
9343 /* Advance the values structure to point to the next value in the data list. */
9346 next_data_value (void)
9349 while (mpz_cmp_ui (values.left, 0) == 0)
9351 if (values.vnode->next == NULL)
9354 values.vnode = values.vnode->next;
9355 mpz_set (values.left, values.vnode->repeat);
9363 check_data_variable (gfc_data_variable *var, locus *where)
9369 ar_type mark = AR_UNKNOWN;
9371 mpz_t section_index[GFC_MAX_DIMENSIONS];
9375 if (gfc_resolve_expr (var->expr) == FAILURE)
9379 mpz_init_set_si (offset, 0);
9382 if (e->expr_type != EXPR_VARIABLE)
9383 gfc_internal_error ("check_data_variable(): Bad expression");
9385 if (e->symtree->n.sym->ns->is_block_data
9386 && !e->symtree->n.sym->attr.in_common)
9388 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9389 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
9392 if (e->ref == NULL && e->symtree->n.sym->as)
9394 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9395 " declaration", e->symtree->n.sym->name, where);
9401 mpz_init_set_ui (size, 1);
9408 /* Find the array section reference. */
9409 for (ref = e->ref; ref; ref = ref->next)
9411 if (ref->type != REF_ARRAY)
9413 if (ref->u.ar.type == AR_ELEMENT)
9419 /* Set marks according to the reference pattern. */
9420 switch (ref->u.ar.type)
9428 /* Get the start position of array section. */
9429 gfc_get_section_index (ar, section_index, &offset);
9437 if (gfc_array_size (e, &size) == FAILURE)
9439 gfc_error ("Nonconstant array section at %L in DATA statement",
9448 while (mpz_cmp_ui (size, 0) > 0)
9450 if (next_data_value () == FAILURE)
9452 gfc_error ("DATA statement at %L has more variables than values",
9458 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
9462 /* If we have more than one element left in the repeat count,
9463 and we have more than one element left in the target variable,
9464 then create a range assignment. */
9465 /* FIXME: Only done for full arrays for now, since array sections
9467 if (mark == AR_FULL && ref && ref->next == NULL
9468 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
9472 if (mpz_cmp (size, values.left) >= 0)
9474 mpz_init_set (range, values.left);
9475 mpz_sub (size, size, values.left);
9476 mpz_set_ui (values.left, 0);
9480 mpz_init_set (range, size);
9481 mpz_sub (values.left, values.left, size);
9482 mpz_set_ui (size, 0);
9485 gfc_assign_data_value_range (var->expr, values.vnode->expr,
9488 mpz_add (offset, offset, range);
9492 /* Assign initial value to symbol. */
9495 mpz_sub_ui (values.left, values.left, 1);
9496 mpz_sub_ui (size, size, 1);
9498 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
9502 if (mark == AR_FULL)
9503 mpz_add_ui (offset, offset, 1);
9505 /* Modify the array section indexes and recalculate the offset
9506 for next element. */
9507 else if (mark == AR_SECTION)
9508 gfc_advance_section (section_index, ar, &offset);
9512 if (mark == AR_SECTION)
9514 for (i = 0; i < ar->dimen; i++)
9515 mpz_clear (section_index[i]);
9525 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
9527 /* Iterate over a list of elements in a DATA statement. */
9530 traverse_data_list (gfc_data_variable *var, locus *where)
9533 iterator_stack frame;
9534 gfc_expr *e, *start, *end, *step;
9535 gfc_try retval = SUCCESS;
9537 mpz_init (frame.value);
9539 start = gfc_copy_expr (var->iter.start);
9540 end = gfc_copy_expr (var->iter.end);
9541 step = gfc_copy_expr (var->iter.step);
9543 if (gfc_simplify_expr (start, 1) == FAILURE
9544 || start->expr_type != EXPR_CONSTANT)
9546 gfc_error ("iterator start at %L does not simplify", &start->where);
9550 if (gfc_simplify_expr (end, 1) == FAILURE
9551 || end->expr_type != EXPR_CONSTANT)
9553 gfc_error ("iterator end at %L does not simplify", &end->where);
9557 if (gfc_simplify_expr (step, 1) == FAILURE
9558 || step->expr_type != EXPR_CONSTANT)
9560 gfc_error ("iterator step at %L does not simplify", &step->where);
9565 mpz_init_set (trip, end->value.integer);
9566 mpz_sub (trip, trip, start->value.integer);
9567 mpz_add (trip, trip, step->value.integer);
9569 mpz_div (trip, trip, step->value.integer);
9571 mpz_set (frame.value, start->value.integer);
9573 frame.prev = iter_stack;
9574 frame.variable = var->iter.var->symtree;
9575 iter_stack = &frame;
9577 while (mpz_cmp_ui (trip, 0) > 0)
9579 if (traverse_data_var (var->list, where) == FAILURE)
9586 e = gfc_copy_expr (var->expr);
9587 if (gfc_simplify_expr (e, 1) == FAILURE)
9595 mpz_add (frame.value, frame.value, step->value.integer);
9597 mpz_sub_ui (trip, trip, 1);
9602 mpz_clear (frame.value);
9604 gfc_free_expr (start);
9605 gfc_free_expr (end);
9606 gfc_free_expr (step);
9608 iter_stack = frame.prev;
9613 /* Type resolve variables in the variable list of a DATA statement. */
9616 traverse_data_var (gfc_data_variable *var, locus *where)
9620 for (; var; var = var->next)
9622 if (var->expr == NULL)
9623 t = traverse_data_list (var, where);
9625 t = check_data_variable (var, where);
9635 /* Resolve the expressions and iterators associated with a data statement.
9636 This is separate from the assignment checking because data lists should
9637 only be resolved once. */
9640 resolve_data_variables (gfc_data_variable *d)
9642 for (; d; d = d->next)
9644 if (d->list == NULL)
9646 if (gfc_resolve_expr (d->expr) == FAILURE)
9651 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
9654 if (resolve_data_variables (d->list) == FAILURE)
9663 /* Resolve a single DATA statement. We implement this by storing a pointer to
9664 the value list into static variables, and then recursively traversing the
9665 variables list, expanding iterators and such. */
9668 resolve_data (gfc_data *d)
9671 if (resolve_data_variables (d->var) == FAILURE)
9674 values.vnode = d->value;
9675 if (d->value == NULL)
9676 mpz_set_ui (values.left, 0);
9678 mpz_set (values.left, d->value->repeat);
9680 if (traverse_data_var (d->var, &d->where) == FAILURE)
9683 /* At this point, we better not have any values left. */
9685 if (next_data_value () == SUCCESS)
9686 gfc_error ("DATA statement at %L has more values than variables",
9691 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
9692 accessed by host or use association, is a dummy argument to a pure function,
9693 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
9694 is storage associated with any such variable, shall not be used in the
9695 following contexts: (clients of this function). */
9697 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
9698 procedure. Returns zero if assignment is OK, nonzero if there is a
9701 gfc_impure_variable (gfc_symbol *sym)
9705 if (sym->attr.use_assoc || sym->attr.in_common)
9708 if (sym->ns != gfc_current_ns)
9709 return !sym->attr.function;
9711 proc = sym->ns->proc_name;
9712 if (sym->attr.dummy && gfc_pure (proc)
9713 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
9715 proc->attr.function))
9718 /* TODO: Sort out what can be storage associated, if anything, and include
9719 it here. In principle equivalences should be scanned but it does not
9720 seem to be possible to storage associate an impure variable this way. */
9725 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
9726 symbol of the current procedure. */
9729 gfc_pure (gfc_symbol *sym)
9731 symbol_attribute attr;
9734 sym = gfc_current_ns->proc_name;
9740 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
9744 /* Test whether the current procedure is elemental or not. */
9747 gfc_elemental (gfc_symbol *sym)
9749 symbol_attribute attr;
9752 sym = gfc_current_ns->proc_name;
9757 return attr.flavor == FL_PROCEDURE && attr.elemental;
9761 /* Warn about unused labels. */
9764 warn_unused_fortran_label (gfc_st_label *label)
9769 warn_unused_fortran_label (label->left);
9771 if (label->defined == ST_LABEL_UNKNOWN)
9774 switch (label->referenced)
9776 case ST_LABEL_UNKNOWN:
9777 gfc_warning ("Label %d at %L defined but not used", label->value,
9781 case ST_LABEL_BAD_TARGET:
9782 gfc_warning ("Label %d at %L defined but cannot be used",
9783 label->value, &label->where);
9790 warn_unused_fortran_label (label->right);
9794 /* Returns the sequence type of a symbol or sequence. */
9797 sequence_type (gfc_typespec ts)
9806 if (ts.derived->components == NULL)
9807 return SEQ_NONDEFAULT;
9809 result = sequence_type (ts.derived->components->ts);
9810 for (c = ts.derived->components->next; c; c = c->next)
9811 if (sequence_type (c->ts) != result)
9817 if (ts.kind != gfc_default_character_kind)
9818 return SEQ_NONDEFAULT;
9820 return SEQ_CHARACTER;
9823 if (ts.kind != gfc_default_integer_kind)
9824 return SEQ_NONDEFAULT;
9829 if (!(ts.kind == gfc_default_real_kind
9830 || ts.kind == gfc_default_double_kind))
9831 return SEQ_NONDEFAULT;
9836 if (ts.kind != gfc_default_complex_kind)
9837 return SEQ_NONDEFAULT;
9842 if (ts.kind != gfc_default_logical_kind)
9843 return SEQ_NONDEFAULT;
9848 return SEQ_NONDEFAULT;
9853 /* Resolve derived type EQUIVALENCE object. */
9856 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
9859 gfc_component *c = derived->components;
9864 /* Shall not be an object of nonsequence derived type. */
9865 if (!derived->attr.sequence)
9867 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
9868 "attribute to be an EQUIVALENCE object", sym->name,
9873 /* Shall not have allocatable components. */
9874 if (derived->attr.alloc_comp)
9876 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
9877 "components to be an EQUIVALENCE object",sym->name,
9882 if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
9884 gfc_error ("Derived type variable '%s' at %L with default "
9885 "initialization cannot be in EQUIVALENCE with a variable "
9886 "in COMMON", sym->name, &e->where);
9890 for (; c ; c = c->next)
9894 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
9897 /* Shall not be an object of sequence derived type containing a pointer
9898 in the structure. */
9899 if (c->attr.pointer)
9901 gfc_error ("Derived type variable '%s' at %L with pointer "
9902 "component(s) cannot be an EQUIVALENCE object",
9903 sym->name, &e->where);
9911 /* Resolve equivalence object.
9912 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
9913 an allocatable array, an object of nonsequence derived type, an object of
9914 sequence derived type containing a pointer at any level of component
9915 selection, an automatic object, a function name, an entry name, a result
9916 name, a named constant, a structure component, or a subobject of any of
9917 the preceding objects. A substring shall not have length zero. A
9918 derived type shall not have components with default initialization nor
9919 shall two objects of an equivalence group be initialized.
9920 Either all or none of the objects shall have an protected attribute.
9921 The simple constraints are done in symbol.c(check_conflict) and the rest
9922 are implemented here. */
9925 resolve_equivalence (gfc_equiv *eq)
9928 gfc_symbol *derived;
9929 gfc_symbol *first_sym;
9932 locus *last_where = NULL;
9933 seq_type eq_type, last_eq_type;
9934 gfc_typespec *last_ts;
9935 int object, cnt_protected;
9936 const char *value_name;
9940 last_ts = &eq->expr->symtree->n.sym->ts;
9942 first_sym = eq->expr->symtree->n.sym;
9946 for (object = 1; eq; eq = eq->eq, object++)
9950 e->ts = e->symtree->n.sym->ts;
9951 /* match_varspec might not know yet if it is seeing
9952 array reference or substring reference, as it doesn't
9954 if (e->ref && e->ref->type == REF_ARRAY)
9956 gfc_ref *ref = e->ref;
9957 sym = e->symtree->n.sym;
9959 if (sym->attr.dimension)
9961 ref->u.ar.as = sym->as;
9965 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
9966 if (e->ts.type == BT_CHARACTER
9968 && ref->type == REF_ARRAY
9969 && ref->u.ar.dimen == 1
9970 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
9971 && ref->u.ar.stride[0] == NULL)
9973 gfc_expr *start = ref->u.ar.start[0];
9974 gfc_expr *end = ref->u.ar.end[0];
9977 /* Optimize away the (:) reference. */
9978 if (start == NULL && end == NULL)
9983 e->ref->next = ref->next;
9988 ref->type = REF_SUBSTRING;
9990 start = gfc_int_expr (1);
9991 ref->u.ss.start = start;
9992 if (end == NULL && e->ts.cl)
9993 end = gfc_copy_expr (e->ts.cl->length);
9994 ref->u.ss.end = end;
9995 ref->u.ss.length = e->ts.cl;
10002 /* Any further ref is an error. */
10005 gcc_assert (ref->type == REF_ARRAY);
10006 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
10012 if (gfc_resolve_expr (e) == FAILURE)
10015 sym = e->symtree->n.sym;
10017 if (sym->attr.is_protected)
10019 if (cnt_protected > 0 && cnt_protected != object)
10021 gfc_error ("Either all or none of the objects in the "
10022 "EQUIVALENCE set at %L shall have the "
10023 "PROTECTED attribute",
10028 /* Shall not equivalence common block variables in a PURE procedure. */
10029 if (sym->ns->proc_name
10030 && sym->ns->proc_name->attr.pure
10031 && sym->attr.in_common)
10033 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
10034 "object in the pure procedure '%s'",
10035 sym->name, &e->where, sym->ns->proc_name->name);
10039 /* Shall not be a named constant. */
10040 if (e->expr_type == EXPR_CONSTANT)
10042 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
10043 "object", sym->name, &e->where);
10047 derived = e->ts.derived;
10048 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
10051 /* Check that the types correspond correctly:
10053 A numeric sequence structure may be equivalenced to another sequence
10054 structure, an object of default integer type, default real type, double
10055 precision real type, default logical type such that components of the
10056 structure ultimately only become associated to objects of the same
10057 kind. A character sequence structure may be equivalenced to an object
10058 of default character kind or another character sequence structure.
10059 Other objects may be equivalenced only to objects of the same type and
10060 kind parameters. */
10062 /* Identical types are unconditionally OK. */
10063 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
10064 goto identical_types;
10066 last_eq_type = sequence_type (*last_ts);
10067 eq_type = sequence_type (sym->ts);
10069 /* Since the pair of objects is not of the same type, mixed or
10070 non-default sequences can be rejected. */
10072 msg = "Sequence %s with mixed components in EQUIVALENCE "
10073 "statement at %L with different type objects";
10075 && last_eq_type == SEQ_MIXED
10076 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
10078 || (eq_type == SEQ_MIXED
10079 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10080 &e->where) == FAILURE))
10083 msg = "Non-default type object or sequence %s in EQUIVALENCE "
10084 "statement at %L with objects of different type";
10086 && last_eq_type == SEQ_NONDEFAULT
10087 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
10088 last_where) == FAILURE)
10089 || (eq_type == SEQ_NONDEFAULT
10090 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10091 &e->where) == FAILURE))
10094 msg ="Non-CHARACTER object '%s' in default CHARACTER "
10095 "EQUIVALENCE statement at %L";
10096 if (last_eq_type == SEQ_CHARACTER
10097 && eq_type != SEQ_CHARACTER
10098 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10099 &e->where) == FAILURE)
10102 msg ="Non-NUMERIC object '%s' in default NUMERIC "
10103 "EQUIVALENCE statement at %L";
10104 if (last_eq_type == SEQ_NUMERIC
10105 && eq_type != SEQ_NUMERIC
10106 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10107 &e->where) == FAILURE)
10112 last_where = &e->where;
10117 /* Shall not be an automatic array. */
10118 if (e->ref->type == REF_ARRAY
10119 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
10121 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
10122 "an EQUIVALENCE object", sym->name, &e->where);
10129 /* Shall not be a structure component. */
10130 if (r->type == REF_COMPONENT)
10132 gfc_error ("Structure component '%s' at %L cannot be an "
10133 "EQUIVALENCE object",
10134 r->u.c.component->name, &e->where);
10138 /* A substring shall not have length zero. */
10139 if (r->type == REF_SUBSTRING)
10141 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
10143 gfc_error ("Substring at %L has length zero",
10144 &r->u.ss.start->where);
10154 /* Resolve function and ENTRY types, issue diagnostics if needed. */
10157 resolve_fntype (gfc_namespace *ns)
10159 gfc_entry_list *el;
10162 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
10165 /* If there are any entries, ns->proc_name is the entry master
10166 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10168 sym = ns->entries->sym;
10170 sym = ns->proc_name;
10171 if (sym->result == sym
10172 && sym->ts.type == BT_UNKNOWN
10173 && gfc_set_default_type (sym, 0, NULL) == FAILURE
10174 && !sym->attr.untyped)
10176 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10177 sym->name, &sym->declared_at);
10178 sym->attr.untyped = 1;
10181 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
10182 && !sym->attr.contained
10183 && !gfc_check_access (sym->ts.derived->attr.access,
10184 sym->ts.derived->ns->default_access)
10185 && gfc_check_access (sym->attr.access, sym->ns->default_access))
10187 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
10188 "%L of PRIVATE type '%s'", sym->name,
10189 &sym->declared_at, sym->ts.derived->name);
10193 for (el = ns->entries->next; el; el = el->next)
10195 if (el->sym->result == el->sym
10196 && el->sym->ts.type == BT_UNKNOWN
10197 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
10198 && !el->sym->attr.untyped)
10200 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10201 el->sym->name, &el->sym->declared_at);
10202 el->sym->attr.untyped = 1;
10207 /* 12.3.2.1.1 Defined operators. */
10210 gfc_resolve_uops (gfc_symtree *symtree)
10212 gfc_interface *itr;
10214 gfc_formal_arglist *formal;
10216 if (symtree == NULL)
10219 gfc_resolve_uops (symtree->left);
10220 gfc_resolve_uops (symtree->right);
10222 for (itr = symtree->n.uop->op; itr; itr = itr->next)
10225 if (!sym->attr.function)
10226 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10227 sym->name, &sym->declared_at);
10229 if (sym->ts.type == BT_CHARACTER
10230 && !(sym->ts.cl && sym->ts.cl->length)
10231 && !(sym->result && sym->result->ts.cl
10232 && sym->result->ts.cl->length))
10233 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10234 "character length", sym->name, &sym->declared_at);
10236 formal = sym->formal;
10237 if (!formal || !formal->sym)
10239 gfc_error ("User operator procedure '%s' at %L must have at least "
10240 "one argument", sym->name, &sym->declared_at);
10244 if (formal->sym->attr.intent != INTENT_IN)
10245 gfc_error ("First argument of operator interface at %L must be "
10246 "INTENT(IN)", &sym->declared_at);
10248 if (formal->sym->attr.optional)
10249 gfc_error ("First argument of operator interface at %L cannot be "
10250 "optional", &sym->declared_at);
10252 formal = formal->next;
10253 if (!formal || !formal->sym)
10256 if (formal->sym->attr.intent != INTENT_IN)
10257 gfc_error ("Second argument of operator interface at %L must be "
10258 "INTENT(IN)", &sym->declared_at);
10260 if (formal->sym->attr.optional)
10261 gfc_error ("Second argument of operator interface at %L cannot be "
10262 "optional", &sym->declared_at);
10265 gfc_error ("Operator interface at %L must have, at most, two "
10266 "arguments", &sym->declared_at);
10271 /* Examine all of the expressions associated with a program unit,
10272 assign types to all intermediate expressions, make sure that all
10273 assignments are to compatible types and figure out which names
10274 refer to which functions or subroutines. It doesn't check code
10275 block, which is handled by resolve_code. */
10278 resolve_types (gfc_namespace *ns)
10284 gfc_namespace* old_ns = gfc_current_ns;
10286 /* Check that all IMPLICIT types are ok. */
10287 if (!ns->seen_implicit_none)
10290 for (letter = 0; letter != GFC_LETTERS; ++letter)
10291 if (ns->set_flag[letter]
10292 && resolve_typespec_used (&ns->default_type[letter],
10293 &ns->implicit_loc[letter],
10298 gfc_current_ns = ns;
10300 resolve_entries (ns);
10302 resolve_common_vars (ns->blank_common.head, false);
10303 resolve_common_blocks (ns->common_root);
10305 resolve_contained_functions (ns);
10307 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
10309 for (cl = ns->cl_list; cl; cl = cl->next)
10310 resolve_charlen (cl);
10312 gfc_traverse_ns (ns, resolve_symbol);
10314 resolve_fntype (ns);
10316 for (n = ns->contained; n; n = n->sibling)
10318 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
10319 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10320 "also be PURE", n->proc_name->name,
10321 &n->proc_name->declared_at);
10327 gfc_check_interfaces (ns);
10329 gfc_traverse_ns (ns, resolve_values);
10335 for (d = ns->data; d; d = d->next)
10339 gfc_traverse_ns (ns, gfc_formalize_init_value);
10341 gfc_traverse_ns (ns, gfc_verify_binding_labels);
10343 if (ns->common_root != NULL)
10344 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
10346 for (eq = ns->equiv; eq; eq = eq->next)
10347 resolve_equivalence (eq);
10349 /* Warn about unused labels. */
10350 if (warn_unused_label)
10351 warn_unused_fortran_label (ns->st_labels);
10353 gfc_resolve_uops (ns->uop_root);
10355 gfc_current_ns = old_ns;
10359 /* Call resolve_code recursively. */
10362 resolve_codes (gfc_namespace *ns)
10366 for (n = ns->contained; n; n = n->sibling)
10369 gfc_current_ns = ns;
10371 /* Set to an out of range value. */
10372 current_entry_id = -1;
10374 bitmap_obstack_initialize (&labels_obstack);
10375 resolve_code (ns->code, ns);
10376 bitmap_obstack_release (&labels_obstack);
10380 /* This function is called after a complete program unit has been compiled.
10381 Its purpose is to examine all of the expressions associated with a program
10382 unit, assign types to all intermediate expressions, make sure that all
10383 assignments are to compatible types and figure out which names refer to
10384 which functions or subroutines. */
10387 gfc_resolve (gfc_namespace *ns)
10389 gfc_namespace *old_ns;
10391 old_ns = gfc_current_ns;
10393 resolve_types (ns);
10394 resolve_codes (ns);
10396 gfc_current_ns = old_ns;