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 /* Resolve an actual argument list. Most of the time, this is just
1044 resolving the expressions in the list.
1045 The exception is that we sometimes have to decide whether arguments
1046 that look like procedure arguments are really simple variable
1050 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
1053 gfc_symtree *parent_st;
1055 int save_need_full_assumed_size;
1057 for (; arg; arg = arg->next)
1062 /* Check the label is a valid branching target. */
1065 if (arg->label->defined == ST_LABEL_UNKNOWN)
1067 gfc_error ("Label %d referenced at %L is never defined",
1068 arg->label->value, &arg->label->where);
1075 if (e->expr_type == EXPR_VARIABLE && e->symtree->ambiguous)
1077 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1082 if (e->ts.type != BT_PROCEDURE)
1084 save_need_full_assumed_size = need_full_assumed_size;
1085 if (e->expr_type != EXPR_VARIABLE)
1086 need_full_assumed_size = 0;
1087 if (gfc_resolve_expr (e) != SUCCESS)
1089 need_full_assumed_size = save_need_full_assumed_size;
1093 /* See if the expression node should really be a variable reference. */
1095 sym = e->symtree->n.sym;
1097 if (sym->attr.flavor == FL_PROCEDURE
1098 || sym->attr.intrinsic
1099 || sym->attr.external)
1103 /* If a procedure is not already determined to be something else
1104 check if it is intrinsic. */
1105 if (!sym->attr.intrinsic
1106 && !(sym->attr.external || sym->attr.use_assoc
1107 || sym->attr.if_source == IFSRC_IFBODY)
1108 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1109 sym->attr.intrinsic = 1;
1111 if (sym->attr.proc == PROC_ST_FUNCTION)
1113 gfc_error ("Statement function '%s' at %L is not allowed as an "
1114 "actual argument", sym->name, &e->where);
1117 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1118 sym->attr.subroutine);
1119 if (sym->attr.intrinsic && actual_ok == 0)
1121 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1122 "actual argument", sym->name, &e->where);
1125 if (sym->attr.contained && !sym->attr.use_assoc
1126 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1128 gfc_error ("Internal procedure '%s' is not allowed as an "
1129 "actual argument at %L", sym->name, &e->where);
1132 if (sym->attr.elemental && !sym->attr.intrinsic)
1134 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1135 "allowed as an actual argument at %L", sym->name,
1139 /* Check if a generic interface has a specific procedure
1140 with the same name before emitting an error. */
1141 if (sym->attr.generic)
1144 for (p = sym->generic; p; p = p->next)
1145 if (strcmp (sym->name, p->sym->name) == 0)
1147 e->symtree = gfc_find_symtree
1148 (p->sym->ns->sym_root, sym->name);
1153 if (p == NULL || e->symtree == NULL)
1154 gfc_error ("GENERIC procedure '%s' is not "
1155 "allowed as an actual argument at %L", sym->name,
1159 /* If the symbol is the function that names the current (or
1160 parent) scope, then we really have a variable reference. */
1162 if (sym->attr.function && sym->result == sym
1163 && (sym->ns->proc_name == sym
1164 || (sym->ns->parent != NULL
1165 && sym->ns->parent->proc_name == sym)))
1168 /* If all else fails, see if we have a specific intrinsic. */
1169 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1171 gfc_intrinsic_sym *isym;
1173 isym = gfc_find_function (sym->name);
1174 if (isym == NULL || !isym->specific)
1176 gfc_error ("Unable to find a specific INTRINSIC procedure "
1177 "for the reference '%s' at %L", sym->name,
1182 sym->attr.intrinsic = 1;
1183 sym->attr.function = 1;
1188 /* See if the name is a module procedure in a parent unit. */
1190 if (was_declared (sym) || sym->ns->parent == NULL)
1193 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1195 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1199 if (parent_st == NULL)
1202 sym = parent_st->n.sym;
1203 e->symtree = parent_st; /* Point to the right thing. */
1205 if (sym->attr.flavor == FL_PROCEDURE
1206 || sym->attr.intrinsic
1207 || sym->attr.external)
1213 e->expr_type = EXPR_VARIABLE;
1215 if (sym->as != NULL)
1217 e->rank = sym->as->rank;
1218 e->ref = gfc_get_ref ();
1219 e->ref->type = REF_ARRAY;
1220 e->ref->u.ar.type = AR_FULL;
1221 e->ref->u.ar.as = sym->as;
1224 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1225 primary.c (match_actual_arg). If above code determines that it
1226 is a variable instead, it needs to be resolved as it was not
1227 done at the beginning of this function. */
1228 save_need_full_assumed_size = need_full_assumed_size;
1229 if (e->expr_type != EXPR_VARIABLE)
1230 need_full_assumed_size = 0;
1231 if (gfc_resolve_expr (e) != SUCCESS)
1233 need_full_assumed_size = save_need_full_assumed_size;
1236 /* Check argument list functions %VAL, %LOC and %REF. There is
1237 nothing to do for %REF. */
1238 if (arg->name && arg->name[0] == '%')
1240 if (strncmp ("%VAL", arg->name, 4) == 0)
1242 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1244 gfc_error ("By-value argument at %L is not of numeric "
1251 gfc_error ("By-value argument at %L cannot be an array or "
1252 "an array section", &e->where);
1256 /* Intrinsics are still PROC_UNKNOWN here. However,
1257 since same file external procedures are not resolvable
1258 in gfortran, it is a good deal easier to leave them to
1260 if (ptype != PROC_UNKNOWN
1261 && ptype != PROC_DUMMY
1262 && ptype != PROC_EXTERNAL
1263 && ptype != PROC_MODULE)
1265 gfc_error ("By-value argument at %L is not allowed "
1266 "in this context", &e->where);
1271 /* Statement functions have already been excluded above. */
1272 else if (strncmp ("%LOC", arg->name, 4) == 0
1273 && e->ts.type == BT_PROCEDURE)
1275 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1277 gfc_error ("Passing internal procedure at %L by location "
1278 "not allowed", &e->where);
1289 /* Do the checks of the actual argument list that are specific to elemental
1290 procedures. If called with c == NULL, we have a function, otherwise if
1291 expr == NULL, we have a subroutine. */
1294 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1296 gfc_actual_arglist *arg0;
1297 gfc_actual_arglist *arg;
1298 gfc_symbol *esym = NULL;
1299 gfc_intrinsic_sym *isym = NULL;
1301 gfc_intrinsic_arg *iformal = NULL;
1302 gfc_formal_arglist *eformal = NULL;
1303 bool formal_optional = false;
1304 bool set_by_optional = false;
1308 /* Is this an elemental procedure? */
1309 if (expr && expr->value.function.actual != NULL)
1311 if (expr->value.function.esym != NULL
1312 && expr->value.function.esym->attr.elemental)
1314 arg0 = expr->value.function.actual;
1315 esym = expr->value.function.esym;
1317 else if (expr->value.function.isym != NULL
1318 && expr->value.function.isym->elemental)
1320 arg0 = expr->value.function.actual;
1321 isym = expr->value.function.isym;
1326 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1328 arg0 = c->ext.actual;
1329 esym = c->symtree->n.sym;
1334 /* The rank of an elemental is the rank of its array argument(s). */
1335 for (arg = arg0; arg; arg = arg->next)
1337 if (arg->expr != NULL && arg->expr->rank > 0)
1339 rank = arg->expr->rank;
1340 if (arg->expr->expr_type == EXPR_VARIABLE
1341 && arg->expr->symtree->n.sym->attr.optional)
1342 set_by_optional = true;
1344 /* Function specific; set the result rank and shape. */
1348 if (!expr->shape && arg->expr->shape)
1350 expr->shape = gfc_get_shape (rank);
1351 for (i = 0; i < rank; i++)
1352 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1359 /* If it is an array, it shall not be supplied as an actual argument
1360 to an elemental procedure unless an array of the same rank is supplied
1361 as an actual argument corresponding to a nonoptional dummy argument of
1362 that elemental procedure(12.4.1.5). */
1363 formal_optional = false;
1365 iformal = isym->formal;
1367 eformal = esym->formal;
1369 for (arg = arg0; arg; arg = arg->next)
1373 if (eformal->sym && eformal->sym->attr.optional)
1374 formal_optional = true;
1375 eformal = eformal->next;
1377 else if (isym && iformal)
1379 if (iformal->optional)
1380 formal_optional = true;
1381 iformal = iformal->next;
1384 formal_optional = true;
1386 if (pedantic && arg->expr != NULL
1387 && arg->expr->expr_type == EXPR_VARIABLE
1388 && arg->expr->symtree->n.sym->attr.optional
1391 && (set_by_optional || arg->expr->rank != rank)
1392 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1394 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1395 "MISSING, it cannot be the actual argument of an "
1396 "ELEMENTAL procedure unless there is a non-optional "
1397 "argument with the same rank (12.4.1.5)",
1398 arg->expr->symtree->n.sym->name, &arg->expr->where);
1403 for (arg = arg0; arg; arg = arg->next)
1405 if (arg->expr == NULL || arg->expr->rank == 0)
1408 /* Being elemental, the last upper bound of an assumed size array
1409 argument must be present. */
1410 if (resolve_assumed_size_actual (arg->expr))
1413 /* Elemental procedure's array actual arguments must conform. */
1416 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1424 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1425 is an array, the intent inout/out variable needs to be also an array. */
1426 if (rank > 0 && esym && expr == NULL)
1427 for (eformal = esym->formal, arg = arg0; arg && eformal;
1428 arg = arg->next, eformal = eformal->next)
1429 if ((eformal->sym->attr.intent == INTENT_OUT
1430 || eformal->sym->attr.intent == INTENT_INOUT)
1431 && arg->expr && arg->expr->rank == 0)
1433 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1434 "ELEMENTAL subroutine '%s' is a scalar, but another "
1435 "actual argument is an array", &arg->expr->where,
1436 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1437 : "INOUT", eformal->sym->name, esym->name);
1444 /* Go through each actual argument in ACTUAL and see if it can be
1445 implemented as an inlined, non-copying intrinsic. FNSYM is the
1446 function being called, or NULL if not known. */
1449 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1451 gfc_actual_arglist *ap;
1454 for (ap = actual; ap; ap = ap->next)
1456 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1457 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1458 ap->expr->inline_noncopying_intrinsic = 1;
1462 /* This function does the checking of references to global procedures
1463 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1464 77 and 95 standards. It checks for a gsymbol for the name, making
1465 one if it does not already exist. If it already exists, then the
1466 reference being resolved must correspond to the type of gsymbol.
1467 Otherwise, the new symbol is equipped with the attributes of the
1468 reference. The corresponding code that is called in creating
1469 global entities is parse.c. */
1472 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1477 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1479 gsym = gfc_get_gsymbol (sym->name);
1481 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1482 gfc_global_used (gsym, where);
1484 if (gsym->type == GSYM_UNKNOWN)
1487 gsym->where = *where;
1494 /************* Function resolution *************/
1496 /* Resolve a function call known to be generic.
1497 Section 14.1.2.4.1. */
1500 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1504 if (sym->attr.generic)
1506 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1509 expr->value.function.name = s->name;
1510 expr->value.function.esym = s;
1512 if (s->ts.type != BT_UNKNOWN)
1514 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1515 expr->ts = s->result->ts;
1518 expr->rank = s->as->rank;
1519 else if (s->result != NULL && s->result->as != NULL)
1520 expr->rank = s->result->as->rank;
1522 gfc_set_sym_referenced (expr->value.function.esym);
1527 /* TODO: Need to search for elemental references in generic
1531 if (sym->attr.intrinsic)
1532 return gfc_intrinsic_func_interface (expr, 0);
1539 resolve_generic_f (gfc_expr *expr)
1544 sym = expr->symtree->n.sym;
1548 m = resolve_generic_f0 (expr, sym);
1551 else if (m == MATCH_ERROR)
1555 if (sym->ns->parent == NULL)
1557 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1561 if (!generic_sym (sym))
1565 /* Last ditch attempt. See if the reference is to an intrinsic
1566 that possesses a matching interface. 14.1.2.4 */
1567 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1569 gfc_error ("There is no specific function for the generic '%s' at %L",
1570 expr->symtree->n.sym->name, &expr->where);
1574 m = gfc_intrinsic_func_interface (expr, 0);
1578 gfc_error ("Generic function '%s' at %L is not consistent with a "
1579 "specific intrinsic interface", expr->symtree->n.sym->name,
1586 /* Resolve a function call known to be specific. */
1589 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1593 /* See if we have an intrinsic interface. */
1595 if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
1597 gfc_intrinsic_sym *isym;
1598 isym = gfc_find_function (sym->ts.interface->name);
1600 /* Existence of isym should be checked already. */
1603 sym->ts.type = isym->ts.type;
1604 sym->ts.kind = isym->ts.kind;
1605 sym->attr.function = 1;
1606 sym->attr.proc = PROC_EXTERNAL;
1610 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1612 if (sym->attr.dummy)
1614 sym->attr.proc = PROC_DUMMY;
1618 sym->attr.proc = PROC_EXTERNAL;
1622 if (sym->attr.proc == PROC_MODULE
1623 || sym->attr.proc == PROC_ST_FUNCTION
1624 || sym->attr.proc == PROC_INTERNAL)
1627 if (sym->attr.intrinsic)
1629 m = gfc_intrinsic_func_interface (expr, 1);
1633 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1634 "with an intrinsic", sym->name, &expr->where);
1642 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1645 expr->value.function.name = sym->name;
1646 expr->value.function.esym = sym;
1647 if (sym->as != NULL)
1648 expr->rank = sym->as->rank;
1655 resolve_specific_f (gfc_expr *expr)
1660 sym = expr->symtree->n.sym;
1664 m = resolve_specific_f0 (sym, expr);
1667 if (m == MATCH_ERROR)
1670 if (sym->ns->parent == NULL)
1673 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1679 gfc_error ("Unable to resolve the specific function '%s' at %L",
1680 expr->symtree->n.sym->name, &expr->where);
1686 /* Resolve a procedure call not known to be generic nor specific. */
1689 resolve_unknown_f (gfc_expr *expr)
1694 sym = expr->symtree->n.sym;
1696 if (sym->attr.dummy)
1698 sym->attr.proc = PROC_DUMMY;
1699 expr->value.function.name = sym->name;
1703 /* See if we have an intrinsic function reference. */
1705 if (gfc_is_intrinsic (sym, 0, expr->where))
1707 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1712 /* The reference is to an external name. */
1714 sym->attr.proc = PROC_EXTERNAL;
1715 expr->value.function.name = sym->name;
1716 expr->value.function.esym = expr->symtree->n.sym;
1718 if (sym->as != NULL)
1719 expr->rank = sym->as->rank;
1721 /* Type of the expression is either the type of the symbol or the
1722 default type of the symbol. */
1725 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1727 if (sym->ts.type != BT_UNKNOWN)
1731 ts = gfc_get_default_type (sym, sym->ns);
1733 if (ts->type == BT_UNKNOWN)
1735 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1736 sym->name, &expr->where);
1747 /* Return true, if the symbol is an external procedure. */
1749 is_external_proc (gfc_symbol *sym)
1751 if (!sym->attr.dummy && !sym->attr.contained
1752 && !(sym->attr.intrinsic
1753 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
1754 && sym->attr.proc != PROC_ST_FUNCTION
1755 && !sym->attr.use_assoc
1763 /* Figure out if a function reference is pure or not. Also set the name
1764 of the function for a potential error message. Return nonzero if the
1765 function is PURE, zero if not. */
1767 pure_stmt_function (gfc_expr *, gfc_symbol *);
1770 pure_function (gfc_expr *e, const char **name)
1776 if (e->symtree != NULL
1777 && e->symtree->n.sym != NULL
1778 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1779 return pure_stmt_function (e, e->symtree->n.sym);
1781 if (e->value.function.esym)
1783 pure = gfc_pure (e->value.function.esym);
1784 *name = e->value.function.esym->name;
1786 else if (e->value.function.isym)
1788 pure = e->value.function.isym->pure
1789 || e->value.function.isym->elemental;
1790 *name = e->value.function.isym->name;
1794 /* Implicit functions are not pure. */
1796 *name = e->value.function.name;
1804 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
1805 int *f ATTRIBUTE_UNUSED)
1809 /* Don't bother recursing into other statement functions
1810 since they will be checked individually for purity. */
1811 if (e->expr_type != EXPR_FUNCTION
1813 || e->symtree->n.sym == sym
1814 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1817 return pure_function (e, &name) ? false : true;
1822 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
1824 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
1829 is_scalar_expr_ptr (gfc_expr *expr)
1831 gfc_try retval = SUCCESS;
1836 /* See if we have a gfc_ref, which means we have a substring, array
1837 reference, or a component. */
1838 if (expr->ref != NULL)
1841 while (ref->next != NULL)
1847 if (ref->u.ss.length != NULL
1848 && ref->u.ss.length->length != NULL
1850 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1852 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1854 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1855 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1856 if (end - start + 1 != 1)
1863 if (ref->u.ar.type == AR_ELEMENT)
1865 else if (ref->u.ar.type == AR_FULL)
1867 /* The user can give a full array if the array is of size 1. */
1868 if (ref->u.ar.as != NULL
1869 && ref->u.ar.as->rank == 1
1870 && ref->u.ar.as->type == AS_EXPLICIT
1871 && ref->u.ar.as->lower[0] != NULL
1872 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1873 && ref->u.ar.as->upper[0] != NULL
1874 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1876 /* If we have a character string, we need to check if
1877 its length is one. */
1878 if (expr->ts.type == BT_CHARACTER)
1880 if (expr->ts.cl == NULL
1881 || expr->ts.cl->length == NULL
1882 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1888 /* We have constant lower and upper bounds. If the
1889 difference between is 1, it can be considered a
1891 start = (int) mpz_get_si
1892 (ref->u.ar.as->lower[0]->value.integer);
1893 end = (int) mpz_get_si
1894 (ref->u.ar.as->upper[0]->value.integer);
1895 if (end - start + 1 != 1)
1910 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1912 /* Character string. Make sure it's of length 1. */
1913 if (expr->ts.cl == NULL
1914 || expr->ts.cl->length == NULL
1915 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1918 else if (expr->rank != 0)
1925 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1926 and, in the case of c_associated, set the binding label based on
1930 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1931 gfc_symbol **new_sym)
1933 char name[GFC_MAX_SYMBOL_LEN + 1];
1934 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1935 int optional_arg = 0;
1936 gfc_try retval = SUCCESS;
1937 gfc_symbol *args_sym;
1938 gfc_typespec *arg_ts;
1939 gfc_ref *parent_ref;
1942 if (args->expr->expr_type == EXPR_CONSTANT
1943 || args->expr->expr_type == EXPR_OP
1944 || args->expr->expr_type == EXPR_NULL)
1946 gfc_error ("Argument to '%s' at %L is not a variable",
1947 sym->name, &(args->expr->where));
1951 args_sym = args->expr->symtree->n.sym;
1953 /* The typespec for the actual arg should be that stored in the expr
1954 and not necessarily that of the expr symbol (args_sym), because
1955 the actual expression could be a part-ref of the expr symbol. */
1956 arg_ts = &(args->expr->ts);
1958 /* Get the parent reference (if any) for the expression. This happens for
1959 cases such as a%b%c. */
1960 parent_ref = args->expr->ref;
1962 if (parent_ref != NULL)
1964 curr_ref = parent_ref->next;
1965 while (curr_ref != NULL && curr_ref->next != NULL)
1967 parent_ref = curr_ref;
1968 curr_ref = curr_ref->next;
1972 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1973 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1974 the name, etc. Otherwise, the current parent_ref should be correct. */
1975 if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
1976 parent_ref = curr_ref;
1978 if (parent_ref == args->expr->ref)
1980 else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
1981 gfc_internal_error ("Unexpected expression reference type in "
1982 "gfc_iso_c_func_interface");
1984 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1986 /* If the user gave two args then they are providing something for
1987 the optional arg (the second cptr). Therefore, set the name and
1988 binding label to the c_associated for two cptrs. Otherwise,
1989 set c_associated to expect one cptr. */
1993 sprintf (name, "%s_2", sym->name);
1994 sprintf (binding_label, "%s_2", sym->binding_label);
2000 sprintf (name, "%s_1", sym->name);
2001 sprintf (binding_label, "%s_1", sym->binding_label);
2005 /* Get a new symbol for the version of c_associated that
2007 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2009 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2010 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2012 sprintf (name, "%s", sym->name);
2013 sprintf (binding_label, "%s", sym->binding_label);
2015 /* Error check the call. */
2016 if (args->next != NULL)
2018 gfc_error_now ("More actual than formal arguments in '%s' "
2019 "call at %L", name, &(args->expr->where));
2022 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2024 /* Make sure we have either the target or pointer attribute. */
2025 if (!(args_sym->attr.target)
2026 && !(args_sym->attr.pointer)
2027 && (parent_ref == NULL ||
2028 !parent_ref->u.c.component->attr.pointer))
2030 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2031 "a TARGET or an associated pointer",
2033 sym->name, &(args->expr->where));
2037 /* See if we have interoperable type and type param. */
2038 if (verify_c_interop (arg_ts,
2039 (parent_ref ? parent_ref->u.c.component->name
2041 &(args->expr->where)) == SUCCESS
2042 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2044 if (args_sym->attr.target == 1)
2046 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2047 has the target attribute and is interoperable. */
2048 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2049 allocatable variable that has the TARGET attribute and
2050 is not an array of zero size. */
2051 if (args_sym->attr.allocatable == 1)
2053 if (args_sym->attr.dimension != 0
2054 && (args_sym->as && args_sym->as->rank == 0))
2056 gfc_error_now ("Allocatable variable '%s' used as a "
2057 "parameter to '%s' at %L must not be "
2058 "an array of zero size",
2059 args_sym->name, sym->name,
2060 &(args->expr->where));
2066 /* A non-allocatable target variable with C
2067 interoperable type and type parameters must be
2069 if (args_sym && args_sym->attr.dimension)
2071 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2073 gfc_error ("Assumed-shape array '%s' at %L "
2074 "cannot be an argument to the "
2075 "procedure '%s' because "
2076 "it is not C interoperable",
2078 &(args->expr->where), sym->name);
2081 else if (args_sym->as->type == AS_DEFERRED)
2083 gfc_error ("Deferred-shape array '%s' at %L "
2084 "cannot be an argument to the "
2085 "procedure '%s' because "
2086 "it is not C interoperable",
2088 &(args->expr->where), sym->name);
2093 /* Make sure it's not a character string. Arrays of
2094 any type should be ok if the variable is of a C
2095 interoperable type. */
2096 if (arg_ts->type == BT_CHARACTER)
2097 if (arg_ts->cl != NULL
2098 && (arg_ts->cl->length == NULL
2099 || arg_ts->cl->length->expr_type
2102 (arg_ts->cl->length->value.integer, 1)
2104 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2106 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2107 "at %L must have a length of 1",
2108 args_sym->name, sym->name,
2109 &(args->expr->where));
2114 else if ((args_sym->attr.pointer == 1 ||
2116 && parent_ref->u.c.component->attr.pointer))
2117 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2119 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2121 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2122 "associated scalar POINTER", args_sym->name,
2123 sym->name, &(args->expr->where));
2129 /* The parameter is not required to be C interoperable. If it
2130 is not C interoperable, it must be a nonpolymorphic scalar
2131 with no length type parameters. It still must have either
2132 the pointer or target attribute, and it can be
2133 allocatable (but must be allocated when c_loc is called). */
2134 if (args->expr->rank != 0
2135 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2137 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2138 "scalar", args_sym->name, sym->name,
2139 &(args->expr->where));
2142 else if (arg_ts->type == BT_CHARACTER
2143 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2145 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2146 "%L must have a length of 1",
2147 args_sym->name, sym->name,
2148 &(args->expr->where));
2153 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2155 if (args_sym->attr.flavor != FL_PROCEDURE)
2157 /* TODO: Update this error message to allow for procedure
2158 pointers once they are implemented. */
2159 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2161 args_sym->name, sym->name,
2162 &(args->expr->where));
2165 else if (args_sym->attr.is_bind_c != 1)
2167 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2169 args_sym->name, sym->name,
2170 &(args->expr->where));
2175 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2180 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2181 "iso_c_binding function: '%s'!\n", sym->name);
2188 /* Resolve a function call, which means resolving the arguments, then figuring
2189 out which entity the name refers to. */
2190 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2191 to INTENT(OUT) or INTENT(INOUT). */
2194 resolve_function (gfc_expr *expr)
2196 gfc_actual_arglist *arg;
2201 procedure_type p = PROC_INTRINSIC;
2205 sym = expr->symtree->n.sym;
2207 if (sym && sym->attr.flavor == FL_VARIABLE)
2209 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2213 if (sym && sym->attr.abstract)
2215 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2216 sym->name, &expr->where);
2220 /* If the procedure is external, check for usage. */
2221 if (sym && is_external_proc (sym))
2222 resolve_global_procedure (sym, &expr->where, 0);
2224 /* Switch off assumed size checking and do this again for certain kinds
2225 of procedure, once the procedure itself is resolved. */
2226 need_full_assumed_size++;
2228 if (expr->symtree && expr->symtree->n.sym)
2229 p = expr->symtree->n.sym->attr.proc;
2231 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
2234 /* Need to setup the call to the correct c_associated, depending on
2235 the number of cptrs to user gives to compare. */
2236 if (sym && sym->attr.is_iso_c == 1)
2238 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2242 /* Get the symtree for the new symbol (resolved func).
2243 the old one will be freed later, when it's no longer used. */
2244 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2247 /* Resume assumed_size checking. */
2248 need_full_assumed_size--;
2250 if (sym && sym->ts.type == BT_CHARACTER
2252 && sym->ts.cl->length == NULL
2254 && expr->value.function.esym == NULL
2255 && !sym->attr.contained)
2257 /* Internal procedures are taken care of in resolve_contained_fntype. */
2258 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2259 "be used at %L since it is not a dummy argument",
2260 sym->name, &expr->where);
2264 /* See if function is already resolved. */
2266 if (expr->value.function.name != NULL)
2268 if (expr->ts.type == BT_UNKNOWN)
2274 /* Apply the rules of section 14.1.2. */
2276 switch (procedure_kind (sym))
2279 t = resolve_generic_f (expr);
2282 case PTYPE_SPECIFIC:
2283 t = resolve_specific_f (expr);
2287 t = resolve_unknown_f (expr);
2291 gfc_internal_error ("resolve_function(): bad function type");
2295 /* If the expression is still a function (it might have simplified),
2296 then we check to see if we are calling an elemental function. */
2298 if (expr->expr_type != EXPR_FUNCTION)
2301 temp = need_full_assumed_size;
2302 need_full_assumed_size = 0;
2304 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2307 if (omp_workshare_flag
2308 && expr->value.function.esym
2309 && ! gfc_elemental (expr->value.function.esym))
2311 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2312 "in WORKSHARE construct", expr->value.function.esym->name,
2317 #define GENERIC_ID expr->value.function.isym->id
2318 else if (expr->value.function.actual != NULL
2319 && expr->value.function.isym != NULL
2320 && GENERIC_ID != GFC_ISYM_LBOUND
2321 && GENERIC_ID != GFC_ISYM_LEN
2322 && GENERIC_ID != GFC_ISYM_LOC
2323 && GENERIC_ID != GFC_ISYM_PRESENT)
2325 /* Array intrinsics must also have the last upper bound of an
2326 assumed size array argument. UBOUND and SIZE have to be
2327 excluded from the check if the second argument is anything
2330 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2331 || GENERIC_ID == GFC_ISYM_SIZE;
2333 for (arg = expr->value.function.actual; arg; arg = arg->next)
2335 if (inquiry && arg->next != NULL && arg->next->expr)
2337 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2340 if ((int)mpz_get_si (arg->next->expr->value.integer)
2345 if (arg->expr != NULL
2346 && arg->expr->rank > 0
2347 && resolve_assumed_size_actual (arg->expr))
2353 need_full_assumed_size = temp;
2356 if (!pure_function (expr, &name) && name)
2360 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2361 "FORALL %s", name, &expr->where,
2362 forall_flag == 2 ? "mask" : "block");
2365 else if (gfc_pure (NULL))
2367 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2368 "procedure within a PURE procedure", name, &expr->where);
2373 /* Functions without the RECURSIVE attribution are not allowed to
2374 * call themselves. */
2375 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2377 gfc_symbol *esym, *proc;
2378 esym = expr->value.function.esym;
2379 proc = gfc_current_ns->proc_name;
2382 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2383 "RECURSIVE", name, &expr->where);
2387 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2388 && esym->ns->entries->sym == proc->ns->entries->sym)
2390 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2391 "'%s' is not declared as RECURSIVE",
2392 esym->name, &expr->where, esym->ns->entries->sym->name);
2397 /* Character lengths of use associated functions may contains references to
2398 symbols not referenced from the current program unit otherwise. Make sure
2399 those symbols are marked as referenced. */
2401 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2402 && expr->value.function.esym->attr.use_assoc)
2404 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2408 && !((expr->value.function.esym
2409 && expr->value.function.esym->attr.elemental)
2411 (expr->value.function.isym
2412 && expr->value.function.isym->elemental)))
2413 find_noncopying_intrinsics (expr->value.function.esym,
2414 expr->value.function.actual);
2416 /* Make sure that the expression has a typespec that works. */
2417 if (expr->ts.type == BT_UNKNOWN)
2419 if (expr->symtree->n.sym->result
2420 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2421 expr->ts = expr->symtree->n.sym->result->ts;
2428 /************* Subroutine resolution *************/
2431 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2437 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2438 sym->name, &c->loc);
2439 else if (gfc_pure (NULL))
2440 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2446 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2450 if (sym->attr.generic)
2452 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2455 c->resolved_sym = s;
2456 pure_subroutine (c, s);
2460 /* TODO: Need to search for elemental references in generic interface. */
2463 if (sym->attr.intrinsic)
2464 return gfc_intrinsic_sub_interface (c, 0);
2471 resolve_generic_s (gfc_code *c)
2476 sym = c->symtree->n.sym;
2480 m = resolve_generic_s0 (c, sym);
2483 else if (m == MATCH_ERROR)
2487 if (sym->ns->parent == NULL)
2489 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2493 if (!generic_sym (sym))
2497 /* Last ditch attempt. See if the reference is to an intrinsic
2498 that possesses a matching interface. 14.1.2.4 */
2499 sym = c->symtree->n.sym;
2501 if (!gfc_is_intrinsic (sym, 1, c->loc))
2503 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2504 sym->name, &c->loc);
2508 m = gfc_intrinsic_sub_interface (c, 0);
2512 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2513 "intrinsic subroutine interface", sym->name, &c->loc);
2519 /* Set the name and binding label of the subroutine symbol in the call
2520 expression represented by 'c' to include the type and kind of the
2521 second parameter. This function is for resolving the appropriate
2522 version of c_f_pointer() and c_f_procpointer(). For example, a
2523 call to c_f_pointer() for a default integer pointer could have a
2524 name of c_f_pointer_i4. If no second arg exists, which is an error
2525 for these two functions, it defaults to the generic symbol's name
2526 and binding label. */
2529 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2530 char *name, char *binding_label)
2532 gfc_expr *arg = NULL;
2536 /* The second arg of c_f_pointer and c_f_procpointer determines
2537 the type and kind for the procedure name. */
2538 arg = c->ext.actual->next->expr;
2542 /* Set up the name to have the given symbol's name,
2543 plus the type and kind. */
2544 /* a derived type is marked with the type letter 'u' */
2545 if (arg->ts.type == BT_DERIVED)
2548 kind = 0; /* set the kind as 0 for now */
2552 type = gfc_type_letter (arg->ts.type);
2553 kind = arg->ts.kind;
2556 if (arg->ts.type == BT_CHARACTER)
2557 /* Kind info for character strings not needed. */
2560 sprintf (name, "%s_%c%d", sym->name, type, kind);
2561 /* Set up the binding label as the given symbol's label plus
2562 the type and kind. */
2563 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2567 /* If the second arg is missing, set the name and label as
2568 was, cause it should at least be found, and the missing
2569 arg error will be caught by compare_parameters(). */
2570 sprintf (name, "%s", sym->name);
2571 sprintf (binding_label, "%s", sym->binding_label);
2578 /* Resolve a generic version of the iso_c_binding procedure given
2579 (sym) to the specific one based on the type and kind of the
2580 argument(s). Currently, this function resolves c_f_pointer() and
2581 c_f_procpointer based on the type and kind of the second argument
2582 (FPTR). Other iso_c_binding procedures aren't specially handled.
2583 Upon successfully exiting, c->resolved_sym will hold the resolved
2584 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2588 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2590 gfc_symbol *new_sym;
2591 /* this is fine, since we know the names won't use the max */
2592 char name[GFC_MAX_SYMBOL_LEN + 1];
2593 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2594 /* default to success; will override if find error */
2595 match m = MATCH_YES;
2597 /* Make sure the actual arguments are in the necessary order (based on the
2598 formal args) before resolving. */
2599 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2601 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2602 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2604 set_name_and_label (c, sym, name, binding_label);
2606 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2608 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2610 /* Make sure we got a third arg if the second arg has non-zero
2611 rank. We must also check that the type and rank are
2612 correct since we short-circuit this check in
2613 gfc_procedure_use() (called above to sort actual args). */
2614 if (c->ext.actual->next->expr->rank != 0)
2616 if(c->ext.actual->next->next == NULL
2617 || c->ext.actual->next->next->expr == NULL)
2620 gfc_error ("Missing SHAPE parameter for call to %s "
2621 "at %L", sym->name, &(c->loc));
2623 else if (c->ext.actual->next->next->expr->ts.type
2625 || c->ext.actual->next->next->expr->rank != 1)
2628 gfc_error ("SHAPE parameter for call to %s at %L must "
2629 "be a rank 1 INTEGER array", sym->name,
2636 if (m != MATCH_ERROR)
2638 /* the 1 means to add the optional arg to formal list */
2639 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2641 /* for error reporting, say it's declared where the original was */
2642 new_sym->declared_at = sym->declared_at;
2647 /* no differences for c_loc or c_funloc */
2651 /* set the resolved symbol */
2652 if (m != MATCH_ERROR)
2653 c->resolved_sym = new_sym;
2655 c->resolved_sym = sym;
2661 /* Resolve a subroutine call known to be specific. */
2664 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2668 /* See if we have an intrinsic interface. */
2669 if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
2670 && !sym->ts.interface->attr.subroutine)
2672 gfc_intrinsic_sym *isym;
2674 isym = gfc_find_function (sym->ts.interface->name);
2676 /* Existence of isym should be checked already. */
2679 sym->ts.type = isym->ts.type;
2680 sym->ts.kind = isym->ts.kind;
2681 sym->attr.subroutine = 1;
2685 if(sym->attr.is_iso_c)
2687 m = gfc_iso_c_sub_interface (c,sym);
2691 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2693 if (sym->attr.dummy)
2695 sym->attr.proc = PROC_DUMMY;
2699 sym->attr.proc = PROC_EXTERNAL;
2703 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2706 if (sym->attr.intrinsic)
2708 m = gfc_intrinsic_sub_interface (c, 1);
2712 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2713 "with an intrinsic", sym->name, &c->loc);
2721 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2723 c->resolved_sym = sym;
2724 pure_subroutine (c, sym);
2731 resolve_specific_s (gfc_code *c)
2736 sym = c->symtree->n.sym;
2740 m = resolve_specific_s0 (c, sym);
2743 if (m == MATCH_ERROR)
2746 if (sym->ns->parent == NULL)
2749 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2755 sym = c->symtree->n.sym;
2756 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2757 sym->name, &c->loc);
2763 /* Resolve a subroutine call not known to be generic nor specific. */
2766 resolve_unknown_s (gfc_code *c)
2770 sym = c->symtree->n.sym;
2772 if (sym->attr.dummy)
2774 sym->attr.proc = PROC_DUMMY;
2778 /* See if we have an intrinsic function reference. */
2780 if (gfc_is_intrinsic (sym, 1, c->loc))
2782 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2787 /* The reference is to an external name. */
2790 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2792 c->resolved_sym = sym;
2794 pure_subroutine (c, sym);
2800 /* Resolve a subroutine call. Although it was tempting to use the same code
2801 for functions, subroutines and functions are stored differently and this
2802 makes things awkward. */
2805 resolve_call (gfc_code *c)
2808 procedure_type ptype = PROC_INTRINSIC;
2810 if (c->symtree && c->symtree->n.sym
2811 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2813 gfc_error ("'%s' at %L has a type, which is not consistent with "
2814 "the CALL at %L", c->symtree->n.sym->name,
2815 &c->symtree->n.sym->declared_at, &c->loc);
2819 /* If external, check for usage. */
2820 if (c->symtree && is_external_proc (c->symtree->n.sym))
2821 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2823 /* Subroutines without the RECURSIVE attribution are not allowed to
2824 * call themselves. */
2825 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2827 gfc_symbol *csym, *proc;
2828 csym = c->symtree->n.sym;
2829 proc = gfc_current_ns->proc_name;
2832 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2833 "RECURSIVE", csym->name, &c->loc);
2837 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2838 && csym->ns->entries->sym == proc->ns->entries->sym)
2840 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2841 "'%s' is not declared as RECURSIVE",
2842 csym->name, &c->loc, csym->ns->entries->sym->name);
2847 /* Switch off assumed size checking and do this again for certain kinds
2848 of procedure, once the procedure itself is resolved. */
2849 need_full_assumed_size++;
2851 if (c->symtree && c->symtree->n.sym)
2852 ptype = c->symtree->n.sym->attr.proc;
2854 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2857 /* Resume assumed_size checking. */
2858 need_full_assumed_size--;
2861 if (c->resolved_sym == NULL)
2862 switch (procedure_kind (c->symtree->n.sym))
2865 t = resolve_generic_s (c);
2868 case PTYPE_SPECIFIC:
2869 t = resolve_specific_s (c);
2873 t = resolve_unknown_s (c);
2877 gfc_internal_error ("resolve_subroutine(): bad function type");
2880 /* Some checks of elemental subroutine actual arguments. */
2881 if (resolve_elemental_actual (NULL, c) == FAILURE)
2884 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
2885 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2890 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2891 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2892 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2893 if their shapes do not match. If either op1->shape or op2->shape is
2894 NULL, return SUCCESS. */
2897 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2904 if (op1->shape != NULL && op2->shape != NULL)
2906 for (i = 0; i < op1->rank; i++)
2908 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2910 gfc_error ("Shapes for operands at %L and %L are not conformable",
2911 &op1->where, &op2->where);
2922 /* Resolve an operator expression node. This can involve replacing the
2923 operation with a user defined function call. */
2926 resolve_operator (gfc_expr *e)
2928 gfc_expr *op1, *op2;
2930 bool dual_locus_error;
2933 /* Resolve all subnodes-- give them types. */
2935 switch (e->value.op.op)
2938 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2941 /* Fall through... */
2944 case INTRINSIC_UPLUS:
2945 case INTRINSIC_UMINUS:
2946 case INTRINSIC_PARENTHESES:
2947 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2952 /* Typecheck the new node. */
2954 op1 = e->value.op.op1;
2955 op2 = e->value.op.op2;
2956 dual_locus_error = false;
2958 if ((op1 && op1->expr_type == EXPR_NULL)
2959 || (op2 && op2->expr_type == EXPR_NULL))
2961 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2965 switch (e->value.op.op)
2967 case INTRINSIC_UPLUS:
2968 case INTRINSIC_UMINUS:
2969 if (op1->ts.type == BT_INTEGER
2970 || op1->ts.type == BT_REAL
2971 || op1->ts.type == BT_COMPLEX)
2977 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2978 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
2981 case INTRINSIC_PLUS:
2982 case INTRINSIC_MINUS:
2983 case INTRINSIC_TIMES:
2984 case INTRINSIC_DIVIDE:
2985 case INTRINSIC_POWER:
2986 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2988 gfc_type_convert_binary (e);
2993 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2994 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
2995 gfc_typename (&op2->ts));
2998 case INTRINSIC_CONCAT:
2999 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3000 && op1->ts.kind == op2->ts.kind)
3002 e->ts.type = BT_CHARACTER;
3003 e->ts.kind = op1->ts.kind;
3008 _("Operands of string concatenation operator at %%L are %s/%s"),
3009 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3015 case INTRINSIC_NEQV:
3016 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3018 e->ts.type = BT_LOGICAL;
3019 e->ts.kind = gfc_kind_max (op1, op2);
3020 if (op1->ts.kind < e->ts.kind)
3021 gfc_convert_type (op1, &e->ts, 2);
3022 else if (op2->ts.kind < e->ts.kind)
3023 gfc_convert_type (op2, &e->ts, 2);
3027 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3028 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3029 gfc_typename (&op2->ts));
3034 if (op1->ts.type == BT_LOGICAL)
3036 e->ts.type = BT_LOGICAL;
3037 e->ts.kind = op1->ts.kind;
3041 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3042 gfc_typename (&op1->ts));
3046 case INTRINSIC_GT_OS:
3048 case INTRINSIC_GE_OS:
3050 case INTRINSIC_LT_OS:
3052 case INTRINSIC_LE_OS:
3053 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3055 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3059 /* Fall through... */
3062 case INTRINSIC_EQ_OS:
3064 case INTRINSIC_NE_OS:
3065 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3066 && op1->ts.kind == op2->ts.kind)
3068 e->ts.type = BT_LOGICAL;
3069 e->ts.kind = gfc_default_logical_kind;
3073 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3075 gfc_type_convert_binary (e);
3077 e->ts.type = BT_LOGICAL;
3078 e->ts.kind = gfc_default_logical_kind;
3082 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3084 _("Logicals at %%L must be compared with %s instead of %s"),
3085 (e->value.op.op == INTRINSIC_EQ
3086 || e->value.op.op == INTRINSIC_EQ_OS)
3087 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3090 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3091 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3092 gfc_typename (&op2->ts));
3096 case INTRINSIC_USER:
3097 if (e->value.op.uop->op == NULL)
3098 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3099 else if (op2 == NULL)
3100 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3101 e->value.op.uop->name, gfc_typename (&op1->ts));
3103 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3104 e->value.op.uop->name, gfc_typename (&op1->ts),
3105 gfc_typename (&op2->ts));
3109 case INTRINSIC_PARENTHESES:
3111 if (e->ts.type == BT_CHARACTER)
3112 e->ts.cl = op1->ts.cl;
3116 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3119 /* Deal with arrayness of an operand through an operator. */
3123 switch (e->value.op.op)
3125 case INTRINSIC_PLUS:
3126 case INTRINSIC_MINUS:
3127 case INTRINSIC_TIMES:
3128 case INTRINSIC_DIVIDE:
3129 case INTRINSIC_POWER:
3130 case INTRINSIC_CONCAT:
3134 case INTRINSIC_NEQV:
3136 case INTRINSIC_EQ_OS:
3138 case INTRINSIC_NE_OS:
3140 case INTRINSIC_GT_OS:
3142 case INTRINSIC_GE_OS:
3144 case INTRINSIC_LT_OS:
3146 case INTRINSIC_LE_OS:
3148 if (op1->rank == 0 && op2->rank == 0)
3151 if (op1->rank == 0 && op2->rank != 0)
3153 e->rank = op2->rank;
3155 if (e->shape == NULL)
3156 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3159 if (op1->rank != 0 && op2->rank == 0)
3161 e->rank = op1->rank;
3163 if (e->shape == NULL)
3164 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3167 if (op1->rank != 0 && op2->rank != 0)
3169 if (op1->rank == op2->rank)
3171 e->rank = op1->rank;
3172 if (e->shape == NULL)
3174 t = compare_shapes(op1, op2);
3178 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3183 /* Allow higher level expressions to work. */
3186 /* Try user-defined operators, and otherwise throw an error. */
3187 dual_locus_error = true;
3189 _("Inconsistent ranks for operator at %%L and %%L"));
3196 case INTRINSIC_PARENTHESES:
3198 case INTRINSIC_UPLUS:
3199 case INTRINSIC_UMINUS:
3200 /* Simply copy arrayness attribute */
3201 e->rank = op1->rank;
3203 if (e->shape == NULL)
3204 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3212 /* Attempt to simplify the expression. */
3215 t = gfc_simplify_expr (e, 0);
3216 /* Some calls do not succeed in simplification and return FAILURE
3217 even though there is no error; e.g. variable references to
3218 PARAMETER arrays. */
3219 if (!gfc_is_constant_expr (e))
3226 if (gfc_extend_expr (e) == SUCCESS)
3229 if (dual_locus_error)
3230 gfc_error (msg, &op1->where, &op2->where);
3232 gfc_error (msg, &e->where);
3238 /************** Array resolution subroutines **************/
3241 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3244 /* Compare two integer expressions. */
3247 compare_bound (gfc_expr *a, gfc_expr *b)
3251 if (a == NULL || a->expr_type != EXPR_CONSTANT
3252 || b == NULL || b->expr_type != EXPR_CONSTANT)
3255 /* If either of the types isn't INTEGER, we must have
3256 raised an error earlier. */
3258 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3261 i = mpz_cmp (a->value.integer, b->value.integer);
3271 /* Compare an integer expression with an integer. */
3274 compare_bound_int (gfc_expr *a, int b)
3278 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3281 if (a->ts.type != BT_INTEGER)
3282 gfc_internal_error ("compare_bound_int(): Bad expression");
3284 i = mpz_cmp_si (a->value.integer, b);
3294 /* Compare an integer expression with a mpz_t. */
3297 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3301 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3304 if (a->ts.type != BT_INTEGER)
3305 gfc_internal_error ("compare_bound_int(): Bad expression");
3307 i = mpz_cmp (a->value.integer, b);
3317 /* Compute the last value of a sequence given by a triplet.
3318 Return 0 if it wasn't able to compute the last value, or if the
3319 sequence if empty, and 1 otherwise. */
3322 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3323 gfc_expr *stride, mpz_t last)
3327 if (start == NULL || start->expr_type != EXPR_CONSTANT
3328 || end == NULL || end->expr_type != EXPR_CONSTANT
3329 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3332 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3333 || (stride != NULL && stride->ts.type != BT_INTEGER))
3336 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3338 if (compare_bound (start, end) == CMP_GT)
3340 mpz_set (last, end->value.integer);
3344 if (compare_bound_int (stride, 0) == CMP_GT)
3346 /* Stride is positive */
3347 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3352 /* Stride is negative */
3353 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3358 mpz_sub (rem, end->value.integer, start->value.integer);
3359 mpz_tdiv_r (rem, rem, stride->value.integer);
3360 mpz_sub (last, end->value.integer, rem);
3367 /* Compare a single dimension of an array reference to the array
3371 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3375 /* Given start, end and stride values, calculate the minimum and
3376 maximum referenced indexes. */
3378 switch (ar->dimen_type[i])
3384 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3386 gfc_warning ("Array reference at %L is out of bounds "
3387 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3388 mpz_get_si (ar->start[i]->value.integer),
3389 mpz_get_si (as->lower[i]->value.integer), i+1);
3392 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3394 gfc_warning ("Array reference at %L is out of bounds "
3395 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3396 mpz_get_si (ar->start[i]->value.integer),
3397 mpz_get_si (as->upper[i]->value.integer), i+1);
3405 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3406 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3408 comparison comp_start_end = compare_bound (AR_START, AR_END);
3410 /* Check for zero stride, which is not allowed. */
3411 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3413 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3417 /* if start == len || (stride > 0 && start < len)
3418 || (stride < 0 && start > len),
3419 then the array section contains at least one element. In this
3420 case, there is an out-of-bounds access if
3421 (start < lower || start > upper). */
3422 if (compare_bound (AR_START, AR_END) == CMP_EQ
3423 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3424 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3425 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3426 && comp_start_end == CMP_GT))
3428 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3430 gfc_warning ("Lower array reference at %L is out of bounds "
3431 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3432 mpz_get_si (AR_START->value.integer),
3433 mpz_get_si (as->lower[i]->value.integer), i+1);
3436 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3438 gfc_warning ("Lower array reference at %L is out of bounds "
3439 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3440 mpz_get_si (AR_START->value.integer),
3441 mpz_get_si (as->upper[i]->value.integer), i+1);
3446 /* If we can compute the highest index of the array section,
3447 then it also has to be between lower and upper. */
3448 mpz_init (last_value);
3449 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3452 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3454 gfc_warning ("Upper array reference at %L is out of bounds "
3455 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3456 mpz_get_si (last_value),
3457 mpz_get_si (as->lower[i]->value.integer), i+1);
3458 mpz_clear (last_value);
3461 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3463 gfc_warning ("Upper array reference at %L is out of bounds "
3464 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3465 mpz_get_si (last_value),
3466 mpz_get_si (as->upper[i]->value.integer), i+1);
3467 mpz_clear (last_value);
3471 mpz_clear (last_value);
3479 gfc_internal_error ("check_dimension(): Bad array reference");
3486 /* Compare an array reference with an array specification. */
3489 compare_spec_to_ref (gfc_array_ref *ar)
3496 /* TODO: Full array sections are only allowed as actual parameters. */
3497 if (as->type == AS_ASSUMED_SIZE
3498 && (/*ar->type == AR_FULL
3499 ||*/ (ar->type == AR_SECTION
3500 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3502 gfc_error ("Rightmost upper bound of assumed size array section "
3503 "not specified at %L", &ar->where);
3507 if (ar->type == AR_FULL)
3510 if (as->rank != ar->dimen)
3512 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3513 &ar->where, ar->dimen, as->rank);
3517 for (i = 0; i < as->rank; i++)
3518 if (check_dimension (i, ar, as) == FAILURE)
3525 /* Resolve one part of an array index. */
3528 gfc_resolve_index (gfc_expr *index, int check_scalar)
3535 if (gfc_resolve_expr (index) == FAILURE)
3538 if (check_scalar && index->rank != 0)
3540 gfc_error ("Array index at %L must be scalar", &index->where);
3544 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3546 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3547 &index->where, gfc_basic_typename (index->ts.type));
3551 if (index->ts.type == BT_REAL)
3552 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3553 &index->where) == FAILURE)
3556 if (index->ts.kind != gfc_index_integer_kind
3557 || index->ts.type != BT_INTEGER)
3560 ts.type = BT_INTEGER;
3561 ts.kind = gfc_index_integer_kind;
3563 gfc_convert_type_warn (index, &ts, 2, 0);
3569 /* Resolve a dim argument to an intrinsic function. */
3572 gfc_resolve_dim_arg (gfc_expr *dim)
3577 if (gfc_resolve_expr (dim) == FAILURE)
3582 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3587 if (dim->ts.type != BT_INTEGER)
3589 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3593 if (dim->ts.kind != gfc_index_integer_kind)
3597 ts.type = BT_INTEGER;
3598 ts.kind = gfc_index_integer_kind;
3600 gfc_convert_type_warn (dim, &ts, 2, 0);
3606 /* Given an expression that contains array references, update those array
3607 references to point to the right array specifications. While this is
3608 filled in during matching, this information is difficult to save and load
3609 in a module, so we take care of it here.
3611 The idea here is that the original array reference comes from the
3612 base symbol. We traverse the list of reference structures, setting
3613 the stored reference to references. Component references can
3614 provide an additional array specification. */
3617 find_array_spec (gfc_expr *e)
3621 gfc_symbol *derived;
3624 as = e->symtree->n.sym->as;
3627 for (ref = e->ref; ref; ref = ref->next)
3632 gfc_internal_error ("find_array_spec(): Missing spec");
3639 if (derived == NULL)
3640 derived = e->symtree->n.sym->ts.derived;
3642 c = derived->components;
3644 for (; c; c = c->next)
3645 if (c == ref->u.c.component)
3647 /* Track the sequence of component references. */
3648 if (c->ts.type == BT_DERIVED)
3649 derived = c->ts.derived;
3654 gfc_internal_error ("find_array_spec(): Component not found");
3656 if (c->attr.dimension)
3659 gfc_internal_error ("find_array_spec(): unused as(1)");
3670 gfc_internal_error ("find_array_spec(): unused as(2)");
3674 /* Resolve an array reference. */
3677 resolve_array_ref (gfc_array_ref *ar)
3679 int i, check_scalar;
3682 for (i = 0; i < ar->dimen; i++)
3684 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3686 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3688 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3690 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3695 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3699 ar->dimen_type[i] = DIMEN_ELEMENT;
3703 ar->dimen_type[i] = DIMEN_VECTOR;
3704 if (e->expr_type == EXPR_VARIABLE
3705 && e->symtree->n.sym->ts.type == BT_DERIVED)
3706 ar->start[i] = gfc_get_parentheses (e);
3710 gfc_error ("Array index at %L is an array of rank %d",
3711 &ar->c_where[i], e->rank);
3716 /* If the reference type is unknown, figure out what kind it is. */
3718 if (ar->type == AR_UNKNOWN)
3720 ar->type = AR_ELEMENT;
3721 for (i = 0; i < ar->dimen; i++)
3722 if (ar->dimen_type[i] == DIMEN_RANGE
3723 || ar->dimen_type[i] == DIMEN_VECTOR)
3725 ar->type = AR_SECTION;
3730 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3738 resolve_substring (gfc_ref *ref)
3740 if (ref->u.ss.start != NULL)
3742 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3745 if (ref->u.ss.start->ts.type != BT_INTEGER)
3747 gfc_error ("Substring start index at %L must be of type INTEGER",
3748 &ref->u.ss.start->where);
3752 if (ref->u.ss.start->rank != 0)
3754 gfc_error ("Substring start index at %L must be scalar",
3755 &ref->u.ss.start->where);
3759 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3760 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3761 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3763 gfc_error ("Substring start index at %L is less than one",
3764 &ref->u.ss.start->where);
3769 if (ref->u.ss.end != NULL)
3771 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3774 if (ref->u.ss.end->ts.type != BT_INTEGER)
3776 gfc_error ("Substring end index at %L must be of type INTEGER",
3777 &ref->u.ss.end->where);
3781 if (ref->u.ss.end->rank != 0)
3783 gfc_error ("Substring end index at %L must be scalar",
3784 &ref->u.ss.end->where);
3788 if (ref->u.ss.length != NULL
3789 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3790 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3791 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3793 gfc_error ("Substring end index at %L exceeds the string length",
3794 &ref->u.ss.start->where);
3803 /* This function supplies missing substring charlens. */
3806 gfc_resolve_substring_charlen (gfc_expr *e)
3809 gfc_expr *start, *end;
3811 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3812 if (char_ref->type == REF_SUBSTRING)
3818 gcc_assert (char_ref->next == NULL);
3822 if (e->ts.cl->length)
3823 gfc_free_expr (e->ts.cl->length);
3824 else if (e->expr_type == EXPR_VARIABLE
3825 && e->symtree->n.sym->attr.dummy)
3829 e->ts.type = BT_CHARACTER;
3830 e->ts.kind = gfc_default_character_kind;
3834 e->ts.cl = gfc_get_charlen ();
3835 e->ts.cl->next = gfc_current_ns->cl_list;
3836 gfc_current_ns->cl_list = e->ts.cl;
3839 if (char_ref->u.ss.start)
3840 start = gfc_copy_expr (char_ref->u.ss.start);
3842 start = gfc_int_expr (1);
3844 if (char_ref->u.ss.end)
3845 end = gfc_copy_expr (char_ref->u.ss.end);
3846 else if (e->expr_type == EXPR_VARIABLE)
3847 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3854 /* Length = (end - start +1). */
3855 e->ts.cl->length = gfc_subtract (end, start);
3856 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3858 e->ts.cl->length->ts.type = BT_INTEGER;
3859 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3861 /* Make sure that the length is simplified. */
3862 gfc_simplify_expr (e->ts.cl->length, 1);
3863 gfc_resolve_expr (e->ts.cl->length);
3867 /* Resolve subtype references. */
3870 resolve_ref (gfc_expr *expr)
3872 int current_part_dimension, n_components, seen_part_dimension;
3875 for (ref = expr->ref; ref; ref = ref->next)
3876 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3878 find_array_spec (expr);
3882 for (ref = expr->ref; ref; ref = ref->next)
3886 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3894 resolve_substring (ref);
3898 /* Check constraints on part references. */
3900 current_part_dimension = 0;
3901 seen_part_dimension = 0;
3904 for (ref = expr->ref; ref; ref = ref->next)
3909 switch (ref->u.ar.type)
3913 current_part_dimension = 1;
3917 current_part_dimension = 0;
3921 gfc_internal_error ("resolve_ref(): Bad array reference");
3927 if (current_part_dimension || seen_part_dimension)
3929 if (ref->u.c.component->attr.pointer)
3931 gfc_error ("Component to the right of a part reference "
3932 "with nonzero rank must not have the POINTER "
3933 "attribute at %L", &expr->where);
3936 else if (ref->u.c.component->attr.allocatable)
3938 gfc_error ("Component to the right of a part reference "
3939 "with nonzero rank must not have the ALLOCATABLE "
3940 "attribute at %L", &expr->where);
3952 if (((ref->type == REF_COMPONENT && n_components > 1)
3953 || ref->next == NULL)
3954 && current_part_dimension
3955 && seen_part_dimension)
3957 gfc_error ("Two or more part references with nonzero rank must "
3958 "not be specified at %L", &expr->where);
3962 if (ref->type == REF_COMPONENT)
3964 if (current_part_dimension)
3965 seen_part_dimension = 1;
3967 /* reset to make sure */
3968 current_part_dimension = 0;
3976 /* Given an expression, determine its shape. This is easier than it sounds.
3977 Leaves the shape array NULL if it is not possible to determine the shape. */
3980 expression_shape (gfc_expr *e)
3982 mpz_t array[GFC_MAX_DIMENSIONS];
3985 if (e->rank == 0 || e->shape != NULL)
3988 for (i = 0; i < e->rank; i++)
3989 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3992 e->shape = gfc_get_shape (e->rank);
3994 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3999 for (i--; i >= 0; i--)
4000 mpz_clear (array[i]);
4004 /* Given a variable expression node, compute the rank of the expression by
4005 examining the base symbol and any reference structures it may have. */
4008 expression_rank (gfc_expr *e)
4015 if (e->expr_type == EXPR_ARRAY)
4017 /* Constructors can have a rank different from one via RESHAPE(). */
4019 if (e->symtree == NULL)
4025 e->rank = (e->symtree->n.sym->as == NULL)
4026 ? 0 : e->symtree->n.sym->as->rank;
4032 for (ref = e->ref; ref; ref = ref->next)
4034 if (ref->type != REF_ARRAY)
4037 if (ref->u.ar.type == AR_FULL)
4039 rank = ref->u.ar.as->rank;
4043 if (ref->u.ar.type == AR_SECTION)
4045 /* Figure out the rank of the section. */
4047 gfc_internal_error ("expression_rank(): Two array specs");
4049 for (i = 0; i < ref->u.ar.dimen; i++)
4050 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4051 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4061 expression_shape (e);
4065 /* Resolve a variable expression. */
4068 resolve_variable (gfc_expr *e)
4075 if (e->symtree == NULL)
4078 if (e->ref && resolve_ref (e) == FAILURE)
4081 sym = e->symtree->n.sym;
4082 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
4084 e->ts.type = BT_PROCEDURE;
4088 if (sym->ts.type != BT_UNKNOWN)
4089 gfc_variable_attr (e, &e->ts);
4092 /* Must be a simple variable reference. */
4093 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4098 if (check_assumed_size_reference (sym, e))
4101 /* Deal with forward references to entries during resolve_code, to
4102 satisfy, at least partially, 12.5.2.5. */
4103 if (gfc_current_ns->entries
4104 && current_entry_id == sym->entry_id
4107 && cs_base->current->op != EXEC_ENTRY)
4109 gfc_entry_list *entry;
4110 gfc_formal_arglist *formal;
4114 /* If the symbol is a dummy... */
4115 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4117 entry = gfc_current_ns->entries;
4120 /* ...test if the symbol is a parameter of previous entries. */
4121 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4122 for (formal = entry->sym->formal; formal; formal = formal->next)
4124 if (formal->sym && sym->name == formal->sym->name)
4128 /* If it has not been seen as a dummy, this is an error. */
4131 if (specification_expr)
4132 gfc_error ("Variable '%s', used in a specification expression"
4133 ", is referenced at %L before the ENTRY statement "
4134 "in which it is a parameter",
4135 sym->name, &cs_base->current->loc);
4137 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4138 "statement in which it is a parameter",
4139 sym->name, &cs_base->current->loc);
4144 /* Now do the same check on the specification expressions. */
4145 specification_expr = 1;
4146 if (sym->ts.type == BT_CHARACTER
4147 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
4151 for (n = 0; n < sym->as->rank; n++)
4153 specification_expr = 1;
4154 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4156 specification_expr = 1;
4157 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4160 specification_expr = 0;
4163 /* Update the symbol's entry level. */
4164 sym->entry_id = current_entry_id + 1;
4171 /* Checks to see that the correct symbol has been host associated.
4172 The only situation where this arises is that in which a twice
4173 contained function is parsed after the host association is made.
4174 Therefore, on detecting this, the line is rematched, having got
4175 rid of the existing references and actual_arg_list. */
4177 check_host_association (gfc_expr *e)
4179 gfc_symbol *sym, *old_sym;
4183 bool retval = e->expr_type == EXPR_FUNCTION;
4185 if (e->symtree == NULL || e->symtree->n.sym == NULL)
4188 old_sym = e->symtree->n.sym;
4190 if (old_sym->attr.use_assoc)
4193 if (gfc_current_ns->parent
4194 && old_sym->ns != gfc_current_ns)
4196 gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym);
4197 if (sym && old_sym != sym
4198 && sym->attr.flavor == FL_PROCEDURE
4199 && sym->attr.contained)
4201 temp_locus = gfc_current_locus;
4202 gfc_current_locus = e->where;
4204 gfc_buffer_error (1);
4206 gfc_free_ref_list (e->ref);
4211 gfc_free_actual_arglist (e->value.function.actual);
4212 e->value.function.actual = NULL;
4215 if (e->shape != NULL)
4217 for (n = 0; n < e->rank; n++)
4218 mpz_clear (e->shape[n]);
4220 gfc_free (e->shape);
4223 gfc_match_rvalue (&expr);
4225 gfc_buffer_error (0);
4227 gcc_assert (expr && sym == expr->symtree->n.sym);
4233 gfc_current_locus = temp_locus;
4236 /* This might have changed! */
4237 return e->expr_type == EXPR_FUNCTION;
4242 gfc_resolve_character_operator (gfc_expr *e)
4244 gfc_expr *op1 = e->value.op.op1;
4245 gfc_expr *op2 = e->value.op.op2;
4246 gfc_expr *e1 = NULL;
4247 gfc_expr *e2 = NULL;
4249 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
4251 if (op1->ts.cl && op1->ts.cl->length)
4252 e1 = gfc_copy_expr (op1->ts.cl->length);
4253 else if (op1->expr_type == EXPR_CONSTANT)
4254 e1 = gfc_int_expr (op1->value.character.length);
4256 if (op2->ts.cl && op2->ts.cl->length)
4257 e2 = gfc_copy_expr (op2->ts.cl->length);
4258 else if (op2->expr_type == EXPR_CONSTANT)
4259 e2 = gfc_int_expr (op2->value.character.length);
4261 e->ts.cl = gfc_get_charlen ();
4262 e->ts.cl->next = gfc_current_ns->cl_list;
4263 gfc_current_ns->cl_list = e->ts.cl;
4268 e->ts.cl->length = gfc_add (e1, e2);
4269 e->ts.cl->length->ts.type = BT_INTEGER;
4270 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4271 gfc_simplify_expr (e->ts.cl->length, 0);
4272 gfc_resolve_expr (e->ts.cl->length);
4278 /* Ensure that an character expression has a charlen and, if possible, a
4279 length expression. */
4282 fixup_charlen (gfc_expr *e)
4284 /* The cases fall through so that changes in expression type and the need
4285 for multiple fixes are picked up. In all circumstances, a charlen should
4286 be available for the middle end to hang a backend_decl on. */
4287 switch (e->expr_type)
4290 gfc_resolve_character_operator (e);
4293 if (e->expr_type == EXPR_ARRAY)
4294 gfc_resolve_character_array_constructor (e);
4296 case EXPR_SUBSTRING:
4297 if (!e->ts.cl && e->ref)
4298 gfc_resolve_substring_charlen (e);
4303 e->ts.cl = gfc_get_charlen ();
4304 e->ts.cl->next = gfc_current_ns->cl_list;
4305 gfc_current_ns->cl_list = e->ts.cl;
4313 /* Update an actual argument to include the passed-object for type-bound
4314 procedures at the right position. */
4316 static gfc_actual_arglist*
4317 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
4321 gfc_actual_arglist* result;
4323 result = gfc_get_actual_arglist ();
4331 gcc_assert (argpos > 1);
4333 lst->next = update_arglist_pass (lst->next, po, argpos - 1);
4338 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4341 extract_compcall_passed_object (gfc_expr* e)
4345 gcc_assert (e->expr_type == EXPR_COMPCALL);
4347 po = gfc_get_expr ();
4348 po->expr_type = EXPR_VARIABLE;
4349 po->symtree = e->symtree;
4350 po->ref = gfc_copy_ref (e->ref);
4352 if (gfc_resolve_expr (po) == FAILURE)
4359 /* Update the arglist of an EXPR_COMPCALL expression to include the
4363 update_compcall_arglist (gfc_expr* e)
4366 gfc_typebound_proc* tbp;
4368 tbp = e->value.compcall.tbp;
4370 po = extract_compcall_passed_object (e);
4376 gfc_error ("Passed-object at %L must be scalar", &e->where);
4386 gcc_assert (tbp->pass_arg_num > 0);
4387 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4394 /* Resolve a call to a type-bound procedure, either function or subroutine,
4395 statically from the data in an EXPR_COMPCALL expression. The adapted
4396 arglist and the target-procedure symtree are returned. */
4399 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
4400 gfc_actual_arglist** actual)
4402 gcc_assert (e->expr_type == EXPR_COMPCALL);
4403 gcc_assert (!e->value.compcall.tbp->is_generic);
4405 /* Update the actual arglist for PASS. */
4406 if (update_compcall_arglist (e) == FAILURE)
4409 *actual = e->value.compcall.actual;
4410 *target = e->value.compcall.tbp->u.specific;
4412 gfc_free_ref_list (e->ref);
4414 e->value.compcall.actual = NULL;
4420 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4421 which of the specific bindings (if any) matches the arglist and transform
4422 the expression into a call of that binding. */
4425 resolve_typebound_generic_call (gfc_expr* e)
4427 gfc_typebound_proc* genproc;
4428 const char* genname;
4430 gcc_assert (e->expr_type == EXPR_COMPCALL);
4431 genname = e->value.compcall.name;
4432 genproc = e->value.compcall.tbp;
4434 if (!genproc->is_generic)
4437 /* Try the bindings on this type and in the inheritance hierarchy. */
4438 for (; genproc; genproc = genproc->overridden)
4442 gcc_assert (genproc->is_generic);
4443 for (g = genproc->u.generic; g; g = g->next)
4446 gfc_actual_arglist* args;
4449 gcc_assert (g->specific);
4450 target = g->specific->u.specific->n.sym;
4452 /* Get the right arglist by handling PASS/NOPASS. */
4453 args = gfc_copy_actual_arglist (e->value.compcall.actual);
4454 if (!g->specific->nopass)
4457 po = extract_compcall_passed_object (e);
4461 args = update_arglist_pass (args, po, g->specific->pass_arg_num);
4464 /* Check if this arglist matches the formal. */
4465 matches = gfc_compare_actual_formal (&args, target->formal, 1,
4466 target->attr.elemental, NULL);
4468 /* Clean up and break out of the loop if we've found it. */
4469 gfc_free_actual_arglist (args);
4472 e->value.compcall.tbp = g->specific;
4478 /* Nothing matching found! */
4479 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4480 " '%s' at %L", genname, &e->where);
4488 /* Resolve a call to a type-bound subroutine. */
4491 resolve_typebound_call (gfc_code* c)
4493 gfc_actual_arglist* newactual;
4494 gfc_symtree* target;
4496 /* Check that's really a SUBROUTINE. */
4497 if (!c->expr->value.compcall.tbp->subroutine)
4499 gfc_error ("'%s' at %L should be a SUBROUTINE",
4500 c->expr->value.compcall.name, &c->loc);
4504 if (resolve_typebound_generic_call (c->expr) == FAILURE)
4507 /* Transform into an ordinary EXEC_CALL for now. */
4509 if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
4512 c->ext.actual = newactual;
4513 c->symtree = target;
4516 gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
4517 gfc_free_expr (c->expr);
4520 return resolve_call (c);
4524 /* Resolve a component-call expression. */
4527 resolve_compcall (gfc_expr* e)
4529 gfc_actual_arglist* newactual;
4530 gfc_symtree* target;
4532 /* Check that's really a FUNCTION. */
4533 if (!e->value.compcall.tbp->function)
4535 gfc_error ("'%s' at %L should be a FUNCTION",
4536 e->value.compcall.name, &e->where);
4540 if (resolve_typebound_generic_call (e) == FAILURE)
4543 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4544 arglist to the TBP's binding target. */
4546 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
4549 e->value.function.actual = newactual;
4550 e->value.function.name = e->value.compcall.name;
4551 e->value.function.isym = NULL;
4552 e->value.function.esym = NULL;
4553 e->symtree = target;
4554 e->expr_type = EXPR_FUNCTION;
4556 return gfc_resolve_expr (e);
4560 /* Resolve an expression. That is, make sure that types of operands agree
4561 with their operators, intrinsic operators are converted to function calls
4562 for overloaded types and unresolved function references are resolved. */
4565 gfc_resolve_expr (gfc_expr *e)
4572 switch (e->expr_type)
4575 t = resolve_operator (e);
4581 if (check_host_association (e))
4582 t = resolve_function (e);
4585 t = resolve_variable (e);
4587 expression_rank (e);
4590 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4591 && e->ref->type != REF_SUBSTRING)
4592 gfc_resolve_substring_charlen (e);
4597 t = resolve_compcall (e);
4600 case EXPR_SUBSTRING:
4601 t = resolve_ref (e);
4611 if (resolve_ref (e) == FAILURE)
4614 t = gfc_resolve_array_constructor (e);
4615 /* Also try to expand a constructor. */
4618 expression_rank (e);
4619 gfc_expand_constructor (e);
4622 /* This provides the opportunity for the length of constructors with
4623 character valued function elements to propagate the string length
4624 to the expression. */
4625 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
4626 t = gfc_resolve_character_array_constructor (e);
4630 case EXPR_STRUCTURE:
4631 t = resolve_ref (e);
4635 t = resolve_structure_cons (e);
4639 t = gfc_simplify_expr (e, 0);
4643 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4646 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4653 /* Resolve an expression from an iterator. They must be scalar and have
4654 INTEGER or (optionally) REAL type. */
4657 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4658 const char *name_msgid)
4660 if (gfc_resolve_expr (expr) == FAILURE)
4663 if (expr->rank != 0)
4665 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4669 if (expr->ts.type != BT_INTEGER)
4671 if (expr->ts.type == BT_REAL)
4674 return gfc_notify_std (GFC_STD_F95_DEL,
4675 "Deleted feature: %s at %L must be integer",
4676 _(name_msgid), &expr->where);
4679 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4686 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4694 /* Resolve the expressions in an iterator structure. If REAL_OK is
4695 false allow only INTEGER type iterators, otherwise allow REAL types. */
4698 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4700 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4704 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4706 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4711 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4712 "Start expression in DO loop") == FAILURE)
4715 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4716 "End expression in DO loop") == FAILURE)
4719 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4720 "Step expression in DO loop") == FAILURE)
4723 if (iter->step->expr_type == EXPR_CONSTANT)
4725 if ((iter->step->ts.type == BT_INTEGER
4726 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4727 || (iter->step->ts.type == BT_REAL
4728 && mpfr_sgn (iter->step->value.real) == 0))
4730 gfc_error ("Step expression in DO loop at %L cannot be zero",
4731 &iter->step->where);
4736 /* Convert start, end, and step to the same type as var. */
4737 if (iter->start->ts.kind != iter->var->ts.kind
4738 || iter->start->ts.type != iter->var->ts.type)
4739 gfc_convert_type (iter->start, &iter->var->ts, 2);
4741 if (iter->end->ts.kind != iter->var->ts.kind
4742 || iter->end->ts.type != iter->var->ts.type)
4743 gfc_convert_type (iter->end, &iter->var->ts, 2);
4745 if (iter->step->ts.kind != iter->var->ts.kind
4746 || iter->step->ts.type != iter->var->ts.type)
4747 gfc_convert_type (iter->step, &iter->var->ts, 2);
4753 /* Traversal function for find_forall_index. f == 2 signals that
4754 that variable itself is not to be checked - only the references. */
4757 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
4759 if (expr->expr_type != EXPR_VARIABLE)
4762 /* A scalar assignment */
4763 if (!expr->ref || *f == 1)
4765 if (expr->symtree->n.sym == sym)
4777 /* Check whether the FORALL index appears in the expression or not.
4778 Returns SUCCESS if SYM is found in EXPR. */
4781 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
4783 if (gfc_traverse_expr (expr, sym, forall_index, f))
4790 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4791 to be a scalar INTEGER variable. The subscripts and stride are scalar
4792 INTEGERs, and if stride is a constant it must be nonzero.
4793 Furthermore "A subscript or stride in a forall-triplet-spec shall
4794 not contain a reference to any index-name in the
4795 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4798 resolve_forall_iterators (gfc_forall_iterator *it)
4800 gfc_forall_iterator *iter, *iter2;
4802 for (iter = it; iter; iter = iter->next)
4804 if (gfc_resolve_expr (iter->var) == SUCCESS
4805 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4806 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4809 if (gfc_resolve_expr (iter->start) == SUCCESS
4810 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4811 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4812 &iter->start->where);
4813 if (iter->var->ts.kind != iter->start->ts.kind)
4814 gfc_convert_type (iter->start, &iter->var->ts, 2);
4816 if (gfc_resolve_expr (iter->end) == SUCCESS
4817 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4818 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4820 if (iter->var->ts.kind != iter->end->ts.kind)
4821 gfc_convert_type (iter->end, &iter->var->ts, 2);
4823 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4825 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4826 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4827 &iter->stride->where, "INTEGER");
4829 if (iter->stride->expr_type == EXPR_CONSTANT
4830 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4831 gfc_error ("FORALL stride expression at %L cannot be zero",
4832 &iter->stride->where);
4834 if (iter->var->ts.kind != iter->stride->ts.kind)
4835 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4838 for (iter = it; iter; iter = iter->next)
4839 for (iter2 = iter; iter2; iter2 = iter2->next)
4841 if (find_forall_index (iter2->start,
4842 iter->var->symtree->n.sym, 0) == SUCCESS
4843 || find_forall_index (iter2->end,
4844 iter->var->symtree->n.sym, 0) == SUCCESS
4845 || find_forall_index (iter2->stride,
4846 iter->var->symtree->n.sym, 0) == SUCCESS)
4847 gfc_error ("FORALL index '%s' may not appear in triplet "
4848 "specification at %L", iter->var->symtree->name,
4849 &iter2->start->where);
4854 /* Given a pointer to a symbol that is a derived type, see if it's
4855 inaccessible, i.e. if it's defined in another module and the components are
4856 PRIVATE. The search is recursive if necessary. Returns zero if no
4857 inaccessible components are found, nonzero otherwise. */
4860 derived_inaccessible (gfc_symbol *sym)
4864 if (sym->attr.use_assoc && sym->attr.private_comp)
4867 for (c = sym->components; c; c = c->next)
4869 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4877 /* Resolve the argument of a deallocate expression. The expression must be
4878 a pointer or a full array. */
4881 resolve_deallocate_expr (gfc_expr *e)
4883 symbol_attribute attr;
4884 int allocatable, pointer, check_intent_in;
4887 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4888 check_intent_in = 1;
4890 if (gfc_resolve_expr (e) == FAILURE)
4893 if (e->expr_type != EXPR_VARIABLE)
4896 allocatable = e->symtree->n.sym->attr.allocatable;
4897 pointer = e->symtree->n.sym->attr.pointer;
4898 for (ref = e->ref; ref; ref = ref->next)
4901 check_intent_in = 0;
4906 if (ref->u.ar.type != AR_FULL)
4911 allocatable = (ref->u.c.component->as != NULL
4912 && ref->u.c.component->as->type == AS_DEFERRED);
4913 pointer = ref->u.c.component->attr.pointer;
4922 attr = gfc_expr_attr (e);
4924 if (allocatable == 0 && attr.pointer == 0)
4927 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4928 "ALLOCATABLE or a POINTER", &e->where);
4932 && e->symtree->n.sym->attr.intent == INTENT_IN)
4934 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4935 e->symtree->n.sym->name, &e->where);
4943 /* Returns true if the expression e contains a reference to the symbol sym. */
4945 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4947 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
4954 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4956 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
4960 /* Given the expression node e for an allocatable/pointer of derived type to be
4961 allocated, get the expression node to be initialized afterwards (needed for
4962 derived types with default initializers, and derived types with allocatable
4963 components that need nullification.) */
4966 expr_to_initialize (gfc_expr *e)
4972 result = gfc_copy_expr (e);
4974 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4975 for (ref = result->ref; ref; ref = ref->next)
4976 if (ref->type == REF_ARRAY && ref->next == NULL)
4978 ref->u.ar.type = AR_FULL;
4980 for (i = 0; i < ref->u.ar.dimen; i++)
4981 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4983 result->rank = ref->u.ar.dimen;
4991 /* Resolve the expression in an ALLOCATE statement, doing the additional
4992 checks to see whether the expression is OK or not. The expression must
4993 have a trailing array reference that gives the size of the array. */
4996 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4998 int i, pointer, allocatable, dimension, check_intent_in;
4999 symbol_attribute attr;
5000 gfc_ref *ref, *ref2;
5007 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5008 check_intent_in = 1;
5010 if (gfc_resolve_expr (e) == FAILURE)
5013 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
5014 sym = code->expr->symtree->n.sym;
5018 /* Make sure the expression is allocatable or a pointer. If it is
5019 pointer, the next-to-last reference must be a pointer. */
5023 if (e->expr_type != EXPR_VARIABLE)
5026 attr = gfc_expr_attr (e);
5027 pointer = attr.pointer;
5028 dimension = attr.dimension;
5032 allocatable = e->symtree->n.sym->attr.allocatable;
5033 pointer = e->symtree->n.sym->attr.pointer;
5034 dimension = e->symtree->n.sym->attr.dimension;
5036 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
5038 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
5039 "not be allocated in the same statement at %L",
5040 sym->name, &e->where);
5044 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
5047 check_intent_in = 0;
5052 if (ref->next != NULL)
5057 allocatable = (ref->u.c.component->as != NULL
5058 && ref->u.c.component->as->type == AS_DEFERRED);
5060 pointer = ref->u.c.component->attr.pointer;
5061 dimension = ref->u.c.component->attr.dimension;
5072 if (allocatable == 0 && pointer == 0)
5074 gfc_error ("Expression in ALLOCATE statement at %L must be "
5075 "ALLOCATABLE or a POINTER", &e->where);
5080 && e->symtree->n.sym->attr.intent == INTENT_IN)
5082 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5083 e->symtree->n.sym->name, &e->where);
5087 /* Add default initializer for those derived types that need them. */
5088 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
5090 init_st = gfc_get_code ();
5091 init_st->loc = code->loc;
5092 init_st->op = EXEC_INIT_ASSIGN;
5093 init_st->expr = expr_to_initialize (e);
5094 init_st->expr2 = init_e;
5095 init_st->next = code->next;
5096 code->next = init_st;
5099 if (pointer && dimension == 0)
5102 /* Make sure the next-to-last reference node is an array specification. */
5104 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
5106 gfc_error ("Array specification required in ALLOCATE statement "
5107 "at %L", &e->where);
5111 /* Make sure that the array section reference makes sense in the
5112 context of an ALLOCATE specification. */
5116 for (i = 0; i < ar->dimen; i++)
5118 if (ref2->u.ar.type == AR_ELEMENT)
5121 switch (ar->dimen_type[i])
5127 if (ar->start[i] != NULL
5128 && ar->end[i] != NULL
5129 && ar->stride[i] == NULL)
5132 /* Fall Through... */
5136 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5143 for (a = code->ext.alloc_list; a; a = a->next)
5145 sym = a->expr->symtree->n.sym;
5147 /* TODO - check derived type components. */
5148 if (sym->ts.type == BT_DERIVED)
5151 if ((ar->start[i] != NULL
5152 && gfc_find_sym_in_expr (sym, ar->start[i]))
5153 || (ar->end[i] != NULL
5154 && gfc_find_sym_in_expr (sym, ar->end[i])))
5156 gfc_error ("'%s' must not appear in the array specification at "
5157 "%L in the same ALLOCATE statement where it is "
5158 "itself allocated", sym->name, &ar->where);
5168 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
5170 gfc_symbol *s = NULL;
5174 s = code->expr->symtree->n.sym;
5178 if (s->attr.intent == INTENT_IN)
5179 gfc_error ("STAT variable '%s' of %s statement at %C cannot "
5180 "be INTENT(IN)", s->name, fcn);
5182 if (gfc_pure (NULL) && gfc_impure_variable (s))
5183 gfc_error ("Illegal STAT variable in %s statement at %C "
5184 "for a PURE procedure", fcn);
5187 if (s && code->expr->ts.type != BT_INTEGER)
5188 gfc_error ("STAT tag in %s statement at %L must be "
5189 "of type INTEGER", fcn, &code->expr->where);
5191 if (strcmp (fcn, "ALLOCATE") == 0)
5193 for (a = code->ext.alloc_list; a; a = a->next)
5194 resolve_allocate_expr (a->expr, code);
5198 for (a = code->ext.alloc_list; a; a = a->next)
5199 resolve_deallocate_expr (a->expr);
5203 /************ SELECT CASE resolution subroutines ************/
5205 /* Callback function for our mergesort variant. Determines interval
5206 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5207 op1 > op2. Assumes we're not dealing with the default case.
5208 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5209 There are nine situations to check. */
5212 compare_cases (const gfc_case *op1, const gfc_case *op2)
5216 if (op1->low == NULL) /* op1 = (:L) */
5218 /* op2 = (:N), so overlap. */
5220 /* op2 = (M:) or (M:N), L < M */
5221 if (op2->low != NULL
5222 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5225 else if (op1->high == NULL) /* op1 = (K:) */
5227 /* op2 = (M:), so overlap. */
5229 /* op2 = (:N) or (M:N), K > N */
5230 if (op2->high != NULL
5231 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5234 else /* op1 = (K:L) */
5236 if (op2->low == NULL) /* op2 = (:N), K > N */
5237 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5239 else if (op2->high == NULL) /* op2 = (M:), L < M */
5240 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5242 else /* op2 = (M:N) */
5246 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5249 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5258 /* Merge-sort a double linked case list, detecting overlap in the
5259 process. LIST is the head of the double linked case list before it
5260 is sorted. Returns the head of the sorted list if we don't see any
5261 overlap, or NULL otherwise. */
5264 check_case_overlap (gfc_case *list)
5266 gfc_case *p, *q, *e, *tail;
5267 int insize, nmerges, psize, qsize, cmp, overlap_seen;
5269 /* If the passed list was empty, return immediately. */
5276 /* Loop unconditionally. The only exit from this loop is a return
5277 statement, when we've finished sorting the case list. */
5284 /* Count the number of merges we do in this pass. */
5287 /* Loop while there exists a merge to be done. */
5292 /* Count this merge. */
5295 /* Cut the list in two pieces by stepping INSIZE places
5296 forward in the list, starting from P. */
5299 for (i = 0; i < insize; i++)
5308 /* Now we have two lists. Merge them! */
5309 while (psize > 0 || (qsize > 0 && q != NULL))
5311 /* See from which the next case to merge comes from. */
5314 /* P is empty so the next case must come from Q. */
5319 else if (qsize == 0 || q == NULL)
5328 cmp = compare_cases (p, q);
5331 /* The whole case range for P is less than the
5339 /* The whole case range for Q is greater than
5340 the case range for P. */
5347 /* The cases overlap, or they are the same
5348 element in the list. Either way, we must
5349 issue an error and get the next case from P. */
5350 /* FIXME: Sort P and Q by line number. */
5351 gfc_error ("CASE label at %L overlaps with CASE "
5352 "label at %L", &p->where, &q->where);
5360 /* Add the next element to the merged list. */
5369 /* P has now stepped INSIZE places along, and so has Q. So
5370 they're the same. */
5375 /* If we have done only one merge or none at all, we've
5376 finished sorting the cases. */
5385 /* Otherwise repeat, merging lists twice the size. */
5391 /* Check to see if an expression is suitable for use in a CASE statement.
5392 Makes sure that all case expressions are scalar constants of the same
5393 type. Return FAILURE if anything is wrong. */
5396 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5398 if (e == NULL) return SUCCESS;
5400 if (e->ts.type != case_expr->ts.type)
5402 gfc_error ("Expression in CASE statement at %L must be of type %s",
5403 &e->where, gfc_basic_typename (case_expr->ts.type));
5407 /* C805 (R808) For a given case-construct, each case-value shall be of
5408 the same type as case-expr. For character type, length differences
5409 are allowed, but the kind type parameters shall be the same. */
5411 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5413 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5414 &e->where, case_expr->ts.kind);
5418 /* Convert the case value kind to that of case expression kind, if needed.
5419 FIXME: Should a warning be issued? */
5420 if (e->ts.kind != case_expr->ts.kind)
5421 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5425 gfc_error ("Expression in CASE statement at %L must be scalar",
5434 /* Given a completely parsed select statement, we:
5436 - Validate all expressions and code within the SELECT.
5437 - Make sure that the selection expression is not of the wrong type.
5438 - Make sure that no case ranges overlap.
5439 - Eliminate unreachable cases and unreachable code resulting from
5440 removing case labels.
5442 The standard does allow unreachable cases, e.g. CASE (5:3). But
5443 they are a hassle for code generation, and to prevent that, we just
5444 cut them out here. This is not necessary for overlapping cases
5445 because they are illegal and we never even try to generate code.
5447 We have the additional caveat that a SELECT construct could have
5448 been a computed GOTO in the source code. Fortunately we can fairly
5449 easily work around that here: The case_expr for a "real" SELECT CASE
5450 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5451 we have to do is make sure that the case_expr is a scalar integer
5455 resolve_select (gfc_code *code)
5458 gfc_expr *case_expr;
5459 gfc_case *cp, *default_case, *tail, *head;
5460 int seen_unreachable;
5466 if (code->expr == NULL)
5468 /* This was actually a computed GOTO statement. */
5469 case_expr = code->expr2;
5470 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5471 gfc_error ("Selection expression in computed GOTO statement "
5472 "at %L must be a scalar integer expression",
5475 /* Further checking is not necessary because this SELECT was built
5476 by the compiler, so it should always be OK. Just move the
5477 case_expr from expr2 to expr so that we can handle computed
5478 GOTOs as normal SELECTs from here on. */
5479 code->expr = code->expr2;
5484 case_expr = code->expr;
5486 type = case_expr->ts.type;
5487 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5489 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5490 &case_expr->where, gfc_typename (&case_expr->ts));
5492 /* Punt. Going on here just produce more garbage error messages. */
5496 if (case_expr->rank != 0)
5498 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5499 "expression", &case_expr->where);
5505 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5506 of the SELECT CASE expression and its CASE values. Walk the lists
5507 of case values, and if we find a mismatch, promote case_expr to
5508 the appropriate kind. */
5510 if (type == BT_LOGICAL || type == BT_INTEGER)
5512 for (body = code->block; body; body = body->block)
5514 /* Walk the case label list. */
5515 for (cp = body->ext.case_list; cp; cp = cp->next)
5517 /* Intercept the DEFAULT case. It does not have a kind. */
5518 if (cp->low == NULL && cp->high == NULL)
5521 /* Unreachable case ranges are discarded, so ignore. */
5522 if (cp->low != NULL && cp->high != NULL
5523 && cp->low != cp->high
5524 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5527 /* FIXME: Should a warning be issued? */
5529 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5530 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5532 if (cp->high != NULL
5533 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5534 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5539 /* Assume there is no DEFAULT case. */
5540 default_case = NULL;
5545 for (body = code->block; body; body = body->block)
5547 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5549 seen_unreachable = 0;
5551 /* Walk the case label list, making sure that all case labels
5553 for (cp = body->ext.case_list; cp; cp = cp->next)
5555 /* Count the number of cases in the whole construct. */
5558 /* Intercept the DEFAULT case. */
5559 if (cp->low == NULL && cp->high == NULL)
5561 if (default_case != NULL)
5563 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5564 "by a second DEFAULT CASE at %L",
5565 &default_case->where, &cp->where);
5576 /* Deal with single value cases and case ranges. Errors are
5577 issued from the validation function. */
5578 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5579 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5585 if (type == BT_LOGICAL
5586 && ((cp->low == NULL || cp->high == NULL)
5587 || cp->low != cp->high))
5589 gfc_error ("Logical range in CASE statement at %L is not "
5590 "allowed", &cp->low->where);
5595 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5598 value = cp->low->value.logical == 0 ? 2 : 1;
5599 if (value & seen_logical)
5601 gfc_error ("constant logical value in CASE statement "
5602 "is repeated at %L",
5607 seen_logical |= value;
5610 if (cp->low != NULL && cp->high != NULL
5611 && cp->low != cp->high
5612 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5614 if (gfc_option.warn_surprising)
5615 gfc_warning ("Range specification at %L can never "
5616 "be matched", &cp->where);
5618 cp->unreachable = 1;
5619 seen_unreachable = 1;
5623 /* If the case range can be matched, it can also overlap with
5624 other cases. To make sure it does not, we put it in a
5625 double linked list here. We sort that with a merge sort
5626 later on to detect any overlapping cases. */
5630 head->right = head->left = NULL;
5635 tail->right->left = tail;
5642 /* It there was a failure in the previous case label, give up
5643 for this case label list. Continue with the next block. */
5647 /* See if any case labels that are unreachable have been seen.
5648 If so, we eliminate them. This is a bit of a kludge because
5649 the case lists for a single case statement (label) is a
5650 single forward linked lists. */
5651 if (seen_unreachable)
5653 /* Advance until the first case in the list is reachable. */
5654 while (body->ext.case_list != NULL
5655 && body->ext.case_list->unreachable)
5657 gfc_case *n = body->ext.case_list;
5658 body->ext.case_list = body->ext.case_list->next;
5660 gfc_free_case_list (n);
5663 /* Strip all other unreachable cases. */
5664 if (body->ext.case_list)
5666 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5668 if (cp->next->unreachable)
5670 gfc_case *n = cp->next;
5671 cp->next = cp->next->next;
5673 gfc_free_case_list (n);
5680 /* See if there were overlapping cases. If the check returns NULL,
5681 there was overlap. In that case we don't do anything. If head
5682 is non-NULL, we prepend the DEFAULT case. The sorted list can
5683 then used during code generation for SELECT CASE constructs with
5684 a case expression of a CHARACTER type. */
5687 head = check_case_overlap (head);
5689 /* Prepend the default_case if it is there. */
5690 if (head != NULL && default_case)
5692 default_case->left = NULL;
5693 default_case->right = head;
5694 head->left = default_case;
5698 /* Eliminate dead blocks that may be the result if we've seen
5699 unreachable case labels for a block. */
5700 for (body = code; body && body->block; body = body->block)
5702 if (body->block->ext.case_list == NULL)
5704 /* Cut the unreachable block from the code chain. */
5705 gfc_code *c = body->block;
5706 body->block = c->block;
5708 /* Kill the dead block, but not the blocks below it. */
5710 gfc_free_statements (c);
5714 /* More than two cases is legal but insane for logical selects.
5715 Issue a warning for it. */
5716 if (gfc_option.warn_surprising && type == BT_LOGICAL
5718 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5723 /* Resolve a transfer statement. This is making sure that:
5724 -- a derived type being transferred has only non-pointer components
5725 -- a derived type being transferred doesn't have private components, unless
5726 it's being transferred from the module where the type was defined
5727 -- we're not trying to transfer a whole assumed size array. */
5730 resolve_transfer (gfc_code *code)
5739 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5742 sym = exp->symtree->n.sym;
5745 /* Go to actual component transferred. */
5746 for (ref = code->expr->ref; ref; ref = ref->next)
5747 if (ref->type == REF_COMPONENT)
5748 ts = &ref->u.c.component->ts;
5750 if (ts->type == BT_DERIVED)
5752 /* Check that transferred derived type doesn't contain POINTER
5754 if (ts->derived->attr.pointer_comp)
5756 gfc_error ("Data transfer element at %L cannot have "
5757 "POINTER components", &code->loc);
5761 if (ts->derived->attr.alloc_comp)
5763 gfc_error ("Data transfer element at %L cannot have "
5764 "ALLOCATABLE components", &code->loc);
5768 if (derived_inaccessible (ts->derived))
5770 gfc_error ("Data transfer element at %L cannot have "
5771 "PRIVATE components",&code->loc);
5776 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5777 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5779 gfc_error ("Data transfer element at %L cannot be a full reference to "
5780 "an assumed-size array", &code->loc);
5786 /*********** Toplevel code resolution subroutines ***********/
5788 /* Find the set of labels that are reachable from this block. We also
5789 record the last statement in each block so that we don't have to do
5790 a linear search to find the END DO statements of the blocks. */
5793 reachable_labels (gfc_code *block)
5800 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5802 /* Collect labels in this block. */
5803 for (c = block; c; c = c->next)
5806 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5808 if (!c->next && cs_base->prev)
5809 cs_base->prev->tail = c;
5812 /* Merge with labels from parent block. */
5815 gcc_assert (cs_base->prev->reachable_labels);
5816 bitmap_ior_into (cs_base->reachable_labels,
5817 cs_base->prev->reachable_labels);
5821 /* Given a branch to a label and a namespace, if the branch is conforming.
5822 The code node describes where the branch is located. */
5825 resolve_branch (gfc_st_label *label, gfc_code *code)
5832 /* Step one: is this a valid branching target? */
5834 if (label->defined == ST_LABEL_UNKNOWN)
5836 gfc_error ("Label %d referenced at %L is never defined", label->value,
5841 if (label->defined != ST_LABEL_TARGET)
5843 gfc_error ("Statement at %L is not a valid branch target statement "
5844 "for the branch statement at %L", &label->where, &code->loc);
5848 /* Step two: make sure this branch is not a branch to itself ;-) */
5850 if (code->here == label)
5852 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
5856 /* Step three: See if the label is in the same block as the
5857 branching statement. The hard work has been done by setting up
5858 the bitmap reachable_labels. */
5860 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5862 /* The label is not in an enclosing block, so illegal. This was
5863 allowed in Fortran 66, so we allow it as extension. No
5864 further checks are necessary in this case. */
5865 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5866 "as the GOTO statement at %L", &label->where,
5871 /* Step four: Make sure that the branching target is legal if
5872 the statement is an END {SELECT,IF}. */
5874 for (stack = cs_base; stack; stack = stack->prev)
5875 if (stack->current->next && stack->current->next->here == label)
5878 if (stack && stack->current->next->op == EXEC_NOP)
5880 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5881 "END of construct at %L", &code->loc,
5882 &stack->current->next->loc);
5883 return; /* We know this is not an END DO. */
5886 /* Step five: Make sure that we're not jumping to the end of a DO
5887 loop from within the loop. */
5889 for (stack = cs_base; stack; stack = stack->prev)
5890 if ((stack->current->op == EXEC_DO
5891 || stack->current->op == EXEC_DO_WHILE)
5892 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5894 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5895 "to END of construct at %L", &code->loc,
5903 /* Check whether EXPR1 has the same shape as EXPR2. */
5906 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5908 mpz_t shape[GFC_MAX_DIMENSIONS];
5909 mpz_t shape2[GFC_MAX_DIMENSIONS];
5910 gfc_try result = FAILURE;
5913 /* Compare the rank. */
5914 if (expr1->rank != expr2->rank)
5917 /* Compare the size of each dimension. */
5918 for (i=0; i<expr1->rank; i++)
5920 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5923 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5926 if (mpz_cmp (shape[i], shape2[i]))
5930 /* When either of the two expression is an assumed size array, we
5931 ignore the comparison of dimension sizes. */
5936 for (i--; i >= 0; i--)
5938 mpz_clear (shape[i]);
5939 mpz_clear (shape2[i]);
5945 /* Check whether a WHERE assignment target or a WHERE mask expression
5946 has the same shape as the outmost WHERE mask expression. */
5949 resolve_where (gfc_code *code, gfc_expr *mask)
5955 cblock = code->block;
5957 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5958 In case of nested WHERE, only the outmost one is stored. */
5959 if (mask == NULL) /* outmost WHERE */
5961 else /* inner WHERE */
5968 /* Check if the mask-expr has a consistent shape with the
5969 outmost WHERE mask-expr. */
5970 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5971 gfc_error ("WHERE mask at %L has inconsistent shape",
5972 &cblock->expr->where);
5975 /* the assignment statement of a WHERE statement, or the first
5976 statement in where-body-construct of a WHERE construct */
5977 cnext = cblock->next;
5982 /* WHERE assignment statement */
5985 /* Check shape consistent for WHERE assignment target. */
5986 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5987 gfc_error ("WHERE assignment target at %L has "
5988 "inconsistent shape", &cnext->expr->where);
5992 case EXEC_ASSIGN_CALL:
5993 resolve_call (cnext);
5994 if (!cnext->resolved_sym->attr.elemental)
5995 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
5996 &cnext->ext.actual->expr->where);
5999 /* WHERE or WHERE construct is part of a where-body-construct */
6001 resolve_where (cnext, e);
6005 gfc_error ("Unsupported statement inside WHERE at %L",
6008 /* the next statement within the same where-body-construct */
6009 cnext = cnext->next;
6011 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6012 cblock = cblock->block;
6017 /* Resolve assignment in FORALL construct.
6018 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6019 FORALL index variables. */
6022 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
6026 for (n = 0; n < nvar; n++)
6028 gfc_symbol *forall_index;
6030 forall_index = var_expr[n]->symtree->n.sym;
6032 /* Check whether the assignment target is one of the FORALL index
6034 if ((code->expr->expr_type == EXPR_VARIABLE)
6035 && (code->expr->symtree->n.sym == forall_index))
6036 gfc_error ("Assignment to a FORALL index variable at %L",
6037 &code->expr->where);
6040 /* If one of the FORALL index variables doesn't appear in the
6041 assignment target, then there will be a many-to-one
6043 if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
6044 gfc_error ("The FORALL with index '%s' cause more than one "
6045 "assignment to this object at %L",
6046 var_expr[n]->symtree->name, &code->expr->where);
6052 /* Resolve WHERE statement in FORALL construct. */
6055 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
6056 gfc_expr **var_expr)
6061 cblock = code->block;
6064 /* the assignment statement of a WHERE statement, or the first
6065 statement in where-body-construct of a WHERE construct */
6066 cnext = cblock->next;
6071 /* WHERE assignment statement */
6073 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
6076 /* WHERE operator assignment statement */
6077 case EXEC_ASSIGN_CALL:
6078 resolve_call (cnext);
6079 if (!cnext->resolved_sym->attr.elemental)
6080 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6081 &cnext->ext.actual->expr->where);
6084 /* WHERE or WHERE construct is part of a where-body-construct */
6086 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
6090 gfc_error ("Unsupported statement inside WHERE at %L",
6093 /* the next statement within the same where-body-construct */
6094 cnext = cnext->next;
6096 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6097 cblock = cblock->block;
6102 /* Traverse the FORALL body to check whether the following errors exist:
6103 1. For assignment, check if a many-to-one assignment happens.
6104 2. For WHERE statement, check the WHERE body to see if there is any
6105 many-to-one assignment. */
6108 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
6112 c = code->block->next;
6118 case EXEC_POINTER_ASSIGN:
6119 gfc_resolve_assign_in_forall (c, nvar, var_expr);
6122 case EXEC_ASSIGN_CALL:
6126 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6127 there is no need to handle it here. */
6131 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
6136 /* The next statement in the FORALL body. */
6142 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6143 gfc_resolve_forall_body to resolve the FORALL body. */
6146 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
6148 static gfc_expr **var_expr;
6149 static int total_var = 0;
6150 static int nvar = 0;
6151 gfc_forall_iterator *fa;
6155 /* Start to resolve a FORALL construct */
6156 if (forall_save == 0)
6158 /* Count the total number of FORALL index in the nested FORALL
6159 construct in order to allocate the VAR_EXPR with proper size. */
6161 while ((next != NULL) && (next->op == EXEC_FORALL))
6163 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
6165 next = next->block->next;
6168 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6169 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
6172 /* The information about FORALL iterator, including FORALL index start, end
6173 and stride. The FORALL index can not appear in start, end or stride. */
6174 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6176 /* Check if any outer FORALL index name is the same as the current
6178 for (i = 0; i < nvar; i++)
6180 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
6182 gfc_error ("An outer FORALL construct already has an index "
6183 "with this name %L", &fa->var->where);
6187 /* Record the current FORALL index. */
6188 var_expr[nvar] = gfc_copy_expr (fa->var);
6193 /* Resolve the FORALL body. */
6194 gfc_resolve_forall_body (code, nvar, var_expr);
6196 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6197 gfc_resolve_blocks (code->block, ns);
6199 /* Free VAR_EXPR after the whole FORALL construct resolved. */
6200 for (i = 0; i < total_var; i++)
6201 gfc_free_expr (var_expr[i]);
6203 /* Reset the counters. */
6209 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6212 static void resolve_code (gfc_code *, gfc_namespace *);
6215 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
6219 for (; b; b = b->block)
6221 t = gfc_resolve_expr (b->expr);
6222 if (gfc_resolve_expr (b->expr2) == FAILURE)
6228 if (t == SUCCESS && b->expr != NULL
6229 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
6230 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6237 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
6238 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6243 resolve_branch (b->label, b);
6256 case EXEC_OMP_ATOMIC:
6257 case EXEC_OMP_CRITICAL:
6259 case EXEC_OMP_MASTER:
6260 case EXEC_OMP_ORDERED:
6261 case EXEC_OMP_PARALLEL:
6262 case EXEC_OMP_PARALLEL_DO:
6263 case EXEC_OMP_PARALLEL_SECTIONS:
6264 case EXEC_OMP_PARALLEL_WORKSHARE:
6265 case EXEC_OMP_SECTIONS:
6266 case EXEC_OMP_SINGLE:
6268 case EXEC_OMP_TASKWAIT:
6269 case EXEC_OMP_WORKSHARE:
6273 gfc_internal_error ("resolve_block(): Bad block type");
6276 resolve_code (b->next, ns);
6281 /* Does everything to resolve an ordinary assignment. Returns true
6282 if this is an interface assignment. */
6284 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
6294 if (gfc_extend_assign (code, ns) == SUCCESS)
6296 lhs = code->ext.actual->expr;
6297 rhs = code->ext.actual->next->expr;
6298 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6300 gfc_error ("Subroutine '%s' called instead of assignment at "
6301 "%L must be PURE", code->symtree->n.sym->name,
6306 /* Make a temporary rhs when there is a default initializer
6307 and rhs is the same symbol as the lhs. */
6308 if (rhs->expr_type == EXPR_VARIABLE
6309 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6310 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6311 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6312 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6321 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
6322 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6323 &code->loc) == FAILURE)
6326 /* Handle the case of a BOZ literal on the RHS. */
6327 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
6330 if (gfc_option.warn_surprising)
6331 gfc_warning ("BOZ literal at %L is bitwise transferred "
6332 "non-integer symbol '%s'", &code->loc,
6333 lhs->symtree->n.sym->name);
6335 if (!gfc_convert_boz (rhs, &lhs->ts))
6337 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
6339 if (rc == ARITH_UNDERFLOW)
6340 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6341 ". This check can be disabled with the option "
6342 "-fno-range-check", &rhs->where);
6343 else if (rc == ARITH_OVERFLOW)
6344 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6345 ". This check can be disabled with the option "
6346 "-fno-range-check", &rhs->where);
6347 else if (rc == ARITH_NAN)
6348 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6349 ". This check can be disabled with the option "
6350 "-fno-range-check", &rhs->where);
6356 if (lhs->ts.type == BT_CHARACTER
6357 && gfc_option.warn_character_truncation)
6359 if (lhs->ts.cl != NULL
6360 && lhs->ts.cl->length != NULL
6361 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6362 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
6364 if (rhs->expr_type == EXPR_CONSTANT)
6365 rlen = rhs->value.character.length;
6367 else if (rhs->ts.cl != NULL
6368 && rhs->ts.cl->length != NULL
6369 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6370 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
6372 if (rlen && llen && rlen > llen)
6373 gfc_warning_now ("CHARACTER expression will be truncated "
6374 "in assignment (%d/%d) at %L",
6375 llen, rlen, &code->loc);
6378 /* Ensure that a vector index expression for the lvalue is evaluated
6379 to a temporary if the lvalue symbol is referenced in it. */
6382 for (ref = lhs->ref; ref; ref= ref->next)
6383 if (ref->type == REF_ARRAY)
6385 for (n = 0; n < ref->u.ar.dimen; n++)
6386 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
6387 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
6388 ref->u.ar.start[n]))
6390 = gfc_get_parentheses (ref->u.ar.start[n]);
6394 if (gfc_pure (NULL))
6396 if (gfc_impure_variable (lhs->symtree->n.sym))
6398 gfc_error ("Cannot assign to variable '%s' in PURE "
6400 lhs->symtree->n.sym->name,
6405 if (lhs->ts.type == BT_DERIVED
6406 && lhs->expr_type == EXPR_VARIABLE
6407 && lhs->ts.derived->attr.pointer_comp
6408 && gfc_impure_variable (rhs->symtree->n.sym))
6410 gfc_error ("The impure variable at %L is assigned to "
6411 "a derived type variable with a POINTER "
6412 "component in a PURE procedure (12.6)",
6418 gfc_check_assign (lhs, rhs, 1);
6422 /* Given a block of code, recursively resolve everything pointed to by this
6426 resolve_code (gfc_code *code, gfc_namespace *ns)
6428 int omp_workshare_save;
6433 frame.prev = cs_base;
6437 reachable_labels (code);
6439 for (; code; code = code->next)
6441 frame.current = code;
6442 forall_save = forall_flag;
6444 if (code->op == EXEC_FORALL)
6447 gfc_resolve_forall (code, ns, forall_save);
6450 else if (code->block)
6452 omp_workshare_save = -1;
6455 case EXEC_OMP_PARALLEL_WORKSHARE:
6456 omp_workshare_save = omp_workshare_flag;
6457 omp_workshare_flag = 1;
6458 gfc_resolve_omp_parallel_blocks (code, ns);
6460 case EXEC_OMP_PARALLEL:
6461 case EXEC_OMP_PARALLEL_DO:
6462 case EXEC_OMP_PARALLEL_SECTIONS:
6464 omp_workshare_save = omp_workshare_flag;
6465 omp_workshare_flag = 0;
6466 gfc_resolve_omp_parallel_blocks (code, ns);
6469 gfc_resolve_omp_do_blocks (code, ns);
6471 case EXEC_OMP_WORKSHARE:
6472 omp_workshare_save = omp_workshare_flag;
6473 omp_workshare_flag = 1;
6476 gfc_resolve_blocks (code->block, ns);
6480 if (omp_workshare_save != -1)
6481 omp_workshare_flag = omp_workshare_save;
6485 if (code->op != EXEC_COMPCALL)
6486 t = gfc_resolve_expr (code->expr);
6487 forall_flag = forall_save;
6489 if (gfc_resolve_expr (code->expr2) == FAILURE)
6504 /* Keep track of which entry we are up to. */
6505 current_entry_id = code->ext.entry->id;
6509 resolve_where (code, NULL);
6513 if (code->expr != NULL)
6515 if (code->expr->ts.type != BT_INTEGER)
6516 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6517 "INTEGER variable", &code->expr->where);
6518 else if (code->expr->symtree->n.sym->attr.assign != 1)
6519 gfc_error ("Variable '%s' has not been assigned a target "
6520 "label at %L", code->expr->symtree->n.sym->name,
6521 &code->expr->where);
6524 resolve_branch (code->label, code);
6528 if (code->expr != NULL
6529 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6530 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6531 "INTEGER return specifier", &code->expr->where);
6534 case EXEC_INIT_ASSIGN:
6541 if (resolve_ordinary_assign (code, ns))
6546 case EXEC_LABEL_ASSIGN:
6547 if (code->label->defined == ST_LABEL_UNKNOWN)
6548 gfc_error ("Label %d referenced at %L is never defined",
6549 code->label->value, &code->label->where);
6551 && (code->expr->expr_type != EXPR_VARIABLE
6552 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6553 || code->expr->symtree->n.sym->ts.kind
6554 != gfc_default_integer_kind
6555 || code->expr->symtree->n.sym->as != NULL))
6556 gfc_error ("ASSIGN statement at %L requires a scalar "
6557 "default INTEGER variable", &code->expr->where);
6560 case EXEC_POINTER_ASSIGN:
6564 gfc_check_pointer_assign (code->expr, code->expr2);
6567 case EXEC_ARITHMETIC_IF:
6569 && code->expr->ts.type != BT_INTEGER
6570 && code->expr->ts.type != BT_REAL)
6571 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6572 "expression", &code->expr->where);
6574 resolve_branch (code->label, code);
6575 resolve_branch (code->label2, code);
6576 resolve_branch (code->label3, code);
6580 if (t == SUCCESS && code->expr != NULL
6581 && (code->expr->ts.type != BT_LOGICAL
6582 || code->expr->rank != 0))
6583 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6584 &code->expr->where);
6589 resolve_call (code);
6593 resolve_typebound_call (code);
6597 /* Select is complicated. Also, a SELECT construct could be
6598 a transformed computed GOTO. */
6599 resolve_select (code);
6603 if (code->ext.iterator != NULL)
6605 gfc_iterator *iter = code->ext.iterator;
6606 if (gfc_resolve_iterator (iter, true) != FAILURE)
6607 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6612 if (code->expr == NULL)
6613 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6615 && (code->expr->rank != 0
6616 || code->expr->ts.type != BT_LOGICAL))
6617 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6618 "a scalar LOGICAL expression", &code->expr->where);
6623 resolve_allocate_deallocate (code, "ALLOCATE");
6627 case EXEC_DEALLOCATE:
6629 resolve_allocate_deallocate (code, "DEALLOCATE");
6634 if (gfc_resolve_open (code->ext.open) == FAILURE)
6637 resolve_branch (code->ext.open->err, code);
6641 if (gfc_resolve_close (code->ext.close) == FAILURE)
6644 resolve_branch (code->ext.close->err, code);
6647 case EXEC_BACKSPACE:
6651 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6654 resolve_branch (code->ext.filepos->err, code);
6658 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6661 resolve_branch (code->ext.inquire->err, code);
6665 gcc_assert (code->ext.inquire != NULL);
6666 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6669 resolve_branch (code->ext.inquire->err, code);
6673 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
6676 resolve_branch (code->ext.wait->err, code);
6677 resolve_branch (code->ext.wait->end, code);
6678 resolve_branch (code->ext.wait->eor, code);
6683 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6686 resolve_branch (code->ext.dt->err, code);
6687 resolve_branch (code->ext.dt->end, code);
6688 resolve_branch (code->ext.dt->eor, code);
6692 resolve_transfer (code);
6696 resolve_forall_iterators (code->ext.forall_iterator);
6698 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6699 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6700 "expression", &code->expr->where);
6703 case EXEC_OMP_ATOMIC:
6704 case EXEC_OMP_BARRIER:
6705 case EXEC_OMP_CRITICAL:
6706 case EXEC_OMP_FLUSH:
6708 case EXEC_OMP_MASTER:
6709 case EXEC_OMP_ORDERED:
6710 case EXEC_OMP_SECTIONS:
6711 case EXEC_OMP_SINGLE:
6712 case EXEC_OMP_TASKWAIT:
6713 case EXEC_OMP_WORKSHARE:
6714 gfc_resolve_omp_directive (code, ns);
6717 case EXEC_OMP_PARALLEL:
6718 case EXEC_OMP_PARALLEL_DO:
6719 case EXEC_OMP_PARALLEL_SECTIONS:
6720 case EXEC_OMP_PARALLEL_WORKSHARE:
6722 omp_workshare_save = omp_workshare_flag;
6723 omp_workshare_flag = 0;
6724 gfc_resolve_omp_directive (code, ns);
6725 omp_workshare_flag = omp_workshare_save;
6729 gfc_internal_error ("resolve_code(): Bad statement code");
6733 cs_base = frame.prev;
6737 /* Resolve initial values and make sure they are compatible with
6741 resolve_values (gfc_symbol *sym)
6743 if (sym->value == NULL)
6746 if (gfc_resolve_expr (sym->value) == FAILURE)
6749 gfc_check_assign_symbol (sym, sym->value);
6753 /* Verify the binding labels for common blocks that are BIND(C). The label
6754 for a BIND(C) common block must be identical in all scoping units in which
6755 the common block is declared. Further, the binding label can not collide
6756 with any other global entity in the program. */
6759 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6761 if (comm_block_tree->n.common->is_bind_c == 1)
6763 gfc_gsymbol *binding_label_gsym;
6764 gfc_gsymbol *comm_name_gsym;
6766 /* See if a global symbol exists by the common block's name. It may
6767 be NULL if the common block is use-associated. */
6768 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6769 comm_block_tree->n.common->name);
6770 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6771 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6772 "with the global entity '%s' at %L",
6773 comm_block_tree->n.common->binding_label,
6774 comm_block_tree->n.common->name,
6775 &(comm_block_tree->n.common->where),
6776 comm_name_gsym->name, &(comm_name_gsym->where));
6777 else if (comm_name_gsym != NULL
6778 && strcmp (comm_name_gsym->name,
6779 comm_block_tree->n.common->name) == 0)
6781 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6783 if (comm_name_gsym->binding_label == NULL)
6784 /* No binding label for common block stored yet; save this one. */
6785 comm_name_gsym->binding_label =
6786 comm_block_tree->n.common->binding_label;
6788 if (strcmp (comm_name_gsym->binding_label,
6789 comm_block_tree->n.common->binding_label) != 0)
6791 /* Common block names match but binding labels do not. */
6792 gfc_error ("Binding label '%s' for common block '%s' at %L "
6793 "does not match the binding label '%s' for common "
6795 comm_block_tree->n.common->binding_label,
6796 comm_block_tree->n.common->name,
6797 &(comm_block_tree->n.common->where),
6798 comm_name_gsym->binding_label,
6799 comm_name_gsym->name,
6800 &(comm_name_gsym->where));
6805 /* There is no binding label (NAME="") so we have nothing further to
6806 check and nothing to add as a global symbol for the label. */
6807 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6810 binding_label_gsym =
6811 gfc_find_gsymbol (gfc_gsym_root,
6812 comm_block_tree->n.common->binding_label);
6813 if (binding_label_gsym == NULL)
6815 /* Need to make a global symbol for the binding label to prevent
6816 it from colliding with another. */
6817 binding_label_gsym =
6818 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6819 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6820 binding_label_gsym->type = GSYM_COMMON;
6824 /* If comm_name_gsym is NULL, the name common block is use
6825 associated and the name could be colliding. */
6826 if (binding_label_gsym->type != GSYM_COMMON)
6827 gfc_error ("Binding label '%s' for common block '%s' at %L "
6828 "collides with the global entity '%s' at %L",
6829 comm_block_tree->n.common->binding_label,
6830 comm_block_tree->n.common->name,
6831 &(comm_block_tree->n.common->where),
6832 binding_label_gsym->name,
6833 &(binding_label_gsym->where));
6834 else if (comm_name_gsym != NULL
6835 && (strcmp (binding_label_gsym->name,
6836 comm_name_gsym->binding_label) != 0)
6837 && (strcmp (binding_label_gsym->sym_name,
6838 comm_name_gsym->name) != 0))
6839 gfc_error ("Binding label '%s' for common block '%s' at %L "
6840 "collides with global entity '%s' at %L",
6841 binding_label_gsym->name, binding_label_gsym->sym_name,
6842 &(comm_block_tree->n.common->where),
6843 comm_name_gsym->name, &(comm_name_gsym->where));
6851 /* Verify any BIND(C) derived types in the namespace so we can report errors
6852 for them once, rather than for each variable declared of that type. */
6855 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6857 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6858 && derived_sym->attr.is_bind_c == 1)
6859 verify_bind_c_derived_type (derived_sym);
6865 /* Verify that any binding labels used in a given namespace do not collide
6866 with the names or binding labels of any global symbols. */
6869 gfc_verify_binding_labels (gfc_symbol *sym)
6873 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6874 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6876 gfc_gsymbol *bind_c_sym;
6878 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6879 if (bind_c_sym != NULL
6880 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6882 if (sym->attr.if_source == IFSRC_DECL
6883 && (bind_c_sym->type != GSYM_SUBROUTINE
6884 && bind_c_sym->type != GSYM_FUNCTION)
6885 && ((sym->attr.contained == 1
6886 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6887 || (sym->attr.use_assoc == 1
6888 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6890 /* Make sure global procedures don't collide with anything. */
6891 gfc_error ("Binding label '%s' at %L collides with the global "
6892 "entity '%s' at %L", sym->binding_label,
6893 &(sym->declared_at), bind_c_sym->name,
6894 &(bind_c_sym->where));
6897 else if (sym->attr.contained == 0
6898 && (sym->attr.if_source == IFSRC_IFBODY
6899 && sym->attr.flavor == FL_PROCEDURE)
6900 && (bind_c_sym->sym_name != NULL
6901 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6903 /* Make sure procedures in interface bodies don't collide. */
6904 gfc_error ("Binding label '%s' in interface body at %L collides "
6905 "with the global entity '%s' at %L",
6907 &(sym->declared_at), bind_c_sym->name,
6908 &(bind_c_sym->where));
6911 else if (sym->attr.contained == 0
6912 && sym->attr.if_source == IFSRC_UNKNOWN)
6913 if ((sym->attr.use_assoc && bind_c_sym->mod_name
6914 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
6915 || sym->attr.use_assoc == 0)
6917 gfc_error ("Binding label '%s' at %L collides with global "
6918 "entity '%s' at %L", sym->binding_label,
6919 &(sym->declared_at), bind_c_sym->name,
6920 &(bind_c_sym->where));
6925 /* Clear the binding label to prevent checking multiple times. */
6926 sym->binding_label[0] = '\0';
6928 else if (bind_c_sym == NULL)
6930 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6931 bind_c_sym->where = sym->declared_at;
6932 bind_c_sym->sym_name = sym->name;
6934 if (sym->attr.use_assoc == 1)
6935 bind_c_sym->mod_name = sym->module;
6937 if (sym->ns->proc_name != NULL)
6938 bind_c_sym->mod_name = sym->ns->proc_name->name;
6940 if (sym->attr.contained == 0)
6942 if (sym->attr.subroutine)
6943 bind_c_sym->type = GSYM_SUBROUTINE;
6944 else if (sym->attr.function)
6945 bind_c_sym->type = GSYM_FUNCTION;
6953 /* Resolve an index expression. */
6956 resolve_index_expr (gfc_expr *e)
6958 if (gfc_resolve_expr (e) == FAILURE)
6961 if (gfc_simplify_expr (e, 0) == FAILURE)
6964 if (gfc_specification_expr (e) == FAILURE)
6970 /* Resolve a charlen structure. */
6973 resolve_charlen (gfc_charlen *cl)
6982 specification_expr = 1;
6984 if (resolve_index_expr (cl->length) == FAILURE)
6986 specification_expr = 0;
6990 /* "If the character length parameter value evaluates to a negative
6991 value, the length of character entities declared is zero." */
6992 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
6994 gfc_warning_now ("CHARACTER variable has zero length at %L",
6995 &cl->length->where);
6996 gfc_replace_expr (cl->length, gfc_int_expr (0));
7003 /* Test for non-constant shape arrays. */
7006 is_non_constant_shape_array (gfc_symbol *sym)
7012 not_constant = false;
7013 if (sym->as != NULL)
7015 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7016 has not been simplified; parameter array references. Do the
7017 simplification now. */
7018 for (i = 0; i < sym->as->rank; i++)
7020 e = sym->as->lower[i];
7021 if (e && (resolve_index_expr (e) == FAILURE
7022 || !gfc_is_constant_expr (e)))
7023 not_constant = true;
7025 e = sym->as->upper[i];
7026 if (e && (resolve_index_expr (e) == FAILURE
7027 || !gfc_is_constant_expr (e)))
7028 not_constant = true;
7031 return not_constant;
7034 /* Given a symbol and an initialization expression, add code to initialize
7035 the symbol to the function entry. */
7037 build_init_assign (gfc_symbol *sym, gfc_expr *init)
7041 gfc_namespace *ns = sym->ns;
7043 /* Search for the function namespace if this is a contained
7044 function without an explicit result. */
7045 if (sym->attr.function && sym == sym->result
7046 && sym->name != sym->ns->proc_name->name)
7049 for (;ns; ns = ns->sibling)
7050 if (strcmp (ns->proc_name->name, sym->name) == 0)
7056 gfc_free_expr (init);
7060 /* Build an l-value expression for the result. */
7061 lval = gfc_lval_expr_from_sym (sym);
7063 /* Add the code at scope entry. */
7064 init_st = gfc_get_code ();
7065 init_st->next = ns->code;
7068 /* Assign the default initializer to the l-value. */
7069 init_st->loc = sym->declared_at;
7070 init_st->op = EXEC_INIT_ASSIGN;
7071 init_st->expr = lval;
7072 init_st->expr2 = init;
7075 /* Assign the default initializer to a derived type variable or result. */
7078 apply_default_init (gfc_symbol *sym)
7080 gfc_expr *init = NULL;
7082 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7085 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
7086 init = gfc_default_initializer (&sym->ts);
7091 build_init_assign (sym, init);
7094 /* Build an initializer for a local integer, real, complex, logical, or
7095 character variable, based on the command line flags finit-local-zero,
7096 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7097 null if the symbol should not have a default initialization. */
7099 build_default_init_expr (gfc_symbol *sym)
7102 gfc_expr *init_expr;
7105 /* These symbols should never have a default initialization. */
7106 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
7107 || sym->attr.external
7109 || sym->attr.pointer
7110 || sym->attr.in_equivalence
7111 || sym->attr.in_common
7114 || sym->attr.cray_pointee
7115 || sym->attr.cray_pointer)
7118 /* Now we'll try to build an initializer expression. */
7119 init_expr = gfc_get_expr ();
7120 init_expr->expr_type = EXPR_CONSTANT;
7121 init_expr->ts.type = sym->ts.type;
7122 init_expr->ts.kind = sym->ts.kind;
7123 init_expr->where = sym->declared_at;
7125 /* We will only initialize integers, reals, complex, logicals, and
7126 characters, and only if the corresponding command-line flags
7127 were set. Otherwise, we free init_expr and return null. */
7128 switch (sym->ts.type)
7131 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
7132 mpz_init_set_si (init_expr->value.integer,
7133 gfc_option.flag_init_integer_value);
7136 gfc_free_expr (init_expr);
7142 mpfr_init (init_expr->value.real);
7143 switch (gfc_option.flag_init_real)
7145 case GFC_INIT_REAL_NAN:
7146 mpfr_set_nan (init_expr->value.real);
7149 case GFC_INIT_REAL_INF:
7150 mpfr_set_inf (init_expr->value.real, 1);
7153 case GFC_INIT_REAL_NEG_INF:
7154 mpfr_set_inf (init_expr->value.real, -1);
7157 case GFC_INIT_REAL_ZERO:
7158 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
7162 gfc_free_expr (init_expr);
7169 mpfr_init (init_expr->value.complex.r);
7170 mpfr_init (init_expr->value.complex.i);
7171 switch (gfc_option.flag_init_real)
7173 case GFC_INIT_REAL_NAN:
7174 mpfr_set_nan (init_expr->value.complex.r);
7175 mpfr_set_nan (init_expr->value.complex.i);
7178 case GFC_INIT_REAL_INF:
7179 mpfr_set_inf (init_expr->value.complex.r, 1);
7180 mpfr_set_inf (init_expr->value.complex.i, 1);
7183 case GFC_INIT_REAL_NEG_INF:
7184 mpfr_set_inf (init_expr->value.complex.r, -1);
7185 mpfr_set_inf (init_expr->value.complex.i, -1);
7188 case GFC_INIT_REAL_ZERO:
7189 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
7190 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
7194 gfc_free_expr (init_expr);
7201 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
7202 init_expr->value.logical = 0;
7203 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
7204 init_expr->value.logical = 1;
7207 gfc_free_expr (init_expr);
7213 /* For characters, the length must be constant in order to
7214 create a default initializer. */
7215 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
7216 && sym->ts.cl->length
7217 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
7219 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
7220 init_expr->value.character.length = char_len;
7221 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
7222 for (i = 0; i < char_len; i++)
7223 init_expr->value.character.string[i]
7224 = (unsigned char) gfc_option.flag_init_character_value;
7228 gfc_free_expr (init_expr);
7234 gfc_free_expr (init_expr);
7240 /* Add an initialization expression to a local variable. */
7242 apply_default_init_local (gfc_symbol *sym)
7244 gfc_expr *init = NULL;
7246 /* The symbol should be a variable or a function return value. */
7247 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7248 || (sym->attr.function && sym->result != sym))
7251 /* Try to build the initializer expression. If we can't initialize
7252 this symbol, then init will be NULL. */
7253 init = build_default_init_expr (sym);
7257 /* For saved variables, we don't want to add an initializer at
7258 function entry, so we just add a static initializer. */
7259 if (sym->attr.save || sym->ns->save_all)
7261 /* Don't clobber an existing initializer! */
7262 gcc_assert (sym->value == NULL);
7267 build_init_assign (sym, init);
7270 /* Resolution of common features of flavors variable and procedure. */
7273 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
7275 /* Constraints on deferred shape variable. */
7276 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
7278 if (sym->attr.allocatable)
7280 if (sym->attr.dimension)
7281 gfc_error ("Allocatable array '%s' at %L must have "
7282 "a deferred shape", sym->name, &sym->declared_at);
7284 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7285 sym->name, &sym->declared_at);
7289 if (sym->attr.pointer && sym->attr.dimension)
7291 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7292 sym->name, &sym->declared_at);
7299 if (!mp_flag && !sym->attr.allocatable
7300 && !sym->attr.pointer && !sym->attr.dummy)
7302 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7303 sym->name, &sym->declared_at);
7311 /* Additional checks for symbols with flavor variable and derived
7312 type. To be called from resolve_fl_variable. */
7315 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
7317 gcc_assert (sym->ts.type == BT_DERIVED);
7319 /* Check to see if a derived type is blocked from being host
7320 associated by the presence of another class I symbol in the same
7321 namespace. 14.6.1.3 of the standard and the discussion on
7322 comp.lang.fortran. */
7323 if (sym->ns != sym->ts.derived->ns
7324 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
7327 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
7328 if (s && (s->attr.flavor != FL_DERIVED
7329 || !gfc_compare_derived_types (s, sym->ts.derived)))
7331 gfc_error ("The type '%s' cannot be host associated at %L "
7332 "because it is blocked by an incompatible object "
7333 "of the same name declared at %L",
7334 sym->ts.derived->name, &sym->declared_at,
7340 /* 4th constraint in section 11.3: "If an object of a type for which
7341 component-initialization is specified (R429) appears in the
7342 specification-part of a module and does not have the ALLOCATABLE
7343 or POINTER attribute, the object shall have the SAVE attribute."
7345 The check for initializers is performed with
7346 has_default_initializer because gfc_default_initializer generates
7347 a hidden default for allocatable components. */
7348 if (!(sym->value || no_init_flag) && sym->ns->proc_name
7349 && sym->ns->proc_name->attr.flavor == FL_MODULE
7350 && !sym->ns->save_all && !sym->attr.save
7351 && !sym->attr.pointer && !sym->attr.allocatable
7352 && has_default_initializer (sym->ts.derived))
7354 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7355 "default initialization of a component",
7356 sym->name, &sym->declared_at);
7360 /* Assign default initializer. */
7361 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
7362 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
7364 sym->value = gfc_default_initializer (&sym->ts);
7371 /* Resolve symbols with flavor variable. */
7374 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
7376 int no_init_flag, automatic_flag;
7378 const char *auto_save_msg;
7380 auto_save_msg = "Automatic object '%s' at %L cannot have the "
7383 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7386 /* Set this flag to check that variables are parameters of all entries.
7387 This check is effected by the call to gfc_resolve_expr through
7388 is_non_constant_shape_array. */
7389 specification_expr = 1;
7391 if (sym->ns->proc_name
7392 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7393 || sym->ns->proc_name->attr.is_main_program)
7394 && !sym->attr.use_assoc
7395 && !sym->attr.allocatable
7396 && !sym->attr.pointer
7397 && is_non_constant_shape_array (sym))
7399 /* The shape of a main program or module array needs to be
7401 gfc_error ("The module or main program array '%s' at %L must "
7402 "have constant shape", sym->name, &sym->declared_at);
7403 specification_expr = 0;
7407 if (sym->ts.type == BT_CHARACTER)
7409 /* Make sure that character string variables with assumed length are
7411 e = sym->ts.cl->length;
7412 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
7414 gfc_error ("Entity with assumed character length at %L must be a "
7415 "dummy argument or a PARAMETER", &sym->declared_at);
7419 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7421 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7425 if (!gfc_is_constant_expr (e)
7426 && !(e->expr_type == EXPR_VARIABLE
7427 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7428 && sym->ns->proc_name
7429 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7430 || sym->ns->proc_name->attr.is_main_program)
7431 && !sym->attr.use_assoc)
7433 gfc_error ("'%s' at %L must have constant character length "
7434 "in this context", sym->name, &sym->declared_at);
7439 if (sym->value == NULL && sym->attr.referenced)
7440 apply_default_init_local (sym); /* Try to apply a default initialization. */
7442 /* Determine if the symbol may not have an initializer. */
7443 no_init_flag = automatic_flag = 0;
7444 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7445 || sym->attr.intrinsic || sym->attr.result)
7447 else if (sym->attr.dimension && !sym->attr.pointer
7448 && is_non_constant_shape_array (sym))
7450 no_init_flag = automatic_flag = 1;
7452 /* Also, they must not have the SAVE attribute.
7453 SAVE_IMPLICIT is checked below. */
7454 if (sym->attr.save == SAVE_EXPLICIT)
7456 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7461 /* Reject illegal initializers. */
7462 if (!sym->mark && sym->value)
7464 if (sym->attr.allocatable)
7465 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7466 sym->name, &sym->declared_at);
7467 else if (sym->attr.external)
7468 gfc_error ("External '%s' at %L cannot have an initializer",
7469 sym->name, &sym->declared_at);
7470 else if (sym->attr.dummy
7471 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7472 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7473 sym->name, &sym->declared_at);
7474 else if (sym->attr.intrinsic)
7475 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7476 sym->name, &sym->declared_at);
7477 else if (sym->attr.result)
7478 gfc_error ("Function result '%s' at %L cannot have an initializer",
7479 sym->name, &sym->declared_at);
7480 else if (automatic_flag)
7481 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7482 sym->name, &sym->declared_at);
7489 if (sym->ts.type == BT_DERIVED)
7490 return resolve_fl_variable_derived (sym, no_init_flag);
7496 /* Resolve a procedure. */
7499 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7501 gfc_formal_arglist *arg;
7503 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7504 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7505 "interfaces", sym->name, &sym->declared_at);
7507 if (sym->attr.function
7508 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7511 if (sym->ts.type == BT_CHARACTER)
7513 gfc_charlen *cl = sym->ts.cl;
7515 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7516 && resolve_charlen (cl) == FAILURE)
7519 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7521 if (sym->attr.proc == PROC_ST_FUNCTION)
7523 gfc_error ("Character-valued statement function '%s' at %L must "
7524 "have constant length", sym->name, &sym->declared_at);
7528 if (sym->attr.external && sym->formal == NULL
7529 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7531 gfc_error ("Automatic character length function '%s' at %L must "
7532 "have an explicit interface", sym->name,
7539 /* Ensure that derived type for are not of a private type. Internal
7540 module procedures are excluded by 2.2.3.3 - i.e., they are not
7541 externally accessible and can access all the objects accessible in
7543 if (!(sym->ns->parent
7544 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7545 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7547 gfc_interface *iface;
7549 for (arg = sym->formal; arg; arg = arg->next)
7552 && arg->sym->ts.type == BT_DERIVED
7553 && !arg->sym->ts.derived->attr.use_assoc
7554 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7555 arg->sym->ts.derived->ns->default_access)
7556 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7557 "PRIVATE type and cannot be a dummy argument"
7558 " of '%s', which is PUBLIC at %L",
7559 arg->sym->name, sym->name, &sym->declared_at)
7562 /* Stop this message from recurring. */
7563 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7568 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7569 PRIVATE to the containing module. */
7570 for (iface = sym->generic; iface; iface = iface->next)
7572 for (arg = iface->sym->formal; arg; arg = arg->next)
7575 && arg->sym->ts.type == BT_DERIVED
7576 && !arg->sym->ts.derived->attr.use_assoc
7577 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7578 arg->sym->ts.derived->ns->default_access)
7579 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7580 "'%s' in PUBLIC interface '%s' at %L "
7581 "takes dummy arguments of '%s' which is "
7582 "PRIVATE", iface->sym->name, sym->name,
7583 &iface->sym->declared_at,
7584 gfc_typename (&arg->sym->ts)) == FAILURE)
7586 /* Stop this message from recurring. */
7587 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7593 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7594 PRIVATE to the containing module. */
7595 for (iface = sym->generic; iface; iface = iface->next)
7597 for (arg = iface->sym->formal; arg; arg = arg->next)
7600 && arg->sym->ts.type == BT_DERIVED
7601 && !arg->sym->ts.derived->attr.use_assoc
7602 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7603 arg->sym->ts.derived->ns->default_access)
7604 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7605 "'%s' in PUBLIC interface '%s' at %L "
7606 "takes dummy arguments of '%s' which is "
7607 "PRIVATE", iface->sym->name, sym->name,
7608 &iface->sym->declared_at,
7609 gfc_typename (&arg->sym->ts)) == FAILURE)
7611 /* Stop this message from recurring. */
7612 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7619 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
7620 && !sym->attr.proc_pointer)
7622 gfc_error ("Function '%s' at %L cannot have an initializer",
7623 sym->name, &sym->declared_at);
7627 /* An external symbol may not have an initializer because it is taken to be
7628 a procedure. Exception: Procedure Pointers. */
7629 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
7631 gfc_error ("External object '%s' at %L may not have an initializer",
7632 sym->name, &sym->declared_at);
7636 /* An elemental function is required to return a scalar 12.7.1 */
7637 if (sym->attr.elemental && sym->attr.function && sym->as)
7639 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7640 "result", sym->name, &sym->declared_at);
7641 /* Reset so that the error only occurs once. */
7642 sym->attr.elemental = 0;
7646 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7647 char-len-param shall not be array-valued, pointer-valued, recursive
7648 or pure. ....snip... A character value of * may only be used in the
7649 following ways: (i) Dummy arg of procedure - dummy associates with
7650 actual length; (ii) To declare a named constant; or (iii) External
7651 function - but length must be declared in calling scoping unit. */
7652 if (sym->attr.function
7653 && sym->ts.type == BT_CHARACTER
7654 && sym->ts.cl && sym->ts.cl->length == NULL)
7656 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7657 || (sym->attr.recursive) || (sym->attr.pure))
7659 if (sym->as && sym->as->rank)
7660 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7661 "array-valued", sym->name, &sym->declared_at);
7663 if (sym->attr.pointer)
7664 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7665 "pointer-valued", sym->name, &sym->declared_at);
7668 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7669 "pure", sym->name, &sym->declared_at);
7671 if (sym->attr.recursive)
7672 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7673 "recursive", sym->name, &sym->declared_at);
7678 /* Appendix B.2 of the standard. Contained functions give an
7679 error anyway. Fixed-form is likely to be F77/legacy. */
7680 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7681 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7682 "'%s' at %L is obsolescent in fortran 95",
7683 sym->name, &sym->declared_at);
7686 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7688 gfc_formal_arglist *curr_arg;
7689 int has_non_interop_arg = 0;
7691 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7692 sym->common_block) == FAILURE)
7694 /* Clear these to prevent looking at them again if there was an
7696 sym->attr.is_bind_c = 0;
7697 sym->attr.is_c_interop = 0;
7698 sym->ts.is_c_interop = 0;
7702 /* So far, no errors have been found. */
7703 sym->attr.is_c_interop = 1;
7704 sym->ts.is_c_interop = 1;
7707 curr_arg = sym->formal;
7708 while (curr_arg != NULL)
7710 /* Skip implicitly typed dummy args here. */
7711 if (curr_arg->sym->attr.implicit_type == 0)
7712 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7713 /* If something is found to fail, record the fact so we
7714 can mark the symbol for the procedure as not being
7715 BIND(C) to try and prevent multiple errors being
7717 has_non_interop_arg = 1;
7719 curr_arg = curr_arg->next;
7722 /* See if any of the arguments were not interoperable and if so, clear
7723 the procedure symbol to prevent duplicate error messages. */
7724 if (has_non_interop_arg != 0)
7726 sym->attr.is_c_interop = 0;
7727 sym->ts.is_c_interop = 0;
7728 sym->attr.is_bind_c = 0;
7732 if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
7734 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
7735 "in '%s' at %L", sym->name, &sym->declared_at);
7739 if (sym->attr.intent && !sym->attr.proc_pointer)
7741 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
7742 "in '%s' at %L", sym->name, &sym->declared_at);
7750 /* Resolve a list of finalizer procedures. That is, after they have hopefully
7751 been defined and we now know their defined arguments, check that they fulfill
7752 the requirements of the standard for procedures used as finalizers. */
7755 gfc_resolve_finalizers (gfc_symbol* derived)
7757 gfc_finalizer* list;
7758 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
7759 gfc_try result = SUCCESS;
7760 bool seen_scalar = false;
7762 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
7765 /* Walk over the list of finalizer-procedures, check them, and if any one
7766 does not fit in with the standard's definition, print an error and remove
7767 it from the list. */
7768 prev_link = &derived->f2k_derived->finalizers;
7769 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
7775 /* Skip this finalizer if we already resolved it. */
7776 if (list->proc_tree)
7778 prev_link = &(list->next);
7782 /* Check this exists and is a SUBROUTINE. */
7783 if (!list->proc_sym->attr.subroutine)
7785 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
7786 list->proc_sym->name, &list->where);
7790 /* We should have exactly one argument. */
7791 if (!list->proc_sym->formal || list->proc_sym->formal->next)
7793 gfc_error ("FINAL procedure at %L must have exactly one argument",
7797 arg = list->proc_sym->formal->sym;
7799 /* This argument must be of our type. */
7800 if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
7802 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
7803 &arg->declared_at, derived->name);
7807 /* It must neither be a pointer nor allocatable nor optional. */
7808 if (arg->attr.pointer)
7810 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
7814 if (arg->attr.allocatable)
7816 gfc_error ("Argument of FINAL procedure at %L must not be"
7817 " ALLOCATABLE", &arg->declared_at);
7820 if (arg->attr.optional)
7822 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
7827 /* It must not be INTENT(OUT). */
7828 if (arg->attr.intent == INTENT_OUT)
7830 gfc_error ("Argument of FINAL procedure at %L must not be"
7831 " INTENT(OUT)", &arg->declared_at);
7835 /* Warn if the procedure is non-scalar and not assumed shape. */
7836 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
7837 && arg->as->type != AS_ASSUMED_SHAPE)
7838 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
7839 " shape argument", &arg->declared_at);
7841 /* Check that it does not match in kind and rank with a FINAL procedure
7842 defined earlier. To really loop over the *earlier* declarations,
7843 we need to walk the tail of the list as new ones were pushed at the
7845 /* TODO: Handle kind parameters once they are implemented. */
7846 my_rank = (arg->as ? arg->as->rank : 0);
7847 for (i = list->next; i; i = i->next)
7849 /* Argument list might be empty; that is an error signalled earlier,
7850 but we nevertheless continued resolving. */
7851 if (i->proc_sym->formal)
7853 gfc_symbol* i_arg = i->proc_sym->formal->sym;
7854 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
7855 if (i_rank == my_rank)
7857 gfc_error ("FINAL procedure '%s' declared at %L has the same"
7858 " rank (%d) as '%s'",
7859 list->proc_sym->name, &list->where, my_rank,
7866 /* Is this the/a scalar finalizer procedure? */
7867 if (!arg->as || arg->as->rank == 0)
7870 /* Find the symtree for this procedure. */
7871 gcc_assert (!list->proc_tree);
7872 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
7874 prev_link = &list->next;
7877 /* Remove wrong nodes immediately from the list so we don't risk any
7878 troubles in the future when they might fail later expectations. */
7882 *prev_link = list->next;
7883 gfc_free_finalizer (i);
7886 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
7887 were nodes in the list, must have been for arrays. It is surely a good
7888 idea to have a scalar version there if there's something to finalize. */
7889 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
7890 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
7891 " defined at %L, suggest also scalar one",
7892 derived->name, &derived->declared_at);
7894 /* TODO: Remove this error when finalization is finished. */
7895 gfc_error ("Finalization at %L is not yet implemented",
7896 &derived->declared_at);
7902 /* Check that it is ok for the typebound procedure proc to override the
7906 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
7909 const gfc_symbol* proc_target;
7910 const gfc_symbol* old_target;
7911 unsigned proc_pass_arg, old_pass_arg, argpos;
7912 gfc_formal_arglist* proc_formal;
7913 gfc_formal_arglist* old_formal;
7915 /* This procedure should only be called for non-GENERIC proc. */
7916 gcc_assert (!proc->typebound->is_generic);
7918 /* If the overwritten procedure is GENERIC, this is an error. */
7919 if (old->typebound->is_generic)
7921 gfc_error ("Can't overwrite GENERIC '%s' at %L",
7922 old->name, &proc->typebound->where);
7926 where = proc->typebound->where;
7927 proc_target = proc->typebound->u.specific->n.sym;
7928 old_target = old->typebound->u.specific->n.sym;
7930 /* Check that overridden binding is not NON_OVERRIDABLE. */
7931 if (old->typebound->non_overridable)
7933 gfc_error ("'%s' at %L overrides a procedure binding declared"
7934 " NON_OVERRIDABLE", proc->name, &where);
7938 /* If the overridden binding is PURE, the overriding must be, too. */
7939 if (old_target->attr.pure && !proc_target->attr.pure)
7941 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
7942 proc->name, &where);
7946 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
7947 is not, the overriding must not be either. */
7948 if (old_target->attr.elemental && !proc_target->attr.elemental)
7950 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
7951 " ELEMENTAL", proc->name, &where);
7954 if (!old_target->attr.elemental && proc_target->attr.elemental)
7956 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
7957 " be ELEMENTAL, either", proc->name, &where);
7961 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
7963 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
7965 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
7966 " SUBROUTINE", proc->name, &where);
7970 /* If the overridden binding is a FUNCTION, the overriding must also be a
7971 FUNCTION and have the same characteristics. */
7972 if (old_target->attr.function)
7974 if (!proc_target->attr.function)
7976 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
7977 " FUNCTION", proc->name, &where);
7981 /* FIXME: Do more comprehensive checking (including, for instance, the
7982 rank and array-shape). */
7983 gcc_assert (proc_target->result && old_target->result);
7984 if (!gfc_compare_types (&proc_target->result->ts,
7985 &old_target->result->ts))
7987 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
7988 " matching result types", proc->name, &where);
7993 /* If the overridden binding is PUBLIC, the overriding one must not be
7995 if (old->typebound->access == ACCESS_PUBLIC
7996 && proc->typebound->access == ACCESS_PRIVATE)
7998 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
7999 " PRIVATE", proc->name, &where);
8003 /* Compare the formal argument lists of both procedures. This is also abused
8004 to find the position of the passed-object dummy arguments of both
8005 bindings as at least the overridden one might not yet be resolved and we
8006 need those positions in the check below. */
8007 proc_pass_arg = old_pass_arg = 0;
8008 if (!proc->typebound->nopass && !proc->typebound->pass_arg)
8010 if (!old->typebound->nopass && !old->typebound->pass_arg)
8013 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
8014 proc_formal && old_formal;
8015 proc_formal = proc_formal->next, old_formal = old_formal->next)
8017 if (proc->typebound->pass_arg
8018 && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name))
8019 proc_pass_arg = argpos;
8020 if (old->typebound->pass_arg
8021 && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
8022 old_pass_arg = argpos;
8024 /* Check that the names correspond. */
8025 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
8027 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8028 " to match the corresponding argument of the overridden"
8029 " procedure", proc_formal->sym->name, proc->name, &where,
8030 old_formal->sym->name);
8034 /* Check that the types correspond if neither is the passed-object
8036 /* FIXME: Do more comprehensive testing here. */
8037 if (proc_pass_arg != argpos && old_pass_arg != argpos
8038 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
8040 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8041 " in respect to the overridden procedure",
8042 proc_formal->sym->name, proc->name, &where);
8048 if (proc_formal || old_formal)
8050 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8051 " the overridden procedure", proc->name, &where);
8055 /* If the overridden binding is NOPASS, the overriding one must also be
8057 if (old->typebound->nopass && !proc->typebound->nopass)
8059 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8060 " NOPASS", proc->name, &where);
8064 /* If the overridden binding is PASS(x), the overriding one must also be
8065 PASS and the passed-object dummy arguments must correspond. */
8066 if (!old->typebound->nopass)
8068 if (proc->typebound->nopass)
8070 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8071 " PASS", proc->name, &where);
8075 if (proc_pass_arg != old_pass_arg)
8077 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8078 " the same position as the passed-object dummy argument of"
8079 " the overridden procedure", proc->name, &where);
8088 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8091 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
8092 const char* generic_name, locus where)
8097 gcc_assert (t1->specific && t2->specific);
8098 gcc_assert (!t1->specific->is_generic);
8099 gcc_assert (!t2->specific->is_generic);
8101 sym1 = t1->specific->u.specific->n.sym;
8102 sym2 = t2->specific->u.specific->n.sym;
8104 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8105 if (sym1->attr.subroutine != sym2->attr.subroutine
8106 || sym1->attr.function != sym2->attr.function)
8108 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8109 " GENERIC '%s' at %L",
8110 sym1->name, sym2->name, generic_name, &where);
8114 /* Compare the interfaces. */
8115 if (gfc_compare_interfaces (sym1, sym2, 1))
8117 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8118 sym1->name, sym2->name, generic_name, &where);
8126 /* Resolve a GENERIC procedure binding for a derived type. */
8129 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
8131 gfc_tbp_generic* target;
8132 gfc_symtree* first_target;
8133 gfc_symbol* super_type;
8134 gfc_symtree* inherited;
8137 gcc_assert (st->typebound);
8138 gcc_assert (st->typebound->is_generic);
8140 where = st->typebound->where;
8141 super_type = gfc_get_derived_super_type (derived);
8143 /* Find the overridden binding if any. */
8144 st->typebound->overridden = NULL;
8147 gfc_symtree* overridden;
8148 overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
8150 if (overridden && overridden->typebound)
8151 st->typebound->overridden = overridden->typebound;
8154 /* Try to find the specific bindings for the symtrees in our target-list. */
8155 gcc_assert (st->typebound->u.generic);
8156 for (target = st->typebound->u.generic; target; target = target->next)
8157 if (!target->specific)
8159 gfc_typebound_proc* overridden_tbp;
8161 const char* target_name;
8163 target_name = target->specific_st->name;
8165 /* Defined for this type directly. */
8166 if (target->specific_st->typebound)
8168 target->specific = target->specific_st->typebound;
8169 goto specific_found;
8172 /* Look for an inherited specific binding. */
8175 inherited = gfc_find_typebound_proc (super_type, NULL,
8180 gcc_assert (inherited->typebound);
8181 target->specific = inherited->typebound;
8182 goto specific_found;
8186 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8187 " at %L", target_name, st->name, &where);
8190 /* Once we've found the specific binding, check it is not ambiguous with
8191 other specifics already found or inherited for the same GENERIC. */
8193 gcc_assert (target->specific);
8195 /* This must really be a specific binding! */
8196 if (target->specific->is_generic)
8198 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8199 " '%s' is GENERIC, too", st->name, &where, target_name);
8203 /* Check those already resolved on this type directly. */
8204 for (g = st->typebound->u.generic; g; g = g->next)
8205 if (g != target && g->specific
8206 && check_generic_tbp_ambiguity (target, g, st->name, where)
8210 /* Check for ambiguity with inherited specific targets. */
8211 for (overridden_tbp = st->typebound->overridden; overridden_tbp;
8212 overridden_tbp = overridden_tbp->overridden)
8213 if (overridden_tbp->is_generic)
8215 for (g = overridden_tbp->u.generic; g; g = g->next)
8217 gcc_assert (g->specific);
8218 if (check_generic_tbp_ambiguity (target, g,
8219 st->name, where) == FAILURE)
8225 /* If we attempt to "overwrite" a specific binding, this is an error. */
8226 if (st->typebound->overridden && !st->typebound->overridden->is_generic)
8228 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8229 " the same name", st->name, &where);
8233 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8234 all must have the same attributes here. */
8235 first_target = st->typebound->u.generic->specific->u.specific;
8236 st->typebound->subroutine = first_target->n.sym->attr.subroutine;
8237 st->typebound->function = first_target->n.sym->attr.function;
8243 /* Resolve the type-bound procedures for a derived type. */
8245 static gfc_symbol* resolve_bindings_derived;
8246 static gfc_try resolve_bindings_result;
8249 resolve_typebound_procedure (gfc_symtree* stree)
8254 gfc_symbol* super_type;
8255 gfc_component* comp;
8257 /* If this is no type-bound procedure, just return. */
8258 if (!stree->typebound)
8261 /* If this is a GENERIC binding, use that routine. */
8262 if (stree->typebound->is_generic)
8264 if (resolve_typebound_generic (resolve_bindings_derived, stree)
8270 /* Get the target-procedure to check it. */
8271 gcc_assert (!stree->typebound->is_generic);
8272 gcc_assert (stree->typebound->u.specific);
8273 proc = stree->typebound->u.specific->n.sym;
8274 where = stree->typebound->where;
8276 /* Default access should already be resolved from the parser. */
8277 gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
8279 /* It should be a module procedure or an external procedure with explicit
8281 if ((!proc->attr.subroutine && !proc->attr.function)
8282 || (proc->attr.proc != PROC_MODULE
8283 && proc->attr.if_source != IFSRC_IFBODY)
8284 || proc->attr.abstract)
8286 gfc_error ("'%s' must be a module procedure or an external procedure with"
8287 " an explicit interface at %L", proc->name, &where);
8290 stree->typebound->subroutine = proc->attr.subroutine;
8291 stree->typebound->function = proc->attr.function;
8293 /* Find the super-type of the current derived type. We could do this once and
8294 store in a global if speed is needed, but as long as not I believe this is
8295 more readable and clearer. */
8296 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
8298 /* If PASS, resolve and check arguments if not already resolved / loaded
8299 from a .mod file. */
8300 if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
8302 if (stree->typebound->pass_arg)
8304 gfc_formal_arglist* i;
8306 /* If an explicit passing argument name is given, walk the arg-list
8310 stree->typebound->pass_arg_num = 1;
8311 for (i = proc->formal; i; i = i->next)
8313 if (!strcmp (i->sym->name, stree->typebound->pass_arg))
8318 ++stree->typebound->pass_arg_num;
8323 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8325 proc->name, stree->typebound->pass_arg, &where,
8326 stree->typebound->pass_arg);
8332 /* Otherwise, take the first one; there should in fact be at least
8334 stree->typebound->pass_arg_num = 1;
8337 gfc_error ("Procedure '%s' with PASS at %L must have at"
8338 " least one argument", proc->name, &where);
8341 me_arg = proc->formal->sym;
8344 /* Now check that the argument-type matches. */
8345 gcc_assert (me_arg);
8346 if (me_arg->ts.type != BT_DERIVED
8347 || me_arg->ts.derived != resolve_bindings_derived)
8349 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8350 " the derived-type '%s'", me_arg->name, proc->name,
8351 me_arg->name, &where, resolve_bindings_derived->name);
8355 gfc_warning ("Polymorphic entities are not yet implemented,"
8356 " non-polymorphic passed-object dummy argument of '%s'"
8357 " at %L accepted", proc->name, &where);
8360 /* If we are extending some type, check that we don't override a procedure
8361 flagged NON_OVERRIDABLE. */
8362 stree->typebound->overridden = NULL;
8365 gfc_symtree* overridden;
8366 overridden = gfc_find_typebound_proc (super_type, NULL,
8369 if (overridden && overridden->typebound)
8370 stree->typebound->overridden = overridden->typebound;
8372 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
8376 /* See if there's a name collision with a component directly in this type. */
8377 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
8378 if (!strcmp (comp->name, stree->name))
8380 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8382 stree->name, &where, resolve_bindings_derived->name);
8386 /* Try to find a name collision with an inherited component. */
8387 if (super_type && gfc_find_component (super_type, stree->name, true, true))
8389 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8390 " component of '%s'",
8391 stree->name, &where, resolve_bindings_derived->name);
8398 resolve_bindings_result = FAILURE;
8402 resolve_typebound_procedures (gfc_symbol* derived)
8404 if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
8407 resolve_bindings_derived = derived;
8408 resolve_bindings_result = SUCCESS;
8409 gfc_traverse_symtree (derived->f2k_derived->sym_root,
8410 &resolve_typebound_procedure);
8412 return resolve_bindings_result;
8416 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8417 to give all identical derived types the same backend_decl. */
8419 add_dt_to_dt_list (gfc_symbol *derived)
8421 gfc_dt_list *dt_list;
8423 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
8424 if (derived == dt_list->derived)
8427 if (dt_list == NULL)
8429 dt_list = gfc_get_dt_list ();
8430 dt_list->next = gfc_derived_types;
8431 dt_list->derived = derived;
8432 gfc_derived_types = dt_list;
8437 /* Resolve the components of a derived type. */
8440 resolve_fl_derived (gfc_symbol *sym)
8442 gfc_symbol* super_type;
8446 super_type = gfc_get_derived_super_type (sym);
8448 /* Ensure the extended type gets resolved before we do. */
8449 if (super_type && resolve_fl_derived (super_type) == FAILURE)
8452 /* An ABSTRACT type must be extensible. */
8453 if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
8455 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
8456 sym->name, &sym->declared_at);
8460 for (c = sym->components; c != NULL; c = c->next)
8462 /* Check type-spec if this is not the parent-type component. */
8463 if ((!sym->attr.extension || c != sym->components)
8464 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
8467 /* If this type is an extension, see if this component has the same name
8468 as an inherited type-bound procedure. */
8470 && gfc_find_typebound_proc (super_type, NULL, c->name, true))
8472 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
8473 " inherited type-bound procedure",
8474 c->name, sym->name, &c->loc);
8478 if (c->ts.type == BT_CHARACTER)
8480 if (c->ts.cl->length == NULL
8481 || (resolve_charlen (c->ts.cl) == FAILURE)
8482 || !gfc_is_constant_expr (c->ts.cl->length))
8484 gfc_error ("Character length of component '%s' needs to "
8485 "be a constant specification expression at %L",
8487 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
8492 if (c->ts.type == BT_DERIVED
8493 && sym->component_access != ACCESS_PRIVATE
8494 && gfc_check_access (sym->attr.access, sym->ns->default_access)
8495 && !c->ts.derived->attr.use_assoc
8496 && !gfc_check_access (c->ts.derived->attr.access,
8497 c->ts.derived->ns->default_access))
8499 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
8500 "a component of '%s', which is PUBLIC at %L",
8501 c->name, sym->name, &sym->declared_at);
8505 if (sym->attr.sequence)
8507 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
8509 gfc_error ("Component %s of SEQUENCE type declared at %L does "
8510 "not have the SEQUENCE attribute",
8511 c->ts.derived->name, &sym->declared_at);
8516 if (c->ts.type == BT_DERIVED && c->attr.pointer
8517 && c->ts.derived->components == NULL
8518 && !c->ts.derived->attr.zero_comp)
8520 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
8521 "that has not been declared", c->name, sym->name,
8526 /* Ensure that all the derived type components are put on the
8527 derived type list; even in formal namespaces, where derived type
8528 pointer components might not have been declared. */
8529 if (c->ts.type == BT_DERIVED
8531 && c->ts.derived->components
8533 && sym != c->ts.derived)
8534 add_dt_to_dt_list (c->ts.derived);
8536 if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
8539 for (i = 0; i < c->as->rank; i++)
8541 if (c->as->lower[i] == NULL
8542 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
8543 || !gfc_is_constant_expr (c->as->lower[i])
8544 || c->as->upper[i] == NULL
8545 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
8546 || !gfc_is_constant_expr (c->as->upper[i]))
8548 gfc_error ("Component '%s' of '%s' at %L must have "
8549 "constant array bounds",
8550 c->name, sym->name, &c->loc);
8556 /* Resolve the type-bound procedures. */
8557 if (resolve_typebound_procedures (sym) == FAILURE)
8560 /* Resolve the finalizer procedures. */
8561 if (gfc_resolve_finalizers (sym) == FAILURE)
8564 /* Add derived type to the derived type list. */
8565 add_dt_to_dt_list (sym);
8572 resolve_fl_namelist (gfc_symbol *sym)
8577 /* Reject PRIVATE objects in a PUBLIC namelist. */
8578 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
8580 for (nl = sym->namelist; nl; nl = nl->next)
8582 if (!nl->sym->attr.use_assoc
8583 && !(sym->ns->parent == nl->sym->ns)
8584 && !(sym->ns->parent
8585 && sym->ns->parent->parent == nl->sym->ns)
8586 && !gfc_check_access(nl->sym->attr.access,
8587 nl->sym->ns->default_access))
8589 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
8590 "cannot be member of PUBLIC namelist '%s' at %L",
8591 nl->sym->name, sym->name, &sym->declared_at);
8595 /* Types with private components that came here by USE-association. */
8596 if (nl->sym->ts.type == BT_DERIVED
8597 && derived_inaccessible (nl->sym->ts.derived))
8599 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
8600 "components and cannot be member of namelist '%s' at %L",
8601 nl->sym->name, sym->name, &sym->declared_at);
8605 /* Types with private components that are defined in the same module. */
8606 if (nl->sym->ts.type == BT_DERIVED
8607 && !(sym->ns->parent == nl->sym->ts.derived->ns)
8608 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
8609 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
8610 nl->sym->ns->default_access))
8612 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
8613 "cannot be a member of PUBLIC namelist '%s' at %L",
8614 nl->sym->name, sym->name, &sym->declared_at);
8620 for (nl = sym->namelist; nl; nl = nl->next)
8622 /* Reject namelist arrays of assumed shape. */
8623 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
8624 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
8625 "must not have assumed shape in namelist "
8626 "'%s' at %L", nl->sym->name, sym->name,
8627 &sym->declared_at) == FAILURE)
8630 /* Reject namelist arrays that are not constant shape. */
8631 if (is_non_constant_shape_array (nl->sym))
8633 gfc_error ("NAMELIST array object '%s' must have constant "
8634 "shape in namelist '%s' at %L", nl->sym->name,
8635 sym->name, &sym->declared_at);
8639 /* Namelist objects cannot have allocatable or pointer components. */
8640 if (nl->sym->ts.type != BT_DERIVED)
8643 if (nl->sym->ts.derived->attr.alloc_comp)
8645 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8646 "have ALLOCATABLE components",
8647 nl->sym->name, sym->name, &sym->declared_at);
8651 if (nl->sym->ts.derived->attr.pointer_comp)
8653 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8654 "have POINTER components",
8655 nl->sym->name, sym->name, &sym->declared_at);
8661 /* 14.1.2 A module or internal procedure represent local entities
8662 of the same type as a namelist member and so are not allowed. */
8663 for (nl = sym->namelist; nl; nl = nl->next)
8665 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
8668 if (nl->sym->attr.function && nl->sym == nl->sym->result)
8669 if ((nl->sym == sym->ns->proc_name)
8671 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
8675 if (nl->sym && nl->sym->name)
8676 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
8677 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
8679 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
8680 "attribute in '%s' at %L", nlsym->name,
8691 resolve_fl_parameter (gfc_symbol *sym)
8693 /* A parameter array's shape needs to be constant. */
8695 && (sym->as->type == AS_DEFERRED
8696 || is_non_constant_shape_array (sym)))
8698 gfc_error ("Parameter array '%s' at %L cannot be automatic "
8699 "or of deferred shape", sym->name, &sym->declared_at);
8703 /* Make sure a parameter that has been implicitly typed still
8704 matches the implicit type, since PARAMETER statements can precede
8705 IMPLICIT statements. */
8706 if (sym->attr.implicit_type
8707 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
8709 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
8710 "later IMPLICIT type", sym->name, &sym->declared_at);
8714 /* Make sure the types of derived parameters are consistent. This
8715 type checking is deferred until resolution because the type may
8716 refer to a derived type from the host. */
8717 if (sym->ts.type == BT_DERIVED
8718 && !gfc_compare_types (&sym->ts, &sym->value->ts))
8720 gfc_error ("Incompatible derived type in PARAMETER at %L",
8721 &sym->value->where);
8728 /* Do anything necessary to resolve a symbol. Right now, we just
8729 assume that an otherwise unknown symbol is a variable. This sort
8730 of thing commonly happens for symbols in module. */
8733 resolve_symbol (gfc_symbol *sym)
8735 int check_constant, mp_flag;
8736 gfc_symtree *symtree;
8737 gfc_symtree *this_symtree;
8741 if (sym->attr.flavor == FL_UNKNOWN)
8744 /* If we find that a flavorless symbol is an interface in one of the
8745 parent namespaces, find its symtree in this namespace, free the
8746 symbol and set the symtree to point to the interface symbol. */
8747 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
8749 symtree = gfc_find_symtree (ns->sym_root, sym->name);
8750 if (symtree && symtree->n.sym->generic)
8752 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
8756 gfc_free_symbol (sym);
8757 symtree->n.sym->refs++;
8758 this_symtree->n.sym = symtree->n.sym;
8763 /* Otherwise give it a flavor according to such attributes as
8765 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
8766 sym->attr.flavor = FL_VARIABLE;
8769 sym->attr.flavor = FL_PROCEDURE;
8770 if (sym->attr.dimension)
8771 sym->attr.function = 1;
8775 if (sym->attr.procedure && sym->ts.interface
8776 && sym->attr.if_source != IFSRC_DECL)
8778 if (sym->ts.interface->attr.procedure)
8779 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
8780 "in a later PROCEDURE statement", sym->ts.interface->name,
8781 sym->name,&sym->declared_at);
8783 /* Get the attributes from the interface (now resolved). */
8784 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
8786 gfc_symbol *ifc = sym->ts.interface;
8788 sym->ts.interface = ifc;
8789 sym->attr.function = ifc->attr.function;
8790 sym->attr.subroutine = ifc->attr.subroutine;
8791 sym->attr.allocatable = ifc->attr.allocatable;
8792 sym->attr.pointer = ifc->attr.pointer;
8793 sym->attr.pure = ifc->attr.pure;
8794 sym->attr.elemental = ifc->attr.elemental;
8795 sym->attr.dimension = ifc->attr.dimension;
8796 sym->attr.recursive = ifc->attr.recursive;
8797 sym->attr.always_explicit = ifc->attr.always_explicit;
8798 sym->as = gfc_copy_array_spec (ifc->as);
8799 copy_formal_args (sym, ifc);
8801 else if (sym->ts.interface->name[0] != '\0')
8803 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
8804 sym->ts.interface->name, sym->name, &sym->declared_at);
8809 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
8812 /* Symbols that are module procedures with results (functions) have
8813 the types and array specification copied for type checking in
8814 procedures that call them, as well as for saving to a module
8815 file. These symbols can't stand the scrutiny that their results
8817 mp_flag = (sym->result != NULL && sym->result != sym);
8820 /* Make sure that the intrinsic is consistent with its internal
8821 representation. This needs to be done before assigning a default
8822 type to avoid spurious warnings. */
8823 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
8825 gfc_intrinsic_sym* isym;
8828 /* We already know this one is an intrinsic, so we don't call
8829 gfc_is_intrinsic for full checking but rather use gfc_find_function and
8830 gfc_find_subroutine directly to check whether it is a function or
8833 if ((isym = gfc_find_function (sym->name)))
8835 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
8836 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
8837 " ignored", sym->name, &sym->declared_at);
8839 else if ((isym = gfc_find_subroutine (sym->name)))
8841 if (sym->ts.type != BT_UNKNOWN)
8843 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
8844 " specifier", sym->name, &sym->declared_at);
8850 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
8851 sym->name, &sym->declared_at);
8855 /* Check it is actually available in the standard settings. */
8856 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
8859 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
8860 " available in the current standard settings but %s. Use"
8861 " an appropriate -std=* option or enable -fall-intrinsics"
8862 " in order to use it.",
8863 sym->name, &sym->declared_at, symstd);
8868 /* Assign default type to symbols that need one and don't have one. */
8869 if (sym->ts.type == BT_UNKNOWN)
8871 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
8872 gfc_set_default_type (sym, 1, NULL);
8874 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
8876 /* The specific case of an external procedure should emit an error
8877 in the case that there is no implicit type. */
8879 gfc_set_default_type (sym, sym->attr.external, NULL);
8882 /* Result may be in another namespace. */
8883 resolve_symbol (sym->result);
8885 sym->ts = sym->result->ts;
8886 sym->as = gfc_copy_array_spec (sym->result->as);
8887 sym->attr.dimension = sym->result->attr.dimension;
8888 sym->attr.pointer = sym->result->attr.pointer;
8889 sym->attr.allocatable = sym->result->attr.allocatable;
8894 /* Assumed size arrays and assumed shape arrays must be dummy
8898 && (sym->as->type == AS_ASSUMED_SIZE
8899 || sym->as->type == AS_ASSUMED_SHAPE)
8900 && sym->attr.dummy == 0)
8902 if (sym->as->type == AS_ASSUMED_SIZE)
8903 gfc_error ("Assumed size array at %L must be a dummy argument",
8906 gfc_error ("Assumed shape array at %L must be a dummy argument",
8911 /* Make sure symbols with known intent or optional are really dummy
8912 variable. Because of ENTRY statement, this has to be deferred
8913 until resolution time. */
8915 if (!sym->attr.dummy
8916 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
8918 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
8922 if (sym->attr.value && !sym->attr.dummy)
8924 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
8925 "it is not a dummy argument", sym->name, &sym->declared_at);
8929 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
8931 gfc_charlen *cl = sym->ts.cl;
8932 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
8934 gfc_error ("Character dummy variable '%s' at %L with VALUE "
8935 "attribute must have constant length",
8936 sym->name, &sym->declared_at);
8940 if (sym->ts.is_c_interop
8941 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
8943 gfc_error ("C interoperable character dummy variable '%s' at %L "
8944 "with VALUE attribute must have length one",
8945 sym->name, &sym->declared_at);
8950 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
8951 do this for something that was implicitly typed because that is handled
8952 in gfc_set_default_type. Handle dummy arguments and procedure
8953 definitions separately. Also, anything that is use associated is not
8954 handled here but instead is handled in the module it is declared in.
8955 Finally, derived type definitions are allowed to be BIND(C) since that
8956 only implies that they're interoperable, and they are checked fully for
8957 interoperability when a variable is declared of that type. */
8958 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
8959 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
8960 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
8962 gfc_try t = SUCCESS;
8964 /* First, make sure the variable is declared at the
8965 module-level scope (J3/04-007, Section 15.3). */
8966 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
8967 sym->attr.in_common == 0)
8969 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
8970 "is neither a COMMON block nor declared at the "
8971 "module level scope", sym->name, &(sym->declared_at));
8974 else if (sym->common_head != NULL)
8976 t = verify_com_block_vars_c_interop (sym->common_head);
8980 /* If type() declaration, we need to verify that the components
8981 of the given type are all C interoperable, etc. */
8982 if (sym->ts.type == BT_DERIVED &&
8983 sym->ts.derived->attr.is_c_interop != 1)
8985 /* Make sure the user marked the derived type as BIND(C). If
8986 not, call the verify routine. This could print an error
8987 for the derived type more than once if multiple variables
8988 of that type are declared. */
8989 if (sym->ts.derived->attr.is_bind_c != 1)
8990 verify_bind_c_derived_type (sym->ts.derived);
8994 /* Verify the variable itself as C interoperable if it
8995 is BIND(C). It is not possible for this to succeed if
8996 the verify_bind_c_derived_type failed, so don't have to handle
8997 any error returned by verify_bind_c_derived_type. */
8998 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9004 /* clear the is_bind_c flag to prevent reporting errors more than
9005 once if something failed. */
9006 sym->attr.is_bind_c = 0;
9011 /* If a derived type symbol has reached this point, without its
9012 type being declared, we have an error. Notice that most
9013 conditions that produce undefined derived types have already
9014 been dealt with. However, the likes of:
9015 implicit type(t) (t) ..... call foo (t) will get us here if
9016 the type is not declared in the scope of the implicit
9017 statement. Change the type to BT_UNKNOWN, both because it is so
9018 and to prevent an ICE. */
9019 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
9020 && !sym->ts.derived->attr.zero_comp)
9022 gfc_error ("The derived type '%s' at %L is of type '%s', "
9023 "which has not been defined", sym->name,
9024 &sym->declared_at, sym->ts.derived->name);
9025 sym->ts.type = BT_UNKNOWN;
9029 /* Make sure that the derived type has been resolved and that the
9030 derived type is visible in the symbol's namespace, if it is a
9031 module function and is not PRIVATE. */
9032 if (sym->ts.type == BT_DERIVED
9033 && sym->ts.derived->attr.use_assoc
9034 && sym->ns->proc_name->attr.flavor == FL_MODULE)
9038 if (resolve_fl_derived (sym->ts.derived) == FAILURE)
9041 gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
9042 if (!ds && sym->attr.function
9043 && gfc_check_access (sym->attr.access, sym->ns->default_access))
9045 symtree = gfc_new_symtree (&sym->ns->sym_root,
9046 sym->ts.derived->name);
9047 symtree->n.sym = sym->ts.derived;
9048 sym->ts.derived->refs++;
9052 /* Unless the derived-type declaration is use associated, Fortran 95
9053 does not allow public entries of private derived types.
9054 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9056 if (sym->ts.type == BT_DERIVED
9057 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
9058 && !sym->ts.derived->attr.use_assoc
9059 && gfc_check_access (sym->attr.access, sym->ns->default_access)
9060 && !gfc_check_access (sym->ts.derived->attr.access,
9061 sym->ts.derived->ns->default_access)
9062 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
9063 "of PRIVATE derived type '%s'",
9064 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
9065 : "variable", sym->name, &sym->declared_at,
9066 sym->ts.derived->name) == FAILURE)
9069 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9070 default initialization is defined (5.1.2.4.4). */
9071 if (sym->ts.type == BT_DERIVED
9073 && sym->attr.intent == INTENT_OUT
9075 && sym->as->type == AS_ASSUMED_SIZE)
9077 for (c = sym->ts.derived->components; c; c = c->next)
9081 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9082 "ASSUMED SIZE and so cannot have a default initializer",
9083 sym->name, &sym->declared_at);
9089 switch (sym->attr.flavor)
9092 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
9097 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
9102 if (resolve_fl_namelist (sym) == FAILURE)
9107 if (resolve_fl_parameter (sym) == FAILURE)
9115 /* Resolve array specifier. Check as well some constraints
9116 on COMMON blocks. */
9118 check_constant = sym->attr.in_common && !sym->attr.pointer;
9120 /* Set the formal_arg_flag so that check_conflict will not throw
9121 an error for host associated variables in the specification
9122 expression for an array_valued function. */
9123 if (sym->attr.function && sym->as)
9124 formal_arg_flag = 1;
9126 gfc_resolve_array_spec (sym->as, check_constant);
9128 formal_arg_flag = 0;
9130 /* Resolve formal namespaces. */
9131 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
9132 gfc_resolve (sym->formal_ns);
9134 /* Check threadprivate restrictions. */
9135 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
9136 && (!sym->attr.in_common
9137 && sym->module == NULL
9138 && (sym->ns->proc_name == NULL
9139 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
9140 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
9142 /* If we have come this far we can apply default-initializers, as
9143 described in 14.7.5, to those variables that have not already
9144 been assigned one. */
9145 if (sym->ts.type == BT_DERIVED
9146 && sym->attr.referenced
9147 && sym->ns == gfc_current_ns
9149 && !sym->attr.allocatable
9150 && !sym->attr.alloc_comp)
9152 symbol_attribute *a = &sym->attr;
9154 if ((!a->save && !a->dummy && !a->pointer
9155 && !a->in_common && !a->use_assoc
9156 && !(a->function && sym != sym->result))
9157 || (a->dummy && a->intent == INTENT_OUT))
9158 apply_default_init (sym);
9161 /* If this symbol has a type-spec, check it. */
9162 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
9163 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
9164 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
9170 /************* Resolve DATA statements *************/
9174 gfc_data_value *vnode;
9180 /* Advance the values structure to point to the next value in the data list. */
9183 next_data_value (void)
9186 while (mpz_cmp_ui (values.left, 0) == 0)
9188 if (values.vnode->next == NULL)
9191 values.vnode = values.vnode->next;
9192 mpz_set (values.left, values.vnode->repeat);
9200 check_data_variable (gfc_data_variable *var, locus *where)
9206 ar_type mark = AR_UNKNOWN;
9208 mpz_t section_index[GFC_MAX_DIMENSIONS];
9212 if (gfc_resolve_expr (var->expr) == FAILURE)
9216 mpz_init_set_si (offset, 0);
9219 if (e->expr_type != EXPR_VARIABLE)
9220 gfc_internal_error ("check_data_variable(): Bad expression");
9222 if (e->symtree->n.sym->ns->is_block_data
9223 && !e->symtree->n.sym->attr.in_common)
9225 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9226 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
9229 if (e->ref == NULL && e->symtree->n.sym->as)
9231 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9232 " declaration", e->symtree->n.sym->name, where);
9238 mpz_init_set_ui (size, 1);
9245 /* Find the array section reference. */
9246 for (ref = e->ref; ref; ref = ref->next)
9248 if (ref->type != REF_ARRAY)
9250 if (ref->u.ar.type == AR_ELEMENT)
9256 /* Set marks according to the reference pattern. */
9257 switch (ref->u.ar.type)
9265 /* Get the start position of array section. */
9266 gfc_get_section_index (ar, section_index, &offset);
9274 if (gfc_array_size (e, &size) == FAILURE)
9276 gfc_error ("Nonconstant array section at %L in DATA statement",
9285 while (mpz_cmp_ui (size, 0) > 0)
9287 if (next_data_value () == FAILURE)
9289 gfc_error ("DATA statement at %L has more variables than values",
9295 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
9299 /* If we have more than one element left in the repeat count,
9300 and we have more than one element left in the target variable,
9301 then create a range assignment. */
9302 /* FIXME: Only done for full arrays for now, since array sections
9304 if (mark == AR_FULL && ref && ref->next == NULL
9305 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
9309 if (mpz_cmp (size, values.left) >= 0)
9311 mpz_init_set (range, values.left);
9312 mpz_sub (size, size, values.left);
9313 mpz_set_ui (values.left, 0);
9317 mpz_init_set (range, size);
9318 mpz_sub (values.left, values.left, size);
9319 mpz_set_ui (size, 0);
9322 gfc_assign_data_value_range (var->expr, values.vnode->expr,
9325 mpz_add (offset, offset, range);
9329 /* Assign initial value to symbol. */
9332 mpz_sub_ui (values.left, values.left, 1);
9333 mpz_sub_ui (size, size, 1);
9335 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
9339 if (mark == AR_FULL)
9340 mpz_add_ui (offset, offset, 1);
9342 /* Modify the array section indexes and recalculate the offset
9343 for next element. */
9344 else if (mark == AR_SECTION)
9345 gfc_advance_section (section_index, ar, &offset);
9349 if (mark == AR_SECTION)
9351 for (i = 0; i < ar->dimen; i++)
9352 mpz_clear (section_index[i]);
9362 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
9364 /* Iterate over a list of elements in a DATA statement. */
9367 traverse_data_list (gfc_data_variable *var, locus *where)
9370 iterator_stack frame;
9371 gfc_expr *e, *start, *end, *step;
9372 gfc_try retval = SUCCESS;
9374 mpz_init (frame.value);
9376 start = gfc_copy_expr (var->iter.start);
9377 end = gfc_copy_expr (var->iter.end);
9378 step = gfc_copy_expr (var->iter.step);
9380 if (gfc_simplify_expr (start, 1) == FAILURE
9381 || start->expr_type != EXPR_CONSTANT)
9383 gfc_error ("iterator start at %L does not simplify", &start->where);
9387 if (gfc_simplify_expr (end, 1) == FAILURE
9388 || end->expr_type != EXPR_CONSTANT)
9390 gfc_error ("iterator end at %L does not simplify", &end->where);
9394 if (gfc_simplify_expr (step, 1) == FAILURE
9395 || step->expr_type != EXPR_CONSTANT)
9397 gfc_error ("iterator step at %L does not simplify", &step->where);
9402 mpz_init_set (trip, end->value.integer);
9403 mpz_sub (trip, trip, start->value.integer);
9404 mpz_add (trip, trip, step->value.integer);
9406 mpz_div (trip, trip, step->value.integer);
9408 mpz_set (frame.value, start->value.integer);
9410 frame.prev = iter_stack;
9411 frame.variable = var->iter.var->symtree;
9412 iter_stack = &frame;
9414 while (mpz_cmp_ui (trip, 0) > 0)
9416 if (traverse_data_var (var->list, where) == FAILURE)
9423 e = gfc_copy_expr (var->expr);
9424 if (gfc_simplify_expr (e, 1) == FAILURE)
9432 mpz_add (frame.value, frame.value, step->value.integer);
9434 mpz_sub_ui (trip, trip, 1);
9439 mpz_clear (frame.value);
9441 gfc_free_expr (start);
9442 gfc_free_expr (end);
9443 gfc_free_expr (step);
9445 iter_stack = frame.prev;
9450 /* Type resolve variables in the variable list of a DATA statement. */
9453 traverse_data_var (gfc_data_variable *var, locus *where)
9457 for (; var; var = var->next)
9459 if (var->expr == NULL)
9460 t = traverse_data_list (var, where);
9462 t = check_data_variable (var, where);
9472 /* Resolve the expressions and iterators associated with a data statement.
9473 This is separate from the assignment checking because data lists should
9474 only be resolved once. */
9477 resolve_data_variables (gfc_data_variable *d)
9479 for (; d; d = d->next)
9481 if (d->list == NULL)
9483 if (gfc_resolve_expr (d->expr) == FAILURE)
9488 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
9491 if (resolve_data_variables (d->list) == FAILURE)
9500 /* Resolve a single DATA statement. We implement this by storing a pointer to
9501 the value list into static variables, and then recursively traversing the
9502 variables list, expanding iterators and such. */
9505 resolve_data (gfc_data *d)
9508 if (resolve_data_variables (d->var) == FAILURE)
9511 values.vnode = d->value;
9512 if (d->value == NULL)
9513 mpz_set_ui (values.left, 0);
9515 mpz_set (values.left, d->value->repeat);
9517 if (traverse_data_var (d->var, &d->where) == FAILURE)
9520 /* At this point, we better not have any values left. */
9522 if (next_data_value () == SUCCESS)
9523 gfc_error ("DATA statement at %L has more values than variables",
9528 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
9529 accessed by host or use association, is a dummy argument to a pure function,
9530 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
9531 is storage associated with any such variable, shall not be used in the
9532 following contexts: (clients of this function). */
9534 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
9535 procedure. Returns zero if assignment is OK, nonzero if there is a
9538 gfc_impure_variable (gfc_symbol *sym)
9542 if (sym->attr.use_assoc || sym->attr.in_common)
9545 if (sym->ns != gfc_current_ns)
9546 return !sym->attr.function;
9548 proc = sym->ns->proc_name;
9549 if (sym->attr.dummy && gfc_pure (proc)
9550 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
9552 proc->attr.function))
9555 /* TODO: Sort out what can be storage associated, if anything, and include
9556 it here. In principle equivalences should be scanned but it does not
9557 seem to be possible to storage associate an impure variable this way. */
9562 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
9563 symbol of the current procedure. */
9566 gfc_pure (gfc_symbol *sym)
9568 symbol_attribute attr;
9571 sym = gfc_current_ns->proc_name;
9577 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
9581 /* Test whether the current procedure is elemental or not. */
9584 gfc_elemental (gfc_symbol *sym)
9586 symbol_attribute attr;
9589 sym = gfc_current_ns->proc_name;
9594 return attr.flavor == FL_PROCEDURE && attr.elemental;
9598 /* Warn about unused labels. */
9601 warn_unused_fortran_label (gfc_st_label *label)
9606 warn_unused_fortran_label (label->left);
9608 if (label->defined == ST_LABEL_UNKNOWN)
9611 switch (label->referenced)
9613 case ST_LABEL_UNKNOWN:
9614 gfc_warning ("Label %d at %L defined but not used", label->value,
9618 case ST_LABEL_BAD_TARGET:
9619 gfc_warning ("Label %d at %L defined but cannot be used",
9620 label->value, &label->where);
9627 warn_unused_fortran_label (label->right);
9631 /* Returns the sequence type of a symbol or sequence. */
9634 sequence_type (gfc_typespec ts)
9643 if (ts.derived->components == NULL)
9644 return SEQ_NONDEFAULT;
9646 result = sequence_type (ts.derived->components->ts);
9647 for (c = ts.derived->components->next; c; c = c->next)
9648 if (sequence_type (c->ts) != result)
9654 if (ts.kind != gfc_default_character_kind)
9655 return SEQ_NONDEFAULT;
9657 return SEQ_CHARACTER;
9660 if (ts.kind != gfc_default_integer_kind)
9661 return SEQ_NONDEFAULT;
9666 if (!(ts.kind == gfc_default_real_kind
9667 || ts.kind == gfc_default_double_kind))
9668 return SEQ_NONDEFAULT;
9673 if (ts.kind != gfc_default_complex_kind)
9674 return SEQ_NONDEFAULT;
9679 if (ts.kind != gfc_default_logical_kind)
9680 return SEQ_NONDEFAULT;
9685 return SEQ_NONDEFAULT;
9690 /* Resolve derived type EQUIVALENCE object. */
9693 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
9696 gfc_component *c = derived->components;
9701 /* Shall not be an object of nonsequence derived type. */
9702 if (!derived->attr.sequence)
9704 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
9705 "attribute to be an EQUIVALENCE object", sym->name,
9710 /* Shall not have allocatable components. */
9711 if (derived->attr.alloc_comp)
9713 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
9714 "components to be an EQUIVALENCE object",sym->name,
9719 if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
9721 gfc_error ("Derived type variable '%s' at %L with default "
9722 "initialization cannot be in EQUIVALENCE with a variable "
9723 "in COMMON", sym->name, &e->where);
9727 for (; c ; c = c->next)
9731 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
9734 /* Shall not be an object of sequence derived type containing a pointer
9735 in the structure. */
9736 if (c->attr.pointer)
9738 gfc_error ("Derived type variable '%s' at %L with pointer "
9739 "component(s) cannot be an EQUIVALENCE object",
9740 sym->name, &e->where);
9748 /* Resolve equivalence object.
9749 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
9750 an allocatable array, an object of nonsequence derived type, an object of
9751 sequence derived type containing a pointer at any level of component
9752 selection, an automatic object, a function name, an entry name, a result
9753 name, a named constant, a structure component, or a subobject of any of
9754 the preceding objects. A substring shall not have length zero. A
9755 derived type shall not have components with default initialization nor
9756 shall two objects of an equivalence group be initialized.
9757 Either all or none of the objects shall have an protected attribute.
9758 The simple constraints are done in symbol.c(check_conflict) and the rest
9759 are implemented here. */
9762 resolve_equivalence (gfc_equiv *eq)
9765 gfc_symbol *derived;
9766 gfc_symbol *first_sym;
9769 locus *last_where = NULL;
9770 seq_type eq_type, last_eq_type;
9771 gfc_typespec *last_ts;
9772 int object, cnt_protected;
9773 const char *value_name;
9777 last_ts = &eq->expr->symtree->n.sym->ts;
9779 first_sym = eq->expr->symtree->n.sym;
9783 for (object = 1; eq; eq = eq->eq, object++)
9787 e->ts = e->symtree->n.sym->ts;
9788 /* match_varspec might not know yet if it is seeing
9789 array reference or substring reference, as it doesn't
9791 if (e->ref && e->ref->type == REF_ARRAY)
9793 gfc_ref *ref = e->ref;
9794 sym = e->symtree->n.sym;
9796 if (sym->attr.dimension)
9798 ref->u.ar.as = sym->as;
9802 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
9803 if (e->ts.type == BT_CHARACTER
9805 && ref->type == REF_ARRAY
9806 && ref->u.ar.dimen == 1
9807 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
9808 && ref->u.ar.stride[0] == NULL)
9810 gfc_expr *start = ref->u.ar.start[0];
9811 gfc_expr *end = ref->u.ar.end[0];
9814 /* Optimize away the (:) reference. */
9815 if (start == NULL && end == NULL)
9820 e->ref->next = ref->next;
9825 ref->type = REF_SUBSTRING;
9827 start = gfc_int_expr (1);
9828 ref->u.ss.start = start;
9829 if (end == NULL && e->ts.cl)
9830 end = gfc_copy_expr (e->ts.cl->length);
9831 ref->u.ss.end = end;
9832 ref->u.ss.length = e->ts.cl;
9839 /* Any further ref is an error. */
9842 gcc_assert (ref->type == REF_ARRAY);
9843 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
9849 if (gfc_resolve_expr (e) == FAILURE)
9852 sym = e->symtree->n.sym;
9854 if (sym->attr.is_protected)
9856 if (cnt_protected > 0 && cnt_protected != object)
9858 gfc_error ("Either all or none of the objects in the "
9859 "EQUIVALENCE set at %L shall have the "
9860 "PROTECTED attribute",
9865 /* Shall not equivalence common block variables in a PURE procedure. */
9866 if (sym->ns->proc_name
9867 && sym->ns->proc_name->attr.pure
9868 && sym->attr.in_common)
9870 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
9871 "object in the pure procedure '%s'",
9872 sym->name, &e->where, sym->ns->proc_name->name);
9876 /* Shall not be a named constant. */
9877 if (e->expr_type == EXPR_CONSTANT)
9879 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
9880 "object", sym->name, &e->where);
9884 derived = e->ts.derived;
9885 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
9888 /* Check that the types correspond correctly:
9890 A numeric sequence structure may be equivalenced to another sequence
9891 structure, an object of default integer type, default real type, double
9892 precision real type, default logical type such that components of the
9893 structure ultimately only become associated to objects of the same
9894 kind. A character sequence structure may be equivalenced to an object
9895 of default character kind or another character sequence structure.
9896 Other objects may be equivalenced only to objects of the same type and
9899 /* Identical types are unconditionally OK. */
9900 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
9901 goto identical_types;
9903 last_eq_type = sequence_type (*last_ts);
9904 eq_type = sequence_type (sym->ts);
9906 /* Since the pair of objects is not of the same type, mixed or
9907 non-default sequences can be rejected. */
9909 msg = "Sequence %s with mixed components in EQUIVALENCE "
9910 "statement at %L with different type objects";
9912 && last_eq_type == SEQ_MIXED
9913 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
9915 || (eq_type == SEQ_MIXED
9916 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
9917 &e->where) == FAILURE))
9920 msg = "Non-default type object or sequence %s in EQUIVALENCE "
9921 "statement at %L with objects of different type";
9923 && last_eq_type == SEQ_NONDEFAULT
9924 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
9925 last_where) == FAILURE)
9926 || (eq_type == SEQ_NONDEFAULT
9927 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
9928 &e->where) == FAILURE))
9931 msg ="Non-CHARACTER object '%s' in default CHARACTER "
9932 "EQUIVALENCE statement at %L";
9933 if (last_eq_type == SEQ_CHARACTER
9934 && eq_type != SEQ_CHARACTER
9935 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
9936 &e->where) == FAILURE)
9939 msg ="Non-NUMERIC object '%s' in default NUMERIC "
9940 "EQUIVALENCE statement at %L";
9941 if (last_eq_type == SEQ_NUMERIC
9942 && eq_type != SEQ_NUMERIC
9943 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
9944 &e->where) == FAILURE)
9949 last_where = &e->where;
9954 /* Shall not be an automatic array. */
9955 if (e->ref->type == REF_ARRAY
9956 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
9958 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
9959 "an EQUIVALENCE object", sym->name, &e->where);
9966 /* Shall not be a structure component. */
9967 if (r->type == REF_COMPONENT)
9969 gfc_error ("Structure component '%s' at %L cannot be an "
9970 "EQUIVALENCE object",
9971 r->u.c.component->name, &e->where);
9975 /* A substring shall not have length zero. */
9976 if (r->type == REF_SUBSTRING)
9978 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
9980 gfc_error ("Substring at %L has length zero",
9981 &r->u.ss.start->where);
9991 /* Resolve function and ENTRY types, issue diagnostics if needed. */
9994 resolve_fntype (gfc_namespace *ns)
9999 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
10002 /* If there are any entries, ns->proc_name is the entry master
10003 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10005 sym = ns->entries->sym;
10007 sym = ns->proc_name;
10008 if (sym->result == sym
10009 && sym->ts.type == BT_UNKNOWN
10010 && gfc_set_default_type (sym, 0, NULL) == FAILURE
10011 && !sym->attr.untyped)
10013 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10014 sym->name, &sym->declared_at);
10015 sym->attr.untyped = 1;
10018 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
10019 && !gfc_check_access (sym->ts.derived->attr.access,
10020 sym->ts.derived->ns->default_access)
10021 && gfc_check_access (sym->attr.access, sym->ns->default_access))
10023 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
10024 sym->name, &sym->declared_at, sym->ts.derived->name);
10028 for (el = ns->entries->next; el; el = el->next)
10030 if (el->sym->result == el->sym
10031 && el->sym->ts.type == BT_UNKNOWN
10032 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
10033 && !el->sym->attr.untyped)
10035 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10036 el->sym->name, &el->sym->declared_at);
10037 el->sym->attr.untyped = 1;
10042 /* 12.3.2.1.1 Defined operators. */
10045 gfc_resolve_uops (gfc_symtree *symtree)
10047 gfc_interface *itr;
10049 gfc_formal_arglist *formal;
10051 if (symtree == NULL)
10054 gfc_resolve_uops (symtree->left);
10055 gfc_resolve_uops (symtree->right);
10057 for (itr = symtree->n.uop->op; itr; itr = itr->next)
10060 if (!sym->attr.function)
10061 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10062 sym->name, &sym->declared_at);
10064 if (sym->ts.type == BT_CHARACTER
10065 && !(sym->ts.cl && sym->ts.cl->length)
10066 && !(sym->result && sym->result->ts.cl
10067 && sym->result->ts.cl->length))
10068 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10069 "character length", sym->name, &sym->declared_at);
10071 formal = sym->formal;
10072 if (!formal || !formal->sym)
10074 gfc_error ("User operator procedure '%s' at %L must have at least "
10075 "one argument", sym->name, &sym->declared_at);
10079 if (formal->sym->attr.intent != INTENT_IN)
10080 gfc_error ("First argument of operator interface at %L must be "
10081 "INTENT(IN)", &sym->declared_at);
10083 if (formal->sym->attr.optional)
10084 gfc_error ("First argument of operator interface at %L cannot be "
10085 "optional", &sym->declared_at);
10087 formal = formal->next;
10088 if (!formal || !formal->sym)
10091 if (formal->sym->attr.intent != INTENT_IN)
10092 gfc_error ("Second argument of operator interface at %L must be "
10093 "INTENT(IN)", &sym->declared_at);
10095 if (formal->sym->attr.optional)
10096 gfc_error ("Second argument of operator interface at %L cannot be "
10097 "optional", &sym->declared_at);
10100 gfc_error ("Operator interface at %L must have, at most, two "
10101 "arguments", &sym->declared_at);
10106 /* Examine all of the expressions associated with a program unit,
10107 assign types to all intermediate expressions, make sure that all
10108 assignments are to compatible types and figure out which names
10109 refer to which functions or subroutines. It doesn't check code
10110 block, which is handled by resolve_code. */
10113 resolve_types (gfc_namespace *ns)
10119 gfc_namespace* old_ns = gfc_current_ns;
10121 /* Check that all IMPLICIT types are ok. */
10122 if (!ns->seen_implicit_none)
10125 for (letter = 0; letter != GFC_LETTERS; ++letter)
10126 if (ns->set_flag[letter]
10127 && resolve_typespec_used (&ns->default_type[letter],
10128 &ns->implicit_loc[letter],
10133 gfc_current_ns = ns;
10135 resolve_entries (ns);
10137 resolve_common_vars (ns->blank_common.head, false);
10138 resolve_common_blocks (ns->common_root);
10140 resolve_contained_functions (ns);
10142 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
10144 for (cl = ns->cl_list; cl; cl = cl->next)
10145 resolve_charlen (cl);
10147 gfc_traverse_ns (ns, resolve_symbol);
10149 resolve_fntype (ns);
10151 for (n = ns->contained; n; n = n->sibling)
10153 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
10154 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10155 "also be PURE", n->proc_name->name,
10156 &n->proc_name->declared_at);
10162 gfc_check_interfaces (ns);
10164 gfc_traverse_ns (ns, resolve_values);
10170 for (d = ns->data; d; d = d->next)
10174 gfc_traverse_ns (ns, gfc_formalize_init_value);
10176 gfc_traverse_ns (ns, gfc_verify_binding_labels);
10178 if (ns->common_root != NULL)
10179 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
10181 for (eq = ns->equiv; eq; eq = eq->next)
10182 resolve_equivalence (eq);
10184 /* Warn about unused labels. */
10185 if (warn_unused_label)
10186 warn_unused_fortran_label (ns->st_labels);
10188 gfc_resolve_uops (ns->uop_root);
10190 gfc_current_ns = old_ns;
10194 /* Call resolve_code recursively. */
10197 resolve_codes (gfc_namespace *ns)
10201 for (n = ns->contained; n; n = n->sibling)
10204 gfc_current_ns = ns;
10206 /* Set to an out of range value. */
10207 current_entry_id = -1;
10209 bitmap_obstack_initialize (&labels_obstack);
10210 resolve_code (ns->code, ns);
10211 bitmap_obstack_release (&labels_obstack);
10215 /* This function is called after a complete program unit has been compiled.
10216 Its purpose is to examine all of the expressions associated with a program
10217 unit, assign types to all intermediate expressions, make sure that all
10218 assignments are to compatible types and figure out which names refer to
10219 which functions or subroutines. */
10222 gfc_resolve (gfc_namespace *ns)
10224 gfc_namespace *old_ns;
10226 old_ns = gfc_current_ns;
10228 resolve_types (ns);
10229 resolve_codes (ns);
10231 gfc_current_ns = old_ns;