1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
41 /* Stack to keep track of the nesting of blocks as we move through the
42 code. See resolve_branch() and resolve_code(). */
44 typedef struct code_stack
46 struct gfc_code *head, *current, *tail;
47 struct code_stack *prev;
49 /* This bitmap keeps track of the targets valid for a branch from
51 bitmap reachable_labels;
55 static code_stack *cs_base = NULL;
58 /* Nonzero if we're inside a FORALL block. */
60 static int forall_flag;
62 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
64 static int omp_workshare_flag;
66 /* Nonzero if we are processing a formal arglist. The corresponding function
67 resets the flag each time that it is read. */
68 static int formal_arg_flag = 0;
70 /* True if we are resolving a specification expression. */
71 static int specification_expr = 0;
73 /* The id of the last entry seen. */
74 static int current_entry_id;
76 /* We use bitmaps to determine if a branch target is valid. */
77 static bitmap_obstack labels_obstack;
80 gfc_is_formal_arg (void)
82 return formal_arg_flag;
86 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
87 an ABSTRACT derived-type. If where is not NULL, an error message with that
88 locus is printed, optionally using name. */
91 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
93 if (ts->type == BT_DERIVED && ts->derived->attr.abstract)
98 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
99 name, where, ts->derived->name);
101 gfc_error ("ABSTRACT type '%s' used at %L",
102 ts->derived->name, where);
112 /* Resolve types of formal argument lists. These have to be done early so that
113 the formal argument lists of module procedures can be copied to the
114 containing module before the individual procedures are resolved
115 individually. We also resolve argument lists of procedures in interface
116 blocks because they are self-contained scoping units.
118 Since a dummy argument cannot be a non-dummy procedure, the only
119 resort left for untyped names are the IMPLICIT types. */
122 resolve_formal_arglist (gfc_symbol *proc)
124 gfc_formal_arglist *f;
128 if (proc->result != NULL)
133 if (gfc_elemental (proc)
134 || sym->attr.pointer || sym->attr.allocatable
135 || (sym->as && sym->as->rank > 0))
137 proc->attr.always_explicit = 1;
138 sym->attr.always_explicit = 1;
143 for (f = proc->formal; f; f = f->next)
149 /* Alternate return placeholder. */
150 if (gfc_elemental (proc))
151 gfc_error ("Alternate return specifier in elemental subroutine "
152 "'%s' at %L is not allowed", proc->name,
154 if (proc->attr.function)
155 gfc_error ("Alternate return specifier in function "
156 "'%s' at %L is not allowed", proc->name,
161 if (sym->attr.if_source != IFSRC_UNKNOWN)
162 resolve_formal_arglist (sym);
164 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
166 if (gfc_pure (proc) && !gfc_pure (sym))
168 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
169 "also be PURE", sym->name, &sym->declared_at);
173 if (gfc_elemental (proc))
175 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
176 "procedure", &sym->declared_at);
180 if (sym->attr.function
181 && sym->ts.type == BT_UNKNOWN
182 && sym->attr.intrinsic)
184 gfc_intrinsic_sym *isym;
185 isym = gfc_find_function (sym->name);
186 if (isym == NULL || !isym->specific)
188 gfc_error ("Unable to find a specific INTRINSIC procedure "
189 "for the reference '%s' at %L", sym->name,
198 if (sym->ts.type == BT_UNKNOWN)
200 if (!sym->attr.function || sym->result == sym)
201 gfc_set_default_type (sym, 1, sym->ns);
204 gfc_resolve_array_spec (sym->as, 0);
206 /* We can't tell if an array with dimension (:) is assumed or deferred
207 shape until we know if it has the pointer or allocatable attributes.
209 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
210 && !(sym->attr.pointer || sym->attr.allocatable))
212 sym->as->type = AS_ASSUMED_SHAPE;
213 for (i = 0; i < sym->as->rank; i++)
214 sym->as->lower[i] = gfc_int_expr (1);
217 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
218 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
219 || sym->attr.optional)
221 proc->attr.always_explicit = 1;
223 proc->result->attr.always_explicit = 1;
226 /* If the flavor is unknown at this point, it has to be a variable.
227 A procedure specification would have already set the type. */
229 if (sym->attr.flavor == FL_UNKNOWN)
230 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
232 if (gfc_pure (proc) && !sym->attr.pointer
233 && sym->attr.flavor != FL_PROCEDURE)
235 if (proc->attr.function && sym->attr.intent != INTENT_IN)
236 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
237 "INTENT(IN)", sym->name, proc->name,
240 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
241 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
242 "have its INTENT specified", sym->name, proc->name,
246 if (gfc_elemental (proc))
250 gfc_error ("Argument '%s' of elemental procedure at %L must "
251 "be scalar", sym->name, &sym->declared_at);
255 if (sym->attr.pointer)
257 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
258 "have the POINTER attribute", sym->name,
263 if (sym->attr.flavor == FL_PROCEDURE)
265 gfc_error ("Dummy procedure '%s' not allowed in elemental "
266 "procedure '%s' at %L", sym->name, proc->name,
272 /* Each dummy shall be specified to be scalar. */
273 if (proc->attr.proc == PROC_ST_FUNCTION)
277 gfc_error ("Argument '%s' of statement function at %L must "
278 "be scalar", sym->name, &sym->declared_at);
282 if (sym->ts.type == BT_CHARACTER)
284 gfc_charlen *cl = sym->ts.cl;
285 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
287 gfc_error ("Character-valued argument '%s' of statement "
288 "function at %L must have constant length",
289 sym->name, &sym->declared_at);
299 /* Work function called when searching for symbols that have argument lists
300 associated with them. */
303 find_arglists (gfc_symbol *sym)
305 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
308 resolve_formal_arglist (sym);
312 /* Given a namespace, resolve all formal argument lists within the namespace.
316 resolve_formal_arglists (gfc_namespace *ns)
321 gfc_traverse_ns (ns, find_arglists);
326 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
330 /* If this namespace is not a function or an entry master function,
332 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
333 || sym->attr.entry_master)
336 /* Try to find out of what the return type is. */
337 if (sym->result->ts.type == BT_UNKNOWN)
339 t = gfc_set_default_type (sym->result, 0, ns);
341 if (t == FAILURE && !sym->result->attr.untyped)
343 if (sym->result == sym)
344 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
345 sym->name, &sym->declared_at);
347 gfc_error ("Result '%s' of contained function '%s' at %L has "
348 "no IMPLICIT type", sym->result->name, sym->name,
349 &sym->result->declared_at);
350 sym->result->attr.untyped = 1;
354 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
355 type, lists the only ways a character length value of * can be used:
356 dummy arguments of procedures, named constants, and function results
357 in external functions. Internal function results are not on that list;
358 ergo, not permitted. */
360 if (sym->result->ts.type == BT_CHARACTER)
362 gfc_charlen *cl = sym->result->ts.cl;
363 if (!cl || !cl->length)
364 gfc_error ("Character-valued internal function '%s' at %L must "
365 "not be assumed length", sym->name, &sym->declared_at);
370 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
371 introduce duplicates. */
374 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
376 gfc_formal_arglist *f, *new_arglist;
379 for (; new_args != NULL; new_args = new_args->next)
381 new_sym = new_args->sym;
382 /* See if this arg is already in the formal argument list. */
383 for (f = proc->formal; f; f = f->next)
385 if (new_sym == f->sym)
392 /* Add a new argument. Argument order is not important. */
393 new_arglist = gfc_get_formal_arglist ();
394 new_arglist->sym = new_sym;
395 new_arglist->next = proc->formal;
396 proc->formal = new_arglist;
401 /* Flag the arguments that are not present in all entries. */
404 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
406 gfc_formal_arglist *f, *head;
409 for (f = proc->formal; f; f = f->next)
414 for (new_args = head; new_args; new_args = new_args->next)
416 if (new_args->sym == f->sym)
423 f->sym->attr.not_always_present = 1;
428 /* Resolve alternate entry points. If a symbol has multiple entry points we
429 create a new master symbol for the main routine, and turn the existing
430 symbol into an entry point. */
433 resolve_entries (gfc_namespace *ns)
435 gfc_namespace *old_ns;
439 char name[GFC_MAX_SYMBOL_LEN + 1];
440 static int master_count = 0;
442 if (ns->proc_name == NULL)
445 /* No need to do anything if this procedure doesn't have alternate entry
450 /* We may already have resolved alternate entry points. */
451 if (ns->proc_name->attr.entry_master)
454 /* If this isn't a procedure something has gone horribly wrong. */
455 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
457 /* Remember the current namespace. */
458 old_ns = gfc_current_ns;
462 /* Add the main entry point to the list of entry points. */
463 el = gfc_get_entry_list ();
464 el->sym = ns->proc_name;
466 el->next = ns->entries;
468 ns->proc_name->attr.entry = 1;
470 /* If it is a module function, it needs to be in the right namespace
471 so that gfc_get_fake_result_decl can gather up the results. The
472 need for this arose in get_proc_name, where these beasts were
473 left in their own namespace, to keep prior references linked to
474 the entry declaration.*/
475 if (ns->proc_name->attr.function
476 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
479 /* Do the same for entries where the master is not a module
480 procedure. These are retained in the module namespace because
481 of the module procedure declaration. */
482 for (el = el->next; el; el = el->next)
483 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
484 && el->sym->attr.mod_proc)
488 /* Add an entry statement for it. */
495 /* Create a new symbol for the master function. */
496 /* Give the internal function a unique name (within this file).
497 Also include the function name so the user has some hope of figuring
498 out what is going on. */
499 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
500 master_count++, ns->proc_name->name);
501 gfc_get_ha_symbol (name, &proc);
502 gcc_assert (proc != NULL);
504 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
505 if (ns->proc_name->attr.subroutine)
506 gfc_add_subroutine (&proc->attr, proc->name, NULL);
510 gfc_typespec *ts, *fts;
511 gfc_array_spec *as, *fas;
512 gfc_add_function (&proc->attr, proc->name, NULL);
514 fas = ns->entries->sym->as;
515 fas = fas ? fas : ns->entries->sym->result->as;
516 fts = &ns->entries->sym->result->ts;
517 if (fts->type == BT_UNKNOWN)
518 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
519 for (el = ns->entries->next; el; el = el->next)
521 ts = &el->sym->result->ts;
523 as = as ? as : el->sym->result->as;
524 if (ts->type == BT_UNKNOWN)
525 ts = gfc_get_default_type (el->sym->result, NULL);
527 if (! gfc_compare_types (ts, fts)
528 || (el->sym->result->attr.dimension
529 != ns->entries->sym->result->attr.dimension)
530 || (el->sym->result->attr.pointer
531 != ns->entries->sym->result->attr.pointer))
533 else if (as && fas && ns->entries->sym->result != el->sym->result
534 && gfc_compare_array_spec (as, fas) == 0)
535 gfc_error ("Function %s at %L has entries with mismatched "
536 "array specifications", ns->entries->sym->name,
537 &ns->entries->sym->declared_at);
538 /* The characteristics need to match and thus both need to have
539 the same string length, i.e. both len=*, or both len=4.
540 Having both len=<variable> is also possible, but difficult to
541 check at compile time. */
542 else if (ts->type == BT_CHARACTER && ts->cl && fts->cl
543 && (((ts->cl->length && !fts->cl->length)
544 ||(!ts->cl->length && fts->cl->length))
546 && ts->cl->length->expr_type
547 != fts->cl->length->expr_type)
549 && ts->cl->length->expr_type == EXPR_CONSTANT
550 && mpz_cmp (ts->cl->length->value.integer,
551 fts->cl->length->value.integer) != 0)))
552 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
553 "entries returning variables of different "
554 "string lengths", ns->entries->sym->name,
555 &ns->entries->sym->declared_at);
560 sym = ns->entries->sym->result;
561 /* All result types the same. */
563 if (sym->attr.dimension)
564 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
565 if (sym->attr.pointer)
566 gfc_add_pointer (&proc->attr, NULL);
570 /* Otherwise the result will be passed through a union by
572 proc->attr.mixed_entry_master = 1;
573 for (el = ns->entries; el; el = el->next)
575 sym = el->sym->result;
576 if (sym->attr.dimension)
578 if (el == ns->entries)
579 gfc_error ("FUNCTION result %s can't be an array in "
580 "FUNCTION %s at %L", sym->name,
581 ns->entries->sym->name, &sym->declared_at);
583 gfc_error ("ENTRY result %s can't be an array in "
584 "FUNCTION %s at %L", sym->name,
585 ns->entries->sym->name, &sym->declared_at);
587 else if (sym->attr.pointer)
589 if (el == ns->entries)
590 gfc_error ("FUNCTION result %s can't be a POINTER in "
591 "FUNCTION %s at %L", sym->name,
592 ns->entries->sym->name, &sym->declared_at);
594 gfc_error ("ENTRY result %s can't be a POINTER in "
595 "FUNCTION %s at %L", sym->name,
596 ns->entries->sym->name, &sym->declared_at);
601 if (ts->type == BT_UNKNOWN)
602 ts = gfc_get_default_type (sym, NULL);
606 if (ts->kind == gfc_default_integer_kind)
610 if (ts->kind == gfc_default_real_kind
611 || ts->kind == gfc_default_double_kind)
615 if (ts->kind == gfc_default_complex_kind)
619 if (ts->kind == gfc_default_logical_kind)
623 /* We will issue error elsewhere. */
631 if (el == ns->entries)
632 gfc_error ("FUNCTION result %s can't be of type %s "
633 "in FUNCTION %s at %L", sym->name,
634 gfc_typename (ts), ns->entries->sym->name,
637 gfc_error ("ENTRY result %s can't be of type %s "
638 "in FUNCTION %s at %L", sym->name,
639 gfc_typename (ts), ns->entries->sym->name,
646 proc->attr.access = ACCESS_PRIVATE;
647 proc->attr.entry_master = 1;
649 /* Merge all the entry point arguments. */
650 for (el = ns->entries; el; el = el->next)
651 merge_argument_lists (proc, el->sym->formal);
653 /* Check the master formal arguments for any that are not
654 present in all entry points. */
655 for (el = ns->entries; el; el = el->next)
656 check_argument_lists (proc, el->sym->formal);
658 /* Use the master function for the function body. */
659 ns->proc_name = proc;
661 /* Finalize the new symbols. */
662 gfc_commit_symbols ();
664 /* Restore the original namespace. */
665 gfc_current_ns = old_ns;
670 has_default_initializer (gfc_symbol *der)
674 gcc_assert (der->attr.flavor == FL_DERIVED);
675 for (c = der->components; c; c = c->next)
676 if ((c->ts.type != BT_DERIVED && c->initializer)
677 || (c->ts.type == BT_DERIVED
678 && (!c->attr.pointer && has_default_initializer (c->ts.derived))))
684 /* Resolve common variables. */
686 resolve_common_vars (gfc_symbol *sym, bool named_common)
688 gfc_symbol *csym = sym;
690 for (; csym; csym = csym->common_next)
692 if (csym->value || csym->attr.data)
694 if (!csym->ns->is_block_data)
695 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
696 "but only in BLOCK DATA initialization is "
697 "allowed", csym->name, &csym->declared_at);
698 else if (!named_common)
699 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
700 "in a blank COMMON but initialization is only "
701 "allowed in named common blocks", csym->name,
705 if (csym->ts.type != BT_DERIVED)
708 if (!(csym->ts.derived->attr.sequence
709 || csym->ts.derived->attr.is_bind_c))
710 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
711 "has neither the SEQUENCE nor the BIND(C) "
712 "attribute", csym->name, &csym->declared_at);
713 if (csym->ts.derived->attr.alloc_comp)
714 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
715 "has an ultimate component that is "
716 "allocatable", csym->name, &csym->declared_at);
717 if (has_default_initializer (csym->ts.derived))
718 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
719 "may not have default initializer", csym->name,
724 /* Resolve common blocks. */
726 resolve_common_blocks (gfc_symtree *common_root)
730 if (common_root == NULL)
733 if (common_root->left)
734 resolve_common_blocks (common_root->left);
735 if (common_root->right)
736 resolve_common_blocks (common_root->right);
738 resolve_common_vars (common_root->n.common->head, true);
740 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
744 if (sym->attr.flavor == FL_PARAMETER)
745 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
746 sym->name, &common_root->n.common->where, &sym->declared_at);
748 if (sym->attr.intrinsic)
749 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
750 sym->name, &common_root->n.common->where);
751 else if (sym->attr.result
752 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
753 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
754 "that is also a function result", sym->name,
755 &common_root->n.common->where);
756 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
757 && sym->attr.proc != PROC_ST_FUNCTION)
758 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
759 "that is also a global procedure", sym->name,
760 &common_root->n.common->where);
764 /* Resolve contained function types. Because contained functions can call one
765 another, they have to be worked out before any of the contained procedures
768 The good news is that if a function doesn't already have a type, the only
769 way it can get one is through an IMPLICIT type or a RESULT variable, because
770 by definition contained functions are contained namespace they're contained
771 in, not in a sibling or parent namespace. */
774 resolve_contained_functions (gfc_namespace *ns)
776 gfc_namespace *child;
779 resolve_formal_arglists (ns);
781 for (child = ns->contained; child; child = child->sibling)
783 /* Resolve alternate entry points first. */
784 resolve_entries (child);
786 /* Then check function return types. */
787 resolve_contained_fntype (child->proc_name, child);
788 for (el = child->entries; el; el = el->next)
789 resolve_contained_fntype (el->sym, child);
794 /* Resolve all of the elements of a structure constructor and make sure that
795 the types are correct. */
798 resolve_structure_cons (gfc_expr *expr)
800 gfc_constructor *cons;
806 cons = expr->value.constructor;
807 /* A constructor may have references if it is the result of substituting a
808 parameter variable. In this case we just pull out the component we
811 comp = expr->ref->u.c.sym->components;
813 comp = expr->ts.derived->components;
815 /* See if the user is trying to invoke a structure constructor for one of
816 the iso_c_binding derived types. */
817 if (expr->ts.derived && expr->ts.derived->ts.is_iso_c && cons
818 && cons->expr != NULL)
820 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
821 expr->ts.derived->name, &(expr->where));
825 for (; comp; comp = comp->next, cons = cons->next)
832 if (gfc_resolve_expr (cons->expr) == FAILURE)
838 rank = comp->as ? comp->as->rank : 0;
839 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
840 && (comp->attr.allocatable || cons->expr->rank))
842 gfc_error ("The rank of the element in the derived type "
843 "constructor at %L does not match that of the "
844 "component (%d/%d)", &cons->expr->where,
845 cons->expr->rank, rank);
849 /* If we don't have the right type, try to convert it. */
851 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
854 if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
855 gfc_error ("The element in the derived type constructor at %L, "
856 "for pointer component '%s', is %s but should be %s",
857 &cons->expr->where, comp->name,
858 gfc_basic_typename (cons->expr->ts.type),
859 gfc_basic_typename (comp->ts.type));
861 t = gfc_convert_type (cons->expr, &comp->ts, 1);
864 if (cons->expr->expr_type == EXPR_NULL
865 && !(comp->attr.pointer || comp->attr.allocatable))
868 gfc_error ("The NULL in the derived type constructor at %L is "
869 "being applied to component '%s', which is neither "
870 "a POINTER nor ALLOCATABLE", &cons->expr->where,
874 if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
877 a = gfc_expr_attr (cons->expr);
879 if (!a.pointer && !a.target)
882 gfc_error ("The element in the derived type constructor at %L, "
883 "for pointer component '%s' should be a POINTER or "
884 "a TARGET", &cons->expr->where, comp->name);
892 /****************** Expression name resolution ******************/
894 /* Returns 0 if a symbol was not declared with a type or
895 attribute declaration statement, nonzero otherwise. */
898 was_declared (gfc_symbol *sym)
904 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
907 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
908 || a.optional || a.pointer || a.save || a.target || a.volatile_
909 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
916 /* Determine if a symbol is generic or not. */
919 generic_sym (gfc_symbol *sym)
923 if (sym->attr.generic ||
924 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
927 if (was_declared (sym) || sym->ns->parent == NULL)
930 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
937 return generic_sym (s);
944 /* Determine if a symbol is specific or not. */
947 specific_sym (gfc_symbol *sym)
951 if (sym->attr.if_source == IFSRC_IFBODY
952 || sym->attr.proc == PROC_MODULE
953 || sym->attr.proc == PROC_INTERNAL
954 || sym->attr.proc == PROC_ST_FUNCTION
955 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
956 || sym->attr.external)
959 if (was_declared (sym) || sym->ns->parent == NULL)
962 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
964 return (s == NULL) ? 0 : specific_sym (s);
968 /* Figure out if the procedure is specific, generic or unknown. */
971 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
975 procedure_kind (gfc_symbol *sym)
977 if (generic_sym (sym))
978 return PTYPE_GENERIC;
980 if (specific_sym (sym))
981 return PTYPE_SPECIFIC;
983 return PTYPE_UNKNOWN;
986 /* Check references to assumed size arrays. The flag need_full_assumed_size
987 is nonzero when matching actual arguments. */
989 static int need_full_assumed_size = 0;
992 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
994 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
997 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
998 What should it be? */
999 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1000 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1001 && (e->ref->u.ar.type == AR_FULL))
1003 gfc_error ("The upper bound in the last dimension must "
1004 "appear in the reference to the assumed size "
1005 "array '%s' at %L", sym->name, &e->where);
1012 /* Look for bad assumed size array references in argument expressions
1013 of elemental and array valued intrinsic procedures. Since this is
1014 called from procedure resolution functions, it only recurses at
1018 resolve_assumed_size_actual (gfc_expr *e)
1023 switch (e->expr_type)
1026 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1031 if (resolve_assumed_size_actual (e->value.op.op1)
1032 || resolve_assumed_size_actual (e->value.op.op2))
1043 /* Check a generic procedure, passed as an actual argument, to see if
1044 there is a matching specific name. If none, it is an error, and if
1045 more than one, the reference is ambiguous. */
1047 count_specific_procs (gfc_expr *e)
1054 sym = e->symtree->n.sym;
1056 for (p = sym->generic; p; p = p->next)
1057 if (strcmp (sym->name, p->sym->name) == 0)
1059 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1065 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1069 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1070 "argument at %L", sym->name, &e->where);
1075 /* Resolve an actual argument list. Most of the time, this is just
1076 resolving the expressions in the list.
1077 The exception is that we sometimes have to decide whether arguments
1078 that look like procedure arguments are really simple variable
1082 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1083 bool no_formal_args)
1086 gfc_symtree *parent_st;
1088 int save_need_full_assumed_size;
1090 for (; arg; arg = arg->next)
1095 /* Check the label is a valid branching target. */
1098 if (arg->label->defined == ST_LABEL_UNKNOWN)
1100 gfc_error ("Label %d referenced at %L is never defined",
1101 arg->label->value, &arg->label->where);
1108 if (e->expr_type == FL_VARIABLE
1109 && e->symtree->n.sym->attr.generic
1111 && count_specific_procs (e) != 1)
1114 if (e->ts.type != BT_PROCEDURE)
1116 save_need_full_assumed_size = need_full_assumed_size;
1117 if (e->expr_type != EXPR_VARIABLE)
1118 need_full_assumed_size = 0;
1119 if (gfc_resolve_expr (e) != SUCCESS)
1121 need_full_assumed_size = save_need_full_assumed_size;
1125 /* See if the expression node should really be a variable reference. */
1127 sym = e->symtree->n.sym;
1129 if (sym->attr.flavor == FL_PROCEDURE
1130 || sym->attr.intrinsic
1131 || sym->attr.external)
1135 /* If a procedure is not already determined to be something else
1136 check if it is intrinsic. */
1137 if (!sym->attr.intrinsic
1138 && !(sym->attr.external || sym->attr.use_assoc
1139 || sym->attr.if_source == IFSRC_IFBODY)
1140 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1141 sym->attr.intrinsic = 1;
1143 if (sym->attr.proc == PROC_ST_FUNCTION)
1145 gfc_error ("Statement function '%s' at %L is not allowed as an "
1146 "actual argument", sym->name, &e->where);
1149 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1150 sym->attr.subroutine);
1151 if (sym->attr.intrinsic && actual_ok == 0)
1153 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1154 "actual argument", sym->name, &e->where);
1157 if (sym->attr.contained && !sym->attr.use_assoc
1158 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1160 gfc_error ("Internal procedure '%s' is not allowed as an "
1161 "actual argument at %L", sym->name, &e->where);
1164 if (sym->attr.elemental && !sym->attr.intrinsic)
1166 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1167 "allowed as an actual argument at %L", sym->name,
1171 /* Check if a generic interface has a specific procedure
1172 with the same name before emitting an error. */
1173 if (sym->attr.generic && count_specific_procs (e) != 1)
1176 /* Just in case a specific was found for the expression. */
1177 sym = e->symtree->n.sym;
1179 if (sym->attr.entry && sym->ns->entries
1180 && sym->ns == gfc_current_ns
1181 && !sym->ns->entries->sym->attr.recursive)
1183 gfc_error ("Reference to ENTRY '%s' at %L is recursive, but procedure "
1184 "'%s' is not declared as RECURSIVE",
1185 sym->name, &e->where, sym->ns->entries->sym->name);
1188 /* If the symbol is the function that names the current (or
1189 parent) scope, then we really have a variable reference. */
1191 if (sym->attr.function && sym->result == sym
1192 && (sym->ns->proc_name == sym
1193 || (sym->ns->parent != NULL
1194 && sym->ns->parent->proc_name == sym)))
1197 /* If all else fails, see if we have a specific intrinsic. */
1198 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1200 gfc_intrinsic_sym *isym;
1202 isym = gfc_find_function (sym->name);
1203 if (isym == NULL || !isym->specific)
1205 gfc_error ("Unable to find a specific INTRINSIC procedure "
1206 "for the reference '%s' at %L", sym->name,
1211 sym->attr.intrinsic = 1;
1212 sym->attr.function = 1;
1217 /* See if the name is a module procedure in a parent unit. */
1219 if (was_declared (sym) || sym->ns->parent == NULL)
1222 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1224 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1228 if (parent_st == NULL)
1231 sym = parent_st->n.sym;
1232 e->symtree = parent_st; /* Point to the right thing. */
1234 if (sym->attr.flavor == FL_PROCEDURE
1235 || sym->attr.intrinsic
1236 || sym->attr.external)
1242 e->expr_type = EXPR_VARIABLE;
1244 if (sym->as != NULL)
1246 e->rank = sym->as->rank;
1247 e->ref = gfc_get_ref ();
1248 e->ref->type = REF_ARRAY;
1249 e->ref->u.ar.type = AR_FULL;
1250 e->ref->u.ar.as = sym->as;
1253 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1254 primary.c (match_actual_arg). If above code determines that it
1255 is a variable instead, it needs to be resolved as it was not
1256 done at the beginning of this function. */
1257 save_need_full_assumed_size = need_full_assumed_size;
1258 if (e->expr_type != EXPR_VARIABLE)
1259 need_full_assumed_size = 0;
1260 if (gfc_resolve_expr (e) != SUCCESS)
1262 need_full_assumed_size = save_need_full_assumed_size;
1265 /* Check argument list functions %VAL, %LOC and %REF. There is
1266 nothing to do for %REF. */
1267 if (arg->name && arg->name[0] == '%')
1269 if (strncmp ("%VAL", arg->name, 4) == 0)
1271 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1273 gfc_error ("By-value argument at %L is not of numeric "
1280 gfc_error ("By-value argument at %L cannot be an array or "
1281 "an array section", &e->where);
1285 /* Intrinsics are still PROC_UNKNOWN here. However,
1286 since same file external procedures are not resolvable
1287 in gfortran, it is a good deal easier to leave them to
1289 if (ptype != PROC_UNKNOWN
1290 && ptype != PROC_DUMMY
1291 && ptype != PROC_EXTERNAL
1292 && ptype != PROC_MODULE)
1294 gfc_error ("By-value argument at %L is not allowed "
1295 "in this context", &e->where);
1300 /* Statement functions have already been excluded above. */
1301 else if (strncmp ("%LOC", arg->name, 4) == 0
1302 && e->ts.type == BT_PROCEDURE)
1304 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1306 gfc_error ("Passing internal procedure at %L by location "
1307 "not allowed", &e->where);
1318 /* Do the checks of the actual argument list that are specific to elemental
1319 procedures. If called with c == NULL, we have a function, otherwise if
1320 expr == NULL, we have a subroutine. */
1323 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1325 gfc_actual_arglist *arg0;
1326 gfc_actual_arglist *arg;
1327 gfc_symbol *esym = NULL;
1328 gfc_intrinsic_sym *isym = NULL;
1330 gfc_intrinsic_arg *iformal = NULL;
1331 gfc_formal_arglist *eformal = NULL;
1332 bool formal_optional = false;
1333 bool set_by_optional = false;
1337 /* Is this an elemental procedure? */
1338 if (expr && expr->value.function.actual != NULL)
1340 if (expr->value.function.esym != NULL
1341 && expr->value.function.esym->attr.elemental)
1343 arg0 = expr->value.function.actual;
1344 esym = expr->value.function.esym;
1346 else if (expr->value.function.isym != NULL
1347 && expr->value.function.isym->elemental)
1349 arg0 = expr->value.function.actual;
1350 isym = expr->value.function.isym;
1355 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1357 arg0 = c->ext.actual;
1358 esym = c->symtree->n.sym;
1363 /* The rank of an elemental is the rank of its array argument(s). */
1364 for (arg = arg0; arg; arg = arg->next)
1366 if (arg->expr != NULL && arg->expr->rank > 0)
1368 rank = arg->expr->rank;
1369 if (arg->expr->expr_type == EXPR_VARIABLE
1370 && arg->expr->symtree->n.sym->attr.optional)
1371 set_by_optional = true;
1373 /* Function specific; set the result rank and shape. */
1377 if (!expr->shape && arg->expr->shape)
1379 expr->shape = gfc_get_shape (rank);
1380 for (i = 0; i < rank; i++)
1381 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1388 /* If it is an array, it shall not be supplied as an actual argument
1389 to an elemental procedure unless an array of the same rank is supplied
1390 as an actual argument corresponding to a nonoptional dummy argument of
1391 that elemental procedure(12.4.1.5). */
1392 formal_optional = false;
1394 iformal = isym->formal;
1396 eformal = esym->formal;
1398 for (arg = arg0; arg; arg = arg->next)
1402 if (eformal->sym && eformal->sym->attr.optional)
1403 formal_optional = true;
1404 eformal = eformal->next;
1406 else if (isym && iformal)
1408 if (iformal->optional)
1409 formal_optional = true;
1410 iformal = iformal->next;
1413 formal_optional = true;
1415 if (pedantic && arg->expr != NULL
1416 && arg->expr->expr_type == EXPR_VARIABLE
1417 && arg->expr->symtree->n.sym->attr.optional
1420 && (set_by_optional || arg->expr->rank != rank)
1421 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1423 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1424 "MISSING, it cannot be the actual argument of an "
1425 "ELEMENTAL procedure unless there is a non-optional "
1426 "argument with the same rank (12.4.1.5)",
1427 arg->expr->symtree->n.sym->name, &arg->expr->where);
1432 for (arg = arg0; arg; arg = arg->next)
1434 if (arg->expr == NULL || arg->expr->rank == 0)
1437 /* Being elemental, the last upper bound of an assumed size array
1438 argument must be present. */
1439 if (resolve_assumed_size_actual (arg->expr))
1442 /* Elemental procedure's array actual arguments must conform. */
1445 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1453 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1454 is an array, the intent inout/out variable needs to be also an array. */
1455 if (rank > 0 && esym && expr == NULL)
1456 for (eformal = esym->formal, arg = arg0; arg && eformal;
1457 arg = arg->next, eformal = eformal->next)
1458 if ((eformal->sym->attr.intent == INTENT_OUT
1459 || eformal->sym->attr.intent == INTENT_INOUT)
1460 && arg->expr && arg->expr->rank == 0)
1462 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1463 "ELEMENTAL subroutine '%s' is a scalar, but another "
1464 "actual argument is an array", &arg->expr->where,
1465 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1466 : "INOUT", eformal->sym->name, esym->name);
1473 /* Go through each actual argument in ACTUAL and see if it can be
1474 implemented as an inlined, non-copying intrinsic. FNSYM is the
1475 function being called, or NULL if not known. */
1478 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1480 gfc_actual_arglist *ap;
1483 for (ap = actual; ap; ap = ap->next)
1485 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1486 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1487 ap->expr->inline_noncopying_intrinsic = 1;
1491 /* This function does the checking of references to global procedures
1492 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1493 77 and 95 standards. It checks for a gsymbol for the name, making
1494 one if it does not already exist. If it already exists, then the
1495 reference being resolved must correspond to the type of gsymbol.
1496 Otherwise, the new symbol is equipped with the attributes of the
1497 reference. The corresponding code that is called in creating
1498 global entities is parse.c. */
1501 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1506 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1508 gsym = gfc_get_gsymbol (sym->name);
1510 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1511 gfc_global_used (gsym, where);
1513 if (gsym->type == GSYM_UNKNOWN)
1516 gsym->where = *where;
1523 /************* Function resolution *************/
1525 /* Resolve a function call known to be generic.
1526 Section 14.1.2.4.1. */
1529 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1533 if (sym->attr.generic)
1535 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1538 expr->value.function.name = s->name;
1539 expr->value.function.esym = s;
1541 if (s->ts.type != BT_UNKNOWN)
1543 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1544 expr->ts = s->result->ts;
1547 expr->rank = s->as->rank;
1548 else if (s->result != NULL && s->result->as != NULL)
1549 expr->rank = s->result->as->rank;
1551 gfc_set_sym_referenced (expr->value.function.esym);
1556 /* TODO: Need to search for elemental references in generic
1560 if (sym->attr.intrinsic)
1561 return gfc_intrinsic_func_interface (expr, 0);
1568 resolve_generic_f (gfc_expr *expr)
1573 sym = expr->symtree->n.sym;
1577 m = resolve_generic_f0 (expr, sym);
1580 else if (m == MATCH_ERROR)
1584 if (sym->ns->parent == NULL)
1586 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1590 if (!generic_sym (sym))
1594 /* Last ditch attempt. See if the reference is to an intrinsic
1595 that possesses a matching interface. 14.1.2.4 */
1596 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1598 gfc_error ("There is no specific function for the generic '%s' at %L",
1599 expr->symtree->n.sym->name, &expr->where);
1603 m = gfc_intrinsic_func_interface (expr, 0);
1607 gfc_error ("Generic function '%s' at %L is not consistent with a "
1608 "specific intrinsic interface", expr->symtree->n.sym->name,
1615 /* Resolve a function call known to be specific. */
1618 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1622 /* See if we have an intrinsic interface. */
1624 if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
1626 gfc_intrinsic_sym *isym;
1627 isym = gfc_find_function (sym->ts.interface->name);
1629 /* Existence of isym should be checked already. */
1632 sym->ts.type = isym->ts.type;
1633 sym->ts.kind = isym->ts.kind;
1634 sym->attr.function = 1;
1635 sym->attr.proc = PROC_EXTERNAL;
1639 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1641 if (sym->attr.dummy)
1643 sym->attr.proc = PROC_DUMMY;
1647 sym->attr.proc = PROC_EXTERNAL;
1651 if (sym->attr.proc == PROC_MODULE
1652 || sym->attr.proc == PROC_ST_FUNCTION
1653 || sym->attr.proc == PROC_INTERNAL)
1656 if (sym->attr.intrinsic)
1658 m = gfc_intrinsic_func_interface (expr, 1);
1662 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1663 "with an intrinsic", sym->name, &expr->where);
1671 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1674 expr->value.function.name = sym->name;
1675 expr->value.function.esym = sym;
1676 if (sym->as != NULL)
1677 expr->rank = sym->as->rank;
1684 resolve_specific_f (gfc_expr *expr)
1689 sym = expr->symtree->n.sym;
1693 m = resolve_specific_f0 (sym, expr);
1696 if (m == MATCH_ERROR)
1699 if (sym->ns->parent == NULL)
1702 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1708 gfc_error ("Unable to resolve the specific function '%s' at %L",
1709 expr->symtree->n.sym->name, &expr->where);
1715 /* Resolve a procedure call not known to be generic nor specific. */
1718 resolve_unknown_f (gfc_expr *expr)
1723 sym = expr->symtree->n.sym;
1725 if (sym->attr.dummy)
1727 sym->attr.proc = PROC_DUMMY;
1728 expr->value.function.name = sym->name;
1732 /* See if we have an intrinsic function reference. */
1734 if (gfc_is_intrinsic (sym, 0, expr->where))
1736 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1741 /* The reference is to an external name. */
1743 sym->attr.proc = PROC_EXTERNAL;
1744 expr->value.function.name = sym->name;
1745 expr->value.function.esym = expr->symtree->n.sym;
1747 if (sym->as != NULL)
1748 expr->rank = sym->as->rank;
1750 /* Type of the expression is either the type of the symbol or the
1751 default type of the symbol. */
1754 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1756 if (sym->ts.type != BT_UNKNOWN)
1760 ts = gfc_get_default_type (sym, sym->ns);
1762 if (ts->type == BT_UNKNOWN)
1764 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1765 sym->name, &expr->where);
1776 /* Return true, if the symbol is an external procedure. */
1778 is_external_proc (gfc_symbol *sym)
1780 if (!sym->attr.dummy && !sym->attr.contained
1781 && !(sym->attr.intrinsic
1782 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
1783 && sym->attr.proc != PROC_ST_FUNCTION
1784 && !sym->attr.use_assoc
1792 /* Figure out if a function reference is pure or not. Also set the name
1793 of the function for a potential error message. Return nonzero if the
1794 function is PURE, zero if not. */
1796 pure_stmt_function (gfc_expr *, gfc_symbol *);
1799 pure_function (gfc_expr *e, const char **name)
1805 if (e->symtree != NULL
1806 && e->symtree->n.sym != NULL
1807 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1808 return pure_stmt_function (e, e->symtree->n.sym);
1810 if (e->value.function.esym)
1812 pure = gfc_pure (e->value.function.esym);
1813 *name = e->value.function.esym->name;
1815 else if (e->value.function.isym)
1817 pure = e->value.function.isym->pure
1818 || e->value.function.isym->elemental;
1819 *name = e->value.function.isym->name;
1823 /* Implicit functions are not pure. */
1825 *name = e->value.function.name;
1833 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
1834 int *f ATTRIBUTE_UNUSED)
1838 /* Don't bother recursing into other statement functions
1839 since they will be checked individually for purity. */
1840 if (e->expr_type != EXPR_FUNCTION
1842 || e->symtree->n.sym == sym
1843 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1846 return pure_function (e, &name) ? false : true;
1851 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
1853 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
1858 is_scalar_expr_ptr (gfc_expr *expr)
1860 gfc_try retval = SUCCESS;
1865 /* See if we have a gfc_ref, which means we have a substring, array
1866 reference, or a component. */
1867 if (expr->ref != NULL)
1870 while (ref->next != NULL)
1876 if (ref->u.ss.length != NULL
1877 && ref->u.ss.length->length != NULL
1879 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1881 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1883 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1884 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1885 if (end - start + 1 != 1)
1892 if (ref->u.ar.type == AR_ELEMENT)
1894 else if (ref->u.ar.type == AR_FULL)
1896 /* The user can give a full array if the array is of size 1. */
1897 if (ref->u.ar.as != NULL
1898 && ref->u.ar.as->rank == 1
1899 && ref->u.ar.as->type == AS_EXPLICIT
1900 && ref->u.ar.as->lower[0] != NULL
1901 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1902 && ref->u.ar.as->upper[0] != NULL
1903 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1905 /* If we have a character string, we need to check if
1906 its length is one. */
1907 if (expr->ts.type == BT_CHARACTER)
1909 if (expr->ts.cl == NULL
1910 || expr->ts.cl->length == NULL
1911 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1917 /* We have constant lower and upper bounds. If the
1918 difference between is 1, it can be considered a
1920 start = (int) mpz_get_si
1921 (ref->u.ar.as->lower[0]->value.integer);
1922 end = (int) mpz_get_si
1923 (ref->u.ar.as->upper[0]->value.integer);
1924 if (end - start + 1 != 1)
1939 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1941 /* Character string. Make sure it's of length 1. */
1942 if (expr->ts.cl == NULL
1943 || expr->ts.cl->length == NULL
1944 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1947 else if (expr->rank != 0)
1954 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1955 and, in the case of c_associated, set the binding label based on
1959 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1960 gfc_symbol **new_sym)
1962 char name[GFC_MAX_SYMBOL_LEN + 1];
1963 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1964 int optional_arg = 0;
1965 gfc_try retval = SUCCESS;
1966 gfc_symbol *args_sym;
1967 gfc_typespec *arg_ts;
1968 gfc_ref *parent_ref;
1971 if (args->expr->expr_type == EXPR_CONSTANT
1972 || args->expr->expr_type == EXPR_OP
1973 || args->expr->expr_type == EXPR_NULL)
1975 gfc_error ("Argument to '%s' at %L is not a variable",
1976 sym->name, &(args->expr->where));
1980 args_sym = args->expr->symtree->n.sym;
1982 /* The typespec for the actual arg should be that stored in the expr
1983 and not necessarily that of the expr symbol (args_sym), because
1984 the actual expression could be a part-ref of the expr symbol. */
1985 arg_ts = &(args->expr->ts);
1987 /* Get the parent reference (if any) for the expression. This happens for
1988 cases such as a%b%c. */
1989 parent_ref = args->expr->ref;
1991 if (parent_ref != NULL)
1993 curr_ref = parent_ref->next;
1994 while (curr_ref != NULL && curr_ref->next != NULL)
1996 parent_ref = curr_ref;
1997 curr_ref = curr_ref->next;
2001 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
2002 is for a REF_COMPONENT, then we need to use it as the parent_ref for
2003 the name, etc. Otherwise, the current parent_ref should be correct. */
2004 if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
2005 parent_ref = curr_ref;
2007 if (parent_ref == args->expr->ref)
2009 else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
2010 gfc_internal_error ("Unexpected expression reference type in "
2011 "gfc_iso_c_func_interface");
2013 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2015 /* If the user gave two args then they are providing something for
2016 the optional arg (the second cptr). Therefore, set the name and
2017 binding label to the c_associated for two cptrs. Otherwise,
2018 set c_associated to expect one cptr. */
2022 sprintf (name, "%s_2", sym->name);
2023 sprintf (binding_label, "%s_2", sym->binding_label);
2029 sprintf (name, "%s_1", sym->name);
2030 sprintf (binding_label, "%s_1", sym->binding_label);
2034 /* Get a new symbol for the version of c_associated that
2036 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2038 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2039 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2041 sprintf (name, "%s", sym->name);
2042 sprintf (binding_label, "%s", sym->binding_label);
2044 /* Error check the call. */
2045 if (args->next != NULL)
2047 gfc_error_now ("More actual than formal arguments in '%s' "
2048 "call at %L", name, &(args->expr->where));
2051 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2053 /* Make sure we have either the target or pointer attribute. */
2054 if (!(args_sym->attr.target)
2055 && !(args_sym->attr.pointer)
2056 && (parent_ref == NULL ||
2057 !parent_ref->u.c.component->attr.pointer))
2059 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2060 "a TARGET or an associated pointer",
2062 sym->name, &(args->expr->where));
2066 /* See if we have interoperable type and type param. */
2067 if (verify_c_interop (arg_ts,
2068 (parent_ref ? parent_ref->u.c.component->name
2070 &(args->expr->where)) == SUCCESS
2071 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2073 if (args_sym->attr.target == 1)
2075 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2076 has the target attribute and is interoperable. */
2077 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2078 allocatable variable that has the TARGET attribute and
2079 is not an array of zero size. */
2080 if (args_sym->attr.allocatable == 1)
2082 if (args_sym->attr.dimension != 0
2083 && (args_sym->as && args_sym->as->rank == 0))
2085 gfc_error_now ("Allocatable variable '%s' used as a "
2086 "parameter to '%s' at %L must not be "
2087 "an array of zero size",
2088 args_sym->name, sym->name,
2089 &(args->expr->where));
2095 /* A non-allocatable target variable with C
2096 interoperable type and type parameters must be
2098 if (args_sym && args_sym->attr.dimension)
2100 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2102 gfc_error ("Assumed-shape array '%s' at %L "
2103 "cannot be an argument to the "
2104 "procedure '%s' because "
2105 "it is not C interoperable",
2107 &(args->expr->where), sym->name);
2110 else if (args_sym->as->type == AS_DEFERRED)
2112 gfc_error ("Deferred-shape array '%s' at %L "
2113 "cannot be an argument to the "
2114 "procedure '%s' because "
2115 "it is not C interoperable",
2117 &(args->expr->where), sym->name);
2122 /* Make sure it's not a character string. Arrays of
2123 any type should be ok if the variable is of a C
2124 interoperable type. */
2125 if (arg_ts->type == BT_CHARACTER)
2126 if (arg_ts->cl != NULL
2127 && (arg_ts->cl->length == NULL
2128 || arg_ts->cl->length->expr_type
2131 (arg_ts->cl->length->value.integer, 1)
2133 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2135 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2136 "at %L must have a length of 1",
2137 args_sym->name, sym->name,
2138 &(args->expr->where));
2143 else if ((args_sym->attr.pointer == 1 ||
2145 && parent_ref->u.c.component->attr.pointer))
2146 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2148 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2150 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2151 "associated scalar POINTER", args_sym->name,
2152 sym->name, &(args->expr->where));
2158 /* The parameter is not required to be C interoperable. If it
2159 is not C interoperable, it must be a nonpolymorphic scalar
2160 with no length type parameters. It still must have either
2161 the pointer or target attribute, and it can be
2162 allocatable (but must be allocated when c_loc is called). */
2163 if (args->expr->rank != 0
2164 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2166 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2167 "scalar", args_sym->name, sym->name,
2168 &(args->expr->where));
2171 else if (arg_ts->type == BT_CHARACTER
2172 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2174 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2175 "%L must have a length of 1",
2176 args_sym->name, sym->name,
2177 &(args->expr->where));
2182 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2184 if (args_sym->attr.flavor != FL_PROCEDURE)
2186 /* TODO: Update this error message to allow for procedure
2187 pointers once they are implemented. */
2188 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2190 args_sym->name, sym->name,
2191 &(args->expr->where));
2194 else if (args_sym->attr.is_bind_c != 1)
2196 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2198 args_sym->name, sym->name,
2199 &(args->expr->where));
2204 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2209 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2210 "iso_c_binding function: '%s'!\n", sym->name);
2217 /* Resolve a function call, which means resolving the arguments, then figuring
2218 out which entity the name refers to. */
2219 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2220 to INTENT(OUT) or INTENT(INOUT). */
2223 resolve_function (gfc_expr *expr)
2225 gfc_actual_arglist *arg;
2230 procedure_type p = PROC_INTRINSIC;
2231 bool no_formal_args;
2235 sym = expr->symtree->n.sym;
2237 if (sym && sym->attr.intrinsic
2238 && !gfc_find_function (sym->name)
2239 && gfc_find_subroutine (sym->name)
2240 && sym->attr.function)
2242 gfc_error ("Intrinsic subroutine '%s' used as "
2243 "a function at %L", sym->name, &expr->where);
2247 if (sym && sym->attr.flavor == FL_VARIABLE)
2249 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2253 if (sym && sym->attr.abstract)
2255 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2256 sym->name, &expr->where);
2260 /* If the procedure is external, check for usage. */
2261 if (sym && is_external_proc (sym))
2262 resolve_global_procedure (sym, &expr->where, 0);
2264 /* Switch off assumed size checking and do this again for certain kinds
2265 of procedure, once the procedure itself is resolved. */
2266 need_full_assumed_size++;
2268 if (expr->symtree && expr->symtree->n.sym)
2269 p = expr->symtree->n.sym->attr.proc;
2271 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2272 if (resolve_actual_arglist (expr->value.function.actual,
2273 p, no_formal_args) == FAILURE)
2276 /* Need to setup the call to the correct c_associated, depending on
2277 the number of cptrs to user gives to compare. */
2278 if (sym && sym->attr.is_iso_c == 1)
2280 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2284 /* Get the symtree for the new symbol (resolved func).
2285 the old one will be freed later, when it's no longer used. */
2286 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2289 /* Resume assumed_size checking. */
2290 need_full_assumed_size--;
2292 if (sym && sym->ts.type == BT_CHARACTER
2294 && sym->ts.cl->length == NULL
2296 && expr->value.function.esym == NULL
2297 && !sym->attr.contained)
2299 /* Internal procedures are taken care of in resolve_contained_fntype. */
2300 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2301 "be used at %L since it is not a dummy argument",
2302 sym->name, &expr->where);
2306 /* See if function is already resolved. */
2308 if (expr->value.function.name != NULL)
2310 if (expr->ts.type == BT_UNKNOWN)
2316 /* Apply the rules of section 14.1.2. */
2318 switch (procedure_kind (sym))
2321 t = resolve_generic_f (expr);
2324 case PTYPE_SPECIFIC:
2325 t = resolve_specific_f (expr);
2329 t = resolve_unknown_f (expr);
2333 gfc_internal_error ("resolve_function(): bad function type");
2337 /* If the expression is still a function (it might have simplified),
2338 then we check to see if we are calling an elemental function. */
2340 if (expr->expr_type != EXPR_FUNCTION)
2343 temp = need_full_assumed_size;
2344 need_full_assumed_size = 0;
2346 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2349 if (omp_workshare_flag
2350 && expr->value.function.esym
2351 && ! gfc_elemental (expr->value.function.esym))
2353 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2354 "in WORKSHARE construct", expr->value.function.esym->name,
2359 #define GENERIC_ID expr->value.function.isym->id
2360 else if (expr->value.function.actual != NULL
2361 && expr->value.function.isym != NULL
2362 && GENERIC_ID != GFC_ISYM_LBOUND
2363 && GENERIC_ID != GFC_ISYM_LEN
2364 && GENERIC_ID != GFC_ISYM_LOC
2365 && GENERIC_ID != GFC_ISYM_PRESENT)
2367 /* Array intrinsics must also have the last upper bound of an
2368 assumed size array argument. UBOUND and SIZE have to be
2369 excluded from the check if the second argument is anything
2372 for (arg = expr->value.function.actual; arg; arg = arg->next)
2374 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2375 && arg->next != NULL && arg->next->expr)
2377 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2380 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2383 if ((int)mpz_get_si (arg->next->expr->value.integer)
2388 if (arg->expr != NULL
2389 && arg->expr->rank > 0
2390 && resolve_assumed_size_actual (arg->expr))
2396 need_full_assumed_size = temp;
2399 if (!pure_function (expr, &name) && name)
2403 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2404 "FORALL %s", name, &expr->where,
2405 forall_flag == 2 ? "mask" : "block");
2408 else if (gfc_pure (NULL))
2410 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2411 "procedure within a PURE procedure", name, &expr->where);
2416 /* Functions without the RECURSIVE attribution are not allowed to
2417 * call themselves. */
2418 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2420 gfc_symbol *esym, *proc;
2421 esym = expr->value.function.esym;
2422 proc = gfc_current_ns->proc_name;
2425 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2426 "RECURSIVE", name, &expr->where);
2430 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2431 && esym->ns->entries->sym == proc->ns->entries->sym)
2433 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2434 "'%s' is not declared as RECURSIVE",
2435 esym->name, &expr->where, esym->ns->entries->sym->name);
2440 /* Character lengths of use associated functions may contains references to
2441 symbols not referenced from the current program unit otherwise. Make sure
2442 those symbols are marked as referenced. */
2444 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2445 && expr->value.function.esym->attr.use_assoc)
2447 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2451 && !((expr->value.function.esym
2452 && expr->value.function.esym->attr.elemental)
2454 (expr->value.function.isym
2455 && expr->value.function.isym->elemental)))
2456 find_noncopying_intrinsics (expr->value.function.esym,
2457 expr->value.function.actual);
2459 /* Make sure that the expression has a typespec that works. */
2460 if (expr->ts.type == BT_UNKNOWN)
2462 if (expr->symtree->n.sym->result
2463 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2464 expr->ts = expr->symtree->n.sym->result->ts;
2471 /************* Subroutine resolution *************/
2474 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2480 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2481 sym->name, &c->loc);
2482 else if (gfc_pure (NULL))
2483 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2489 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2493 if (sym->attr.generic)
2495 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2498 c->resolved_sym = s;
2499 pure_subroutine (c, s);
2503 /* TODO: Need to search for elemental references in generic interface. */
2506 if (sym->attr.intrinsic)
2507 return gfc_intrinsic_sub_interface (c, 0);
2514 resolve_generic_s (gfc_code *c)
2519 sym = c->symtree->n.sym;
2523 m = resolve_generic_s0 (c, sym);
2526 else if (m == MATCH_ERROR)
2530 if (sym->ns->parent == NULL)
2532 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2536 if (!generic_sym (sym))
2540 /* Last ditch attempt. See if the reference is to an intrinsic
2541 that possesses a matching interface. 14.1.2.4 */
2542 sym = c->symtree->n.sym;
2544 if (!gfc_is_intrinsic (sym, 1, c->loc))
2546 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2547 sym->name, &c->loc);
2551 m = gfc_intrinsic_sub_interface (c, 0);
2555 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2556 "intrinsic subroutine interface", sym->name, &c->loc);
2562 /* Set the name and binding label of the subroutine symbol in the call
2563 expression represented by 'c' to include the type and kind of the
2564 second parameter. This function is for resolving the appropriate
2565 version of c_f_pointer() and c_f_procpointer(). For example, a
2566 call to c_f_pointer() for a default integer pointer could have a
2567 name of c_f_pointer_i4. If no second arg exists, which is an error
2568 for these two functions, it defaults to the generic symbol's name
2569 and binding label. */
2572 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2573 char *name, char *binding_label)
2575 gfc_expr *arg = NULL;
2579 /* The second arg of c_f_pointer and c_f_procpointer determines
2580 the type and kind for the procedure name. */
2581 arg = c->ext.actual->next->expr;
2585 /* Set up the name to have the given symbol's name,
2586 plus the type and kind. */
2587 /* a derived type is marked with the type letter 'u' */
2588 if (arg->ts.type == BT_DERIVED)
2591 kind = 0; /* set the kind as 0 for now */
2595 type = gfc_type_letter (arg->ts.type);
2596 kind = arg->ts.kind;
2599 if (arg->ts.type == BT_CHARACTER)
2600 /* Kind info for character strings not needed. */
2603 sprintf (name, "%s_%c%d", sym->name, type, kind);
2604 /* Set up the binding label as the given symbol's label plus
2605 the type and kind. */
2606 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2610 /* If the second arg is missing, set the name and label as
2611 was, cause it should at least be found, and the missing
2612 arg error will be caught by compare_parameters(). */
2613 sprintf (name, "%s", sym->name);
2614 sprintf (binding_label, "%s", sym->binding_label);
2621 /* Resolve a generic version of the iso_c_binding procedure given
2622 (sym) to the specific one based on the type and kind of the
2623 argument(s). Currently, this function resolves c_f_pointer() and
2624 c_f_procpointer based on the type and kind of the second argument
2625 (FPTR). Other iso_c_binding procedures aren't specially handled.
2626 Upon successfully exiting, c->resolved_sym will hold the resolved
2627 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2631 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2633 gfc_symbol *new_sym;
2634 /* this is fine, since we know the names won't use the max */
2635 char name[GFC_MAX_SYMBOL_LEN + 1];
2636 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2637 /* default to success; will override if find error */
2638 match m = MATCH_YES;
2640 /* Make sure the actual arguments are in the necessary order (based on the
2641 formal args) before resolving. */
2642 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2644 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2645 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2647 set_name_and_label (c, sym, name, binding_label);
2649 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2651 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2653 /* Make sure we got a third arg if the second arg has non-zero
2654 rank. We must also check that the type and rank are
2655 correct since we short-circuit this check in
2656 gfc_procedure_use() (called above to sort actual args). */
2657 if (c->ext.actual->next->expr->rank != 0)
2659 if(c->ext.actual->next->next == NULL
2660 || c->ext.actual->next->next->expr == NULL)
2663 gfc_error ("Missing SHAPE parameter for call to %s "
2664 "at %L", sym->name, &(c->loc));
2666 else if (c->ext.actual->next->next->expr->ts.type
2668 || c->ext.actual->next->next->expr->rank != 1)
2671 gfc_error ("SHAPE parameter for call to %s at %L must "
2672 "be a rank 1 INTEGER array", sym->name,
2679 if (m != MATCH_ERROR)
2681 /* the 1 means to add the optional arg to formal list */
2682 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2684 /* for error reporting, say it's declared where the original was */
2685 new_sym->declared_at = sym->declared_at;
2690 /* no differences for c_loc or c_funloc */
2694 /* set the resolved symbol */
2695 if (m != MATCH_ERROR)
2696 c->resolved_sym = new_sym;
2698 c->resolved_sym = sym;
2704 /* Resolve a subroutine call known to be specific. */
2707 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2711 /* See if we have an intrinsic interface. */
2712 if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
2713 && !sym->ts.interface->attr.subroutine)
2715 gfc_intrinsic_sym *isym;
2717 isym = gfc_find_function (sym->ts.interface->name);
2719 /* Existence of isym should be checked already. */
2722 sym->ts.type = isym->ts.type;
2723 sym->ts.kind = isym->ts.kind;
2724 sym->attr.subroutine = 1;
2728 if(sym->attr.is_iso_c)
2730 m = gfc_iso_c_sub_interface (c,sym);
2734 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2736 if (sym->attr.dummy)
2738 sym->attr.proc = PROC_DUMMY;
2742 sym->attr.proc = PROC_EXTERNAL;
2746 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2749 if (sym->attr.intrinsic)
2751 m = gfc_intrinsic_sub_interface (c, 1);
2755 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2756 "with an intrinsic", sym->name, &c->loc);
2764 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2766 c->resolved_sym = sym;
2767 pure_subroutine (c, sym);
2774 resolve_specific_s (gfc_code *c)
2779 sym = c->symtree->n.sym;
2783 m = resolve_specific_s0 (c, sym);
2786 if (m == MATCH_ERROR)
2789 if (sym->ns->parent == NULL)
2792 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2798 sym = c->symtree->n.sym;
2799 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2800 sym->name, &c->loc);
2806 /* Resolve a subroutine call not known to be generic nor specific. */
2809 resolve_unknown_s (gfc_code *c)
2813 sym = c->symtree->n.sym;
2815 if (sym->attr.dummy)
2817 sym->attr.proc = PROC_DUMMY;
2821 /* See if we have an intrinsic function reference. */
2823 if (gfc_is_intrinsic (sym, 1, c->loc))
2825 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2830 /* The reference is to an external name. */
2833 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2835 c->resolved_sym = sym;
2837 pure_subroutine (c, sym);
2843 /* Resolve a subroutine call. Although it was tempting to use the same code
2844 for functions, subroutines and functions are stored differently and this
2845 makes things awkward. */
2848 resolve_call (gfc_code *c)
2851 procedure_type ptype = PROC_INTRINSIC;
2853 bool no_formal_args;
2855 csym = c->symtree ? c->symtree->n.sym : NULL;
2857 if (csym && csym->ts.type != BT_UNKNOWN)
2859 gfc_error ("'%s' at %L has a type, which is not consistent with "
2860 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
2864 /* If external, check for usage. */
2865 if (csym && is_external_proc (csym))
2866 resolve_global_procedure (csym, &c->loc, 1);
2868 /* Subroutines without the RECURSIVE attribution are not allowed to
2869 * call themselves. */
2870 if (csym && !csym->attr.recursive)
2873 proc = gfc_current_ns->proc_name;
2876 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2877 "RECURSIVE", csym->name, &c->loc);
2881 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2882 && csym->ns->entries->sym == proc->ns->entries->sym)
2884 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2885 "'%s' is not declared as RECURSIVE",
2886 csym->name, &c->loc, csym->ns->entries->sym->name);
2891 /* Switch off assumed size checking and do this again for certain kinds
2892 of procedure, once the procedure itself is resolved. */
2893 need_full_assumed_size++;
2896 ptype = csym->attr.proc;
2898 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
2899 if (resolve_actual_arglist (c->ext.actual, ptype,
2900 no_formal_args) == FAILURE)
2903 /* Resume assumed_size checking. */
2904 need_full_assumed_size--;
2907 if (c->resolved_sym == NULL)
2908 switch (procedure_kind (csym))
2911 t = resolve_generic_s (c);
2914 case PTYPE_SPECIFIC:
2915 t = resolve_specific_s (c);
2919 t = resolve_unknown_s (c);
2923 gfc_internal_error ("resolve_subroutine(): bad function type");
2926 /* Some checks of elemental subroutine actual arguments. */
2927 if (resolve_elemental_actual (NULL, c) == FAILURE)
2930 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
2931 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2936 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2937 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2938 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2939 if their shapes do not match. If either op1->shape or op2->shape is
2940 NULL, return SUCCESS. */
2943 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2950 if (op1->shape != NULL && op2->shape != NULL)
2952 for (i = 0; i < op1->rank; i++)
2954 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2956 gfc_error ("Shapes for operands at %L and %L are not conformable",
2957 &op1->where, &op2->where);
2968 /* Resolve an operator expression node. This can involve replacing the
2969 operation with a user defined function call. */
2972 resolve_operator (gfc_expr *e)
2974 gfc_expr *op1, *op2;
2976 bool dual_locus_error;
2979 /* Resolve all subnodes-- give them types. */
2981 switch (e->value.op.op)
2984 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2987 /* Fall through... */
2990 case INTRINSIC_UPLUS:
2991 case INTRINSIC_UMINUS:
2992 case INTRINSIC_PARENTHESES:
2993 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2998 /* Typecheck the new node. */
3000 op1 = e->value.op.op1;
3001 op2 = e->value.op.op2;
3002 dual_locus_error = false;
3004 if ((op1 && op1->expr_type == EXPR_NULL)
3005 || (op2 && op2->expr_type == EXPR_NULL))
3007 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3011 switch (e->value.op.op)
3013 case INTRINSIC_UPLUS:
3014 case INTRINSIC_UMINUS:
3015 if (op1->ts.type == BT_INTEGER
3016 || op1->ts.type == BT_REAL
3017 || op1->ts.type == BT_COMPLEX)
3023 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3024 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3027 case INTRINSIC_PLUS:
3028 case INTRINSIC_MINUS:
3029 case INTRINSIC_TIMES:
3030 case INTRINSIC_DIVIDE:
3031 case INTRINSIC_POWER:
3032 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3034 gfc_type_convert_binary (e);
3039 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3040 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3041 gfc_typename (&op2->ts));
3044 case INTRINSIC_CONCAT:
3045 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3046 && op1->ts.kind == op2->ts.kind)
3048 e->ts.type = BT_CHARACTER;
3049 e->ts.kind = op1->ts.kind;
3054 _("Operands of string concatenation operator at %%L are %s/%s"),
3055 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3061 case INTRINSIC_NEQV:
3062 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3064 e->ts.type = BT_LOGICAL;
3065 e->ts.kind = gfc_kind_max (op1, op2);
3066 if (op1->ts.kind < e->ts.kind)
3067 gfc_convert_type (op1, &e->ts, 2);
3068 else if (op2->ts.kind < e->ts.kind)
3069 gfc_convert_type (op2, &e->ts, 2);
3073 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3074 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3075 gfc_typename (&op2->ts));
3080 if (op1->ts.type == BT_LOGICAL)
3082 e->ts.type = BT_LOGICAL;
3083 e->ts.kind = op1->ts.kind;
3087 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3088 gfc_typename (&op1->ts));
3092 case INTRINSIC_GT_OS:
3094 case INTRINSIC_GE_OS:
3096 case INTRINSIC_LT_OS:
3098 case INTRINSIC_LE_OS:
3099 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3101 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3105 /* Fall through... */
3108 case INTRINSIC_EQ_OS:
3110 case INTRINSIC_NE_OS:
3111 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3112 && op1->ts.kind == op2->ts.kind)
3114 e->ts.type = BT_LOGICAL;
3115 e->ts.kind = gfc_default_logical_kind;
3119 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3121 gfc_type_convert_binary (e);
3123 e->ts.type = BT_LOGICAL;
3124 e->ts.kind = gfc_default_logical_kind;
3128 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3130 _("Logicals at %%L must be compared with %s instead of %s"),
3131 (e->value.op.op == INTRINSIC_EQ
3132 || e->value.op.op == INTRINSIC_EQ_OS)
3133 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3136 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3137 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3138 gfc_typename (&op2->ts));
3142 case INTRINSIC_USER:
3143 if (e->value.op.uop->op == NULL)
3144 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3145 else if (op2 == NULL)
3146 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3147 e->value.op.uop->name, gfc_typename (&op1->ts));
3149 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3150 e->value.op.uop->name, gfc_typename (&op1->ts),
3151 gfc_typename (&op2->ts));
3155 case INTRINSIC_PARENTHESES:
3157 if (e->ts.type == BT_CHARACTER)
3158 e->ts.cl = op1->ts.cl;
3162 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3165 /* Deal with arrayness of an operand through an operator. */
3169 switch (e->value.op.op)
3171 case INTRINSIC_PLUS:
3172 case INTRINSIC_MINUS:
3173 case INTRINSIC_TIMES:
3174 case INTRINSIC_DIVIDE:
3175 case INTRINSIC_POWER:
3176 case INTRINSIC_CONCAT:
3180 case INTRINSIC_NEQV:
3182 case INTRINSIC_EQ_OS:
3184 case INTRINSIC_NE_OS:
3186 case INTRINSIC_GT_OS:
3188 case INTRINSIC_GE_OS:
3190 case INTRINSIC_LT_OS:
3192 case INTRINSIC_LE_OS:
3194 if (op1->rank == 0 && op2->rank == 0)
3197 if (op1->rank == 0 && op2->rank != 0)
3199 e->rank = op2->rank;
3201 if (e->shape == NULL)
3202 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3205 if (op1->rank != 0 && op2->rank == 0)
3207 e->rank = op1->rank;
3209 if (e->shape == NULL)
3210 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3213 if (op1->rank != 0 && op2->rank != 0)
3215 if (op1->rank == op2->rank)
3217 e->rank = op1->rank;
3218 if (e->shape == NULL)
3220 t = compare_shapes(op1, op2);
3224 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3229 /* Allow higher level expressions to work. */
3232 /* Try user-defined operators, and otherwise throw an error. */
3233 dual_locus_error = true;
3235 _("Inconsistent ranks for operator at %%L and %%L"));
3242 case INTRINSIC_PARENTHESES:
3244 case INTRINSIC_UPLUS:
3245 case INTRINSIC_UMINUS:
3246 /* Simply copy arrayness attribute */
3247 e->rank = op1->rank;
3249 if (e->shape == NULL)
3250 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3258 /* Attempt to simplify the expression. */
3261 t = gfc_simplify_expr (e, 0);
3262 /* Some calls do not succeed in simplification and return FAILURE
3263 even though there is no error; e.g. variable references to
3264 PARAMETER arrays. */
3265 if (!gfc_is_constant_expr (e))
3272 if (gfc_extend_expr (e) == SUCCESS)
3275 if (dual_locus_error)
3276 gfc_error (msg, &op1->where, &op2->where);
3278 gfc_error (msg, &e->where);
3284 /************** Array resolution subroutines **************/
3287 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3290 /* Compare two integer expressions. */
3293 compare_bound (gfc_expr *a, gfc_expr *b)
3297 if (a == NULL || a->expr_type != EXPR_CONSTANT
3298 || b == NULL || b->expr_type != EXPR_CONSTANT)
3301 /* If either of the types isn't INTEGER, we must have
3302 raised an error earlier. */
3304 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3307 i = mpz_cmp (a->value.integer, b->value.integer);
3317 /* Compare an integer expression with an integer. */
3320 compare_bound_int (gfc_expr *a, int b)
3324 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3327 if (a->ts.type != BT_INTEGER)
3328 gfc_internal_error ("compare_bound_int(): Bad expression");
3330 i = mpz_cmp_si (a->value.integer, b);
3340 /* Compare an integer expression with a mpz_t. */
3343 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3347 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3350 if (a->ts.type != BT_INTEGER)
3351 gfc_internal_error ("compare_bound_int(): Bad expression");
3353 i = mpz_cmp (a->value.integer, b);
3363 /* Compute the last value of a sequence given by a triplet.
3364 Return 0 if it wasn't able to compute the last value, or if the
3365 sequence if empty, and 1 otherwise. */
3368 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3369 gfc_expr *stride, mpz_t last)
3373 if (start == NULL || start->expr_type != EXPR_CONSTANT
3374 || end == NULL || end->expr_type != EXPR_CONSTANT
3375 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3378 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3379 || (stride != NULL && stride->ts.type != BT_INTEGER))
3382 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3384 if (compare_bound (start, end) == CMP_GT)
3386 mpz_set (last, end->value.integer);
3390 if (compare_bound_int (stride, 0) == CMP_GT)
3392 /* Stride is positive */
3393 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3398 /* Stride is negative */
3399 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3404 mpz_sub (rem, end->value.integer, start->value.integer);
3405 mpz_tdiv_r (rem, rem, stride->value.integer);
3406 mpz_sub (last, end->value.integer, rem);
3413 /* Compare a single dimension of an array reference to the array
3417 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3421 /* Given start, end and stride values, calculate the minimum and
3422 maximum referenced indexes. */
3424 switch (ar->dimen_type[i])
3430 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3432 gfc_warning ("Array reference at %L is out of bounds "
3433 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3434 mpz_get_si (ar->start[i]->value.integer),
3435 mpz_get_si (as->lower[i]->value.integer), i+1);
3438 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3440 gfc_warning ("Array reference at %L is out of bounds "
3441 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3442 mpz_get_si (ar->start[i]->value.integer),
3443 mpz_get_si (as->upper[i]->value.integer), i+1);
3451 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3452 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3454 comparison comp_start_end = compare_bound (AR_START, AR_END);
3456 /* Check for zero stride, which is not allowed. */
3457 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3459 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3463 /* if start == len || (stride > 0 && start < len)
3464 || (stride < 0 && start > len),
3465 then the array section contains at least one element. In this
3466 case, there is an out-of-bounds access if
3467 (start < lower || start > upper). */
3468 if (compare_bound (AR_START, AR_END) == CMP_EQ
3469 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3470 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3471 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3472 && comp_start_end == CMP_GT))
3474 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3476 gfc_warning ("Lower array reference at %L is out of bounds "
3477 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3478 mpz_get_si (AR_START->value.integer),
3479 mpz_get_si (as->lower[i]->value.integer), i+1);
3482 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3484 gfc_warning ("Lower array reference at %L is out of bounds "
3485 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3486 mpz_get_si (AR_START->value.integer),
3487 mpz_get_si (as->upper[i]->value.integer), i+1);
3492 /* If we can compute the highest index of the array section,
3493 then it also has to be between lower and upper. */
3494 mpz_init (last_value);
3495 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3498 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3500 gfc_warning ("Upper array reference at %L is out of bounds "
3501 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3502 mpz_get_si (last_value),
3503 mpz_get_si (as->lower[i]->value.integer), i+1);
3504 mpz_clear (last_value);
3507 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3509 gfc_warning ("Upper array reference at %L is out of bounds "
3510 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3511 mpz_get_si (last_value),
3512 mpz_get_si (as->upper[i]->value.integer), i+1);
3513 mpz_clear (last_value);
3517 mpz_clear (last_value);
3525 gfc_internal_error ("check_dimension(): Bad array reference");
3532 /* Compare an array reference with an array specification. */
3535 compare_spec_to_ref (gfc_array_ref *ar)
3542 /* TODO: Full array sections are only allowed as actual parameters. */
3543 if (as->type == AS_ASSUMED_SIZE
3544 && (/*ar->type == AR_FULL
3545 ||*/ (ar->type == AR_SECTION
3546 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3548 gfc_error ("Rightmost upper bound of assumed size array section "
3549 "not specified at %L", &ar->where);
3553 if (ar->type == AR_FULL)
3556 if (as->rank != ar->dimen)
3558 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3559 &ar->where, ar->dimen, as->rank);
3563 for (i = 0; i < as->rank; i++)
3564 if (check_dimension (i, ar, as) == FAILURE)
3571 /* Resolve one part of an array index. */
3574 gfc_resolve_index (gfc_expr *index, int check_scalar)
3581 if (gfc_resolve_expr (index) == FAILURE)
3584 if (check_scalar && index->rank != 0)
3586 gfc_error ("Array index at %L must be scalar", &index->where);
3590 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3592 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3593 &index->where, gfc_basic_typename (index->ts.type));
3597 if (index->ts.type == BT_REAL)
3598 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3599 &index->where) == FAILURE)
3602 if (index->ts.kind != gfc_index_integer_kind
3603 || index->ts.type != BT_INTEGER)
3606 ts.type = BT_INTEGER;
3607 ts.kind = gfc_index_integer_kind;
3609 gfc_convert_type_warn (index, &ts, 2, 0);
3615 /* Resolve a dim argument to an intrinsic function. */
3618 gfc_resolve_dim_arg (gfc_expr *dim)
3623 if (gfc_resolve_expr (dim) == FAILURE)
3628 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3633 if (dim->ts.type != BT_INTEGER)
3635 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3639 if (dim->ts.kind != gfc_index_integer_kind)
3643 ts.type = BT_INTEGER;
3644 ts.kind = gfc_index_integer_kind;
3646 gfc_convert_type_warn (dim, &ts, 2, 0);
3652 /* Given an expression that contains array references, update those array
3653 references to point to the right array specifications. While this is
3654 filled in during matching, this information is difficult to save and load
3655 in a module, so we take care of it here.
3657 The idea here is that the original array reference comes from the
3658 base symbol. We traverse the list of reference structures, setting
3659 the stored reference to references. Component references can
3660 provide an additional array specification. */
3663 find_array_spec (gfc_expr *e)
3667 gfc_symbol *derived;
3670 as = e->symtree->n.sym->as;
3673 for (ref = e->ref; ref; ref = ref->next)
3678 gfc_internal_error ("find_array_spec(): Missing spec");
3685 if (derived == NULL)
3686 derived = e->symtree->n.sym->ts.derived;
3688 c = derived->components;
3690 for (; c; c = c->next)
3691 if (c == ref->u.c.component)
3693 /* Track the sequence of component references. */
3694 if (c->ts.type == BT_DERIVED)
3695 derived = c->ts.derived;
3700 gfc_internal_error ("find_array_spec(): Component not found");
3702 if (c->attr.dimension)
3705 gfc_internal_error ("find_array_spec(): unused as(1)");
3716 gfc_internal_error ("find_array_spec(): unused as(2)");
3720 /* Resolve an array reference. */
3723 resolve_array_ref (gfc_array_ref *ar)
3725 int i, check_scalar;
3728 for (i = 0; i < ar->dimen; i++)
3730 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3732 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3734 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3736 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3741 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3745 ar->dimen_type[i] = DIMEN_ELEMENT;
3749 ar->dimen_type[i] = DIMEN_VECTOR;
3750 if (e->expr_type == EXPR_VARIABLE
3751 && e->symtree->n.sym->ts.type == BT_DERIVED)
3752 ar->start[i] = gfc_get_parentheses (e);
3756 gfc_error ("Array index at %L is an array of rank %d",
3757 &ar->c_where[i], e->rank);
3762 /* If the reference type is unknown, figure out what kind it is. */
3764 if (ar->type == AR_UNKNOWN)
3766 ar->type = AR_ELEMENT;
3767 for (i = 0; i < ar->dimen; i++)
3768 if (ar->dimen_type[i] == DIMEN_RANGE
3769 || ar->dimen_type[i] == DIMEN_VECTOR)
3771 ar->type = AR_SECTION;
3776 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3784 resolve_substring (gfc_ref *ref)
3786 if (ref->u.ss.start != NULL)
3788 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3791 if (ref->u.ss.start->ts.type != BT_INTEGER)
3793 gfc_error ("Substring start index at %L must be of type INTEGER",
3794 &ref->u.ss.start->where);
3798 if (ref->u.ss.start->rank != 0)
3800 gfc_error ("Substring start index at %L must be scalar",
3801 &ref->u.ss.start->where);
3805 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3806 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3807 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3809 gfc_error ("Substring start index at %L is less than one",
3810 &ref->u.ss.start->where);
3815 if (ref->u.ss.end != NULL)
3817 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3820 if (ref->u.ss.end->ts.type != BT_INTEGER)
3822 gfc_error ("Substring end index at %L must be of type INTEGER",
3823 &ref->u.ss.end->where);
3827 if (ref->u.ss.end->rank != 0)
3829 gfc_error ("Substring end index at %L must be scalar",
3830 &ref->u.ss.end->where);
3834 if (ref->u.ss.length != NULL
3835 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3836 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3837 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3839 gfc_error ("Substring end index at %L exceeds the string length",
3840 &ref->u.ss.start->where);
3849 /* This function supplies missing substring charlens. */
3852 gfc_resolve_substring_charlen (gfc_expr *e)
3855 gfc_expr *start, *end;
3857 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3858 if (char_ref->type == REF_SUBSTRING)
3864 gcc_assert (char_ref->next == NULL);
3868 if (e->ts.cl->length)
3869 gfc_free_expr (e->ts.cl->length);
3870 else if (e->expr_type == EXPR_VARIABLE
3871 && e->symtree->n.sym->attr.dummy)
3875 e->ts.type = BT_CHARACTER;
3876 e->ts.kind = gfc_default_character_kind;
3880 e->ts.cl = gfc_get_charlen ();
3881 e->ts.cl->next = gfc_current_ns->cl_list;
3882 gfc_current_ns->cl_list = e->ts.cl;
3885 if (char_ref->u.ss.start)
3886 start = gfc_copy_expr (char_ref->u.ss.start);
3888 start = gfc_int_expr (1);
3890 if (char_ref->u.ss.end)
3891 end = gfc_copy_expr (char_ref->u.ss.end);
3892 else if (e->expr_type == EXPR_VARIABLE)
3893 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3900 /* Length = (end - start +1). */
3901 e->ts.cl->length = gfc_subtract (end, start);
3902 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3904 e->ts.cl->length->ts.type = BT_INTEGER;
3905 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3907 /* Make sure that the length is simplified. */
3908 gfc_simplify_expr (e->ts.cl->length, 1);
3909 gfc_resolve_expr (e->ts.cl->length);
3913 /* Resolve subtype references. */
3916 resolve_ref (gfc_expr *expr)
3918 int current_part_dimension, n_components, seen_part_dimension;
3921 for (ref = expr->ref; ref; ref = ref->next)
3922 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3924 find_array_spec (expr);
3928 for (ref = expr->ref; ref; ref = ref->next)
3932 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3940 resolve_substring (ref);
3944 /* Check constraints on part references. */
3946 current_part_dimension = 0;
3947 seen_part_dimension = 0;
3950 for (ref = expr->ref; ref; ref = ref->next)
3955 switch (ref->u.ar.type)
3959 current_part_dimension = 1;
3963 current_part_dimension = 0;
3967 gfc_internal_error ("resolve_ref(): Bad array reference");
3973 if (current_part_dimension || seen_part_dimension)
3975 if (ref->u.c.component->attr.pointer)
3977 gfc_error ("Component to the right of a part reference "
3978 "with nonzero rank must not have the POINTER "
3979 "attribute at %L", &expr->where);
3982 else if (ref->u.c.component->attr.allocatable)
3984 gfc_error ("Component to the right of a part reference "
3985 "with nonzero rank must not have the ALLOCATABLE "
3986 "attribute at %L", &expr->where);
3998 if (((ref->type == REF_COMPONENT && n_components > 1)
3999 || ref->next == NULL)
4000 && current_part_dimension
4001 && seen_part_dimension)
4003 gfc_error ("Two or more part references with nonzero rank must "
4004 "not be specified at %L", &expr->where);
4008 if (ref->type == REF_COMPONENT)
4010 if (current_part_dimension)
4011 seen_part_dimension = 1;
4013 /* reset to make sure */
4014 current_part_dimension = 0;
4022 /* Given an expression, determine its shape. This is easier than it sounds.
4023 Leaves the shape array NULL if it is not possible to determine the shape. */
4026 expression_shape (gfc_expr *e)
4028 mpz_t array[GFC_MAX_DIMENSIONS];
4031 if (e->rank == 0 || e->shape != NULL)
4034 for (i = 0; i < e->rank; i++)
4035 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4038 e->shape = gfc_get_shape (e->rank);
4040 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4045 for (i--; i >= 0; i--)
4046 mpz_clear (array[i]);
4050 /* Given a variable expression node, compute the rank of the expression by
4051 examining the base symbol and any reference structures it may have. */
4054 expression_rank (gfc_expr *e)
4059 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4060 could lead to serious confusion... */
4061 gcc_assert (e->expr_type != EXPR_COMPCALL);
4065 if (e->expr_type == EXPR_ARRAY)
4067 /* Constructors can have a rank different from one via RESHAPE(). */
4069 if (e->symtree == NULL)
4075 e->rank = (e->symtree->n.sym->as == NULL)
4076 ? 0 : e->symtree->n.sym->as->rank;
4082 for (ref = e->ref; ref; ref = ref->next)
4084 if (ref->type != REF_ARRAY)
4087 if (ref->u.ar.type == AR_FULL)
4089 rank = ref->u.ar.as->rank;
4093 if (ref->u.ar.type == AR_SECTION)
4095 /* Figure out the rank of the section. */
4097 gfc_internal_error ("expression_rank(): Two array specs");
4099 for (i = 0; i < ref->u.ar.dimen; i++)
4100 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4101 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4111 expression_shape (e);
4115 /* Resolve a variable expression. */
4118 resolve_variable (gfc_expr *e)
4125 if (e->symtree == NULL)
4128 if (e->ref && resolve_ref (e) == FAILURE)
4131 sym = e->symtree->n.sym;
4132 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
4134 e->ts.type = BT_PROCEDURE;
4138 if (sym->ts.type != BT_UNKNOWN)
4139 gfc_variable_attr (e, &e->ts);
4142 /* Must be a simple variable reference. */
4143 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4148 if (check_assumed_size_reference (sym, e))
4151 /* Deal with forward references to entries during resolve_code, to
4152 satisfy, at least partially, 12.5.2.5. */
4153 if (gfc_current_ns->entries
4154 && current_entry_id == sym->entry_id
4157 && cs_base->current->op != EXEC_ENTRY)
4159 gfc_entry_list *entry;
4160 gfc_formal_arglist *formal;
4164 /* If the symbol is a dummy... */
4165 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4167 entry = gfc_current_ns->entries;
4170 /* ...test if the symbol is a parameter of previous entries. */
4171 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4172 for (formal = entry->sym->formal; formal; formal = formal->next)
4174 if (formal->sym && sym->name == formal->sym->name)
4178 /* If it has not been seen as a dummy, this is an error. */
4181 if (specification_expr)
4182 gfc_error ("Variable '%s', used in a specification expression"
4183 ", is referenced at %L before the ENTRY statement "
4184 "in which it is a parameter",
4185 sym->name, &cs_base->current->loc);
4187 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4188 "statement in which it is a parameter",
4189 sym->name, &cs_base->current->loc);
4194 /* Now do the same check on the specification expressions. */
4195 specification_expr = 1;
4196 if (sym->ts.type == BT_CHARACTER
4197 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
4201 for (n = 0; n < sym->as->rank; n++)
4203 specification_expr = 1;
4204 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4206 specification_expr = 1;
4207 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4210 specification_expr = 0;
4213 /* Update the symbol's entry level. */
4214 sym->entry_id = current_entry_id + 1;
4221 /* Checks to see that the correct symbol has been host associated.
4222 The only situation where this arises is that in which a twice
4223 contained function is parsed after the host association is made.
4224 Therefore, on detecting this, the line is rematched, having got
4225 rid of the existing references and actual_arg_list. */
4227 check_host_association (gfc_expr *e)
4229 gfc_symbol *sym, *old_sym;
4233 bool retval = e->expr_type == EXPR_FUNCTION;
4235 if (e->symtree == NULL || e->symtree->n.sym == NULL)
4238 old_sym = e->symtree->n.sym;
4240 if (old_sym->attr.use_assoc)
4243 if (gfc_current_ns->parent
4244 && old_sym->ns != gfc_current_ns)
4246 gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym);
4247 if (sym && old_sym != sym
4248 && sym->attr.flavor == FL_PROCEDURE
4249 && sym->attr.contained)
4251 temp_locus = gfc_current_locus;
4252 gfc_current_locus = e->where;
4254 gfc_buffer_error (1);
4256 gfc_free_ref_list (e->ref);
4261 gfc_free_actual_arglist (e->value.function.actual);
4262 e->value.function.actual = NULL;
4265 if (e->shape != NULL)
4267 for (n = 0; n < e->rank; n++)
4268 mpz_clear (e->shape[n]);
4270 gfc_free (e->shape);
4273 gfc_match_rvalue (&expr);
4275 gfc_buffer_error (0);
4277 gcc_assert (expr && sym == expr->symtree->n.sym);
4283 gfc_current_locus = temp_locus;
4286 /* This might have changed! */
4287 return e->expr_type == EXPR_FUNCTION;
4292 gfc_resolve_character_operator (gfc_expr *e)
4294 gfc_expr *op1 = e->value.op.op1;
4295 gfc_expr *op2 = e->value.op.op2;
4296 gfc_expr *e1 = NULL;
4297 gfc_expr *e2 = NULL;
4299 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
4301 if (op1->ts.cl && op1->ts.cl->length)
4302 e1 = gfc_copy_expr (op1->ts.cl->length);
4303 else if (op1->expr_type == EXPR_CONSTANT)
4304 e1 = gfc_int_expr (op1->value.character.length);
4306 if (op2->ts.cl && op2->ts.cl->length)
4307 e2 = gfc_copy_expr (op2->ts.cl->length);
4308 else if (op2->expr_type == EXPR_CONSTANT)
4309 e2 = gfc_int_expr (op2->value.character.length);
4311 e->ts.cl = gfc_get_charlen ();
4312 e->ts.cl->next = gfc_current_ns->cl_list;
4313 gfc_current_ns->cl_list = e->ts.cl;
4318 e->ts.cl->length = gfc_add (e1, e2);
4319 e->ts.cl->length->ts.type = BT_INTEGER;
4320 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4321 gfc_simplify_expr (e->ts.cl->length, 0);
4322 gfc_resolve_expr (e->ts.cl->length);
4328 /* Ensure that an character expression has a charlen and, if possible, a
4329 length expression. */
4332 fixup_charlen (gfc_expr *e)
4334 /* The cases fall through so that changes in expression type and the need
4335 for multiple fixes are picked up. In all circumstances, a charlen should
4336 be available for the middle end to hang a backend_decl on. */
4337 switch (e->expr_type)
4340 gfc_resolve_character_operator (e);
4343 if (e->expr_type == EXPR_ARRAY)
4344 gfc_resolve_character_array_constructor (e);
4346 case EXPR_SUBSTRING:
4347 if (!e->ts.cl && e->ref)
4348 gfc_resolve_substring_charlen (e);
4353 e->ts.cl = gfc_get_charlen ();
4354 e->ts.cl->next = gfc_current_ns->cl_list;
4355 gfc_current_ns->cl_list = e->ts.cl;
4363 /* Update an actual argument to include the passed-object for type-bound
4364 procedures at the right position. */
4366 static gfc_actual_arglist*
4367 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
4371 gfc_actual_arglist* result;
4373 result = gfc_get_actual_arglist ();
4381 gcc_assert (argpos > 1);
4383 lst->next = update_arglist_pass (lst->next, po, argpos - 1);
4388 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4391 extract_compcall_passed_object (gfc_expr* e)
4395 gcc_assert (e->expr_type == EXPR_COMPCALL);
4397 po = gfc_get_expr ();
4398 po->expr_type = EXPR_VARIABLE;
4399 po->symtree = e->symtree;
4400 po->ref = gfc_copy_ref (e->ref);
4402 if (gfc_resolve_expr (po) == FAILURE)
4409 /* Update the arglist of an EXPR_COMPCALL expression to include the
4413 update_compcall_arglist (gfc_expr* e)
4416 gfc_typebound_proc* tbp;
4418 tbp = e->value.compcall.tbp;
4420 po = extract_compcall_passed_object (e);
4426 gfc_error ("Passed-object at %L must be scalar", &e->where);
4436 gcc_assert (tbp->pass_arg_num > 0);
4437 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4444 /* Resolve a call to a type-bound procedure, either function or subroutine,
4445 statically from the data in an EXPR_COMPCALL expression. The adapted
4446 arglist and the target-procedure symtree are returned. */
4449 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
4450 gfc_actual_arglist** actual)
4452 gcc_assert (e->expr_type == EXPR_COMPCALL);
4453 gcc_assert (!e->value.compcall.tbp->is_generic);
4455 /* Update the actual arglist for PASS. */
4456 if (update_compcall_arglist (e) == FAILURE)
4459 *actual = e->value.compcall.actual;
4460 *target = e->value.compcall.tbp->u.specific;
4462 gfc_free_ref_list (e->ref);
4464 e->value.compcall.actual = NULL;
4470 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4471 which of the specific bindings (if any) matches the arglist and transform
4472 the expression into a call of that binding. */
4475 resolve_typebound_generic_call (gfc_expr* e)
4477 gfc_typebound_proc* genproc;
4478 const char* genname;
4480 gcc_assert (e->expr_type == EXPR_COMPCALL);
4481 genname = e->value.compcall.name;
4482 genproc = e->value.compcall.tbp;
4484 if (!genproc->is_generic)
4487 /* Try the bindings on this type and in the inheritance hierarchy. */
4488 for (; genproc; genproc = genproc->overridden)
4492 gcc_assert (genproc->is_generic);
4493 for (g = genproc->u.generic; g; g = g->next)
4496 gfc_actual_arglist* args;
4499 gcc_assert (g->specific);
4500 target = g->specific->u.specific->n.sym;
4502 /* Get the right arglist by handling PASS/NOPASS. */
4503 args = gfc_copy_actual_arglist (e->value.compcall.actual);
4504 if (!g->specific->nopass)
4507 po = extract_compcall_passed_object (e);
4511 args = update_arglist_pass (args, po, g->specific->pass_arg_num);
4513 resolve_actual_arglist (args, target->attr.proc,
4514 is_external_proc (target) && !target->formal);
4516 /* Check if this arglist matches the formal. */
4517 matches = gfc_arglist_matches_symbol (&args, target);
4519 /* Clean up and break out of the loop if we've found it. */
4520 gfc_free_actual_arglist (args);
4523 e->value.compcall.tbp = g->specific;
4529 /* Nothing matching found! */
4530 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4531 " '%s' at %L", genname, &e->where);
4539 /* Resolve a call to a type-bound subroutine. */
4542 resolve_typebound_call (gfc_code* c)
4544 gfc_actual_arglist* newactual;
4545 gfc_symtree* target;
4547 /* Check that's really a SUBROUTINE. */
4548 if (!c->expr->value.compcall.tbp->subroutine)
4550 gfc_error ("'%s' at %L should be a SUBROUTINE",
4551 c->expr->value.compcall.name, &c->loc);
4555 if (resolve_typebound_generic_call (c->expr) == FAILURE)
4558 /* Transform into an ordinary EXEC_CALL for now. */
4560 if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
4563 c->ext.actual = newactual;
4564 c->symtree = target;
4567 gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
4568 gfc_free_expr (c->expr);
4571 return resolve_call (c);
4575 /* Resolve a component-call expression. */
4578 resolve_compcall (gfc_expr* e)
4580 gfc_actual_arglist* newactual;
4581 gfc_symtree* target;
4583 /* Check that's really a FUNCTION. */
4584 if (!e->value.compcall.tbp->function)
4586 gfc_error ("'%s' at %L should be a FUNCTION",
4587 e->value.compcall.name, &e->where);
4591 if (resolve_typebound_generic_call (e) == FAILURE)
4593 gcc_assert (!e->value.compcall.tbp->is_generic);
4595 /* Take the rank from the function's symbol. */
4596 if (e->value.compcall.tbp->u.specific->n.sym->as)
4597 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
4599 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4600 arglist to the TBP's binding target. */
4602 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
4605 e->value.function.actual = newactual;
4606 e->value.function.name = e->value.compcall.name;
4607 e->value.function.isym = NULL;
4608 e->value.function.esym = NULL;
4609 e->symtree = target;
4610 e->ts = target->n.sym->ts;
4611 e->expr_type = EXPR_FUNCTION;
4613 return gfc_resolve_expr (e);
4617 /* Resolve an expression. That is, make sure that types of operands agree
4618 with their operators, intrinsic operators are converted to function calls
4619 for overloaded types and unresolved function references are resolved. */
4622 gfc_resolve_expr (gfc_expr *e)
4629 switch (e->expr_type)
4632 t = resolve_operator (e);
4638 if (check_host_association (e))
4639 t = resolve_function (e);
4642 t = resolve_variable (e);
4644 expression_rank (e);
4647 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4648 && e->ref->type != REF_SUBSTRING)
4649 gfc_resolve_substring_charlen (e);
4654 t = resolve_compcall (e);
4657 case EXPR_SUBSTRING:
4658 t = resolve_ref (e);
4668 if (resolve_ref (e) == FAILURE)
4671 t = gfc_resolve_array_constructor (e);
4672 /* Also try to expand a constructor. */
4675 expression_rank (e);
4676 gfc_expand_constructor (e);
4679 /* This provides the opportunity for the length of constructors with
4680 character valued function elements to propagate the string length
4681 to the expression. */
4682 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
4683 t = gfc_resolve_character_array_constructor (e);
4687 case EXPR_STRUCTURE:
4688 t = resolve_ref (e);
4692 t = resolve_structure_cons (e);
4696 t = gfc_simplify_expr (e, 0);
4700 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4703 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4710 /* Resolve an expression from an iterator. They must be scalar and have
4711 INTEGER or (optionally) REAL type. */
4714 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4715 const char *name_msgid)
4717 if (gfc_resolve_expr (expr) == FAILURE)
4720 if (expr->rank != 0)
4722 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4726 if (expr->ts.type != BT_INTEGER)
4728 if (expr->ts.type == BT_REAL)
4731 return gfc_notify_std (GFC_STD_F95_DEL,
4732 "Deleted feature: %s at %L must be integer",
4733 _(name_msgid), &expr->where);
4736 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4743 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4751 /* Resolve the expressions in an iterator structure. If REAL_OK is
4752 false allow only INTEGER type iterators, otherwise allow REAL types. */
4755 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4757 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4761 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4763 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4768 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4769 "Start expression in DO loop") == FAILURE)
4772 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4773 "End expression in DO loop") == FAILURE)
4776 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4777 "Step expression in DO loop") == FAILURE)
4780 if (iter->step->expr_type == EXPR_CONSTANT)
4782 if ((iter->step->ts.type == BT_INTEGER
4783 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4784 || (iter->step->ts.type == BT_REAL
4785 && mpfr_sgn (iter->step->value.real) == 0))
4787 gfc_error ("Step expression in DO loop at %L cannot be zero",
4788 &iter->step->where);
4793 /* Convert start, end, and step to the same type as var. */
4794 if (iter->start->ts.kind != iter->var->ts.kind
4795 || iter->start->ts.type != iter->var->ts.type)
4796 gfc_convert_type (iter->start, &iter->var->ts, 2);
4798 if (iter->end->ts.kind != iter->var->ts.kind
4799 || iter->end->ts.type != iter->var->ts.type)
4800 gfc_convert_type (iter->end, &iter->var->ts, 2);
4802 if (iter->step->ts.kind != iter->var->ts.kind
4803 || iter->step->ts.type != iter->var->ts.type)
4804 gfc_convert_type (iter->step, &iter->var->ts, 2);
4810 /* Traversal function for find_forall_index. f == 2 signals that
4811 that variable itself is not to be checked - only the references. */
4814 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
4816 if (expr->expr_type != EXPR_VARIABLE)
4819 /* A scalar assignment */
4820 if (!expr->ref || *f == 1)
4822 if (expr->symtree->n.sym == sym)
4834 /* Check whether the FORALL index appears in the expression or not.
4835 Returns SUCCESS if SYM is found in EXPR. */
4838 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
4840 if (gfc_traverse_expr (expr, sym, forall_index, f))
4847 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4848 to be a scalar INTEGER variable. The subscripts and stride are scalar
4849 INTEGERs, and if stride is a constant it must be nonzero.
4850 Furthermore "A subscript or stride in a forall-triplet-spec shall
4851 not contain a reference to any index-name in the
4852 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4855 resolve_forall_iterators (gfc_forall_iterator *it)
4857 gfc_forall_iterator *iter, *iter2;
4859 for (iter = it; iter; iter = iter->next)
4861 if (gfc_resolve_expr (iter->var) == SUCCESS
4862 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4863 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4866 if (gfc_resolve_expr (iter->start) == SUCCESS
4867 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4868 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4869 &iter->start->where);
4870 if (iter->var->ts.kind != iter->start->ts.kind)
4871 gfc_convert_type (iter->start, &iter->var->ts, 2);
4873 if (gfc_resolve_expr (iter->end) == SUCCESS
4874 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4875 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4877 if (iter->var->ts.kind != iter->end->ts.kind)
4878 gfc_convert_type (iter->end, &iter->var->ts, 2);
4880 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4882 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4883 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4884 &iter->stride->where, "INTEGER");
4886 if (iter->stride->expr_type == EXPR_CONSTANT
4887 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4888 gfc_error ("FORALL stride expression at %L cannot be zero",
4889 &iter->stride->where);
4891 if (iter->var->ts.kind != iter->stride->ts.kind)
4892 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4895 for (iter = it; iter; iter = iter->next)
4896 for (iter2 = iter; iter2; iter2 = iter2->next)
4898 if (find_forall_index (iter2->start,
4899 iter->var->symtree->n.sym, 0) == SUCCESS
4900 || find_forall_index (iter2->end,
4901 iter->var->symtree->n.sym, 0) == SUCCESS
4902 || find_forall_index (iter2->stride,
4903 iter->var->symtree->n.sym, 0) == SUCCESS)
4904 gfc_error ("FORALL index '%s' may not appear in triplet "
4905 "specification at %L", iter->var->symtree->name,
4906 &iter2->start->where);
4911 /* Given a pointer to a symbol that is a derived type, see if it's
4912 inaccessible, i.e. if it's defined in another module and the components are
4913 PRIVATE. The search is recursive if necessary. Returns zero if no
4914 inaccessible components are found, nonzero otherwise. */
4917 derived_inaccessible (gfc_symbol *sym)
4921 if (sym->attr.use_assoc && sym->attr.private_comp)
4924 for (c = sym->components; c; c = c->next)
4926 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4934 /* Resolve the argument of a deallocate expression. The expression must be
4935 a pointer or a full array. */
4938 resolve_deallocate_expr (gfc_expr *e)
4940 symbol_attribute attr;
4941 int allocatable, pointer, check_intent_in;
4944 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4945 check_intent_in = 1;
4947 if (gfc_resolve_expr (e) == FAILURE)
4950 if (e->expr_type != EXPR_VARIABLE)
4953 allocatable = e->symtree->n.sym->attr.allocatable;
4954 pointer = e->symtree->n.sym->attr.pointer;
4955 for (ref = e->ref; ref; ref = ref->next)
4958 check_intent_in = 0;
4963 if (ref->u.ar.type != AR_FULL)
4968 allocatable = (ref->u.c.component->as != NULL
4969 && ref->u.c.component->as->type == AS_DEFERRED);
4970 pointer = ref->u.c.component->attr.pointer;
4979 attr = gfc_expr_attr (e);
4981 if (allocatable == 0 && attr.pointer == 0)
4984 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4985 "ALLOCATABLE or a POINTER", &e->where);
4989 && e->symtree->n.sym->attr.intent == INTENT_IN)
4991 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4992 e->symtree->n.sym->name, &e->where);
5000 /* Returns true if the expression e contains a reference to the symbol sym. */
5002 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5004 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
5011 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
5013 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
5017 /* Given the expression node e for an allocatable/pointer of derived type to be
5018 allocated, get the expression node to be initialized afterwards (needed for
5019 derived types with default initializers, and derived types with allocatable
5020 components that need nullification.) */
5023 expr_to_initialize (gfc_expr *e)
5029 result = gfc_copy_expr (e);
5031 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5032 for (ref = result->ref; ref; ref = ref->next)
5033 if (ref->type == REF_ARRAY && ref->next == NULL)
5035 ref->u.ar.type = AR_FULL;
5037 for (i = 0; i < ref->u.ar.dimen; i++)
5038 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
5040 result->rank = ref->u.ar.dimen;
5048 /* Resolve the expression in an ALLOCATE statement, doing the additional
5049 checks to see whether the expression is OK or not. The expression must
5050 have a trailing array reference that gives the size of the array. */
5053 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
5055 int i, pointer, allocatable, dimension, check_intent_in;
5056 symbol_attribute attr;
5057 gfc_ref *ref, *ref2;
5064 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5065 check_intent_in = 1;
5067 if (gfc_resolve_expr (e) == FAILURE)
5070 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
5071 sym = code->expr->symtree->n.sym;
5075 /* Make sure the expression is allocatable or a pointer. If it is
5076 pointer, the next-to-last reference must be a pointer. */
5080 if (e->expr_type != EXPR_VARIABLE)
5083 attr = gfc_expr_attr (e);
5084 pointer = attr.pointer;
5085 dimension = attr.dimension;
5089 allocatable = e->symtree->n.sym->attr.allocatable;
5090 pointer = e->symtree->n.sym->attr.pointer;
5091 dimension = e->symtree->n.sym->attr.dimension;
5093 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
5095 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
5096 "not be allocated in the same statement at %L",
5097 sym->name, &e->where);
5101 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
5104 check_intent_in = 0;
5109 if (ref->next != NULL)
5114 allocatable = (ref->u.c.component->as != NULL
5115 && ref->u.c.component->as->type == AS_DEFERRED);
5117 pointer = ref->u.c.component->attr.pointer;
5118 dimension = ref->u.c.component->attr.dimension;
5129 if (allocatable == 0 && pointer == 0)
5131 gfc_error ("Expression in ALLOCATE statement at %L must be "
5132 "ALLOCATABLE or a POINTER", &e->where);
5137 && e->symtree->n.sym->attr.intent == INTENT_IN)
5139 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5140 e->symtree->n.sym->name, &e->where);
5144 /* Add default initializer for those derived types that need them. */
5145 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
5147 init_st = gfc_get_code ();
5148 init_st->loc = code->loc;
5149 init_st->op = EXEC_INIT_ASSIGN;
5150 init_st->expr = expr_to_initialize (e);
5151 init_st->expr2 = init_e;
5152 init_st->next = code->next;
5153 code->next = init_st;
5156 if (pointer && dimension == 0)
5159 /* Make sure the next-to-last reference node is an array specification. */
5161 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
5163 gfc_error ("Array specification required in ALLOCATE statement "
5164 "at %L", &e->where);
5168 /* Make sure that the array section reference makes sense in the
5169 context of an ALLOCATE specification. */
5173 for (i = 0; i < ar->dimen; i++)
5175 if (ref2->u.ar.type == AR_ELEMENT)
5178 switch (ar->dimen_type[i])
5184 if (ar->start[i] != NULL
5185 && ar->end[i] != NULL
5186 && ar->stride[i] == NULL)
5189 /* Fall Through... */
5193 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5200 for (a = code->ext.alloc_list; a; a = a->next)
5202 sym = a->expr->symtree->n.sym;
5204 /* TODO - check derived type components. */
5205 if (sym->ts.type == BT_DERIVED)
5208 if ((ar->start[i] != NULL
5209 && gfc_find_sym_in_expr (sym, ar->start[i]))
5210 || (ar->end[i] != NULL
5211 && gfc_find_sym_in_expr (sym, ar->end[i])))
5213 gfc_error ("'%s' must not appear in the array specification at "
5214 "%L in the same ALLOCATE statement where it is "
5215 "itself allocated", sym->name, &ar->where);
5225 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
5227 gfc_symbol *s = NULL;
5231 s = code->expr->symtree->n.sym;
5235 if (s->attr.intent == INTENT_IN)
5236 gfc_error ("STAT variable '%s' of %s statement at %C cannot "
5237 "be INTENT(IN)", s->name, fcn);
5239 if (gfc_pure (NULL) && gfc_impure_variable (s))
5240 gfc_error ("Illegal STAT variable in %s statement at %C "
5241 "for a PURE procedure", fcn);
5244 if (s && code->expr->ts.type != BT_INTEGER)
5245 gfc_error ("STAT tag in %s statement at %L must be "
5246 "of type INTEGER", fcn, &code->expr->where);
5248 if (strcmp (fcn, "ALLOCATE") == 0)
5250 for (a = code->ext.alloc_list; a; a = a->next)
5251 resolve_allocate_expr (a->expr, code);
5255 for (a = code->ext.alloc_list; a; a = a->next)
5256 resolve_deallocate_expr (a->expr);
5260 /************ SELECT CASE resolution subroutines ************/
5262 /* Callback function for our mergesort variant. Determines interval
5263 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5264 op1 > op2. Assumes we're not dealing with the default case.
5265 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5266 There are nine situations to check. */
5269 compare_cases (const gfc_case *op1, const gfc_case *op2)
5273 if (op1->low == NULL) /* op1 = (:L) */
5275 /* op2 = (:N), so overlap. */
5277 /* op2 = (M:) or (M:N), L < M */
5278 if (op2->low != NULL
5279 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5282 else if (op1->high == NULL) /* op1 = (K:) */
5284 /* op2 = (M:), so overlap. */
5286 /* op2 = (:N) or (M:N), K > N */
5287 if (op2->high != NULL
5288 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5291 else /* op1 = (K:L) */
5293 if (op2->low == NULL) /* op2 = (:N), K > N */
5294 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5296 else if (op2->high == NULL) /* op2 = (M:), L < M */
5297 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5299 else /* op2 = (M:N) */
5303 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5306 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5315 /* Merge-sort a double linked case list, detecting overlap in the
5316 process. LIST is the head of the double linked case list before it
5317 is sorted. Returns the head of the sorted list if we don't see any
5318 overlap, or NULL otherwise. */
5321 check_case_overlap (gfc_case *list)
5323 gfc_case *p, *q, *e, *tail;
5324 int insize, nmerges, psize, qsize, cmp, overlap_seen;
5326 /* If the passed list was empty, return immediately. */
5333 /* Loop unconditionally. The only exit from this loop is a return
5334 statement, when we've finished sorting the case list. */
5341 /* Count the number of merges we do in this pass. */
5344 /* Loop while there exists a merge to be done. */
5349 /* Count this merge. */
5352 /* Cut the list in two pieces by stepping INSIZE places
5353 forward in the list, starting from P. */
5356 for (i = 0; i < insize; i++)
5365 /* Now we have two lists. Merge them! */
5366 while (psize > 0 || (qsize > 0 && q != NULL))
5368 /* See from which the next case to merge comes from. */
5371 /* P is empty so the next case must come from Q. */
5376 else if (qsize == 0 || q == NULL)
5385 cmp = compare_cases (p, q);
5388 /* The whole case range for P is less than the
5396 /* The whole case range for Q is greater than
5397 the case range for P. */
5404 /* The cases overlap, or they are the same
5405 element in the list. Either way, we must
5406 issue an error and get the next case from P. */
5407 /* FIXME: Sort P and Q by line number. */
5408 gfc_error ("CASE label at %L overlaps with CASE "
5409 "label at %L", &p->where, &q->where);
5417 /* Add the next element to the merged list. */
5426 /* P has now stepped INSIZE places along, and so has Q. So
5427 they're the same. */
5432 /* If we have done only one merge or none at all, we've
5433 finished sorting the cases. */
5442 /* Otherwise repeat, merging lists twice the size. */
5448 /* Check to see if an expression is suitable for use in a CASE statement.
5449 Makes sure that all case expressions are scalar constants of the same
5450 type. Return FAILURE if anything is wrong. */
5453 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5455 if (e == NULL) return SUCCESS;
5457 if (e->ts.type != case_expr->ts.type)
5459 gfc_error ("Expression in CASE statement at %L must be of type %s",
5460 &e->where, gfc_basic_typename (case_expr->ts.type));
5464 /* C805 (R808) For a given case-construct, each case-value shall be of
5465 the same type as case-expr. For character type, length differences
5466 are allowed, but the kind type parameters shall be the same. */
5468 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5470 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5471 &e->where, case_expr->ts.kind);
5475 /* Convert the case value kind to that of case expression kind, if needed.
5476 FIXME: Should a warning be issued? */
5477 if (e->ts.kind != case_expr->ts.kind)
5478 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5482 gfc_error ("Expression in CASE statement at %L must be scalar",
5491 /* Given a completely parsed select statement, we:
5493 - Validate all expressions and code within the SELECT.
5494 - Make sure that the selection expression is not of the wrong type.
5495 - Make sure that no case ranges overlap.
5496 - Eliminate unreachable cases and unreachable code resulting from
5497 removing case labels.
5499 The standard does allow unreachable cases, e.g. CASE (5:3). But
5500 they are a hassle for code generation, and to prevent that, we just
5501 cut them out here. This is not necessary for overlapping cases
5502 because they are illegal and we never even try to generate code.
5504 We have the additional caveat that a SELECT construct could have
5505 been a computed GOTO in the source code. Fortunately we can fairly
5506 easily work around that here: The case_expr for a "real" SELECT CASE
5507 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5508 we have to do is make sure that the case_expr is a scalar integer
5512 resolve_select (gfc_code *code)
5515 gfc_expr *case_expr;
5516 gfc_case *cp, *default_case, *tail, *head;
5517 int seen_unreachable;
5523 if (code->expr == NULL)
5525 /* This was actually a computed GOTO statement. */
5526 case_expr = code->expr2;
5527 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5528 gfc_error ("Selection expression in computed GOTO statement "
5529 "at %L must be a scalar integer expression",
5532 /* Further checking is not necessary because this SELECT was built
5533 by the compiler, so it should always be OK. Just move the
5534 case_expr from expr2 to expr so that we can handle computed
5535 GOTOs as normal SELECTs from here on. */
5536 code->expr = code->expr2;
5541 case_expr = code->expr;
5543 type = case_expr->ts.type;
5544 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5546 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5547 &case_expr->where, gfc_typename (&case_expr->ts));
5549 /* Punt. Going on here just produce more garbage error messages. */
5553 if (case_expr->rank != 0)
5555 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5556 "expression", &case_expr->where);
5562 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5563 of the SELECT CASE expression and its CASE values. Walk the lists
5564 of case values, and if we find a mismatch, promote case_expr to
5565 the appropriate kind. */
5567 if (type == BT_LOGICAL || type == BT_INTEGER)
5569 for (body = code->block; body; body = body->block)
5571 /* Walk the case label list. */
5572 for (cp = body->ext.case_list; cp; cp = cp->next)
5574 /* Intercept the DEFAULT case. It does not have a kind. */
5575 if (cp->low == NULL && cp->high == NULL)
5578 /* Unreachable case ranges are discarded, so ignore. */
5579 if (cp->low != NULL && cp->high != NULL
5580 && cp->low != cp->high
5581 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5584 /* FIXME: Should a warning be issued? */
5586 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5587 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5589 if (cp->high != NULL
5590 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5591 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5596 /* Assume there is no DEFAULT case. */
5597 default_case = NULL;
5602 for (body = code->block; body; body = body->block)
5604 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5606 seen_unreachable = 0;
5608 /* Walk the case label list, making sure that all case labels
5610 for (cp = body->ext.case_list; cp; cp = cp->next)
5612 /* Count the number of cases in the whole construct. */
5615 /* Intercept the DEFAULT case. */
5616 if (cp->low == NULL && cp->high == NULL)
5618 if (default_case != NULL)
5620 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5621 "by a second DEFAULT CASE at %L",
5622 &default_case->where, &cp->where);
5633 /* Deal with single value cases and case ranges. Errors are
5634 issued from the validation function. */
5635 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5636 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5642 if (type == BT_LOGICAL
5643 && ((cp->low == NULL || cp->high == NULL)
5644 || cp->low != cp->high))
5646 gfc_error ("Logical range in CASE statement at %L is not "
5647 "allowed", &cp->low->where);
5652 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5655 value = cp->low->value.logical == 0 ? 2 : 1;
5656 if (value & seen_logical)
5658 gfc_error ("constant logical value in CASE statement "
5659 "is repeated at %L",
5664 seen_logical |= value;
5667 if (cp->low != NULL && cp->high != NULL
5668 && cp->low != cp->high
5669 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5671 if (gfc_option.warn_surprising)
5672 gfc_warning ("Range specification at %L can never "
5673 "be matched", &cp->where);
5675 cp->unreachable = 1;
5676 seen_unreachable = 1;
5680 /* If the case range can be matched, it can also overlap with
5681 other cases. To make sure it does not, we put it in a
5682 double linked list here. We sort that with a merge sort
5683 later on to detect any overlapping cases. */
5687 head->right = head->left = NULL;
5692 tail->right->left = tail;
5699 /* It there was a failure in the previous case label, give up
5700 for this case label list. Continue with the next block. */
5704 /* See if any case labels that are unreachable have been seen.
5705 If so, we eliminate them. This is a bit of a kludge because
5706 the case lists for a single case statement (label) is a
5707 single forward linked lists. */
5708 if (seen_unreachable)
5710 /* Advance until the first case in the list is reachable. */
5711 while (body->ext.case_list != NULL
5712 && body->ext.case_list->unreachable)
5714 gfc_case *n = body->ext.case_list;
5715 body->ext.case_list = body->ext.case_list->next;
5717 gfc_free_case_list (n);
5720 /* Strip all other unreachable cases. */
5721 if (body->ext.case_list)
5723 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5725 if (cp->next->unreachable)
5727 gfc_case *n = cp->next;
5728 cp->next = cp->next->next;
5730 gfc_free_case_list (n);
5737 /* See if there were overlapping cases. If the check returns NULL,
5738 there was overlap. In that case we don't do anything. If head
5739 is non-NULL, we prepend the DEFAULT case. The sorted list can
5740 then used during code generation for SELECT CASE constructs with
5741 a case expression of a CHARACTER type. */
5744 head = check_case_overlap (head);
5746 /* Prepend the default_case if it is there. */
5747 if (head != NULL && default_case)
5749 default_case->left = NULL;
5750 default_case->right = head;
5751 head->left = default_case;
5755 /* Eliminate dead blocks that may be the result if we've seen
5756 unreachable case labels for a block. */
5757 for (body = code; body && body->block; body = body->block)
5759 if (body->block->ext.case_list == NULL)
5761 /* Cut the unreachable block from the code chain. */
5762 gfc_code *c = body->block;
5763 body->block = c->block;
5765 /* Kill the dead block, but not the blocks below it. */
5767 gfc_free_statements (c);
5771 /* More than two cases is legal but insane for logical selects.
5772 Issue a warning for it. */
5773 if (gfc_option.warn_surprising && type == BT_LOGICAL
5775 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5780 /* Resolve a transfer statement. This is making sure that:
5781 -- a derived type being transferred has only non-pointer components
5782 -- a derived type being transferred doesn't have private components, unless
5783 it's being transferred from the module where the type was defined
5784 -- we're not trying to transfer a whole assumed size array. */
5787 resolve_transfer (gfc_code *code)
5796 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5799 sym = exp->symtree->n.sym;
5802 /* Go to actual component transferred. */
5803 for (ref = code->expr->ref; ref; ref = ref->next)
5804 if (ref->type == REF_COMPONENT)
5805 ts = &ref->u.c.component->ts;
5807 if (ts->type == BT_DERIVED)
5809 /* Check that transferred derived type doesn't contain POINTER
5811 if (ts->derived->attr.pointer_comp)
5813 gfc_error ("Data transfer element at %L cannot have "
5814 "POINTER components", &code->loc);
5818 if (ts->derived->attr.alloc_comp)
5820 gfc_error ("Data transfer element at %L cannot have "
5821 "ALLOCATABLE components", &code->loc);
5825 if (derived_inaccessible (ts->derived))
5827 gfc_error ("Data transfer element at %L cannot have "
5828 "PRIVATE components",&code->loc);
5833 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5834 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5836 gfc_error ("Data transfer element at %L cannot be a full reference to "
5837 "an assumed-size array", &code->loc);
5843 /*********** Toplevel code resolution subroutines ***********/
5845 /* Find the set of labels that are reachable from this block. We also
5846 record the last statement in each block so that we don't have to do
5847 a linear search to find the END DO statements of the blocks. */
5850 reachable_labels (gfc_code *block)
5857 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5859 /* Collect labels in this block. */
5860 for (c = block; c; c = c->next)
5863 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5865 if (!c->next && cs_base->prev)
5866 cs_base->prev->tail = c;
5869 /* Merge with labels from parent block. */
5872 gcc_assert (cs_base->prev->reachable_labels);
5873 bitmap_ior_into (cs_base->reachable_labels,
5874 cs_base->prev->reachable_labels);
5878 /* Given a branch to a label and a namespace, if the branch is conforming.
5879 The code node describes where the branch is located. */
5882 resolve_branch (gfc_st_label *label, gfc_code *code)
5889 /* Step one: is this a valid branching target? */
5891 if (label->defined == ST_LABEL_UNKNOWN)
5893 gfc_error ("Label %d referenced at %L is never defined", label->value,
5898 if (label->defined != ST_LABEL_TARGET)
5900 gfc_error ("Statement at %L is not a valid branch target statement "
5901 "for the branch statement at %L", &label->where, &code->loc);
5905 /* Step two: make sure this branch is not a branch to itself ;-) */
5907 if (code->here == label)
5909 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
5913 /* Step three: See if the label is in the same block as the
5914 branching statement. The hard work has been done by setting up
5915 the bitmap reachable_labels. */
5917 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5919 /* The label is not in an enclosing block, so illegal. This was
5920 allowed in Fortran 66, so we allow it as extension. No
5921 further checks are necessary in this case. */
5922 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5923 "as the GOTO statement at %L", &label->where,
5928 /* Step four: Make sure that the branching target is legal if
5929 the statement is an END {SELECT,IF}. */
5931 for (stack = cs_base; stack; stack = stack->prev)
5932 if (stack->current->next && stack->current->next->here == label)
5935 if (stack && stack->current->next->op == EXEC_NOP)
5937 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5938 "END of construct at %L", &code->loc,
5939 &stack->current->next->loc);
5940 return; /* We know this is not an END DO. */
5943 /* Step five: Make sure that we're not jumping to the end of a DO
5944 loop from within the loop. */
5946 for (stack = cs_base; stack; stack = stack->prev)
5947 if ((stack->current->op == EXEC_DO
5948 || stack->current->op == EXEC_DO_WHILE)
5949 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5951 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5952 "to END of construct at %L", &code->loc,
5960 /* Check whether EXPR1 has the same shape as EXPR2. */
5963 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5965 mpz_t shape[GFC_MAX_DIMENSIONS];
5966 mpz_t shape2[GFC_MAX_DIMENSIONS];
5967 gfc_try result = FAILURE;
5970 /* Compare the rank. */
5971 if (expr1->rank != expr2->rank)
5974 /* Compare the size of each dimension. */
5975 for (i=0; i<expr1->rank; i++)
5977 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5980 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5983 if (mpz_cmp (shape[i], shape2[i]))
5987 /* When either of the two expression is an assumed size array, we
5988 ignore the comparison of dimension sizes. */
5993 for (i--; i >= 0; i--)
5995 mpz_clear (shape[i]);
5996 mpz_clear (shape2[i]);
6002 /* Check whether a WHERE assignment target or a WHERE mask expression
6003 has the same shape as the outmost WHERE mask expression. */
6006 resolve_where (gfc_code *code, gfc_expr *mask)
6012 cblock = code->block;
6014 /* Store the first WHERE mask-expr of the WHERE statement or construct.
6015 In case of nested WHERE, only the outmost one is stored. */
6016 if (mask == NULL) /* outmost WHERE */
6018 else /* inner WHERE */
6025 /* Check if the mask-expr has a consistent shape with the
6026 outmost WHERE mask-expr. */
6027 if (resolve_where_shape (cblock->expr, e) == FAILURE)
6028 gfc_error ("WHERE mask at %L has inconsistent shape",
6029 &cblock->expr->where);
6032 /* the assignment statement of a WHERE statement, or the first
6033 statement in where-body-construct of a WHERE construct */
6034 cnext = cblock->next;
6039 /* WHERE assignment statement */
6042 /* Check shape consistent for WHERE assignment target. */
6043 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
6044 gfc_error ("WHERE assignment target at %L has "
6045 "inconsistent shape", &cnext->expr->where);
6049 case EXEC_ASSIGN_CALL:
6050 resolve_call (cnext);
6051 if (!cnext->resolved_sym->attr.elemental)
6052 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6053 &cnext->ext.actual->expr->where);
6056 /* WHERE or WHERE construct is part of a where-body-construct */
6058 resolve_where (cnext, e);
6062 gfc_error ("Unsupported statement inside WHERE at %L",
6065 /* the next statement within the same where-body-construct */
6066 cnext = cnext->next;
6068 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6069 cblock = cblock->block;
6074 /* Resolve assignment in FORALL construct.
6075 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6076 FORALL index variables. */
6079 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
6083 for (n = 0; n < nvar; n++)
6085 gfc_symbol *forall_index;
6087 forall_index = var_expr[n]->symtree->n.sym;
6089 /* Check whether the assignment target is one of the FORALL index
6091 if ((code->expr->expr_type == EXPR_VARIABLE)
6092 && (code->expr->symtree->n.sym == forall_index))
6093 gfc_error ("Assignment to a FORALL index variable at %L",
6094 &code->expr->where);
6097 /* If one of the FORALL index variables doesn't appear in the
6098 assignment target, then there will be a many-to-one
6100 if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
6101 gfc_error ("The FORALL with index '%s' cause more than one "
6102 "assignment to this object at %L",
6103 var_expr[n]->symtree->name, &code->expr->where);
6109 /* Resolve WHERE statement in FORALL construct. */
6112 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
6113 gfc_expr **var_expr)
6118 cblock = code->block;
6121 /* the assignment statement of a WHERE statement, or the first
6122 statement in where-body-construct of a WHERE construct */
6123 cnext = cblock->next;
6128 /* WHERE assignment statement */
6130 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
6133 /* WHERE operator assignment statement */
6134 case EXEC_ASSIGN_CALL:
6135 resolve_call (cnext);
6136 if (!cnext->resolved_sym->attr.elemental)
6137 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6138 &cnext->ext.actual->expr->where);
6141 /* WHERE or WHERE construct is part of a where-body-construct */
6143 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
6147 gfc_error ("Unsupported statement inside WHERE at %L",
6150 /* the next statement within the same where-body-construct */
6151 cnext = cnext->next;
6153 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6154 cblock = cblock->block;
6159 /* Traverse the FORALL body to check whether the following errors exist:
6160 1. For assignment, check if a many-to-one assignment happens.
6161 2. For WHERE statement, check the WHERE body to see if there is any
6162 many-to-one assignment. */
6165 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
6169 c = code->block->next;
6175 case EXEC_POINTER_ASSIGN:
6176 gfc_resolve_assign_in_forall (c, nvar, var_expr);
6179 case EXEC_ASSIGN_CALL:
6183 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6184 there is no need to handle it here. */
6188 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
6193 /* The next statement in the FORALL body. */
6199 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6200 gfc_resolve_forall_body to resolve the FORALL body. */
6203 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
6205 static gfc_expr **var_expr;
6206 static int total_var = 0;
6207 static int nvar = 0;
6208 gfc_forall_iterator *fa;
6212 /* Start to resolve a FORALL construct */
6213 if (forall_save == 0)
6215 /* Count the total number of FORALL index in the nested FORALL
6216 construct in order to allocate the VAR_EXPR with proper size. */
6218 while ((next != NULL) && (next->op == EXEC_FORALL))
6220 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
6222 next = next->block->next;
6225 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6226 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
6229 /* The information about FORALL iterator, including FORALL index start, end
6230 and stride. The FORALL index can not appear in start, end or stride. */
6231 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6233 /* Check if any outer FORALL index name is the same as the current
6235 for (i = 0; i < nvar; i++)
6237 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
6239 gfc_error ("An outer FORALL construct already has an index "
6240 "with this name %L", &fa->var->where);
6244 /* Record the current FORALL index. */
6245 var_expr[nvar] = gfc_copy_expr (fa->var);
6250 /* Resolve the FORALL body. */
6251 gfc_resolve_forall_body (code, nvar, var_expr);
6253 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6254 gfc_resolve_blocks (code->block, ns);
6256 /* Free VAR_EXPR after the whole FORALL construct resolved. */
6257 for (i = 0; i < total_var; i++)
6258 gfc_free_expr (var_expr[i]);
6260 /* Reset the counters. */
6266 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6269 static void resolve_code (gfc_code *, gfc_namespace *);
6272 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
6276 for (; b; b = b->block)
6278 t = gfc_resolve_expr (b->expr);
6279 if (gfc_resolve_expr (b->expr2) == FAILURE)
6285 if (t == SUCCESS && b->expr != NULL
6286 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
6287 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6294 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
6295 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6300 resolve_branch (b->label, b);
6313 case EXEC_OMP_ATOMIC:
6314 case EXEC_OMP_CRITICAL:
6316 case EXEC_OMP_MASTER:
6317 case EXEC_OMP_ORDERED:
6318 case EXEC_OMP_PARALLEL:
6319 case EXEC_OMP_PARALLEL_DO:
6320 case EXEC_OMP_PARALLEL_SECTIONS:
6321 case EXEC_OMP_PARALLEL_WORKSHARE:
6322 case EXEC_OMP_SECTIONS:
6323 case EXEC_OMP_SINGLE:
6325 case EXEC_OMP_TASKWAIT:
6326 case EXEC_OMP_WORKSHARE:
6330 gfc_internal_error ("resolve_block(): Bad block type");
6333 resolve_code (b->next, ns);
6338 /* Does everything to resolve an ordinary assignment. Returns true
6339 if this is an interface assignment. */
6341 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
6351 if (gfc_extend_assign (code, ns) == SUCCESS)
6353 lhs = code->ext.actual->expr;
6354 rhs = code->ext.actual->next->expr;
6355 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6357 gfc_error ("Subroutine '%s' called instead of assignment at "
6358 "%L must be PURE", code->symtree->n.sym->name,
6363 /* Make a temporary rhs when there is a default initializer
6364 and rhs is the same symbol as the lhs. */
6365 if (rhs->expr_type == EXPR_VARIABLE
6366 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6367 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6368 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6369 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6378 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
6379 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6380 &code->loc) == FAILURE)
6383 /* Handle the case of a BOZ literal on the RHS. */
6384 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
6387 if (gfc_option.warn_surprising)
6388 gfc_warning ("BOZ literal at %L is bitwise transferred "
6389 "non-integer symbol '%s'", &code->loc,
6390 lhs->symtree->n.sym->name);
6392 if (!gfc_convert_boz (rhs, &lhs->ts))
6394 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
6396 if (rc == ARITH_UNDERFLOW)
6397 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6398 ". This check can be disabled with the option "
6399 "-fno-range-check", &rhs->where);
6400 else if (rc == ARITH_OVERFLOW)
6401 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6402 ". This check can be disabled with the option "
6403 "-fno-range-check", &rhs->where);
6404 else if (rc == ARITH_NAN)
6405 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6406 ". This check can be disabled with the option "
6407 "-fno-range-check", &rhs->where);
6413 if (lhs->ts.type == BT_CHARACTER
6414 && gfc_option.warn_character_truncation)
6416 if (lhs->ts.cl != NULL
6417 && lhs->ts.cl->length != NULL
6418 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6419 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
6421 if (rhs->expr_type == EXPR_CONSTANT)
6422 rlen = rhs->value.character.length;
6424 else if (rhs->ts.cl != NULL
6425 && rhs->ts.cl->length != NULL
6426 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6427 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
6429 if (rlen && llen && rlen > llen)
6430 gfc_warning_now ("CHARACTER expression will be truncated "
6431 "in assignment (%d/%d) at %L",
6432 llen, rlen, &code->loc);
6435 /* Ensure that a vector index expression for the lvalue is evaluated
6436 to a temporary if the lvalue symbol is referenced in it. */
6439 for (ref = lhs->ref; ref; ref= ref->next)
6440 if (ref->type == REF_ARRAY)
6442 for (n = 0; n < ref->u.ar.dimen; n++)
6443 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
6444 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
6445 ref->u.ar.start[n]))
6447 = gfc_get_parentheses (ref->u.ar.start[n]);
6451 if (gfc_pure (NULL))
6453 if (gfc_impure_variable (lhs->symtree->n.sym))
6455 gfc_error ("Cannot assign to variable '%s' in PURE "
6457 lhs->symtree->n.sym->name,
6462 if (lhs->ts.type == BT_DERIVED
6463 && lhs->expr_type == EXPR_VARIABLE
6464 && lhs->ts.derived->attr.pointer_comp
6465 && gfc_impure_variable (rhs->symtree->n.sym))
6467 gfc_error ("The impure variable at %L is assigned to "
6468 "a derived type variable with a POINTER "
6469 "component in a PURE procedure (12.6)",
6475 gfc_check_assign (lhs, rhs, 1);
6479 /* Given a block of code, recursively resolve everything pointed to by this
6483 resolve_code (gfc_code *code, gfc_namespace *ns)
6485 int omp_workshare_save;
6490 frame.prev = cs_base;
6494 reachable_labels (code);
6496 for (; code; code = code->next)
6498 frame.current = code;
6499 forall_save = forall_flag;
6501 if (code->op == EXEC_FORALL)
6504 gfc_resolve_forall (code, ns, forall_save);
6507 else if (code->block)
6509 omp_workshare_save = -1;
6512 case EXEC_OMP_PARALLEL_WORKSHARE:
6513 omp_workshare_save = omp_workshare_flag;
6514 omp_workshare_flag = 1;
6515 gfc_resolve_omp_parallel_blocks (code, ns);
6517 case EXEC_OMP_PARALLEL:
6518 case EXEC_OMP_PARALLEL_DO:
6519 case EXEC_OMP_PARALLEL_SECTIONS:
6521 omp_workshare_save = omp_workshare_flag;
6522 omp_workshare_flag = 0;
6523 gfc_resolve_omp_parallel_blocks (code, ns);
6526 gfc_resolve_omp_do_blocks (code, ns);
6528 case EXEC_OMP_WORKSHARE:
6529 omp_workshare_save = omp_workshare_flag;
6530 omp_workshare_flag = 1;
6533 gfc_resolve_blocks (code->block, ns);
6537 if (omp_workshare_save != -1)
6538 omp_workshare_flag = omp_workshare_save;
6542 if (code->op != EXEC_COMPCALL)
6543 t = gfc_resolve_expr (code->expr);
6544 forall_flag = forall_save;
6546 if (gfc_resolve_expr (code->expr2) == FAILURE)
6561 /* Keep track of which entry we are up to. */
6562 current_entry_id = code->ext.entry->id;
6566 resolve_where (code, NULL);
6570 if (code->expr != NULL)
6572 if (code->expr->ts.type != BT_INTEGER)
6573 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6574 "INTEGER variable", &code->expr->where);
6575 else if (code->expr->symtree->n.sym->attr.assign != 1)
6576 gfc_error ("Variable '%s' has not been assigned a target "
6577 "label at %L", code->expr->symtree->n.sym->name,
6578 &code->expr->where);
6581 resolve_branch (code->label, code);
6585 if (code->expr != NULL
6586 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6587 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6588 "INTEGER return specifier", &code->expr->where);
6591 case EXEC_INIT_ASSIGN:
6598 if (resolve_ordinary_assign (code, ns))
6603 case EXEC_LABEL_ASSIGN:
6604 if (code->label->defined == ST_LABEL_UNKNOWN)
6605 gfc_error ("Label %d referenced at %L is never defined",
6606 code->label->value, &code->label->where);
6608 && (code->expr->expr_type != EXPR_VARIABLE
6609 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6610 || code->expr->symtree->n.sym->ts.kind
6611 != gfc_default_integer_kind
6612 || code->expr->symtree->n.sym->as != NULL))
6613 gfc_error ("ASSIGN statement at %L requires a scalar "
6614 "default INTEGER variable", &code->expr->where);
6617 case EXEC_POINTER_ASSIGN:
6621 gfc_check_pointer_assign (code->expr, code->expr2);
6624 case EXEC_ARITHMETIC_IF:
6626 && code->expr->ts.type != BT_INTEGER
6627 && code->expr->ts.type != BT_REAL)
6628 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6629 "expression", &code->expr->where);
6631 resolve_branch (code->label, code);
6632 resolve_branch (code->label2, code);
6633 resolve_branch (code->label3, code);
6637 if (t == SUCCESS && code->expr != NULL
6638 && (code->expr->ts.type != BT_LOGICAL
6639 || code->expr->rank != 0))
6640 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6641 &code->expr->where);
6646 resolve_call (code);
6650 resolve_typebound_call (code);
6654 /* Select is complicated. Also, a SELECT construct could be
6655 a transformed computed GOTO. */
6656 resolve_select (code);
6660 if (code->ext.iterator != NULL)
6662 gfc_iterator *iter = code->ext.iterator;
6663 if (gfc_resolve_iterator (iter, true) != FAILURE)
6664 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6669 if (code->expr == NULL)
6670 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6672 && (code->expr->rank != 0
6673 || code->expr->ts.type != BT_LOGICAL))
6674 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6675 "a scalar LOGICAL expression", &code->expr->where);
6680 resolve_allocate_deallocate (code, "ALLOCATE");
6684 case EXEC_DEALLOCATE:
6686 resolve_allocate_deallocate (code, "DEALLOCATE");
6691 if (gfc_resolve_open (code->ext.open) == FAILURE)
6694 resolve_branch (code->ext.open->err, code);
6698 if (gfc_resolve_close (code->ext.close) == FAILURE)
6701 resolve_branch (code->ext.close->err, code);
6704 case EXEC_BACKSPACE:
6708 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6711 resolve_branch (code->ext.filepos->err, code);
6715 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6718 resolve_branch (code->ext.inquire->err, code);
6722 gcc_assert (code->ext.inquire != NULL);
6723 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6726 resolve_branch (code->ext.inquire->err, code);
6730 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
6733 resolve_branch (code->ext.wait->err, code);
6734 resolve_branch (code->ext.wait->end, code);
6735 resolve_branch (code->ext.wait->eor, code);
6740 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6743 resolve_branch (code->ext.dt->err, code);
6744 resolve_branch (code->ext.dt->end, code);
6745 resolve_branch (code->ext.dt->eor, code);
6749 resolve_transfer (code);
6753 resolve_forall_iterators (code->ext.forall_iterator);
6755 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6756 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6757 "expression", &code->expr->where);
6760 case EXEC_OMP_ATOMIC:
6761 case EXEC_OMP_BARRIER:
6762 case EXEC_OMP_CRITICAL:
6763 case EXEC_OMP_FLUSH:
6765 case EXEC_OMP_MASTER:
6766 case EXEC_OMP_ORDERED:
6767 case EXEC_OMP_SECTIONS:
6768 case EXEC_OMP_SINGLE:
6769 case EXEC_OMP_TASKWAIT:
6770 case EXEC_OMP_WORKSHARE:
6771 gfc_resolve_omp_directive (code, ns);
6774 case EXEC_OMP_PARALLEL:
6775 case EXEC_OMP_PARALLEL_DO:
6776 case EXEC_OMP_PARALLEL_SECTIONS:
6777 case EXEC_OMP_PARALLEL_WORKSHARE:
6779 omp_workshare_save = omp_workshare_flag;
6780 omp_workshare_flag = 0;
6781 gfc_resolve_omp_directive (code, ns);
6782 omp_workshare_flag = omp_workshare_save;
6786 gfc_internal_error ("resolve_code(): Bad statement code");
6790 cs_base = frame.prev;
6794 /* Resolve initial values and make sure they are compatible with
6798 resolve_values (gfc_symbol *sym)
6800 if (sym->value == NULL)
6803 if (gfc_resolve_expr (sym->value) == FAILURE)
6806 gfc_check_assign_symbol (sym, sym->value);
6810 /* Verify the binding labels for common blocks that are BIND(C). The label
6811 for a BIND(C) common block must be identical in all scoping units in which
6812 the common block is declared. Further, the binding label can not collide
6813 with any other global entity in the program. */
6816 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6818 if (comm_block_tree->n.common->is_bind_c == 1)
6820 gfc_gsymbol *binding_label_gsym;
6821 gfc_gsymbol *comm_name_gsym;
6823 /* See if a global symbol exists by the common block's name. It may
6824 be NULL if the common block is use-associated. */
6825 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6826 comm_block_tree->n.common->name);
6827 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6828 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6829 "with the global entity '%s' at %L",
6830 comm_block_tree->n.common->binding_label,
6831 comm_block_tree->n.common->name,
6832 &(comm_block_tree->n.common->where),
6833 comm_name_gsym->name, &(comm_name_gsym->where));
6834 else if (comm_name_gsym != NULL
6835 && strcmp (comm_name_gsym->name,
6836 comm_block_tree->n.common->name) == 0)
6838 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6840 if (comm_name_gsym->binding_label == NULL)
6841 /* No binding label for common block stored yet; save this one. */
6842 comm_name_gsym->binding_label =
6843 comm_block_tree->n.common->binding_label;
6845 if (strcmp (comm_name_gsym->binding_label,
6846 comm_block_tree->n.common->binding_label) != 0)
6848 /* Common block names match but binding labels do not. */
6849 gfc_error ("Binding label '%s' for common block '%s' at %L "
6850 "does not match the binding label '%s' for common "
6852 comm_block_tree->n.common->binding_label,
6853 comm_block_tree->n.common->name,
6854 &(comm_block_tree->n.common->where),
6855 comm_name_gsym->binding_label,
6856 comm_name_gsym->name,
6857 &(comm_name_gsym->where));
6862 /* There is no binding label (NAME="") so we have nothing further to
6863 check and nothing to add as a global symbol for the label. */
6864 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6867 binding_label_gsym =
6868 gfc_find_gsymbol (gfc_gsym_root,
6869 comm_block_tree->n.common->binding_label);
6870 if (binding_label_gsym == NULL)
6872 /* Need to make a global symbol for the binding label to prevent
6873 it from colliding with another. */
6874 binding_label_gsym =
6875 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6876 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6877 binding_label_gsym->type = GSYM_COMMON;
6881 /* If comm_name_gsym is NULL, the name common block is use
6882 associated and the name could be colliding. */
6883 if (binding_label_gsym->type != GSYM_COMMON)
6884 gfc_error ("Binding label '%s' for common block '%s' at %L "
6885 "collides with the global entity '%s' at %L",
6886 comm_block_tree->n.common->binding_label,
6887 comm_block_tree->n.common->name,
6888 &(comm_block_tree->n.common->where),
6889 binding_label_gsym->name,
6890 &(binding_label_gsym->where));
6891 else if (comm_name_gsym != NULL
6892 && (strcmp (binding_label_gsym->name,
6893 comm_name_gsym->binding_label) != 0)
6894 && (strcmp (binding_label_gsym->sym_name,
6895 comm_name_gsym->name) != 0))
6896 gfc_error ("Binding label '%s' for common block '%s' at %L "
6897 "collides with global entity '%s' at %L",
6898 binding_label_gsym->name, binding_label_gsym->sym_name,
6899 &(comm_block_tree->n.common->where),
6900 comm_name_gsym->name, &(comm_name_gsym->where));
6908 /* Verify any BIND(C) derived types in the namespace so we can report errors
6909 for them once, rather than for each variable declared of that type. */
6912 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6914 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6915 && derived_sym->attr.is_bind_c == 1)
6916 verify_bind_c_derived_type (derived_sym);
6922 /* Verify that any binding labels used in a given namespace do not collide
6923 with the names or binding labels of any global symbols. */
6926 gfc_verify_binding_labels (gfc_symbol *sym)
6930 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6931 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6933 gfc_gsymbol *bind_c_sym;
6935 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6936 if (bind_c_sym != NULL
6937 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6939 if (sym->attr.if_source == IFSRC_DECL
6940 && (bind_c_sym->type != GSYM_SUBROUTINE
6941 && bind_c_sym->type != GSYM_FUNCTION)
6942 && ((sym->attr.contained == 1
6943 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6944 || (sym->attr.use_assoc == 1
6945 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6947 /* Make sure global procedures don't collide with anything. */
6948 gfc_error ("Binding label '%s' at %L collides with the global "
6949 "entity '%s' at %L", sym->binding_label,
6950 &(sym->declared_at), bind_c_sym->name,
6951 &(bind_c_sym->where));
6954 else if (sym->attr.contained == 0
6955 && (sym->attr.if_source == IFSRC_IFBODY
6956 && sym->attr.flavor == FL_PROCEDURE)
6957 && (bind_c_sym->sym_name != NULL
6958 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6960 /* Make sure procedures in interface bodies don't collide. */
6961 gfc_error ("Binding label '%s' in interface body at %L collides "
6962 "with the global entity '%s' at %L",
6964 &(sym->declared_at), bind_c_sym->name,
6965 &(bind_c_sym->where));
6968 else if (sym->attr.contained == 0
6969 && sym->attr.if_source == IFSRC_UNKNOWN)
6970 if ((sym->attr.use_assoc && bind_c_sym->mod_name
6971 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
6972 || sym->attr.use_assoc == 0)
6974 gfc_error ("Binding label '%s' at %L collides with global "
6975 "entity '%s' at %L", sym->binding_label,
6976 &(sym->declared_at), bind_c_sym->name,
6977 &(bind_c_sym->where));
6982 /* Clear the binding label to prevent checking multiple times. */
6983 sym->binding_label[0] = '\0';
6985 else if (bind_c_sym == NULL)
6987 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6988 bind_c_sym->where = sym->declared_at;
6989 bind_c_sym->sym_name = sym->name;
6991 if (sym->attr.use_assoc == 1)
6992 bind_c_sym->mod_name = sym->module;
6994 if (sym->ns->proc_name != NULL)
6995 bind_c_sym->mod_name = sym->ns->proc_name->name;
6997 if (sym->attr.contained == 0)
6999 if (sym->attr.subroutine)
7000 bind_c_sym->type = GSYM_SUBROUTINE;
7001 else if (sym->attr.function)
7002 bind_c_sym->type = GSYM_FUNCTION;
7010 /* Resolve an index expression. */
7013 resolve_index_expr (gfc_expr *e)
7015 if (gfc_resolve_expr (e) == FAILURE)
7018 if (gfc_simplify_expr (e, 0) == FAILURE)
7021 if (gfc_specification_expr (e) == FAILURE)
7027 /* Resolve a charlen structure. */
7030 resolve_charlen (gfc_charlen *cl)
7039 specification_expr = 1;
7041 if (resolve_index_expr (cl->length) == FAILURE)
7043 specification_expr = 0;
7047 /* "If the character length parameter value evaluates to a negative
7048 value, the length of character entities declared is zero." */
7049 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
7051 gfc_warning_now ("CHARACTER variable has zero length at %L",
7052 &cl->length->where);
7053 gfc_replace_expr (cl->length, gfc_int_expr (0));
7060 /* Test for non-constant shape arrays. */
7063 is_non_constant_shape_array (gfc_symbol *sym)
7069 not_constant = false;
7070 if (sym->as != NULL)
7072 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7073 has not been simplified; parameter array references. Do the
7074 simplification now. */
7075 for (i = 0; i < sym->as->rank; i++)
7077 e = sym->as->lower[i];
7078 if (e && (resolve_index_expr (e) == FAILURE
7079 || !gfc_is_constant_expr (e)))
7080 not_constant = true;
7082 e = sym->as->upper[i];
7083 if (e && (resolve_index_expr (e) == FAILURE
7084 || !gfc_is_constant_expr (e)))
7085 not_constant = true;
7088 return not_constant;
7091 /* Given a symbol and an initialization expression, add code to initialize
7092 the symbol to the function entry. */
7094 build_init_assign (gfc_symbol *sym, gfc_expr *init)
7098 gfc_namespace *ns = sym->ns;
7100 /* Search for the function namespace if this is a contained
7101 function without an explicit result. */
7102 if (sym->attr.function && sym == sym->result
7103 && sym->name != sym->ns->proc_name->name)
7106 for (;ns; ns = ns->sibling)
7107 if (strcmp (ns->proc_name->name, sym->name) == 0)
7113 gfc_free_expr (init);
7117 /* Build an l-value expression for the result. */
7118 lval = gfc_lval_expr_from_sym (sym);
7120 /* Add the code at scope entry. */
7121 init_st = gfc_get_code ();
7122 init_st->next = ns->code;
7125 /* Assign the default initializer to the l-value. */
7126 init_st->loc = sym->declared_at;
7127 init_st->op = EXEC_INIT_ASSIGN;
7128 init_st->expr = lval;
7129 init_st->expr2 = init;
7132 /* Assign the default initializer to a derived type variable or result. */
7135 apply_default_init (gfc_symbol *sym)
7137 gfc_expr *init = NULL;
7139 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7142 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
7143 init = gfc_default_initializer (&sym->ts);
7148 build_init_assign (sym, init);
7151 /* Build an initializer for a local integer, real, complex, logical, or
7152 character variable, based on the command line flags finit-local-zero,
7153 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7154 null if the symbol should not have a default initialization. */
7156 build_default_init_expr (gfc_symbol *sym)
7159 gfc_expr *init_expr;
7162 /* These symbols should never have a default initialization. */
7163 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
7164 || sym->attr.external
7166 || sym->attr.pointer
7167 || sym->attr.in_equivalence
7168 || sym->attr.in_common
7171 || sym->attr.cray_pointee
7172 || sym->attr.cray_pointer)
7175 /* Now we'll try to build an initializer expression. */
7176 init_expr = gfc_get_expr ();
7177 init_expr->expr_type = EXPR_CONSTANT;
7178 init_expr->ts.type = sym->ts.type;
7179 init_expr->ts.kind = sym->ts.kind;
7180 init_expr->where = sym->declared_at;
7182 /* We will only initialize integers, reals, complex, logicals, and
7183 characters, and only if the corresponding command-line flags
7184 were set. Otherwise, we free init_expr and return null. */
7185 switch (sym->ts.type)
7188 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
7189 mpz_init_set_si (init_expr->value.integer,
7190 gfc_option.flag_init_integer_value);
7193 gfc_free_expr (init_expr);
7199 mpfr_init (init_expr->value.real);
7200 switch (gfc_option.flag_init_real)
7202 case GFC_INIT_REAL_NAN:
7203 mpfr_set_nan (init_expr->value.real);
7206 case GFC_INIT_REAL_INF:
7207 mpfr_set_inf (init_expr->value.real, 1);
7210 case GFC_INIT_REAL_NEG_INF:
7211 mpfr_set_inf (init_expr->value.real, -1);
7214 case GFC_INIT_REAL_ZERO:
7215 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
7219 gfc_free_expr (init_expr);
7226 mpfr_init (init_expr->value.complex.r);
7227 mpfr_init (init_expr->value.complex.i);
7228 switch (gfc_option.flag_init_real)
7230 case GFC_INIT_REAL_NAN:
7231 mpfr_set_nan (init_expr->value.complex.r);
7232 mpfr_set_nan (init_expr->value.complex.i);
7235 case GFC_INIT_REAL_INF:
7236 mpfr_set_inf (init_expr->value.complex.r, 1);
7237 mpfr_set_inf (init_expr->value.complex.i, 1);
7240 case GFC_INIT_REAL_NEG_INF:
7241 mpfr_set_inf (init_expr->value.complex.r, -1);
7242 mpfr_set_inf (init_expr->value.complex.i, -1);
7245 case GFC_INIT_REAL_ZERO:
7246 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
7247 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
7251 gfc_free_expr (init_expr);
7258 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
7259 init_expr->value.logical = 0;
7260 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
7261 init_expr->value.logical = 1;
7264 gfc_free_expr (init_expr);
7270 /* For characters, the length must be constant in order to
7271 create a default initializer. */
7272 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
7273 && sym->ts.cl->length
7274 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
7276 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
7277 init_expr->value.character.length = char_len;
7278 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
7279 for (i = 0; i < char_len; i++)
7280 init_expr->value.character.string[i]
7281 = (unsigned char) gfc_option.flag_init_character_value;
7285 gfc_free_expr (init_expr);
7291 gfc_free_expr (init_expr);
7297 /* Add an initialization expression to a local variable. */
7299 apply_default_init_local (gfc_symbol *sym)
7301 gfc_expr *init = NULL;
7303 /* The symbol should be a variable or a function return value. */
7304 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7305 || (sym->attr.function && sym->result != sym))
7308 /* Try to build the initializer expression. If we can't initialize
7309 this symbol, then init will be NULL. */
7310 init = build_default_init_expr (sym);
7314 /* For saved variables, we don't want to add an initializer at
7315 function entry, so we just add a static initializer. */
7316 if (sym->attr.save || sym->ns->save_all)
7318 /* Don't clobber an existing initializer! */
7319 gcc_assert (sym->value == NULL);
7324 build_init_assign (sym, init);
7327 /* Resolution of common features of flavors variable and procedure. */
7330 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
7332 /* Constraints on deferred shape variable. */
7333 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
7335 if (sym->attr.allocatable)
7337 if (sym->attr.dimension)
7338 gfc_error ("Allocatable array '%s' at %L must have "
7339 "a deferred shape", sym->name, &sym->declared_at);
7341 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7342 sym->name, &sym->declared_at);
7346 if (sym->attr.pointer && sym->attr.dimension)
7348 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7349 sym->name, &sym->declared_at);
7356 if (!mp_flag && !sym->attr.allocatable
7357 && !sym->attr.pointer && !sym->attr.dummy)
7359 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7360 sym->name, &sym->declared_at);
7368 /* Additional checks for symbols with flavor variable and derived
7369 type. To be called from resolve_fl_variable. */
7372 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
7374 gcc_assert (sym->ts.type == BT_DERIVED);
7376 /* Check to see if a derived type is blocked from being host
7377 associated by the presence of another class I symbol in the same
7378 namespace. 14.6.1.3 of the standard and the discussion on
7379 comp.lang.fortran. */
7380 if (sym->ns != sym->ts.derived->ns
7381 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
7384 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
7385 if (s && s->attr.flavor != FL_DERIVED)
7387 gfc_error ("The type '%s' cannot be host associated at %L "
7388 "because it is blocked by an incompatible object "
7389 "of the same name declared at %L",
7390 sym->ts.derived->name, &sym->declared_at,
7396 /* 4th constraint in section 11.3: "If an object of a type for which
7397 component-initialization is specified (R429) appears in the
7398 specification-part of a module and does not have the ALLOCATABLE
7399 or POINTER attribute, the object shall have the SAVE attribute."
7401 The check for initializers is performed with
7402 has_default_initializer because gfc_default_initializer generates
7403 a hidden default for allocatable components. */
7404 if (!(sym->value || no_init_flag) && sym->ns->proc_name
7405 && sym->ns->proc_name->attr.flavor == FL_MODULE
7406 && !sym->ns->save_all && !sym->attr.save
7407 && !sym->attr.pointer && !sym->attr.allocatable
7408 && has_default_initializer (sym->ts.derived))
7410 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7411 "default initialization of a component",
7412 sym->name, &sym->declared_at);
7416 /* Assign default initializer. */
7417 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
7418 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
7420 sym->value = gfc_default_initializer (&sym->ts);
7427 /* Resolve symbols with flavor variable. */
7430 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
7432 int no_init_flag, automatic_flag;
7434 const char *auto_save_msg;
7436 auto_save_msg = "Automatic object '%s' at %L cannot have the "
7439 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7442 /* Set this flag to check that variables are parameters of all entries.
7443 This check is effected by the call to gfc_resolve_expr through
7444 is_non_constant_shape_array. */
7445 specification_expr = 1;
7447 if (sym->ns->proc_name
7448 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7449 || sym->ns->proc_name->attr.is_main_program)
7450 && !sym->attr.use_assoc
7451 && !sym->attr.allocatable
7452 && !sym->attr.pointer
7453 && is_non_constant_shape_array (sym))
7455 /* The shape of a main program or module array needs to be
7457 gfc_error ("The module or main program array '%s' at %L must "
7458 "have constant shape", sym->name, &sym->declared_at);
7459 specification_expr = 0;
7463 if (sym->ts.type == BT_CHARACTER)
7465 /* Make sure that character string variables with assumed length are
7467 e = sym->ts.cl->length;
7468 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
7470 gfc_error ("Entity with assumed character length at %L must be a "
7471 "dummy argument or a PARAMETER", &sym->declared_at);
7475 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7477 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7481 if (!gfc_is_constant_expr (e)
7482 && !(e->expr_type == EXPR_VARIABLE
7483 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7484 && sym->ns->proc_name
7485 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7486 || sym->ns->proc_name->attr.is_main_program)
7487 && !sym->attr.use_assoc)
7489 gfc_error ("'%s' at %L must have constant character length "
7490 "in this context", sym->name, &sym->declared_at);
7495 if (sym->value == NULL && sym->attr.referenced)
7496 apply_default_init_local (sym); /* Try to apply a default initialization. */
7498 /* Determine if the symbol may not have an initializer. */
7499 no_init_flag = automatic_flag = 0;
7500 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7501 || sym->attr.intrinsic || sym->attr.result)
7503 else if (sym->attr.dimension && !sym->attr.pointer
7504 && is_non_constant_shape_array (sym))
7506 no_init_flag = automatic_flag = 1;
7508 /* Also, they must not have the SAVE attribute.
7509 SAVE_IMPLICIT is checked below. */
7510 if (sym->attr.save == SAVE_EXPLICIT)
7512 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7517 /* Reject illegal initializers. */
7518 if (!sym->mark && sym->value)
7520 if (sym->attr.allocatable)
7521 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7522 sym->name, &sym->declared_at);
7523 else if (sym->attr.external)
7524 gfc_error ("External '%s' at %L cannot have an initializer",
7525 sym->name, &sym->declared_at);
7526 else if (sym->attr.dummy
7527 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7528 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7529 sym->name, &sym->declared_at);
7530 else if (sym->attr.intrinsic)
7531 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7532 sym->name, &sym->declared_at);
7533 else if (sym->attr.result)
7534 gfc_error ("Function result '%s' at %L cannot have an initializer",
7535 sym->name, &sym->declared_at);
7536 else if (automatic_flag)
7537 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7538 sym->name, &sym->declared_at);
7545 if (sym->ts.type == BT_DERIVED)
7546 return resolve_fl_variable_derived (sym, no_init_flag);
7552 /* Resolve a procedure. */
7555 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7557 gfc_formal_arglist *arg;
7559 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7560 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7561 "interfaces", sym->name, &sym->declared_at);
7563 if (sym->attr.function
7564 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7567 if (sym->ts.type == BT_CHARACTER)
7569 gfc_charlen *cl = sym->ts.cl;
7571 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7572 && resolve_charlen (cl) == FAILURE)
7575 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7577 if (sym->attr.proc == PROC_ST_FUNCTION)
7579 gfc_error ("Character-valued statement function '%s' at %L must "
7580 "have constant length", sym->name, &sym->declared_at);
7584 if (sym->attr.external && sym->formal == NULL
7585 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7587 gfc_error ("Automatic character length function '%s' at %L must "
7588 "have an explicit interface", sym->name,
7595 /* Ensure that derived type for are not of a private type. Internal
7596 module procedures are excluded by 2.2.3.3 - i.e., they are not
7597 externally accessible and can access all the objects accessible in
7599 if (!(sym->ns->parent
7600 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7601 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7603 gfc_interface *iface;
7605 for (arg = sym->formal; arg; arg = arg->next)
7608 && arg->sym->ts.type == BT_DERIVED
7609 && !arg->sym->ts.derived->attr.use_assoc
7610 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7611 arg->sym->ts.derived->ns->default_access)
7612 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7613 "PRIVATE type and cannot be a dummy argument"
7614 " of '%s', which is PUBLIC at %L",
7615 arg->sym->name, sym->name, &sym->declared_at)
7618 /* Stop this message from recurring. */
7619 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7624 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7625 PRIVATE to the containing module. */
7626 for (iface = sym->generic; iface; iface = iface->next)
7628 for (arg = iface->sym->formal; arg; arg = arg->next)
7631 && arg->sym->ts.type == BT_DERIVED
7632 && !arg->sym->ts.derived->attr.use_assoc
7633 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7634 arg->sym->ts.derived->ns->default_access)
7635 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7636 "'%s' in PUBLIC interface '%s' at %L "
7637 "takes dummy arguments of '%s' which is "
7638 "PRIVATE", iface->sym->name, sym->name,
7639 &iface->sym->declared_at,
7640 gfc_typename (&arg->sym->ts)) == FAILURE)
7642 /* Stop this message from recurring. */
7643 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7649 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7650 PRIVATE to the containing module. */
7651 for (iface = sym->generic; iface; iface = iface->next)
7653 for (arg = iface->sym->formal; arg; arg = arg->next)
7656 && arg->sym->ts.type == BT_DERIVED
7657 && !arg->sym->ts.derived->attr.use_assoc
7658 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7659 arg->sym->ts.derived->ns->default_access)
7660 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7661 "'%s' in PUBLIC interface '%s' at %L "
7662 "takes dummy arguments of '%s' which is "
7663 "PRIVATE", iface->sym->name, sym->name,
7664 &iface->sym->declared_at,
7665 gfc_typename (&arg->sym->ts)) == FAILURE)
7667 /* Stop this message from recurring. */
7668 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7675 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
7676 && !sym->attr.proc_pointer)
7678 gfc_error ("Function '%s' at %L cannot have an initializer",
7679 sym->name, &sym->declared_at);
7683 /* An external symbol may not have an initializer because it is taken to be
7684 a procedure. Exception: Procedure Pointers. */
7685 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
7687 gfc_error ("External object '%s' at %L may not have an initializer",
7688 sym->name, &sym->declared_at);
7692 /* An elemental function is required to return a scalar 12.7.1 */
7693 if (sym->attr.elemental && sym->attr.function && sym->as)
7695 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7696 "result", sym->name, &sym->declared_at);
7697 /* Reset so that the error only occurs once. */
7698 sym->attr.elemental = 0;
7702 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7703 char-len-param shall not be array-valued, pointer-valued, recursive
7704 or pure. ....snip... A character value of * may only be used in the
7705 following ways: (i) Dummy arg of procedure - dummy associates with
7706 actual length; (ii) To declare a named constant; or (iii) External
7707 function - but length must be declared in calling scoping unit. */
7708 if (sym->attr.function
7709 && sym->ts.type == BT_CHARACTER
7710 && sym->ts.cl && sym->ts.cl->length == NULL)
7712 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7713 || (sym->attr.recursive) || (sym->attr.pure))
7715 if (sym->as && sym->as->rank)
7716 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7717 "array-valued", sym->name, &sym->declared_at);
7719 if (sym->attr.pointer)
7720 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7721 "pointer-valued", sym->name, &sym->declared_at);
7724 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7725 "pure", sym->name, &sym->declared_at);
7727 if (sym->attr.recursive)
7728 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7729 "recursive", sym->name, &sym->declared_at);
7734 /* Appendix B.2 of the standard. Contained functions give an
7735 error anyway. Fixed-form is likely to be F77/legacy. */
7736 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7737 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7738 "'%s' at %L is obsolescent in fortran 95",
7739 sym->name, &sym->declared_at);
7742 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7744 gfc_formal_arglist *curr_arg;
7745 int has_non_interop_arg = 0;
7747 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7748 sym->common_block) == FAILURE)
7750 /* Clear these to prevent looking at them again if there was an
7752 sym->attr.is_bind_c = 0;
7753 sym->attr.is_c_interop = 0;
7754 sym->ts.is_c_interop = 0;
7758 /* So far, no errors have been found. */
7759 sym->attr.is_c_interop = 1;
7760 sym->ts.is_c_interop = 1;
7763 curr_arg = sym->formal;
7764 while (curr_arg != NULL)
7766 /* Skip implicitly typed dummy args here. */
7767 if (curr_arg->sym->attr.implicit_type == 0)
7768 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7769 /* If something is found to fail, record the fact so we
7770 can mark the symbol for the procedure as not being
7771 BIND(C) to try and prevent multiple errors being
7773 has_non_interop_arg = 1;
7775 curr_arg = curr_arg->next;
7778 /* See if any of the arguments were not interoperable and if so, clear
7779 the procedure symbol to prevent duplicate error messages. */
7780 if (has_non_interop_arg != 0)
7782 sym->attr.is_c_interop = 0;
7783 sym->ts.is_c_interop = 0;
7784 sym->attr.is_bind_c = 0;
7788 if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
7790 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
7791 "in '%s' at %L", sym->name, &sym->declared_at);
7795 if (sym->attr.intent && !sym->attr.proc_pointer)
7797 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
7798 "in '%s' at %L", sym->name, &sym->declared_at);
7806 /* Resolve a list of finalizer procedures. That is, after they have hopefully
7807 been defined and we now know their defined arguments, check that they fulfill
7808 the requirements of the standard for procedures used as finalizers. */
7811 gfc_resolve_finalizers (gfc_symbol* derived)
7813 gfc_finalizer* list;
7814 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
7815 gfc_try result = SUCCESS;
7816 bool seen_scalar = false;
7818 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
7821 /* Walk over the list of finalizer-procedures, check them, and if any one
7822 does not fit in with the standard's definition, print an error and remove
7823 it from the list. */
7824 prev_link = &derived->f2k_derived->finalizers;
7825 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
7831 /* Skip this finalizer if we already resolved it. */
7832 if (list->proc_tree)
7834 prev_link = &(list->next);
7838 /* Check this exists and is a SUBROUTINE. */
7839 if (!list->proc_sym->attr.subroutine)
7841 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
7842 list->proc_sym->name, &list->where);
7846 /* We should have exactly one argument. */
7847 if (!list->proc_sym->formal || list->proc_sym->formal->next)
7849 gfc_error ("FINAL procedure at %L must have exactly one argument",
7853 arg = list->proc_sym->formal->sym;
7855 /* This argument must be of our type. */
7856 if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
7858 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
7859 &arg->declared_at, derived->name);
7863 /* It must neither be a pointer nor allocatable nor optional. */
7864 if (arg->attr.pointer)
7866 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
7870 if (arg->attr.allocatable)
7872 gfc_error ("Argument of FINAL procedure at %L must not be"
7873 " ALLOCATABLE", &arg->declared_at);
7876 if (arg->attr.optional)
7878 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
7883 /* It must not be INTENT(OUT). */
7884 if (arg->attr.intent == INTENT_OUT)
7886 gfc_error ("Argument of FINAL procedure at %L must not be"
7887 " INTENT(OUT)", &arg->declared_at);
7891 /* Warn if the procedure is non-scalar and not assumed shape. */
7892 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
7893 && arg->as->type != AS_ASSUMED_SHAPE)
7894 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
7895 " shape argument", &arg->declared_at);
7897 /* Check that it does not match in kind and rank with a FINAL procedure
7898 defined earlier. To really loop over the *earlier* declarations,
7899 we need to walk the tail of the list as new ones were pushed at the
7901 /* TODO: Handle kind parameters once they are implemented. */
7902 my_rank = (arg->as ? arg->as->rank : 0);
7903 for (i = list->next; i; i = i->next)
7905 /* Argument list might be empty; that is an error signalled earlier,
7906 but we nevertheless continued resolving. */
7907 if (i->proc_sym->formal)
7909 gfc_symbol* i_arg = i->proc_sym->formal->sym;
7910 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
7911 if (i_rank == my_rank)
7913 gfc_error ("FINAL procedure '%s' declared at %L has the same"
7914 " rank (%d) as '%s'",
7915 list->proc_sym->name, &list->where, my_rank,
7922 /* Is this the/a scalar finalizer procedure? */
7923 if (!arg->as || arg->as->rank == 0)
7926 /* Find the symtree for this procedure. */
7927 gcc_assert (!list->proc_tree);
7928 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
7930 prev_link = &list->next;
7933 /* Remove wrong nodes immediately from the list so we don't risk any
7934 troubles in the future when they might fail later expectations. */
7938 *prev_link = list->next;
7939 gfc_free_finalizer (i);
7942 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
7943 were nodes in the list, must have been for arrays. It is surely a good
7944 idea to have a scalar version there if there's something to finalize. */
7945 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
7946 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
7947 " defined at %L, suggest also scalar one",
7948 derived->name, &derived->declared_at);
7950 /* TODO: Remove this error when finalization is finished. */
7951 gfc_error ("Finalization at %L is not yet implemented",
7952 &derived->declared_at);
7958 /* Check that it is ok for the typebound procedure proc to override the
7962 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
7965 const gfc_symbol* proc_target;
7966 const gfc_symbol* old_target;
7967 unsigned proc_pass_arg, old_pass_arg, argpos;
7968 gfc_formal_arglist* proc_formal;
7969 gfc_formal_arglist* old_formal;
7971 /* This procedure should only be called for non-GENERIC proc. */
7972 gcc_assert (!proc->typebound->is_generic);
7974 /* If the overwritten procedure is GENERIC, this is an error. */
7975 if (old->typebound->is_generic)
7977 gfc_error ("Can't overwrite GENERIC '%s' at %L",
7978 old->name, &proc->typebound->where);
7982 where = proc->typebound->where;
7983 proc_target = proc->typebound->u.specific->n.sym;
7984 old_target = old->typebound->u.specific->n.sym;
7986 /* Check that overridden binding is not NON_OVERRIDABLE. */
7987 if (old->typebound->non_overridable)
7989 gfc_error ("'%s' at %L overrides a procedure binding declared"
7990 " NON_OVERRIDABLE", proc->name, &where);
7994 /* If the overridden binding is PURE, the overriding must be, too. */
7995 if (old_target->attr.pure && !proc_target->attr.pure)
7997 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
7998 proc->name, &where);
8002 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
8003 is not, the overriding must not be either. */
8004 if (old_target->attr.elemental && !proc_target->attr.elemental)
8006 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
8007 " ELEMENTAL", proc->name, &where);
8010 if (!old_target->attr.elemental && proc_target->attr.elemental)
8012 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
8013 " be ELEMENTAL, either", proc->name, &where);
8017 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
8019 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
8021 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
8022 " SUBROUTINE", proc->name, &where);
8026 /* If the overridden binding is a FUNCTION, the overriding must also be a
8027 FUNCTION and have the same characteristics. */
8028 if (old_target->attr.function)
8030 if (!proc_target->attr.function)
8032 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
8033 " FUNCTION", proc->name, &where);
8037 /* FIXME: Do more comprehensive checking (including, for instance, the
8038 rank and array-shape). */
8039 gcc_assert (proc_target->result && old_target->result);
8040 if (!gfc_compare_types (&proc_target->result->ts,
8041 &old_target->result->ts))
8043 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
8044 " matching result types", proc->name, &where);
8049 /* If the overridden binding is PUBLIC, the overriding one must not be
8051 if (old->typebound->access == ACCESS_PUBLIC
8052 && proc->typebound->access == ACCESS_PRIVATE)
8054 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
8055 " PRIVATE", proc->name, &where);
8059 /* Compare the formal argument lists of both procedures. This is also abused
8060 to find the position of the passed-object dummy arguments of both
8061 bindings as at least the overridden one might not yet be resolved and we
8062 need those positions in the check below. */
8063 proc_pass_arg = old_pass_arg = 0;
8064 if (!proc->typebound->nopass && !proc->typebound->pass_arg)
8066 if (!old->typebound->nopass && !old->typebound->pass_arg)
8069 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
8070 proc_formal && old_formal;
8071 proc_formal = proc_formal->next, old_formal = old_formal->next)
8073 if (proc->typebound->pass_arg
8074 && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name))
8075 proc_pass_arg = argpos;
8076 if (old->typebound->pass_arg
8077 && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
8078 old_pass_arg = argpos;
8080 /* Check that the names correspond. */
8081 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
8083 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8084 " to match the corresponding argument of the overridden"
8085 " procedure", proc_formal->sym->name, proc->name, &where,
8086 old_formal->sym->name);
8090 /* Check that the types correspond if neither is the passed-object
8092 /* FIXME: Do more comprehensive testing here. */
8093 if (proc_pass_arg != argpos && old_pass_arg != argpos
8094 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
8096 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8097 " in respect to the overridden procedure",
8098 proc_formal->sym->name, proc->name, &where);
8104 if (proc_formal || old_formal)
8106 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8107 " the overridden procedure", proc->name, &where);
8111 /* If the overridden binding is NOPASS, the overriding one must also be
8113 if (old->typebound->nopass && !proc->typebound->nopass)
8115 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8116 " NOPASS", proc->name, &where);
8120 /* If the overridden binding is PASS(x), the overriding one must also be
8121 PASS and the passed-object dummy arguments must correspond. */
8122 if (!old->typebound->nopass)
8124 if (proc->typebound->nopass)
8126 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8127 " PASS", proc->name, &where);
8131 if (proc_pass_arg != old_pass_arg)
8133 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8134 " the same position as the passed-object dummy argument of"
8135 " the overridden procedure", proc->name, &where);
8144 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8147 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
8148 const char* generic_name, locus where)
8153 gcc_assert (t1->specific && t2->specific);
8154 gcc_assert (!t1->specific->is_generic);
8155 gcc_assert (!t2->specific->is_generic);
8157 sym1 = t1->specific->u.specific->n.sym;
8158 sym2 = t2->specific->u.specific->n.sym;
8160 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8161 if (sym1->attr.subroutine != sym2->attr.subroutine
8162 || sym1->attr.function != sym2->attr.function)
8164 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8165 " GENERIC '%s' at %L",
8166 sym1->name, sym2->name, generic_name, &where);
8170 /* Compare the interfaces. */
8171 if (gfc_compare_interfaces (sym1, sym2, 1))
8173 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8174 sym1->name, sym2->name, generic_name, &where);
8182 /* Resolve a GENERIC procedure binding for a derived type. */
8185 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
8187 gfc_tbp_generic* target;
8188 gfc_symtree* first_target;
8189 gfc_symbol* super_type;
8190 gfc_symtree* inherited;
8193 gcc_assert (st->typebound);
8194 gcc_assert (st->typebound->is_generic);
8196 where = st->typebound->where;
8197 super_type = gfc_get_derived_super_type (derived);
8199 /* Find the overridden binding if any. */
8200 st->typebound->overridden = NULL;
8203 gfc_symtree* overridden;
8204 overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
8206 if (overridden && overridden->typebound)
8207 st->typebound->overridden = overridden->typebound;
8210 /* Try to find the specific bindings for the symtrees in our target-list. */
8211 gcc_assert (st->typebound->u.generic);
8212 for (target = st->typebound->u.generic; target; target = target->next)
8213 if (!target->specific)
8215 gfc_typebound_proc* overridden_tbp;
8217 const char* target_name;
8219 target_name = target->specific_st->name;
8221 /* Defined for this type directly. */
8222 if (target->specific_st->typebound)
8224 target->specific = target->specific_st->typebound;
8225 goto specific_found;
8228 /* Look for an inherited specific binding. */
8231 inherited = gfc_find_typebound_proc (super_type, NULL,
8236 gcc_assert (inherited->typebound);
8237 target->specific = inherited->typebound;
8238 goto specific_found;
8242 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8243 " at %L", target_name, st->name, &where);
8246 /* Once we've found the specific binding, check it is not ambiguous with
8247 other specifics already found or inherited for the same GENERIC. */
8249 gcc_assert (target->specific);
8251 /* This must really be a specific binding! */
8252 if (target->specific->is_generic)
8254 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8255 " '%s' is GENERIC, too", st->name, &where, target_name);
8259 /* Check those already resolved on this type directly. */
8260 for (g = st->typebound->u.generic; g; g = g->next)
8261 if (g != target && g->specific
8262 && check_generic_tbp_ambiguity (target, g, st->name, where)
8266 /* Check for ambiguity with inherited specific targets. */
8267 for (overridden_tbp = st->typebound->overridden; overridden_tbp;
8268 overridden_tbp = overridden_tbp->overridden)
8269 if (overridden_tbp->is_generic)
8271 for (g = overridden_tbp->u.generic; g; g = g->next)
8273 gcc_assert (g->specific);
8274 if (check_generic_tbp_ambiguity (target, g,
8275 st->name, where) == FAILURE)
8281 /* If we attempt to "overwrite" a specific binding, this is an error. */
8282 if (st->typebound->overridden && !st->typebound->overridden->is_generic)
8284 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8285 " the same name", st->name, &where);
8289 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8290 all must have the same attributes here. */
8291 first_target = st->typebound->u.generic->specific->u.specific;
8292 st->typebound->subroutine = first_target->n.sym->attr.subroutine;
8293 st->typebound->function = first_target->n.sym->attr.function;
8299 /* Resolve the type-bound procedures for a derived type. */
8301 static gfc_symbol* resolve_bindings_derived;
8302 static gfc_try resolve_bindings_result;
8305 resolve_typebound_procedure (gfc_symtree* stree)
8310 gfc_symbol* super_type;
8311 gfc_component* comp;
8313 /* If this is no type-bound procedure, just return. */
8314 if (!stree->typebound)
8317 /* If this is a GENERIC binding, use that routine. */
8318 if (stree->typebound->is_generic)
8320 if (resolve_typebound_generic (resolve_bindings_derived, stree)
8326 /* Get the target-procedure to check it. */
8327 gcc_assert (!stree->typebound->is_generic);
8328 gcc_assert (stree->typebound->u.specific);
8329 proc = stree->typebound->u.specific->n.sym;
8330 where = stree->typebound->where;
8332 /* Default access should already be resolved from the parser. */
8333 gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
8335 /* It should be a module procedure or an external procedure with explicit
8337 if ((!proc->attr.subroutine && !proc->attr.function)
8338 || (proc->attr.proc != PROC_MODULE
8339 && proc->attr.if_source != IFSRC_IFBODY)
8340 || proc->attr.abstract)
8342 gfc_error ("'%s' must be a module procedure or an external procedure with"
8343 " an explicit interface at %L", proc->name, &where);
8346 stree->typebound->subroutine = proc->attr.subroutine;
8347 stree->typebound->function = proc->attr.function;
8349 /* Find the super-type of the current derived type. We could do this once and
8350 store in a global if speed is needed, but as long as not I believe this is
8351 more readable and clearer. */
8352 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
8354 /* If PASS, resolve and check arguments if not already resolved / loaded
8355 from a .mod file. */
8356 if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
8358 if (stree->typebound->pass_arg)
8360 gfc_formal_arglist* i;
8362 /* If an explicit passing argument name is given, walk the arg-list
8366 stree->typebound->pass_arg_num = 1;
8367 for (i = proc->formal; i; i = i->next)
8369 if (!strcmp (i->sym->name, stree->typebound->pass_arg))
8374 ++stree->typebound->pass_arg_num;
8379 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8381 proc->name, stree->typebound->pass_arg, &where,
8382 stree->typebound->pass_arg);
8388 /* Otherwise, take the first one; there should in fact be at least
8390 stree->typebound->pass_arg_num = 1;
8393 gfc_error ("Procedure '%s' with PASS at %L must have at"
8394 " least one argument", proc->name, &where);
8397 me_arg = proc->formal->sym;
8400 /* Now check that the argument-type matches. */
8401 gcc_assert (me_arg);
8402 if (me_arg->ts.type != BT_DERIVED
8403 || me_arg->ts.derived != resolve_bindings_derived)
8405 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8406 " the derived-type '%s'", me_arg->name, proc->name,
8407 me_arg->name, &where, resolve_bindings_derived->name);
8411 gfc_warning ("Polymorphic entities are not yet implemented,"
8412 " non-polymorphic passed-object dummy argument of '%s'"
8413 " at %L accepted", proc->name, &where);
8416 /* If we are extending some type, check that we don't override a procedure
8417 flagged NON_OVERRIDABLE. */
8418 stree->typebound->overridden = NULL;
8421 gfc_symtree* overridden;
8422 overridden = gfc_find_typebound_proc (super_type, NULL,
8425 if (overridden && overridden->typebound)
8426 stree->typebound->overridden = overridden->typebound;
8428 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
8432 /* See if there's a name collision with a component directly in this type. */
8433 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
8434 if (!strcmp (comp->name, stree->name))
8436 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8438 stree->name, &where, resolve_bindings_derived->name);
8442 /* Try to find a name collision with an inherited component. */
8443 if (super_type && gfc_find_component (super_type, stree->name, true, true))
8445 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8446 " component of '%s'",
8447 stree->name, &where, resolve_bindings_derived->name);
8454 resolve_bindings_result = FAILURE;
8458 resolve_typebound_procedures (gfc_symbol* derived)
8460 if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
8463 resolve_bindings_derived = derived;
8464 resolve_bindings_result = SUCCESS;
8465 gfc_traverse_symtree (derived->f2k_derived->sym_root,
8466 &resolve_typebound_procedure);
8468 return resolve_bindings_result;
8472 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8473 to give all identical derived types the same backend_decl. */
8475 add_dt_to_dt_list (gfc_symbol *derived)
8477 gfc_dt_list *dt_list;
8479 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
8480 if (derived == dt_list->derived)
8483 if (dt_list == NULL)
8485 dt_list = gfc_get_dt_list ();
8486 dt_list->next = gfc_derived_types;
8487 dt_list->derived = derived;
8488 gfc_derived_types = dt_list;
8493 /* Resolve the components of a derived type. */
8496 resolve_fl_derived (gfc_symbol *sym)
8498 gfc_symbol* super_type;
8502 super_type = gfc_get_derived_super_type (sym);
8504 /* Ensure the extended type gets resolved before we do. */
8505 if (super_type && resolve_fl_derived (super_type) == FAILURE)
8508 /* An ABSTRACT type must be extensible. */
8509 if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
8511 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
8512 sym->name, &sym->declared_at);
8516 for (c = sym->components; c != NULL; c = c->next)
8518 /* Check type-spec if this is not the parent-type component. */
8519 if ((!sym->attr.extension || c != sym->components)
8520 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
8523 /* If this type is an extension, see if this component has the same name
8524 as an inherited type-bound procedure. */
8526 && gfc_find_typebound_proc (super_type, NULL, c->name, true))
8528 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
8529 " inherited type-bound procedure",
8530 c->name, sym->name, &c->loc);
8534 if (c->ts.type == BT_CHARACTER)
8536 if (c->ts.cl->length == NULL
8537 || (resolve_charlen (c->ts.cl) == FAILURE)
8538 || !gfc_is_constant_expr (c->ts.cl->length))
8540 gfc_error ("Character length of component '%s' needs to "
8541 "be a constant specification expression at %L",
8543 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
8548 if (c->ts.type == BT_DERIVED
8549 && sym->component_access != ACCESS_PRIVATE
8550 && gfc_check_access (sym->attr.access, sym->ns->default_access)
8551 && !c->ts.derived->attr.use_assoc
8552 && !gfc_check_access (c->ts.derived->attr.access,
8553 c->ts.derived->ns->default_access))
8555 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
8556 "a component of '%s', which is PUBLIC at %L",
8557 c->name, sym->name, &sym->declared_at);
8561 if (sym->attr.sequence)
8563 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
8565 gfc_error ("Component %s of SEQUENCE type declared at %L does "
8566 "not have the SEQUENCE attribute",
8567 c->ts.derived->name, &sym->declared_at);
8572 if (c->ts.type == BT_DERIVED && c->attr.pointer
8573 && c->ts.derived->components == NULL
8574 && !c->ts.derived->attr.zero_comp)
8576 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
8577 "that has not been declared", c->name, sym->name,
8582 /* Ensure that all the derived type components are put on the
8583 derived type list; even in formal namespaces, where derived type
8584 pointer components might not have been declared. */
8585 if (c->ts.type == BT_DERIVED
8587 && c->ts.derived->components
8589 && sym != c->ts.derived)
8590 add_dt_to_dt_list (c->ts.derived);
8592 if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
8595 for (i = 0; i < c->as->rank; i++)
8597 if (c->as->lower[i] == NULL
8598 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
8599 || !gfc_is_constant_expr (c->as->lower[i])
8600 || c->as->upper[i] == NULL
8601 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
8602 || !gfc_is_constant_expr (c->as->upper[i]))
8604 gfc_error ("Component '%s' of '%s' at %L must have "
8605 "constant array bounds",
8606 c->name, sym->name, &c->loc);
8612 /* Resolve the type-bound procedures. */
8613 if (resolve_typebound_procedures (sym) == FAILURE)
8616 /* Resolve the finalizer procedures. */
8617 if (gfc_resolve_finalizers (sym) == FAILURE)
8620 /* Add derived type to the derived type list. */
8621 add_dt_to_dt_list (sym);
8628 resolve_fl_namelist (gfc_symbol *sym)
8633 /* Reject PRIVATE objects in a PUBLIC namelist. */
8634 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
8636 for (nl = sym->namelist; nl; nl = nl->next)
8638 if (!nl->sym->attr.use_assoc
8639 && !(sym->ns->parent == nl->sym->ns)
8640 && !(sym->ns->parent
8641 && sym->ns->parent->parent == nl->sym->ns)
8642 && !gfc_check_access(nl->sym->attr.access,
8643 nl->sym->ns->default_access))
8645 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
8646 "cannot be member of PUBLIC namelist '%s' at %L",
8647 nl->sym->name, sym->name, &sym->declared_at);
8651 /* Types with private components that came here by USE-association. */
8652 if (nl->sym->ts.type == BT_DERIVED
8653 && derived_inaccessible (nl->sym->ts.derived))
8655 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
8656 "components and cannot be member of namelist '%s' at %L",
8657 nl->sym->name, sym->name, &sym->declared_at);
8661 /* Types with private components that are defined in the same module. */
8662 if (nl->sym->ts.type == BT_DERIVED
8663 && !(sym->ns->parent == nl->sym->ts.derived->ns)
8664 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
8665 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
8666 nl->sym->ns->default_access))
8668 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
8669 "cannot be a member of PUBLIC namelist '%s' at %L",
8670 nl->sym->name, sym->name, &sym->declared_at);
8676 for (nl = sym->namelist; nl; nl = nl->next)
8678 /* Reject namelist arrays of assumed shape. */
8679 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
8680 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
8681 "must not have assumed shape in namelist "
8682 "'%s' at %L", nl->sym->name, sym->name,
8683 &sym->declared_at) == FAILURE)
8686 /* Reject namelist arrays that are not constant shape. */
8687 if (is_non_constant_shape_array (nl->sym))
8689 gfc_error ("NAMELIST array object '%s' must have constant "
8690 "shape in namelist '%s' at %L", nl->sym->name,
8691 sym->name, &sym->declared_at);
8695 /* Namelist objects cannot have allocatable or pointer components. */
8696 if (nl->sym->ts.type != BT_DERIVED)
8699 if (nl->sym->ts.derived->attr.alloc_comp)
8701 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8702 "have ALLOCATABLE components",
8703 nl->sym->name, sym->name, &sym->declared_at);
8707 if (nl->sym->ts.derived->attr.pointer_comp)
8709 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8710 "have POINTER components",
8711 nl->sym->name, sym->name, &sym->declared_at);
8717 /* 14.1.2 A module or internal procedure represent local entities
8718 of the same type as a namelist member and so are not allowed. */
8719 for (nl = sym->namelist; nl; nl = nl->next)
8721 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
8724 if (nl->sym->attr.function && nl->sym == nl->sym->result)
8725 if ((nl->sym == sym->ns->proc_name)
8727 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
8731 if (nl->sym && nl->sym->name)
8732 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
8733 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
8735 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
8736 "attribute in '%s' at %L", nlsym->name,
8747 resolve_fl_parameter (gfc_symbol *sym)
8749 /* A parameter array's shape needs to be constant. */
8751 && (sym->as->type == AS_DEFERRED
8752 || is_non_constant_shape_array (sym)))
8754 gfc_error ("Parameter array '%s' at %L cannot be automatic "
8755 "or of deferred shape", sym->name, &sym->declared_at);
8759 /* Make sure a parameter that has been implicitly typed still
8760 matches the implicit type, since PARAMETER statements can precede
8761 IMPLICIT statements. */
8762 if (sym->attr.implicit_type
8763 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
8765 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
8766 "later IMPLICIT type", sym->name, &sym->declared_at);
8770 /* Make sure the types of derived parameters are consistent. This
8771 type checking is deferred until resolution because the type may
8772 refer to a derived type from the host. */
8773 if (sym->ts.type == BT_DERIVED
8774 && !gfc_compare_types (&sym->ts, &sym->value->ts))
8776 gfc_error ("Incompatible derived type in PARAMETER at %L",
8777 &sym->value->where);
8784 /* Do anything necessary to resolve a symbol. Right now, we just
8785 assume that an otherwise unknown symbol is a variable. This sort
8786 of thing commonly happens for symbols in module. */
8789 resolve_symbol (gfc_symbol *sym)
8791 int check_constant, mp_flag;
8792 gfc_symtree *symtree;
8793 gfc_symtree *this_symtree;
8797 if (sym->attr.flavor == FL_UNKNOWN)
8800 /* If we find that a flavorless symbol is an interface in one of the
8801 parent namespaces, find its symtree in this namespace, free the
8802 symbol and set the symtree to point to the interface symbol. */
8803 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
8805 symtree = gfc_find_symtree (ns->sym_root, sym->name);
8806 if (symtree && symtree->n.sym->generic)
8808 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
8812 gfc_free_symbol (sym);
8813 symtree->n.sym->refs++;
8814 this_symtree->n.sym = symtree->n.sym;
8819 /* Otherwise give it a flavor according to such attributes as
8821 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
8822 sym->attr.flavor = FL_VARIABLE;
8825 sym->attr.flavor = FL_PROCEDURE;
8826 if (sym->attr.dimension)
8827 sym->attr.function = 1;
8831 if (sym->attr.procedure && sym->ts.interface
8832 && sym->attr.if_source != IFSRC_DECL)
8834 if (sym->ts.interface->attr.procedure)
8835 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
8836 "in a later PROCEDURE statement", sym->ts.interface->name,
8837 sym->name,&sym->declared_at);
8839 /* Get the attributes from the interface (now resolved). */
8840 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
8842 gfc_symbol *ifc = sym->ts.interface;
8844 sym->ts.interface = ifc;
8845 sym->attr.function = ifc->attr.function;
8846 sym->attr.subroutine = ifc->attr.subroutine;
8847 sym->attr.allocatable = ifc->attr.allocatable;
8848 sym->attr.pointer = ifc->attr.pointer;
8849 sym->attr.pure = ifc->attr.pure;
8850 sym->attr.elemental = ifc->attr.elemental;
8851 sym->attr.dimension = ifc->attr.dimension;
8852 sym->attr.recursive = ifc->attr.recursive;
8853 sym->attr.always_explicit = ifc->attr.always_explicit;
8854 sym->as = gfc_copy_array_spec (ifc->as);
8855 copy_formal_args (sym, ifc);
8857 else if (sym->ts.interface->name[0] != '\0')
8859 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
8860 sym->ts.interface->name, sym->name, &sym->declared_at);
8865 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
8868 /* Symbols that are module procedures with results (functions) have
8869 the types and array specification copied for type checking in
8870 procedures that call them, as well as for saving to a module
8871 file. These symbols can't stand the scrutiny that their results
8873 mp_flag = (sym->result != NULL && sym->result != sym);
8876 /* Make sure that the intrinsic is consistent with its internal
8877 representation. This needs to be done before assigning a default
8878 type to avoid spurious warnings. */
8879 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
8881 gfc_intrinsic_sym* isym;
8884 /* We already know this one is an intrinsic, so we don't call
8885 gfc_is_intrinsic for full checking but rather use gfc_find_function and
8886 gfc_find_subroutine directly to check whether it is a function or
8889 if ((isym = gfc_find_function (sym->name)))
8891 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
8892 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
8893 " ignored", sym->name, &sym->declared_at);
8895 else if ((isym = gfc_find_subroutine (sym->name)))
8897 if (sym->ts.type != BT_UNKNOWN)
8899 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
8900 " specifier", sym->name, &sym->declared_at);
8906 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
8907 sym->name, &sym->declared_at);
8911 /* Check it is actually available in the standard settings. */
8912 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
8915 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
8916 " available in the current standard settings but %s. Use"
8917 " an appropriate -std=* option or enable -fall-intrinsics"
8918 " in order to use it.",
8919 sym->name, &sym->declared_at, symstd);
8924 /* Assign default type to symbols that need one and don't have one. */
8925 if (sym->ts.type == BT_UNKNOWN)
8927 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
8928 gfc_set_default_type (sym, 1, NULL);
8930 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
8932 /* The specific case of an external procedure should emit an error
8933 in the case that there is no implicit type. */
8935 gfc_set_default_type (sym, sym->attr.external, NULL);
8938 /* Result may be in another namespace. */
8939 resolve_symbol (sym->result);
8941 sym->ts = sym->result->ts;
8942 sym->as = gfc_copy_array_spec (sym->result->as);
8943 sym->attr.dimension = sym->result->attr.dimension;
8944 sym->attr.pointer = sym->result->attr.pointer;
8945 sym->attr.allocatable = sym->result->attr.allocatable;
8950 /* Assumed size arrays and assumed shape arrays must be dummy
8954 && (sym->as->type == AS_ASSUMED_SIZE
8955 || sym->as->type == AS_ASSUMED_SHAPE)
8956 && sym->attr.dummy == 0)
8958 if (sym->as->type == AS_ASSUMED_SIZE)
8959 gfc_error ("Assumed size array at %L must be a dummy argument",
8962 gfc_error ("Assumed shape array at %L must be a dummy argument",
8967 /* Make sure symbols with known intent or optional are really dummy
8968 variable. Because of ENTRY statement, this has to be deferred
8969 until resolution time. */
8971 if (!sym->attr.dummy
8972 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
8974 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
8978 if (sym->attr.value && !sym->attr.dummy)
8980 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
8981 "it is not a dummy argument", sym->name, &sym->declared_at);
8985 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
8987 gfc_charlen *cl = sym->ts.cl;
8988 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
8990 gfc_error ("Character dummy variable '%s' at %L with VALUE "
8991 "attribute must have constant length",
8992 sym->name, &sym->declared_at);
8996 if (sym->ts.is_c_interop
8997 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
8999 gfc_error ("C interoperable character dummy variable '%s' at %L "
9000 "with VALUE attribute must have length one",
9001 sym->name, &sym->declared_at);
9006 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
9007 do this for something that was implicitly typed because that is handled
9008 in gfc_set_default_type. Handle dummy arguments and procedure
9009 definitions separately. Also, anything that is use associated is not
9010 handled here but instead is handled in the module it is declared in.
9011 Finally, derived type definitions are allowed to be BIND(C) since that
9012 only implies that they're interoperable, and they are checked fully for
9013 interoperability when a variable is declared of that type. */
9014 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
9015 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
9016 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
9018 gfc_try t = SUCCESS;
9020 /* First, make sure the variable is declared at the
9021 module-level scope (J3/04-007, Section 15.3). */
9022 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
9023 sym->attr.in_common == 0)
9025 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
9026 "is neither a COMMON block nor declared at the "
9027 "module level scope", sym->name, &(sym->declared_at));
9030 else if (sym->common_head != NULL)
9032 t = verify_com_block_vars_c_interop (sym->common_head);
9036 /* If type() declaration, we need to verify that the components
9037 of the given type are all C interoperable, etc. */
9038 if (sym->ts.type == BT_DERIVED &&
9039 sym->ts.derived->attr.is_c_interop != 1)
9041 /* Make sure the user marked the derived type as BIND(C). If
9042 not, call the verify routine. This could print an error
9043 for the derived type more than once if multiple variables
9044 of that type are declared. */
9045 if (sym->ts.derived->attr.is_bind_c != 1)
9046 verify_bind_c_derived_type (sym->ts.derived);
9050 /* Verify the variable itself as C interoperable if it
9051 is BIND(C). It is not possible for this to succeed if
9052 the verify_bind_c_derived_type failed, so don't have to handle
9053 any error returned by verify_bind_c_derived_type. */
9054 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9060 /* clear the is_bind_c flag to prevent reporting errors more than
9061 once if something failed. */
9062 sym->attr.is_bind_c = 0;
9067 /* If a derived type symbol has reached this point, without its
9068 type being declared, we have an error. Notice that most
9069 conditions that produce undefined derived types have already
9070 been dealt with. However, the likes of:
9071 implicit type(t) (t) ..... call foo (t) will get us here if
9072 the type is not declared in the scope of the implicit
9073 statement. Change the type to BT_UNKNOWN, both because it is so
9074 and to prevent an ICE. */
9075 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
9076 && !sym->ts.derived->attr.zero_comp)
9078 gfc_error ("The derived type '%s' at %L is of type '%s', "
9079 "which has not been defined", sym->name,
9080 &sym->declared_at, sym->ts.derived->name);
9081 sym->ts.type = BT_UNKNOWN;
9085 /* Make sure that the derived type has been resolved and that the
9086 derived type is visible in the symbol's namespace, if it is a
9087 module function and is not PRIVATE. */
9088 if (sym->ts.type == BT_DERIVED
9089 && sym->ts.derived->attr.use_assoc
9090 && sym->ns->proc_name->attr.flavor == FL_MODULE)
9094 if (resolve_fl_derived (sym->ts.derived) == FAILURE)
9097 gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
9098 if (!ds && sym->attr.function
9099 && gfc_check_access (sym->attr.access, sym->ns->default_access))
9101 symtree = gfc_new_symtree (&sym->ns->sym_root,
9102 sym->ts.derived->name);
9103 symtree->n.sym = sym->ts.derived;
9104 sym->ts.derived->refs++;
9108 /* Unless the derived-type declaration is use associated, Fortran 95
9109 does not allow public entries of private derived types.
9110 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9112 if (sym->ts.type == BT_DERIVED
9113 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
9114 && !sym->ts.derived->attr.use_assoc
9115 && gfc_check_access (sym->attr.access, sym->ns->default_access)
9116 && !gfc_check_access (sym->ts.derived->attr.access,
9117 sym->ts.derived->ns->default_access)
9118 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
9119 "of PRIVATE derived type '%s'",
9120 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
9121 : "variable", sym->name, &sym->declared_at,
9122 sym->ts.derived->name) == FAILURE)
9125 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9126 default initialization is defined (5.1.2.4.4). */
9127 if (sym->ts.type == BT_DERIVED
9129 && sym->attr.intent == INTENT_OUT
9131 && sym->as->type == AS_ASSUMED_SIZE)
9133 for (c = sym->ts.derived->components; c; c = c->next)
9137 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9138 "ASSUMED SIZE and so cannot have a default initializer",
9139 sym->name, &sym->declared_at);
9145 switch (sym->attr.flavor)
9148 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
9153 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
9158 if (resolve_fl_namelist (sym) == FAILURE)
9163 if (resolve_fl_parameter (sym) == FAILURE)
9171 /* Resolve array specifier. Check as well some constraints
9172 on COMMON blocks. */
9174 check_constant = sym->attr.in_common && !sym->attr.pointer;
9176 /* Set the formal_arg_flag so that check_conflict will not throw
9177 an error for host associated variables in the specification
9178 expression for an array_valued function. */
9179 if (sym->attr.function && sym->as)
9180 formal_arg_flag = 1;
9182 gfc_resolve_array_spec (sym->as, check_constant);
9184 formal_arg_flag = 0;
9186 /* Resolve formal namespaces. */
9187 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
9188 gfc_resolve (sym->formal_ns);
9190 /* Check threadprivate restrictions. */
9191 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
9192 && (!sym->attr.in_common
9193 && sym->module == NULL
9194 && (sym->ns->proc_name == NULL
9195 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
9196 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
9198 /* If we have come this far we can apply default-initializers, as
9199 described in 14.7.5, to those variables that have not already
9200 been assigned one. */
9201 if (sym->ts.type == BT_DERIVED
9202 && sym->attr.referenced
9203 && sym->ns == gfc_current_ns
9205 && !sym->attr.allocatable
9206 && !sym->attr.alloc_comp)
9208 symbol_attribute *a = &sym->attr;
9210 if ((!a->save && !a->dummy && !a->pointer
9211 && !a->in_common && !a->use_assoc
9212 && !(a->function && sym != sym->result))
9213 || (a->dummy && a->intent == INTENT_OUT))
9214 apply_default_init (sym);
9217 /* If this symbol has a type-spec, check it. */
9218 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
9219 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
9220 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
9226 /************* Resolve DATA statements *************/
9230 gfc_data_value *vnode;
9236 /* Advance the values structure to point to the next value in the data list. */
9239 next_data_value (void)
9242 while (mpz_cmp_ui (values.left, 0) == 0)
9244 if (values.vnode->next == NULL)
9247 values.vnode = values.vnode->next;
9248 mpz_set (values.left, values.vnode->repeat);
9256 check_data_variable (gfc_data_variable *var, locus *where)
9262 ar_type mark = AR_UNKNOWN;
9264 mpz_t section_index[GFC_MAX_DIMENSIONS];
9268 if (gfc_resolve_expr (var->expr) == FAILURE)
9272 mpz_init_set_si (offset, 0);
9275 if (e->expr_type != EXPR_VARIABLE)
9276 gfc_internal_error ("check_data_variable(): Bad expression");
9278 if (e->symtree->n.sym->ns->is_block_data
9279 && !e->symtree->n.sym->attr.in_common)
9281 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9282 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
9285 if (e->ref == NULL && e->symtree->n.sym->as)
9287 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9288 " declaration", e->symtree->n.sym->name, where);
9294 mpz_init_set_ui (size, 1);
9301 /* Find the array section reference. */
9302 for (ref = e->ref; ref; ref = ref->next)
9304 if (ref->type != REF_ARRAY)
9306 if (ref->u.ar.type == AR_ELEMENT)
9312 /* Set marks according to the reference pattern. */
9313 switch (ref->u.ar.type)
9321 /* Get the start position of array section. */
9322 gfc_get_section_index (ar, section_index, &offset);
9330 if (gfc_array_size (e, &size) == FAILURE)
9332 gfc_error ("Nonconstant array section at %L in DATA statement",
9341 while (mpz_cmp_ui (size, 0) > 0)
9343 if (next_data_value () == FAILURE)
9345 gfc_error ("DATA statement at %L has more variables than values",
9351 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
9355 /* If we have more than one element left in the repeat count,
9356 and we have more than one element left in the target variable,
9357 then create a range assignment. */
9358 /* FIXME: Only done for full arrays for now, since array sections
9360 if (mark == AR_FULL && ref && ref->next == NULL
9361 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
9365 if (mpz_cmp (size, values.left) >= 0)
9367 mpz_init_set (range, values.left);
9368 mpz_sub (size, size, values.left);
9369 mpz_set_ui (values.left, 0);
9373 mpz_init_set (range, size);
9374 mpz_sub (values.left, values.left, size);
9375 mpz_set_ui (size, 0);
9378 gfc_assign_data_value_range (var->expr, values.vnode->expr,
9381 mpz_add (offset, offset, range);
9385 /* Assign initial value to symbol. */
9388 mpz_sub_ui (values.left, values.left, 1);
9389 mpz_sub_ui (size, size, 1);
9391 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
9395 if (mark == AR_FULL)
9396 mpz_add_ui (offset, offset, 1);
9398 /* Modify the array section indexes and recalculate the offset
9399 for next element. */
9400 else if (mark == AR_SECTION)
9401 gfc_advance_section (section_index, ar, &offset);
9405 if (mark == AR_SECTION)
9407 for (i = 0; i < ar->dimen; i++)
9408 mpz_clear (section_index[i]);
9418 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
9420 /* Iterate over a list of elements in a DATA statement. */
9423 traverse_data_list (gfc_data_variable *var, locus *where)
9426 iterator_stack frame;
9427 gfc_expr *e, *start, *end, *step;
9428 gfc_try retval = SUCCESS;
9430 mpz_init (frame.value);
9432 start = gfc_copy_expr (var->iter.start);
9433 end = gfc_copy_expr (var->iter.end);
9434 step = gfc_copy_expr (var->iter.step);
9436 if (gfc_simplify_expr (start, 1) == FAILURE
9437 || start->expr_type != EXPR_CONSTANT)
9439 gfc_error ("iterator start at %L does not simplify", &start->where);
9443 if (gfc_simplify_expr (end, 1) == FAILURE
9444 || end->expr_type != EXPR_CONSTANT)
9446 gfc_error ("iterator end at %L does not simplify", &end->where);
9450 if (gfc_simplify_expr (step, 1) == FAILURE
9451 || step->expr_type != EXPR_CONSTANT)
9453 gfc_error ("iterator step at %L does not simplify", &step->where);
9458 mpz_init_set (trip, end->value.integer);
9459 mpz_sub (trip, trip, start->value.integer);
9460 mpz_add (trip, trip, step->value.integer);
9462 mpz_div (trip, trip, step->value.integer);
9464 mpz_set (frame.value, start->value.integer);
9466 frame.prev = iter_stack;
9467 frame.variable = var->iter.var->symtree;
9468 iter_stack = &frame;
9470 while (mpz_cmp_ui (trip, 0) > 0)
9472 if (traverse_data_var (var->list, where) == FAILURE)
9479 e = gfc_copy_expr (var->expr);
9480 if (gfc_simplify_expr (e, 1) == FAILURE)
9488 mpz_add (frame.value, frame.value, step->value.integer);
9490 mpz_sub_ui (trip, trip, 1);
9495 mpz_clear (frame.value);
9497 gfc_free_expr (start);
9498 gfc_free_expr (end);
9499 gfc_free_expr (step);
9501 iter_stack = frame.prev;
9506 /* Type resolve variables in the variable list of a DATA statement. */
9509 traverse_data_var (gfc_data_variable *var, locus *where)
9513 for (; var; var = var->next)
9515 if (var->expr == NULL)
9516 t = traverse_data_list (var, where);
9518 t = check_data_variable (var, where);
9528 /* Resolve the expressions and iterators associated with a data statement.
9529 This is separate from the assignment checking because data lists should
9530 only be resolved once. */
9533 resolve_data_variables (gfc_data_variable *d)
9535 for (; d; d = d->next)
9537 if (d->list == NULL)
9539 if (gfc_resolve_expr (d->expr) == FAILURE)
9544 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
9547 if (resolve_data_variables (d->list) == FAILURE)
9556 /* Resolve a single DATA statement. We implement this by storing a pointer to
9557 the value list into static variables, and then recursively traversing the
9558 variables list, expanding iterators and such. */
9561 resolve_data (gfc_data *d)
9564 if (resolve_data_variables (d->var) == FAILURE)
9567 values.vnode = d->value;
9568 if (d->value == NULL)
9569 mpz_set_ui (values.left, 0);
9571 mpz_set (values.left, d->value->repeat);
9573 if (traverse_data_var (d->var, &d->where) == FAILURE)
9576 /* At this point, we better not have any values left. */
9578 if (next_data_value () == SUCCESS)
9579 gfc_error ("DATA statement at %L has more values than variables",
9584 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
9585 accessed by host or use association, is a dummy argument to a pure function,
9586 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
9587 is storage associated with any such variable, shall not be used in the
9588 following contexts: (clients of this function). */
9590 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
9591 procedure. Returns zero if assignment is OK, nonzero if there is a
9594 gfc_impure_variable (gfc_symbol *sym)
9598 if (sym->attr.use_assoc || sym->attr.in_common)
9601 if (sym->ns != gfc_current_ns)
9602 return !sym->attr.function;
9604 proc = sym->ns->proc_name;
9605 if (sym->attr.dummy && gfc_pure (proc)
9606 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
9608 proc->attr.function))
9611 /* TODO: Sort out what can be storage associated, if anything, and include
9612 it here. In principle equivalences should be scanned but it does not
9613 seem to be possible to storage associate an impure variable this way. */
9618 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
9619 symbol of the current procedure. */
9622 gfc_pure (gfc_symbol *sym)
9624 symbol_attribute attr;
9627 sym = gfc_current_ns->proc_name;
9633 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
9637 /* Test whether the current procedure is elemental or not. */
9640 gfc_elemental (gfc_symbol *sym)
9642 symbol_attribute attr;
9645 sym = gfc_current_ns->proc_name;
9650 return attr.flavor == FL_PROCEDURE && attr.elemental;
9654 /* Warn about unused labels. */
9657 warn_unused_fortran_label (gfc_st_label *label)
9662 warn_unused_fortran_label (label->left);
9664 if (label->defined == ST_LABEL_UNKNOWN)
9667 switch (label->referenced)
9669 case ST_LABEL_UNKNOWN:
9670 gfc_warning ("Label %d at %L defined but not used", label->value,
9674 case ST_LABEL_BAD_TARGET:
9675 gfc_warning ("Label %d at %L defined but cannot be used",
9676 label->value, &label->where);
9683 warn_unused_fortran_label (label->right);
9687 /* Returns the sequence type of a symbol or sequence. */
9690 sequence_type (gfc_typespec ts)
9699 if (ts.derived->components == NULL)
9700 return SEQ_NONDEFAULT;
9702 result = sequence_type (ts.derived->components->ts);
9703 for (c = ts.derived->components->next; c; c = c->next)
9704 if (sequence_type (c->ts) != result)
9710 if (ts.kind != gfc_default_character_kind)
9711 return SEQ_NONDEFAULT;
9713 return SEQ_CHARACTER;
9716 if (ts.kind != gfc_default_integer_kind)
9717 return SEQ_NONDEFAULT;
9722 if (!(ts.kind == gfc_default_real_kind
9723 || ts.kind == gfc_default_double_kind))
9724 return SEQ_NONDEFAULT;
9729 if (ts.kind != gfc_default_complex_kind)
9730 return SEQ_NONDEFAULT;
9735 if (ts.kind != gfc_default_logical_kind)
9736 return SEQ_NONDEFAULT;
9741 return SEQ_NONDEFAULT;
9746 /* Resolve derived type EQUIVALENCE object. */
9749 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
9752 gfc_component *c = derived->components;
9757 /* Shall not be an object of nonsequence derived type. */
9758 if (!derived->attr.sequence)
9760 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
9761 "attribute to be an EQUIVALENCE object", sym->name,
9766 /* Shall not have allocatable components. */
9767 if (derived->attr.alloc_comp)
9769 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
9770 "components to be an EQUIVALENCE object",sym->name,
9775 if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
9777 gfc_error ("Derived type variable '%s' at %L with default "
9778 "initialization cannot be in EQUIVALENCE with a variable "
9779 "in COMMON", sym->name, &e->where);
9783 for (; c ; c = c->next)
9787 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
9790 /* Shall not be an object of sequence derived type containing a pointer
9791 in the structure. */
9792 if (c->attr.pointer)
9794 gfc_error ("Derived type variable '%s' at %L with pointer "
9795 "component(s) cannot be an EQUIVALENCE object",
9796 sym->name, &e->where);
9804 /* Resolve equivalence object.
9805 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
9806 an allocatable array, an object of nonsequence derived type, an object of
9807 sequence derived type containing a pointer at any level of component
9808 selection, an automatic object, a function name, an entry name, a result
9809 name, a named constant, a structure component, or a subobject of any of
9810 the preceding objects. A substring shall not have length zero. A
9811 derived type shall not have components with default initialization nor
9812 shall two objects of an equivalence group be initialized.
9813 Either all or none of the objects shall have an protected attribute.
9814 The simple constraints are done in symbol.c(check_conflict) and the rest
9815 are implemented here. */
9818 resolve_equivalence (gfc_equiv *eq)
9821 gfc_symbol *derived;
9822 gfc_symbol *first_sym;
9825 locus *last_where = NULL;
9826 seq_type eq_type, last_eq_type;
9827 gfc_typespec *last_ts;
9828 int object, cnt_protected;
9829 const char *value_name;
9833 last_ts = &eq->expr->symtree->n.sym->ts;
9835 first_sym = eq->expr->symtree->n.sym;
9839 for (object = 1; eq; eq = eq->eq, object++)
9843 e->ts = e->symtree->n.sym->ts;
9844 /* match_varspec might not know yet if it is seeing
9845 array reference or substring reference, as it doesn't
9847 if (e->ref && e->ref->type == REF_ARRAY)
9849 gfc_ref *ref = e->ref;
9850 sym = e->symtree->n.sym;
9852 if (sym->attr.dimension)
9854 ref->u.ar.as = sym->as;
9858 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
9859 if (e->ts.type == BT_CHARACTER
9861 && ref->type == REF_ARRAY
9862 && ref->u.ar.dimen == 1
9863 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
9864 && ref->u.ar.stride[0] == NULL)
9866 gfc_expr *start = ref->u.ar.start[0];
9867 gfc_expr *end = ref->u.ar.end[0];
9870 /* Optimize away the (:) reference. */
9871 if (start == NULL && end == NULL)
9876 e->ref->next = ref->next;
9881 ref->type = REF_SUBSTRING;
9883 start = gfc_int_expr (1);
9884 ref->u.ss.start = start;
9885 if (end == NULL && e->ts.cl)
9886 end = gfc_copy_expr (e->ts.cl->length);
9887 ref->u.ss.end = end;
9888 ref->u.ss.length = e->ts.cl;
9895 /* Any further ref is an error. */
9898 gcc_assert (ref->type == REF_ARRAY);
9899 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
9905 if (gfc_resolve_expr (e) == FAILURE)
9908 sym = e->symtree->n.sym;
9910 if (sym->attr.is_protected)
9912 if (cnt_protected > 0 && cnt_protected != object)
9914 gfc_error ("Either all or none of the objects in the "
9915 "EQUIVALENCE set at %L shall have the "
9916 "PROTECTED attribute",
9921 /* Shall not equivalence common block variables in a PURE procedure. */
9922 if (sym->ns->proc_name
9923 && sym->ns->proc_name->attr.pure
9924 && sym->attr.in_common)
9926 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
9927 "object in the pure procedure '%s'",
9928 sym->name, &e->where, sym->ns->proc_name->name);
9932 /* Shall not be a named constant. */
9933 if (e->expr_type == EXPR_CONSTANT)
9935 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
9936 "object", sym->name, &e->where);
9940 derived = e->ts.derived;
9941 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
9944 /* Check that the types correspond correctly:
9946 A numeric sequence structure may be equivalenced to another sequence
9947 structure, an object of default integer type, default real type, double
9948 precision real type, default logical type such that components of the
9949 structure ultimately only become associated to objects of the same
9950 kind. A character sequence structure may be equivalenced to an object
9951 of default character kind or another character sequence structure.
9952 Other objects may be equivalenced only to objects of the same type and
9955 /* Identical types are unconditionally OK. */
9956 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
9957 goto identical_types;
9959 last_eq_type = sequence_type (*last_ts);
9960 eq_type = sequence_type (sym->ts);
9962 /* Since the pair of objects is not of the same type, mixed or
9963 non-default sequences can be rejected. */
9965 msg = "Sequence %s with mixed components in EQUIVALENCE "
9966 "statement at %L with different type objects";
9968 && last_eq_type == SEQ_MIXED
9969 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
9971 || (eq_type == SEQ_MIXED
9972 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
9973 &e->where) == FAILURE))
9976 msg = "Non-default type object or sequence %s in EQUIVALENCE "
9977 "statement at %L with objects of different type";
9979 && last_eq_type == SEQ_NONDEFAULT
9980 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
9981 last_where) == FAILURE)
9982 || (eq_type == SEQ_NONDEFAULT
9983 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
9984 &e->where) == FAILURE))
9987 msg ="Non-CHARACTER object '%s' in default CHARACTER "
9988 "EQUIVALENCE statement at %L";
9989 if (last_eq_type == SEQ_CHARACTER
9990 && eq_type != SEQ_CHARACTER
9991 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
9992 &e->where) == FAILURE)
9995 msg ="Non-NUMERIC object '%s' in default NUMERIC "
9996 "EQUIVALENCE statement at %L";
9997 if (last_eq_type == SEQ_NUMERIC
9998 && eq_type != SEQ_NUMERIC
9999 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10000 &e->where) == FAILURE)
10005 last_where = &e->where;
10010 /* Shall not be an automatic array. */
10011 if (e->ref->type == REF_ARRAY
10012 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
10014 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
10015 "an EQUIVALENCE object", sym->name, &e->where);
10022 /* Shall not be a structure component. */
10023 if (r->type == REF_COMPONENT)
10025 gfc_error ("Structure component '%s' at %L cannot be an "
10026 "EQUIVALENCE object",
10027 r->u.c.component->name, &e->where);
10031 /* A substring shall not have length zero. */
10032 if (r->type == REF_SUBSTRING)
10034 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
10036 gfc_error ("Substring at %L has length zero",
10037 &r->u.ss.start->where);
10047 /* Resolve function and ENTRY types, issue diagnostics if needed. */
10050 resolve_fntype (gfc_namespace *ns)
10052 gfc_entry_list *el;
10055 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
10058 /* If there are any entries, ns->proc_name is the entry master
10059 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10061 sym = ns->entries->sym;
10063 sym = ns->proc_name;
10064 if (sym->result == sym
10065 && sym->ts.type == BT_UNKNOWN
10066 && gfc_set_default_type (sym, 0, NULL) == FAILURE
10067 && !sym->attr.untyped)
10069 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10070 sym->name, &sym->declared_at);
10071 sym->attr.untyped = 1;
10074 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
10075 && !gfc_check_access (sym->ts.derived->attr.access,
10076 sym->ts.derived->ns->default_access)
10077 && gfc_check_access (sym->attr.access, sym->ns->default_access))
10079 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
10080 sym->name, &sym->declared_at, sym->ts.derived->name);
10084 for (el = ns->entries->next; el; el = el->next)
10086 if (el->sym->result == el->sym
10087 && el->sym->ts.type == BT_UNKNOWN
10088 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
10089 && !el->sym->attr.untyped)
10091 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10092 el->sym->name, &el->sym->declared_at);
10093 el->sym->attr.untyped = 1;
10098 /* 12.3.2.1.1 Defined operators. */
10101 gfc_resolve_uops (gfc_symtree *symtree)
10103 gfc_interface *itr;
10105 gfc_formal_arglist *formal;
10107 if (symtree == NULL)
10110 gfc_resolve_uops (symtree->left);
10111 gfc_resolve_uops (symtree->right);
10113 for (itr = symtree->n.uop->op; itr; itr = itr->next)
10116 if (!sym->attr.function)
10117 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10118 sym->name, &sym->declared_at);
10120 if (sym->ts.type == BT_CHARACTER
10121 && !(sym->ts.cl && sym->ts.cl->length)
10122 && !(sym->result && sym->result->ts.cl
10123 && sym->result->ts.cl->length))
10124 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10125 "character length", sym->name, &sym->declared_at);
10127 formal = sym->formal;
10128 if (!formal || !formal->sym)
10130 gfc_error ("User operator procedure '%s' at %L must have at least "
10131 "one argument", sym->name, &sym->declared_at);
10135 if (formal->sym->attr.intent != INTENT_IN)
10136 gfc_error ("First argument of operator interface at %L must be "
10137 "INTENT(IN)", &sym->declared_at);
10139 if (formal->sym->attr.optional)
10140 gfc_error ("First argument of operator interface at %L cannot be "
10141 "optional", &sym->declared_at);
10143 formal = formal->next;
10144 if (!formal || !formal->sym)
10147 if (formal->sym->attr.intent != INTENT_IN)
10148 gfc_error ("Second argument of operator interface at %L must be "
10149 "INTENT(IN)", &sym->declared_at);
10151 if (formal->sym->attr.optional)
10152 gfc_error ("Second argument of operator interface at %L cannot be "
10153 "optional", &sym->declared_at);
10156 gfc_error ("Operator interface at %L must have, at most, two "
10157 "arguments", &sym->declared_at);
10162 /* Examine all of the expressions associated with a program unit,
10163 assign types to all intermediate expressions, make sure that all
10164 assignments are to compatible types and figure out which names
10165 refer to which functions or subroutines. It doesn't check code
10166 block, which is handled by resolve_code. */
10169 resolve_types (gfc_namespace *ns)
10175 gfc_namespace* old_ns = gfc_current_ns;
10177 /* Check that all IMPLICIT types are ok. */
10178 if (!ns->seen_implicit_none)
10181 for (letter = 0; letter != GFC_LETTERS; ++letter)
10182 if (ns->set_flag[letter]
10183 && resolve_typespec_used (&ns->default_type[letter],
10184 &ns->implicit_loc[letter],
10189 gfc_current_ns = ns;
10191 resolve_entries (ns);
10193 resolve_common_vars (ns->blank_common.head, false);
10194 resolve_common_blocks (ns->common_root);
10196 resolve_contained_functions (ns);
10198 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
10200 for (cl = ns->cl_list; cl; cl = cl->next)
10201 resolve_charlen (cl);
10203 gfc_traverse_ns (ns, resolve_symbol);
10205 resolve_fntype (ns);
10207 for (n = ns->contained; n; n = n->sibling)
10209 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
10210 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10211 "also be PURE", n->proc_name->name,
10212 &n->proc_name->declared_at);
10218 gfc_check_interfaces (ns);
10220 gfc_traverse_ns (ns, resolve_values);
10226 for (d = ns->data; d; d = d->next)
10230 gfc_traverse_ns (ns, gfc_formalize_init_value);
10232 gfc_traverse_ns (ns, gfc_verify_binding_labels);
10234 if (ns->common_root != NULL)
10235 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
10237 for (eq = ns->equiv; eq; eq = eq->next)
10238 resolve_equivalence (eq);
10240 /* Warn about unused labels. */
10241 if (warn_unused_label)
10242 warn_unused_fortran_label (ns->st_labels);
10244 gfc_resolve_uops (ns->uop_root);
10246 gfc_current_ns = old_ns;
10250 /* Call resolve_code recursively. */
10253 resolve_codes (gfc_namespace *ns)
10257 for (n = ns->contained; n; n = n->sibling)
10260 gfc_current_ns = ns;
10262 /* Set to an out of range value. */
10263 current_entry_id = -1;
10265 bitmap_obstack_initialize (&labels_obstack);
10266 resolve_code (ns->code, ns);
10267 bitmap_obstack_release (&labels_obstack);
10271 /* This function is called after a complete program unit has been compiled.
10272 Its purpose is to examine all of the expressions associated with a program
10273 unit, assign types to all intermediate expressions, make sure that all
10274 assignments are to compatible types and figure out which names refer to
10275 which functions or subroutines. */
10278 gfc_resolve (gfc_namespace *ns)
10280 gfc_namespace *old_ns;
10282 old_ns = gfc_current_ns;
10284 resolve_types (ns);
10285 resolve_codes (ns);
10287 gfc_current_ns = old_ns;