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)
4369 gcc_assert (argpos > 0);
4373 gfc_actual_arglist* result;
4375 result = gfc_get_actual_arglist ();
4383 gcc_assert (argpos > 1);
4385 lst->next = update_arglist_pass (lst->next, po, argpos - 1);
4390 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4393 extract_compcall_passed_object (gfc_expr* e)
4397 gcc_assert (e->expr_type == EXPR_COMPCALL);
4399 po = gfc_get_expr ();
4400 po->expr_type = EXPR_VARIABLE;
4401 po->symtree = e->symtree;
4402 po->ref = gfc_copy_ref (e->ref);
4404 if (gfc_resolve_expr (po) == FAILURE)
4411 /* Update the arglist of an EXPR_COMPCALL expression to include the
4415 update_compcall_arglist (gfc_expr* e)
4418 gfc_typebound_proc* tbp;
4420 tbp = e->value.compcall.tbp;
4425 po = extract_compcall_passed_object (e);
4431 gfc_error ("Passed-object at %L must be scalar", &e->where);
4441 gcc_assert (tbp->pass_arg_num > 0);
4442 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4449 /* Resolve a call to a type-bound procedure, either function or subroutine,
4450 statically from the data in an EXPR_COMPCALL expression. The adapted
4451 arglist and the target-procedure symtree are returned. */
4454 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
4455 gfc_actual_arglist** actual)
4457 gcc_assert (e->expr_type == EXPR_COMPCALL);
4458 gcc_assert (!e->value.compcall.tbp->is_generic);
4460 /* Update the actual arglist for PASS. */
4461 if (update_compcall_arglist (e) == FAILURE)
4464 *actual = e->value.compcall.actual;
4465 *target = e->value.compcall.tbp->u.specific;
4467 gfc_free_ref_list (e->ref);
4469 e->value.compcall.actual = NULL;
4475 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4476 which of the specific bindings (if any) matches the arglist and transform
4477 the expression into a call of that binding. */
4480 resolve_typebound_generic_call (gfc_expr* e)
4482 gfc_typebound_proc* genproc;
4483 const char* genname;
4485 gcc_assert (e->expr_type == EXPR_COMPCALL);
4486 genname = e->value.compcall.name;
4487 genproc = e->value.compcall.tbp;
4489 if (!genproc->is_generic)
4492 /* Try the bindings on this type and in the inheritance hierarchy. */
4493 for (; genproc; genproc = genproc->overridden)
4497 gcc_assert (genproc->is_generic);
4498 for (g = genproc->u.generic; g; g = g->next)
4501 gfc_actual_arglist* args;
4504 gcc_assert (g->specific);
4506 if (g->specific->error)
4509 target = g->specific->u.specific->n.sym;
4511 /* Get the right arglist by handling PASS/NOPASS. */
4512 args = gfc_copy_actual_arglist (e->value.compcall.actual);
4513 if (!g->specific->nopass)
4516 po = extract_compcall_passed_object (e);
4520 gcc_assert (g->specific->pass_arg_num > 0);
4521 gcc_assert (!g->specific->error);
4522 args = update_arglist_pass (args, po, g->specific->pass_arg_num);
4524 resolve_actual_arglist (args, target->attr.proc,
4525 is_external_proc (target) && !target->formal);
4527 /* Check if this arglist matches the formal. */
4528 matches = gfc_arglist_matches_symbol (&args, target);
4530 /* Clean up and break out of the loop if we've found it. */
4531 gfc_free_actual_arglist (args);
4534 e->value.compcall.tbp = g->specific;
4540 /* Nothing matching found! */
4541 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4542 " '%s' at %L", genname, &e->where);
4550 /* Resolve a call to a type-bound subroutine. */
4553 resolve_typebound_call (gfc_code* c)
4555 gfc_actual_arglist* newactual;
4556 gfc_symtree* target;
4558 /* Check that's really a SUBROUTINE. */
4559 if (!c->expr->value.compcall.tbp->subroutine)
4561 gfc_error ("'%s' at %L should be a SUBROUTINE",
4562 c->expr->value.compcall.name, &c->loc);
4566 if (resolve_typebound_generic_call (c->expr) == FAILURE)
4569 /* Transform into an ordinary EXEC_CALL for now. */
4571 if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
4574 c->ext.actual = newactual;
4575 c->symtree = target;
4578 gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
4579 gfc_free_expr (c->expr);
4582 return resolve_call (c);
4586 /* Resolve a component-call expression. */
4589 resolve_compcall (gfc_expr* e)
4591 gfc_actual_arglist* newactual;
4592 gfc_symtree* target;
4594 /* Check that's really a FUNCTION. */
4595 if (!e->value.compcall.tbp->function)
4597 gfc_error ("'%s' at %L should be a FUNCTION",
4598 e->value.compcall.name, &e->where);
4602 if (resolve_typebound_generic_call (e) == FAILURE)
4604 gcc_assert (!e->value.compcall.tbp->is_generic);
4606 /* Take the rank from the function's symbol. */
4607 if (e->value.compcall.tbp->u.specific->n.sym->as)
4608 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
4610 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4611 arglist to the TBP's binding target. */
4613 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
4616 e->value.function.actual = newactual;
4617 e->value.function.name = e->value.compcall.name;
4618 e->value.function.isym = NULL;
4619 e->value.function.esym = NULL;
4620 e->symtree = target;
4621 e->ts = target->n.sym->ts;
4622 e->expr_type = EXPR_FUNCTION;
4624 return gfc_resolve_expr (e);
4628 /* Resolve an expression. That is, make sure that types of operands agree
4629 with their operators, intrinsic operators are converted to function calls
4630 for overloaded types and unresolved function references are resolved. */
4633 gfc_resolve_expr (gfc_expr *e)
4640 switch (e->expr_type)
4643 t = resolve_operator (e);
4649 if (check_host_association (e))
4650 t = resolve_function (e);
4653 t = resolve_variable (e);
4655 expression_rank (e);
4658 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4659 && e->ref->type != REF_SUBSTRING)
4660 gfc_resolve_substring_charlen (e);
4665 t = resolve_compcall (e);
4668 case EXPR_SUBSTRING:
4669 t = resolve_ref (e);
4679 if (resolve_ref (e) == FAILURE)
4682 t = gfc_resolve_array_constructor (e);
4683 /* Also try to expand a constructor. */
4686 expression_rank (e);
4687 gfc_expand_constructor (e);
4690 /* This provides the opportunity for the length of constructors with
4691 character valued function elements to propagate the string length
4692 to the expression. */
4693 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
4694 t = gfc_resolve_character_array_constructor (e);
4698 case EXPR_STRUCTURE:
4699 t = resolve_ref (e);
4703 t = resolve_structure_cons (e);
4707 t = gfc_simplify_expr (e, 0);
4711 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4714 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4721 /* Resolve an expression from an iterator. They must be scalar and have
4722 INTEGER or (optionally) REAL type. */
4725 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4726 const char *name_msgid)
4728 if (gfc_resolve_expr (expr) == FAILURE)
4731 if (expr->rank != 0)
4733 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4737 if (expr->ts.type != BT_INTEGER)
4739 if (expr->ts.type == BT_REAL)
4742 return gfc_notify_std (GFC_STD_F95_DEL,
4743 "Deleted feature: %s at %L must be integer",
4744 _(name_msgid), &expr->where);
4747 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4754 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4762 /* Resolve the expressions in an iterator structure. If REAL_OK is
4763 false allow only INTEGER type iterators, otherwise allow REAL types. */
4766 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4768 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4772 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4774 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4779 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4780 "Start expression in DO loop") == FAILURE)
4783 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4784 "End expression in DO loop") == FAILURE)
4787 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4788 "Step expression in DO loop") == FAILURE)
4791 if (iter->step->expr_type == EXPR_CONSTANT)
4793 if ((iter->step->ts.type == BT_INTEGER
4794 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4795 || (iter->step->ts.type == BT_REAL
4796 && mpfr_sgn (iter->step->value.real) == 0))
4798 gfc_error ("Step expression in DO loop at %L cannot be zero",
4799 &iter->step->where);
4804 /* Convert start, end, and step to the same type as var. */
4805 if (iter->start->ts.kind != iter->var->ts.kind
4806 || iter->start->ts.type != iter->var->ts.type)
4807 gfc_convert_type (iter->start, &iter->var->ts, 2);
4809 if (iter->end->ts.kind != iter->var->ts.kind
4810 || iter->end->ts.type != iter->var->ts.type)
4811 gfc_convert_type (iter->end, &iter->var->ts, 2);
4813 if (iter->step->ts.kind != iter->var->ts.kind
4814 || iter->step->ts.type != iter->var->ts.type)
4815 gfc_convert_type (iter->step, &iter->var->ts, 2);
4821 /* Traversal function for find_forall_index. f == 2 signals that
4822 that variable itself is not to be checked - only the references. */
4825 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
4827 if (expr->expr_type != EXPR_VARIABLE)
4830 /* A scalar assignment */
4831 if (!expr->ref || *f == 1)
4833 if (expr->symtree->n.sym == sym)
4845 /* Check whether the FORALL index appears in the expression or not.
4846 Returns SUCCESS if SYM is found in EXPR. */
4849 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
4851 if (gfc_traverse_expr (expr, sym, forall_index, f))
4858 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4859 to be a scalar INTEGER variable. The subscripts and stride are scalar
4860 INTEGERs, and if stride is a constant it must be nonzero.
4861 Furthermore "A subscript or stride in a forall-triplet-spec shall
4862 not contain a reference to any index-name in the
4863 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4866 resolve_forall_iterators (gfc_forall_iterator *it)
4868 gfc_forall_iterator *iter, *iter2;
4870 for (iter = it; iter; iter = iter->next)
4872 if (gfc_resolve_expr (iter->var) == SUCCESS
4873 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4874 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4877 if (gfc_resolve_expr (iter->start) == SUCCESS
4878 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4879 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4880 &iter->start->where);
4881 if (iter->var->ts.kind != iter->start->ts.kind)
4882 gfc_convert_type (iter->start, &iter->var->ts, 2);
4884 if (gfc_resolve_expr (iter->end) == SUCCESS
4885 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4886 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4888 if (iter->var->ts.kind != iter->end->ts.kind)
4889 gfc_convert_type (iter->end, &iter->var->ts, 2);
4891 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4893 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4894 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4895 &iter->stride->where, "INTEGER");
4897 if (iter->stride->expr_type == EXPR_CONSTANT
4898 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4899 gfc_error ("FORALL stride expression at %L cannot be zero",
4900 &iter->stride->where);
4902 if (iter->var->ts.kind != iter->stride->ts.kind)
4903 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4906 for (iter = it; iter; iter = iter->next)
4907 for (iter2 = iter; iter2; iter2 = iter2->next)
4909 if (find_forall_index (iter2->start,
4910 iter->var->symtree->n.sym, 0) == SUCCESS
4911 || find_forall_index (iter2->end,
4912 iter->var->symtree->n.sym, 0) == SUCCESS
4913 || find_forall_index (iter2->stride,
4914 iter->var->symtree->n.sym, 0) == SUCCESS)
4915 gfc_error ("FORALL index '%s' may not appear in triplet "
4916 "specification at %L", iter->var->symtree->name,
4917 &iter2->start->where);
4922 /* Given a pointer to a symbol that is a derived type, see if it's
4923 inaccessible, i.e. if it's defined in another module and the components are
4924 PRIVATE. The search is recursive if necessary. Returns zero if no
4925 inaccessible components are found, nonzero otherwise. */
4928 derived_inaccessible (gfc_symbol *sym)
4932 if (sym->attr.use_assoc && sym->attr.private_comp)
4935 for (c = sym->components; c; c = c->next)
4937 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4945 /* Resolve the argument of a deallocate expression. The expression must be
4946 a pointer or a full array. */
4949 resolve_deallocate_expr (gfc_expr *e)
4951 symbol_attribute attr;
4952 int allocatable, pointer, check_intent_in;
4955 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4956 check_intent_in = 1;
4958 if (gfc_resolve_expr (e) == FAILURE)
4961 if (e->expr_type != EXPR_VARIABLE)
4964 allocatable = e->symtree->n.sym->attr.allocatable;
4965 pointer = e->symtree->n.sym->attr.pointer;
4966 for (ref = e->ref; ref; ref = ref->next)
4969 check_intent_in = 0;
4974 if (ref->u.ar.type != AR_FULL)
4979 allocatable = (ref->u.c.component->as != NULL
4980 && ref->u.c.component->as->type == AS_DEFERRED);
4981 pointer = ref->u.c.component->attr.pointer;
4990 attr = gfc_expr_attr (e);
4992 if (allocatable == 0 && attr.pointer == 0)
4995 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4996 "ALLOCATABLE or a POINTER", &e->where);
5000 && e->symtree->n.sym->attr.intent == INTENT_IN)
5002 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5003 e->symtree->n.sym->name, &e->where);
5011 /* Returns true if the expression e contains a reference to the symbol sym. */
5013 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5015 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
5022 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
5024 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
5028 /* Given the expression node e for an allocatable/pointer of derived type to be
5029 allocated, get the expression node to be initialized afterwards (needed for
5030 derived types with default initializers, and derived types with allocatable
5031 components that need nullification.) */
5034 expr_to_initialize (gfc_expr *e)
5040 result = gfc_copy_expr (e);
5042 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5043 for (ref = result->ref; ref; ref = ref->next)
5044 if (ref->type == REF_ARRAY && ref->next == NULL)
5046 ref->u.ar.type = AR_FULL;
5048 for (i = 0; i < ref->u.ar.dimen; i++)
5049 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
5051 result->rank = ref->u.ar.dimen;
5059 /* Resolve the expression in an ALLOCATE statement, doing the additional
5060 checks to see whether the expression is OK or not. The expression must
5061 have a trailing array reference that gives the size of the array. */
5064 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
5066 int i, pointer, allocatable, dimension, check_intent_in;
5067 symbol_attribute attr;
5068 gfc_ref *ref, *ref2;
5075 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5076 check_intent_in = 1;
5078 if (gfc_resolve_expr (e) == FAILURE)
5081 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
5082 sym = code->expr->symtree->n.sym;
5086 /* Make sure the expression is allocatable or a pointer. If it is
5087 pointer, the next-to-last reference must be a pointer. */
5091 if (e->expr_type != EXPR_VARIABLE)
5094 attr = gfc_expr_attr (e);
5095 pointer = attr.pointer;
5096 dimension = attr.dimension;
5100 allocatable = e->symtree->n.sym->attr.allocatable;
5101 pointer = e->symtree->n.sym->attr.pointer;
5102 dimension = e->symtree->n.sym->attr.dimension;
5104 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
5106 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
5107 "not be allocated in the same statement at %L",
5108 sym->name, &e->where);
5112 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
5115 check_intent_in = 0;
5120 if (ref->next != NULL)
5125 allocatable = (ref->u.c.component->as != NULL
5126 && ref->u.c.component->as->type == AS_DEFERRED);
5128 pointer = ref->u.c.component->attr.pointer;
5129 dimension = ref->u.c.component->attr.dimension;
5140 if (allocatable == 0 && pointer == 0)
5142 gfc_error ("Expression in ALLOCATE statement at %L must be "
5143 "ALLOCATABLE or a POINTER", &e->where);
5148 && e->symtree->n.sym->attr.intent == INTENT_IN)
5150 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5151 e->symtree->n.sym->name, &e->where);
5155 /* Add default initializer for those derived types that need them. */
5156 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
5158 init_st = gfc_get_code ();
5159 init_st->loc = code->loc;
5160 init_st->op = EXEC_INIT_ASSIGN;
5161 init_st->expr = expr_to_initialize (e);
5162 init_st->expr2 = init_e;
5163 init_st->next = code->next;
5164 code->next = init_st;
5167 if (pointer && dimension == 0)
5170 /* Make sure the next-to-last reference node is an array specification. */
5172 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
5174 gfc_error ("Array specification required in ALLOCATE statement "
5175 "at %L", &e->where);
5179 /* Make sure that the array section reference makes sense in the
5180 context of an ALLOCATE specification. */
5184 for (i = 0; i < ar->dimen; i++)
5186 if (ref2->u.ar.type == AR_ELEMENT)
5189 switch (ar->dimen_type[i])
5195 if (ar->start[i] != NULL
5196 && ar->end[i] != NULL
5197 && ar->stride[i] == NULL)
5200 /* Fall Through... */
5204 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5211 for (a = code->ext.alloc_list; a; a = a->next)
5213 sym = a->expr->symtree->n.sym;
5215 /* TODO - check derived type components. */
5216 if (sym->ts.type == BT_DERIVED)
5219 if ((ar->start[i] != NULL
5220 && gfc_find_sym_in_expr (sym, ar->start[i]))
5221 || (ar->end[i] != NULL
5222 && gfc_find_sym_in_expr (sym, ar->end[i])))
5224 gfc_error ("'%s' must not appear in the array specification at "
5225 "%L in the same ALLOCATE statement where it is "
5226 "itself allocated", sym->name, &ar->where);
5236 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
5238 gfc_symbol *s = NULL;
5242 s = code->expr->symtree->n.sym;
5246 if (s->attr.intent == INTENT_IN)
5247 gfc_error ("STAT variable '%s' of %s statement at %C cannot "
5248 "be INTENT(IN)", s->name, fcn);
5250 if (gfc_pure (NULL) && gfc_impure_variable (s))
5251 gfc_error ("Illegal STAT variable in %s statement at %C "
5252 "for a PURE procedure", fcn);
5255 if (s && code->expr->ts.type != BT_INTEGER)
5256 gfc_error ("STAT tag in %s statement at %L must be "
5257 "of type INTEGER", fcn, &code->expr->where);
5259 if (strcmp (fcn, "ALLOCATE") == 0)
5261 for (a = code->ext.alloc_list; a; a = a->next)
5262 resolve_allocate_expr (a->expr, code);
5266 for (a = code->ext.alloc_list; a; a = a->next)
5267 resolve_deallocate_expr (a->expr);
5271 /************ SELECT CASE resolution subroutines ************/
5273 /* Callback function for our mergesort variant. Determines interval
5274 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5275 op1 > op2. Assumes we're not dealing with the default case.
5276 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5277 There are nine situations to check. */
5280 compare_cases (const gfc_case *op1, const gfc_case *op2)
5284 if (op1->low == NULL) /* op1 = (:L) */
5286 /* op2 = (:N), so overlap. */
5288 /* op2 = (M:) or (M:N), L < M */
5289 if (op2->low != NULL
5290 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5293 else if (op1->high == NULL) /* op1 = (K:) */
5295 /* op2 = (M:), so overlap. */
5297 /* op2 = (:N) or (M:N), K > N */
5298 if (op2->high != NULL
5299 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5302 else /* op1 = (K:L) */
5304 if (op2->low == NULL) /* op2 = (:N), K > N */
5305 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5307 else if (op2->high == NULL) /* op2 = (M:), L < M */
5308 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5310 else /* op2 = (M:N) */
5314 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5317 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5326 /* Merge-sort a double linked case list, detecting overlap in the
5327 process. LIST is the head of the double linked case list before it
5328 is sorted. Returns the head of the sorted list if we don't see any
5329 overlap, or NULL otherwise. */
5332 check_case_overlap (gfc_case *list)
5334 gfc_case *p, *q, *e, *tail;
5335 int insize, nmerges, psize, qsize, cmp, overlap_seen;
5337 /* If the passed list was empty, return immediately. */
5344 /* Loop unconditionally. The only exit from this loop is a return
5345 statement, when we've finished sorting the case list. */
5352 /* Count the number of merges we do in this pass. */
5355 /* Loop while there exists a merge to be done. */
5360 /* Count this merge. */
5363 /* Cut the list in two pieces by stepping INSIZE places
5364 forward in the list, starting from P. */
5367 for (i = 0; i < insize; i++)
5376 /* Now we have two lists. Merge them! */
5377 while (psize > 0 || (qsize > 0 && q != NULL))
5379 /* See from which the next case to merge comes from. */
5382 /* P is empty so the next case must come from Q. */
5387 else if (qsize == 0 || q == NULL)
5396 cmp = compare_cases (p, q);
5399 /* The whole case range for P is less than the
5407 /* The whole case range for Q is greater than
5408 the case range for P. */
5415 /* The cases overlap, or they are the same
5416 element in the list. Either way, we must
5417 issue an error and get the next case from P. */
5418 /* FIXME: Sort P and Q by line number. */
5419 gfc_error ("CASE label at %L overlaps with CASE "
5420 "label at %L", &p->where, &q->where);
5428 /* Add the next element to the merged list. */
5437 /* P has now stepped INSIZE places along, and so has Q. So
5438 they're the same. */
5443 /* If we have done only one merge or none at all, we've
5444 finished sorting the cases. */
5453 /* Otherwise repeat, merging lists twice the size. */
5459 /* Check to see if an expression is suitable for use in a CASE statement.
5460 Makes sure that all case expressions are scalar constants of the same
5461 type. Return FAILURE if anything is wrong. */
5464 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5466 if (e == NULL) return SUCCESS;
5468 if (e->ts.type != case_expr->ts.type)
5470 gfc_error ("Expression in CASE statement at %L must be of type %s",
5471 &e->where, gfc_basic_typename (case_expr->ts.type));
5475 /* C805 (R808) For a given case-construct, each case-value shall be of
5476 the same type as case-expr. For character type, length differences
5477 are allowed, but the kind type parameters shall be the same. */
5479 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5481 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5482 &e->where, case_expr->ts.kind);
5486 /* Convert the case value kind to that of case expression kind, if needed.
5487 FIXME: Should a warning be issued? */
5488 if (e->ts.kind != case_expr->ts.kind)
5489 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5493 gfc_error ("Expression in CASE statement at %L must be scalar",
5502 /* Given a completely parsed select statement, we:
5504 - Validate all expressions and code within the SELECT.
5505 - Make sure that the selection expression is not of the wrong type.
5506 - Make sure that no case ranges overlap.
5507 - Eliminate unreachable cases and unreachable code resulting from
5508 removing case labels.
5510 The standard does allow unreachable cases, e.g. CASE (5:3). But
5511 they are a hassle for code generation, and to prevent that, we just
5512 cut them out here. This is not necessary for overlapping cases
5513 because they are illegal and we never even try to generate code.
5515 We have the additional caveat that a SELECT construct could have
5516 been a computed GOTO in the source code. Fortunately we can fairly
5517 easily work around that here: The case_expr for a "real" SELECT CASE
5518 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5519 we have to do is make sure that the case_expr is a scalar integer
5523 resolve_select (gfc_code *code)
5526 gfc_expr *case_expr;
5527 gfc_case *cp, *default_case, *tail, *head;
5528 int seen_unreachable;
5534 if (code->expr == NULL)
5536 /* This was actually a computed GOTO statement. */
5537 case_expr = code->expr2;
5538 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5539 gfc_error ("Selection expression in computed GOTO statement "
5540 "at %L must be a scalar integer expression",
5543 /* Further checking is not necessary because this SELECT was built
5544 by the compiler, so it should always be OK. Just move the
5545 case_expr from expr2 to expr so that we can handle computed
5546 GOTOs as normal SELECTs from here on. */
5547 code->expr = code->expr2;
5552 case_expr = code->expr;
5554 type = case_expr->ts.type;
5555 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5557 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5558 &case_expr->where, gfc_typename (&case_expr->ts));
5560 /* Punt. Going on here just produce more garbage error messages. */
5564 if (case_expr->rank != 0)
5566 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5567 "expression", &case_expr->where);
5573 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5574 of the SELECT CASE expression and its CASE values. Walk the lists
5575 of case values, and if we find a mismatch, promote case_expr to
5576 the appropriate kind. */
5578 if (type == BT_LOGICAL || type == BT_INTEGER)
5580 for (body = code->block; body; body = body->block)
5582 /* Walk the case label list. */
5583 for (cp = body->ext.case_list; cp; cp = cp->next)
5585 /* Intercept the DEFAULT case. It does not have a kind. */
5586 if (cp->low == NULL && cp->high == NULL)
5589 /* Unreachable case ranges are discarded, so ignore. */
5590 if (cp->low != NULL && cp->high != NULL
5591 && cp->low != cp->high
5592 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5595 /* FIXME: Should a warning be issued? */
5597 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5598 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5600 if (cp->high != NULL
5601 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5602 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5607 /* Assume there is no DEFAULT case. */
5608 default_case = NULL;
5613 for (body = code->block; body; body = body->block)
5615 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5617 seen_unreachable = 0;
5619 /* Walk the case label list, making sure that all case labels
5621 for (cp = body->ext.case_list; cp; cp = cp->next)
5623 /* Count the number of cases in the whole construct. */
5626 /* Intercept the DEFAULT case. */
5627 if (cp->low == NULL && cp->high == NULL)
5629 if (default_case != NULL)
5631 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5632 "by a second DEFAULT CASE at %L",
5633 &default_case->where, &cp->where);
5644 /* Deal with single value cases and case ranges. Errors are
5645 issued from the validation function. */
5646 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5647 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5653 if (type == BT_LOGICAL
5654 && ((cp->low == NULL || cp->high == NULL)
5655 || cp->low != cp->high))
5657 gfc_error ("Logical range in CASE statement at %L is not "
5658 "allowed", &cp->low->where);
5663 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5666 value = cp->low->value.logical == 0 ? 2 : 1;
5667 if (value & seen_logical)
5669 gfc_error ("constant logical value in CASE statement "
5670 "is repeated at %L",
5675 seen_logical |= value;
5678 if (cp->low != NULL && cp->high != NULL
5679 && cp->low != cp->high
5680 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5682 if (gfc_option.warn_surprising)
5683 gfc_warning ("Range specification at %L can never "
5684 "be matched", &cp->where);
5686 cp->unreachable = 1;
5687 seen_unreachable = 1;
5691 /* If the case range can be matched, it can also overlap with
5692 other cases. To make sure it does not, we put it in a
5693 double linked list here. We sort that with a merge sort
5694 later on to detect any overlapping cases. */
5698 head->right = head->left = NULL;
5703 tail->right->left = tail;
5710 /* It there was a failure in the previous case label, give up
5711 for this case label list. Continue with the next block. */
5715 /* See if any case labels that are unreachable have been seen.
5716 If so, we eliminate them. This is a bit of a kludge because
5717 the case lists for a single case statement (label) is a
5718 single forward linked lists. */
5719 if (seen_unreachable)
5721 /* Advance until the first case in the list is reachable. */
5722 while (body->ext.case_list != NULL
5723 && body->ext.case_list->unreachable)
5725 gfc_case *n = body->ext.case_list;
5726 body->ext.case_list = body->ext.case_list->next;
5728 gfc_free_case_list (n);
5731 /* Strip all other unreachable cases. */
5732 if (body->ext.case_list)
5734 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5736 if (cp->next->unreachable)
5738 gfc_case *n = cp->next;
5739 cp->next = cp->next->next;
5741 gfc_free_case_list (n);
5748 /* See if there were overlapping cases. If the check returns NULL,
5749 there was overlap. In that case we don't do anything. If head
5750 is non-NULL, we prepend the DEFAULT case. The sorted list can
5751 then used during code generation for SELECT CASE constructs with
5752 a case expression of a CHARACTER type. */
5755 head = check_case_overlap (head);
5757 /* Prepend the default_case if it is there. */
5758 if (head != NULL && default_case)
5760 default_case->left = NULL;
5761 default_case->right = head;
5762 head->left = default_case;
5766 /* Eliminate dead blocks that may be the result if we've seen
5767 unreachable case labels for a block. */
5768 for (body = code; body && body->block; body = body->block)
5770 if (body->block->ext.case_list == NULL)
5772 /* Cut the unreachable block from the code chain. */
5773 gfc_code *c = body->block;
5774 body->block = c->block;
5776 /* Kill the dead block, but not the blocks below it. */
5778 gfc_free_statements (c);
5782 /* More than two cases is legal but insane for logical selects.
5783 Issue a warning for it. */
5784 if (gfc_option.warn_surprising && type == BT_LOGICAL
5786 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5791 /* Resolve a transfer statement. This is making sure that:
5792 -- a derived type being transferred has only non-pointer components
5793 -- a derived type being transferred doesn't have private components, unless
5794 it's being transferred from the module where the type was defined
5795 -- we're not trying to transfer a whole assumed size array. */
5798 resolve_transfer (gfc_code *code)
5807 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5810 sym = exp->symtree->n.sym;
5813 /* Go to actual component transferred. */
5814 for (ref = code->expr->ref; ref; ref = ref->next)
5815 if (ref->type == REF_COMPONENT)
5816 ts = &ref->u.c.component->ts;
5818 if (ts->type == BT_DERIVED)
5820 /* Check that transferred derived type doesn't contain POINTER
5822 if (ts->derived->attr.pointer_comp)
5824 gfc_error ("Data transfer element at %L cannot have "
5825 "POINTER components", &code->loc);
5829 if (ts->derived->attr.alloc_comp)
5831 gfc_error ("Data transfer element at %L cannot have "
5832 "ALLOCATABLE components", &code->loc);
5836 if (derived_inaccessible (ts->derived))
5838 gfc_error ("Data transfer element at %L cannot have "
5839 "PRIVATE components",&code->loc);
5844 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5845 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5847 gfc_error ("Data transfer element at %L cannot be a full reference to "
5848 "an assumed-size array", &code->loc);
5854 /*********** Toplevel code resolution subroutines ***********/
5856 /* Find the set of labels that are reachable from this block. We also
5857 record the last statement in each block so that we don't have to do
5858 a linear search to find the END DO statements of the blocks. */
5861 reachable_labels (gfc_code *block)
5868 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5870 /* Collect labels in this block. */
5871 for (c = block; c; c = c->next)
5874 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5876 if (!c->next && cs_base->prev)
5877 cs_base->prev->tail = c;
5880 /* Merge with labels from parent block. */
5883 gcc_assert (cs_base->prev->reachable_labels);
5884 bitmap_ior_into (cs_base->reachable_labels,
5885 cs_base->prev->reachable_labels);
5889 /* Given a branch to a label and a namespace, if the branch is conforming.
5890 The code node describes where the branch is located. */
5893 resolve_branch (gfc_st_label *label, gfc_code *code)
5900 /* Step one: is this a valid branching target? */
5902 if (label->defined == ST_LABEL_UNKNOWN)
5904 gfc_error ("Label %d referenced at %L is never defined", label->value,
5909 if (label->defined != ST_LABEL_TARGET)
5911 gfc_error ("Statement at %L is not a valid branch target statement "
5912 "for the branch statement at %L", &label->where, &code->loc);
5916 /* Step two: make sure this branch is not a branch to itself ;-) */
5918 if (code->here == label)
5920 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
5924 /* Step three: See if the label is in the same block as the
5925 branching statement. The hard work has been done by setting up
5926 the bitmap reachable_labels. */
5928 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5930 /* The label is not in an enclosing block, so illegal. This was
5931 allowed in Fortran 66, so we allow it as extension. No
5932 further checks are necessary in this case. */
5933 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5934 "as the GOTO statement at %L", &label->where,
5939 /* Step four: Make sure that the branching target is legal if
5940 the statement is an END {SELECT,IF}. */
5942 for (stack = cs_base; stack; stack = stack->prev)
5943 if (stack->current->next && stack->current->next->here == label)
5946 if (stack && stack->current->next->op == EXEC_NOP)
5948 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5949 "END of construct at %L", &code->loc,
5950 &stack->current->next->loc);
5951 return; /* We know this is not an END DO. */
5954 /* Step five: Make sure that we're not jumping to the end of a DO
5955 loop from within the loop. */
5957 for (stack = cs_base; stack; stack = stack->prev)
5958 if ((stack->current->op == EXEC_DO
5959 || stack->current->op == EXEC_DO_WHILE)
5960 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5962 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5963 "to END of construct at %L", &code->loc,
5971 /* Check whether EXPR1 has the same shape as EXPR2. */
5974 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5976 mpz_t shape[GFC_MAX_DIMENSIONS];
5977 mpz_t shape2[GFC_MAX_DIMENSIONS];
5978 gfc_try result = FAILURE;
5981 /* Compare the rank. */
5982 if (expr1->rank != expr2->rank)
5985 /* Compare the size of each dimension. */
5986 for (i=0; i<expr1->rank; i++)
5988 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5991 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5994 if (mpz_cmp (shape[i], shape2[i]))
5998 /* When either of the two expression is an assumed size array, we
5999 ignore the comparison of dimension sizes. */
6004 for (i--; i >= 0; i--)
6006 mpz_clear (shape[i]);
6007 mpz_clear (shape2[i]);
6013 /* Check whether a WHERE assignment target or a WHERE mask expression
6014 has the same shape as the outmost WHERE mask expression. */
6017 resolve_where (gfc_code *code, gfc_expr *mask)
6023 cblock = code->block;
6025 /* Store the first WHERE mask-expr of the WHERE statement or construct.
6026 In case of nested WHERE, only the outmost one is stored. */
6027 if (mask == NULL) /* outmost WHERE */
6029 else /* inner WHERE */
6036 /* Check if the mask-expr has a consistent shape with the
6037 outmost WHERE mask-expr. */
6038 if (resolve_where_shape (cblock->expr, e) == FAILURE)
6039 gfc_error ("WHERE mask at %L has inconsistent shape",
6040 &cblock->expr->where);
6043 /* the assignment statement of a WHERE statement, or the first
6044 statement in where-body-construct of a WHERE construct */
6045 cnext = cblock->next;
6050 /* WHERE assignment statement */
6053 /* Check shape consistent for WHERE assignment target. */
6054 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
6055 gfc_error ("WHERE assignment target at %L has "
6056 "inconsistent shape", &cnext->expr->where);
6060 case EXEC_ASSIGN_CALL:
6061 resolve_call (cnext);
6062 if (!cnext->resolved_sym->attr.elemental)
6063 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6064 &cnext->ext.actual->expr->where);
6067 /* WHERE or WHERE construct is part of a where-body-construct */
6069 resolve_where (cnext, e);
6073 gfc_error ("Unsupported statement inside WHERE at %L",
6076 /* the next statement within the same where-body-construct */
6077 cnext = cnext->next;
6079 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6080 cblock = cblock->block;
6085 /* Resolve assignment in FORALL construct.
6086 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6087 FORALL index variables. */
6090 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
6094 for (n = 0; n < nvar; n++)
6096 gfc_symbol *forall_index;
6098 forall_index = var_expr[n]->symtree->n.sym;
6100 /* Check whether the assignment target is one of the FORALL index
6102 if ((code->expr->expr_type == EXPR_VARIABLE)
6103 && (code->expr->symtree->n.sym == forall_index))
6104 gfc_error ("Assignment to a FORALL index variable at %L",
6105 &code->expr->where);
6108 /* If one of the FORALL index variables doesn't appear in the
6109 assignment target, then there will be a many-to-one
6111 if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
6112 gfc_error ("The FORALL with index '%s' cause more than one "
6113 "assignment to this object at %L",
6114 var_expr[n]->symtree->name, &code->expr->where);
6120 /* Resolve WHERE statement in FORALL construct. */
6123 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
6124 gfc_expr **var_expr)
6129 cblock = code->block;
6132 /* the assignment statement of a WHERE statement, or the first
6133 statement in where-body-construct of a WHERE construct */
6134 cnext = cblock->next;
6139 /* WHERE assignment statement */
6141 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
6144 /* WHERE operator assignment statement */
6145 case EXEC_ASSIGN_CALL:
6146 resolve_call (cnext);
6147 if (!cnext->resolved_sym->attr.elemental)
6148 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6149 &cnext->ext.actual->expr->where);
6152 /* WHERE or WHERE construct is part of a where-body-construct */
6154 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
6158 gfc_error ("Unsupported statement inside WHERE at %L",
6161 /* the next statement within the same where-body-construct */
6162 cnext = cnext->next;
6164 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6165 cblock = cblock->block;
6170 /* Traverse the FORALL body to check whether the following errors exist:
6171 1. For assignment, check if a many-to-one assignment happens.
6172 2. For WHERE statement, check the WHERE body to see if there is any
6173 many-to-one assignment. */
6176 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
6180 c = code->block->next;
6186 case EXEC_POINTER_ASSIGN:
6187 gfc_resolve_assign_in_forall (c, nvar, var_expr);
6190 case EXEC_ASSIGN_CALL:
6194 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6195 there is no need to handle it here. */
6199 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
6204 /* The next statement in the FORALL body. */
6210 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6211 gfc_resolve_forall_body to resolve the FORALL body. */
6214 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
6216 static gfc_expr **var_expr;
6217 static int total_var = 0;
6218 static int nvar = 0;
6219 gfc_forall_iterator *fa;
6223 /* Start to resolve a FORALL construct */
6224 if (forall_save == 0)
6226 /* Count the total number of FORALL index in the nested FORALL
6227 construct in order to allocate the VAR_EXPR with proper size. */
6229 while ((next != NULL) && (next->op == EXEC_FORALL))
6231 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
6233 next = next->block->next;
6236 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6237 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
6240 /* The information about FORALL iterator, including FORALL index start, end
6241 and stride. The FORALL index can not appear in start, end or stride. */
6242 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6244 /* Check if any outer FORALL index name is the same as the current
6246 for (i = 0; i < nvar; i++)
6248 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
6250 gfc_error ("An outer FORALL construct already has an index "
6251 "with this name %L", &fa->var->where);
6255 /* Record the current FORALL index. */
6256 var_expr[nvar] = gfc_copy_expr (fa->var);
6261 /* Resolve the FORALL body. */
6262 gfc_resolve_forall_body (code, nvar, var_expr);
6264 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6265 gfc_resolve_blocks (code->block, ns);
6267 /* Free VAR_EXPR after the whole FORALL construct resolved. */
6268 for (i = 0; i < total_var; i++)
6269 gfc_free_expr (var_expr[i]);
6271 /* Reset the counters. */
6277 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6280 static void resolve_code (gfc_code *, gfc_namespace *);
6283 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
6287 for (; b; b = b->block)
6289 t = gfc_resolve_expr (b->expr);
6290 if (gfc_resolve_expr (b->expr2) == FAILURE)
6296 if (t == SUCCESS && b->expr != NULL
6297 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
6298 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6305 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
6306 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6311 resolve_branch (b->label, b);
6324 case EXEC_OMP_ATOMIC:
6325 case EXEC_OMP_CRITICAL:
6327 case EXEC_OMP_MASTER:
6328 case EXEC_OMP_ORDERED:
6329 case EXEC_OMP_PARALLEL:
6330 case EXEC_OMP_PARALLEL_DO:
6331 case EXEC_OMP_PARALLEL_SECTIONS:
6332 case EXEC_OMP_PARALLEL_WORKSHARE:
6333 case EXEC_OMP_SECTIONS:
6334 case EXEC_OMP_SINGLE:
6336 case EXEC_OMP_TASKWAIT:
6337 case EXEC_OMP_WORKSHARE:
6341 gfc_internal_error ("resolve_block(): Bad block type");
6344 resolve_code (b->next, ns);
6349 /* Does everything to resolve an ordinary assignment. Returns true
6350 if this is an interface assignment. */
6352 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
6362 if (gfc_extend_assign (code, ns) == SUCCESS)
6364 lhs = code->ext.actual->expr;
6365 rhs = code->ext.actual->next->expr;
6366 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6368 gfc_error ("Subroutine '%s' called instead of assignment at "
6369 "%L must be PURE", code->symtree->n.sym->name,
6374 /* Make a temporary rhs when there is a default initializer
6375 and rhs is the same symbol as the lhs. */
6376 if (rhs->expr_type == EXPR_VARIABLE
6377 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6378 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6379 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6380 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6389 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
6390 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6391 &code->loc) == FAILURE)
6394 /* Handle the case of a BOZ literal on the RHS. */
6395 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
6398 if (gfc_option.warn_surprising)
6399 gfc_warning ("BOZ literal at %L is bitwise transferred "
6400 "non-integer symbol '%s'", &code->loc,
6401 lhs->symtree->n.sym->name);
6403 if (!gfc_convert_boz (rhs, &lhs->ts))
6405 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
6407 if (rc == ARITH_UNDERFLOW)
6408 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6409 ". This check can be disabled with the option "
6410 "-fno-range-check", &rhs->where);
6411 else if (rc == ARITH_OVERFLOW)
6412 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6413 ". This check can be disabled with the option "
6414 "-fno-range-check", &rhs->where);
6415 else if (rc == ARITH_NAN)
6416 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6417 ". This check can be disabled with the option "
6418 "-fno-range-check", &rhs->where);
6424 if (lhs->ts.type == BT_CHARACTER
6425 && gfc_option.warn_character_truncation)
6427 if (lhs->ts.cl != NULL
6428 && lhs->ts.cl->length != NULL
6429 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6430 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
6432 if (rhs->expr_type == EXPR_CONSTANT)
6433 rlen = rhs->value.character.length;
6435 else if (rhs->ts.cl != NULL
6436 && rhs->ts.cl->length != NULL
6437 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6438 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
6440 if (rlen && llen && rlen > llen)
6441 gfc_warning_now ("CHARACTER expression will be truncated "
6442 "in assignment (%d/%d) at %L",
6443 llen, rlen, &code->loc);
6446 /* Ensure that a vector index expression for the lvalue is evaluated
6447 to a temporary if the lvalue symbol is referenced in it. */
6450 for (ref = lhs->ref; ref; ref= ref->next)
6451 if (ref->type == REF_ARRAY)
6453 for (n = 0; n < ref->u.ar.dimen; n++)
6454 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
6455 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
6456 ref->u.ar.start[n]))
6458 = gfc_get_parentheses (ref->u.ar.start[n]);
6462 if (gfc_pure (NULL))
6464 if (gfc_impure_variable (lhs->symtree->n.sym))
6466 gfc_error ("Cannot assign to variable '%s' in PURE "
6468 lhs->symtree->n.sym->name,
6473 if (lhs->ts.type == BT_DERIVED
6474 && lhs->expr_type == EXPR_VARIABLE
6475 && lhs->ts.derived->attr.pointer_comp
6476 && gfc_impure_variable (rhs->symtree->n.sym))
6478 gfc_error ("The impure variable at %L is assigned to "
6479 "a derived type variable with a POINTER "
6480 "component in a PURE procedure (12.6)",
6486 gfc_check_assign (lhs, rhs, 1);
6490 /* Given a block of code, recursively resolve everything pointed to by this
6494 resolve_code (gfc_code *code, gfc_namespace *ns)
6496 int omp_workshare_save;
6501 frame.prev = cs_base;
6505 reachable_labels (code);
6507 for (; code; code = code->next)
6509 frame.current = code;
6510 forall_save = forall_flag;
6512 if (code->op == EXEC_FORALL)
6515 gfc_resolve_forall (code, ns, forall_save);
6518 else if (code->block)
6520 omp_workshare_save = -1;
6523 case EXEC_OMP_PARALLEL_WORKSHARE:
6524 omp_workshare_save = omp_workshare_flag;
6525 omp_workshare_flag = 1;
6526 gfc_resolve_omp_parallel_blocks (code, ns);
6528 case EXEC_OMP_PARALLEL:
6529 case EXEC_OMP_PARALLEL_DO:
6530 case EXEC_OMP_PARALLEL_SECTIONS:
6532 omp_workshare_save = omp_workshare_flag;
6533 omp_workshare_flag = 0;
6534 gfc_resolve_omp_parallel_blocks (code, ns);
6537 gfc_resolve_omp_do_blocks (code, ns);
6539 case EXEC_OMP_WORKSHARE:
6540 omp_workshare_save = omp_workshare_flag;
6541 omp_workshare_flag = 1;
6544 gfc_resolve_blocks (code->block, ns);
6548 if (omp_workshare_save != -1)
6549 omp_workshare_flag = omp_workshare_save;
6553 if (code->op != EXEC_COMPCALL)
6554 t = gfc_resolve_expr (code->expr);
6555 forall_flag = forall_save;
6557 if (gfc_resolve_expr (code->expr2) == FAILURE)
6572 /* Keep track of which entry we are up to. */
6573 current_entry_id = code->ext.entry->id;
6577 resolve_where (code, NULL);
6581 if (code->expr != NULL)
6583 if (code->expr->ts.type != BT_INTEGER)
6584 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6585 "INTEGER variable", &code->expr->where);
6586 else if (code->expr->symtree->n.sym->attr.assign != 1)
6587 gfc_error ("Variable '%s' has not been assigned a target "
6588 "label at %L", code->expr->symtree->n.sym->name,
6589 &code->expr->where);
6592 resolve_branch (code->label, code);
6596 if (code->expr != NULL
6597 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6598 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6599 "INTEGER return specifier", &code->expr->where);
6602 case EXEC_INIT_ASSIGN:
6609 if (resolve_ordinary_assign (code, ns))
6614 case EXEC_LABEL_ASSIGN:
6615 if (code->label->defined == ST_LABEL_UNKNOWN)
6616 gfc_error ("Label %d referenced at %L is never defined",
6617 code->label->value, &code->label->where);
6619 && (code->expr->expr_type != EXPR_VARIABLE
6620 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6621 || code->expr->symtree->n.sym->ts.kind
6622 != gfc_default_integer_kind
6623 || code->expr->symtree->n.sym->as != NULL))
6624 gfc_error ("ASSIGN statement at %L requires a scalar "
6625 "default INTEGER variable", &code->expr->where);
6628 case EXEC_POINTER_ASSIGN:
6632 gfc_check_pointer_assign (code->expr, code->expr2);
6635 case EXEC_ARITHMETIC_IF:
6637 && code->expr->ts.type != BT_INTEGER
6638 && code->expr->ts.type != BT_REAL)
6639 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6640 "expression", &code->expr->where);
6642 resolve_branch (code->label, code);
6643 resolve_branch (code->label2, code);
6644 resolve_branch (code->label3, code);
6648 if (t == SUCCESS && code->expr != NULL
6649 && (code->expr->ts.type != BT_LOGICAL
6650 || code->expr->rank != 0))
6651 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6652 &code->expr->where);
6657 resolve_call (code);
6661 resolve_typebound_call (code);
6665 /* Select is complicated. Also, a SELECT construct could be
6666 a transformed computed GOTO. */
6667 resolve_select (code);
6671 if (code->ext.iterator != NULL)
6673 gfc_iterator *iter = code->ext.iterator;
6674 if (gfc_resolve_iterator (iter, true) != FAILURE)
6675 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6680 if (code->expr == NULL)
6681 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6683 && (code->expr->rank != 0
6684 || code->expr->ts.type != BT_LOGICAL))
6685 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6686 "a scalar LOGICAL expression", &code->expr->where);
6691 resolve_allocate_deallocate (code, "ALLOCATE");
6695 case EXEC_DEALLOCATE:
6697 resolve_allocate_deallocate (code, "DEALLOCATE");
6702 if (gfc_resolve_open (code->ext.open) == FAILURE)
6705 resolve_branch (code->ext.open->err, code);
6709 if (gfc_resolve_close (code->ext.close) == FAILURE)
6712 resolve_branch (code->ext.close->err, code);
6715 case EXEC_BACKSPACE:
6719 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6722 resolve_branch (code->ext.filepos->err, code);
6726 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6729 resolve_branch (code->ext.inquire->err, code);
6733 gcc_assert (code->ext.inquire != NULL);
6734 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6737 resolve_branch (code->ext.inquire->err, code);
6741 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
6744 resolve_branch (code->ext.wait->err, code);
6745 resolve_branch (code->ext.wait->end, code);
6746 resolve_branch (code->ext.wait->eor, code);
6751 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6754 resolve_branch (code->ext.dt->err, code);
6755 resolve_branch (code->ext.dt->end, code);
6756 resolve_branch (code->ext.dt->eor, code);
6760 resolve_transfer (code);
6764 resolve_forall_iterators (code->ext.forall_iterator);
6766 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6767 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6768 "expression", &code->expr->where);
6771 case EXEC_OMP_ATOMIC:
6772 case EXEC_OMP_BARRIER:
6773 case EXEC_OMP_CRITICAL:
6774 case EXEC_OMP_FLUSH:
6776 case EXEC_OMP_MASTER:
6777 case EXEC_OMP_ORDERED:
6778 case EXEC_OMP_SECTIONS:
6779 case EXEC_OMP_SINGLE:
6780 case EXEC_OMP_TASKWAIT:
6781 case EXEC_OMP_WORKSHARE:
6782 gfc_resolve_omp_directive (code, ns);
6785 case EXEC_OMP_PARALLEL:
6786 case EXEC_OMP_PARALLEL_DO:
6787 case EXEC_OMP_PARALLEL_SECTIONS:
6788 case EXEC_OMP_PARALLEL_WORKSHARE:
6790 omp_workshare_save = omp_workshare_flag;
6791 omp_workshare_flag = 0;
6792 gfc_resolve_omp_directive (code, ns);
6793 omp_workshare_flag = omp_workshare_save;
6797 gfc_internal_error ("resolve_code(): Bad statement code");
6801 cs_base = frame.prev;
6805 /* Resolve initial values and make sure they are compatible with
6809 resolve_values (gfc_symbol *sym)
6811 if (sym->value == NULL)
6814 if (gfc_resolve_expr (sym->value) == FAILURE)
6817 gfc_check_assign_symbol (sym, sym->value);
6821 /* Verify the binding labels for common blocks that are BIND(C). The label
6822 for a BIND(C) common block must be identical in all scoping units in which
6823 the common block is declared. Further, the binding label can not collide
6824 with any other global entity in the program. */
6827 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6829 if (comm_block_tree->n.common->is_bind_c == 1)
6831 gfc_gsymbol *binding_label_gsym;
6832 gfc_gsymbol *comm_name_gsym;
6834 /* See if a global symbol exists by the common block's name. It may
6835 be NULL if the common block is use-associated. */
6836 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6837 comm_block_tree->n.common->name);
6838 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6839 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6840 "with the global entity '%s' at %L",
6841 comm_block_tree->n.common->binding_label,
6842 comm_block_tree->n.common->name,
6843 &(comm_block_tree->n.common->where),
6844 comm_name_gsym->name, &(comm_name_gsym->where));
6845 else if (comm_name_gsym != NULL
6846 && strcmp (comm_name_gsym->name,
6847 comm_block_tree->n.common->name) == 0)
6849 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6851 if (comm_name_gsym->binding_label == NULL)
6852 /* No binding label for common block stored yet; save this one. */
6853 comm_name_gsym->binding_label =
6854 comm_block_tree->n.common->binding_label;
6856 if (strcmp (comm_name_gsym->binding_label,
6857 comm_block_tree->n.common->binding_label) != 0)
6859 /* Common block names match but binding labels do not. */
6860 gfc_error ("Binding label '%s' for common block '%s' at %L "
6861 "does not match the binding label '%s' for common "
6863 comm_block_tree->n.common->binding_label,
6864 comm_block_tree->n.common->name,
6865 &(comm_block_tree->n.common->where),
6866 comm_name_gsym->binding_label,
6867 comm_name_gsym->name,
6868 &(comm_name_gsym->where));
6873 /* There is no binding label (NAME="") so we have nothing further to
6874 check and nothing to add as a global symbol for the label. */
6875 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6878 binding_label_gsym =
6879 gfc_find_gsymbol (gfc_gsym_root,
6880 comm_block_tree->n.common->binding_label);
6881 if (binding_label_gsym == NULL)
6883 /* Need to make a global symbol for the binding label to prevent
6884 it from colliding with another. */
6885 binding_label_gsym =
6886 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6887 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6888 binding_label_gsym->type = GSYM_COMMON;
6892 /* If comm_name_gsym is NULL, the name common block is use
6893 associated and the name could be colliding. */
6894 if (binding_label_gsym->type != GSYM_COMMON)
6895 gfc_error ("Binding label '%s' for common block '%s' at %L "
6896 "collides with the global entity '%s' at %L",
6897 comm_block_tree->n.common->binding_label,
6898 comm_block_tree->n.common->name,
6899 &(comm_block_tree->n.common->where),
6900 binding_label_gsym->name,
6901 &(binding_label_gsym->where));
6902 else if (comm_name_gsym != NULL
6903 && (strcmp (binding_label_gsym->name,
6904 comm_name_gsym->binding_label) != 0)
6905 && (strcmp (binding_label_gsym->sym_name,
6906 comm_name_gsym->name) != 0))
6907 gfc_error ("Binding label '%s' for common block '%s' at %L "
6908 "collides with global entity '%s' at %L",
6909 binding_label_gsym->name, binding_label_gsym->sym_name,
6910 &(comm_block_tree->n.common->where),
6911 comm_name_gsym->name, &(comm_name_gsym->where));
6919 /* Verify any BIND(C) derived types in the namespace so we can report errors
6920 for them once, rather than for each variable declared of that type. */
6923 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6925 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6926 && derived_sym->attr.is_bind_c == 1)
6927 verify_bind_c_derived_type (derived_sym);
6933 /* Verify that any binding labels used in a given namespace do not collide
6934 with the names or binding labels of any global symbols. */
6937 gfc_verify_binding_labels (gfc_symbol *sym)
6941 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6942 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6944 gfc_gsymbol *bind_c_sym;
6946 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6947 if (bind_c_sym != NULL
6948 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6950 if (sym->attr.if_source == IFSRC_DECL
6951 && (bind_c_sym->type != GSYM_SUBROUTINE
6952 && bind_c_sym->type != GSYM_FUNCTION)
6953 && ((sym->attr.contained == 1
6954 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6955 || (sym->attr.use_assoc == 1
6956 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6958 /* Make sure global procedures don't collide with anything. */
6959 gfc_error ("Binding label '%s' at %L collides with the global "
6960 "entity '%s' at %L", sym->binding_label,
6961 &(sym->declared_at), bind_c_sym->name,
6962 &(bind_c_sym->where));
6965 else if (sym->attr.contained == 0
6966 && (sym->attr.if_source == IFSRC_IFBODY
6967 && sym->attr.flavor == FL_PROCEDURE)
6968 && (bind_c_sym->sym_name != NULL
6969 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6971 /* Make sure procedures in interface bodies don't collide. */
6972 gfc_error ("Binding label '%s' in interface body at %L collides "
6973 "with the global entity '%s' at %L",
6975 &(sym->declared_at), bind_c_sym->name,
6976 &(bind_c_sym->where));
6979 else if (sym->attr.contained == 0
6980 && sym->attr.if_source == IFSRC_UNKNOWN)
6981 if ((sym->attr.use_assoc && bind_c_sym->mod_name
6982 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
6983 || sym->attr.use_assoc == 0)
6985 gfc_error ("Binding label '%s' at %L collides with global "
6986 "entity '%s' at %L", sym->binding_label,
6987 &(sym->declared_at), bind_c_sym->name,
6988 &(bind_c_sym->where));
6993 /* Clear the binding label to prevent checking multiple times. */
6994 sym->binding_label[0] = '\0';
6996 else if (bind_c_sym == NULL)
6998 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6999 bind_c_sym->where = sym->declared_at;
7000 bind_c_sym->sym_name = sym->name;
7002 if (sym->attr.use_assoc == 1)
7003 bind_c_sym->mod_name = sym->module;
7005 if (sym->ns->proc_name != NULL)
7006 bind_c_sym->mod_name = sym->ns->proc_name->name;
7008 if (sym->attr.contained == 0)
7010 if (sym->attr.subroutine)
7011 bind_c_sym->type = GSYM_SUBROUTINE;
7012 else if (sym->attr.function)
7013 bind_c_sym->type = GSYM_FUNCTION;
7021 /* Resolve an index expression. */
7024 resolve_index_expr (gfc_expr *e)
7026 if (gfc_resolve_expr (e) == FAILURE)
7029 if (gfc_simplify_expr (e, 0) == FAILURE)
7032 if (gfc_specification_expr (e) == FAILURE)
7038 /* Resolve a charlen structure. */
7041 resolve_charlen (gfc_charlen *cl)
7050 specification_expr = 1;
7052 if (resolve_index_expr (cl->length) == FAILURE)
7054 specification_expr = 0;
7058 /* "If the character length parameter value evaluates to a negative
7059 value, the length of character entities declared is zero." */
7060 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
7062 gfc_warning_now ("CHARACTER variable has zero length at %L",
7063 &cl->length->where);
7064 gfc_replace_expr (cl->length, gfc_int_expr (0));
7071 /* Test for non-constant shape arrays. */
7074 is_non_constant_shape_array (gfc_symbol *sym)
7080 not_constant = false;
7081 if (sym->as != NULL)
7083 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7084 has not been simplified; parameter array references. Do the
7085 simplification now. */
7086 for (i = 0; i < sym->as->rank; i++)
7088 e = sym->as->lower[i];
7089 if (e && (resolve_index_expr (e) == FAILURE
7090 || !gfc_is_constant_expr (e)))
7091 not_constant = true;
7093 e = sym->as->upper[i];
7094 if (e && (resolve_index_expr (e) == FAILURE
7095 || !gfc_is_constant_expr (e)))
7096 not_constant = true;
7099 return not_constant;
7102 /* Given a symbol and an initialization expression, add code to initialize
7103 the symbol to the function entry. */
7105 build_init_assign (gfc_symbol *sym, gfc_expr *init)
7109 gfc_namespace *ns = sym->ns;
7111 /* Search for the function namespace if this is a contained
7112 function without an explicit result. */
7113 if (sym->attr.function && sym == sym->result
7114 && sym->name != sym->ns->proc_name->name)
7117 for (;ns; ns = ns->sibling)
7118 if (strcmp (ns->proc_name->name, sym->name) == 0)
7124 gfc_free_expr (init);
7128 /* Build an l-value expression for the result. */
7129 lval = gfc_lval_expr_from_sym (sym);
7131 /* Add the code at scope entry. */
7132 init_st = gfc_get_code ();
7133 init_st->next = ns->code;
7136 /* Assign the default initializer to the l-value. */
7137 init_st->loc = sym->declared_at;
7138 init_st->op = EXEC_INIT_ASSIGN;
7139 init_st->expr = lval;
7140 init_st->expr2 = init;
7143 /* Assign the default initializer to a derived type variable or result. */
7146 apply_default_init (gfc_symbol *sym)
7148 gfc_expr *init = NULL;
7150 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7153 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
7154 init = gfc_default_initializer (&sym->ts);
7159 build_init_assign (sym, init);
7162 /* Build an initializer for a local integer, real, complex, logical, or
7163 character variable, based on the command line flags finit-local-zero,
7164 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7165 null if the symbol should not have a default initialization. */
7167 build_default_init_expr (gfc_symbol *sym)
7170 gfc_expr *init_expr;
7173 /* These symbols should never have a default initialization. */
7174 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
7175 || sym->attr.external
7177 || sym->attr.pointer
7178 || sym->attr.in_equivalence
7179 || sym->attr.in_common
7182 || sym->attr.cray_pointee
7183 || sym->attr.cray_pointer)
7186 /* Now we'll try to build an initializer expression. */
7187 init_expr = gfc_get_expr ();
7188 init_expr->expr_type = EXPR_CONSTANT;
7189 init_expr->ts.type = sym->ts.type;
7190 init_expr->ts.kind = sym->ts.kind;
7191 init_expr->where = sym->declared_at;
7193 /* We will only initialize integers, reals, complex, logicals, and
7194 characters, and only if the corresponding command-line flags
7195 were set. Otherwise, we free init_expr and return null. */
7196 switch (sym->ts.type)
7199 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
7200 mpz_init_set_si (init_expr->value.integer,
7201 gfc_option.flag_init_integer_value);
7204 gfc_free_expr (init_expr);
7210 mpfr_init (init_expr->value.real);
7211 switch (gfc_option.flag_init_real)
7213 case GFC_INIT_REAL_NAN:
7214 mpfr_set_nan (init_expr->value.real);
7217 case GFC_INIT_REAL_INF:
7218 mpfr_set_inf (init_expr->value.real, 1);
7221 case GFC_INIT_REAL_NEG_INF:
7222 mpfr_set_inf (init_expr->value.real, -1);
7225 case GFC_INIT_REAL_ZERO:
7226 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
7230 gfc_free_expr (init_expr);
7237 mpfr_init (init_expr->value.complex.r);
7238 mpfr_init (init_expr->value.complex.i);
7239 switch (gfc_option.flag_init_real)
7241 case GFC_INIT_REAL_NAN:
7242 mpfr_set_nan (init_expr->value.complex.r);
7243 mpfr_set_nan (init_expr->value.complex.i);
7246 case GFC_INIT_REAL_INF:
7247 mpfr_set_inf (init_expr->value.complex.r, 1);
7248 mpfr_set_inf (init_expr->value.complex.i, 1);
7251 case GFC_INIT_REAL_NEG_INF:
7252 mpfr_set_inf (init_expr->value.complex.r, -1);
7253 mpfr_set_inf (init_expr->value.complex.i, -1);
7256 case GFC_INIT_REAL_ZERO:
7257 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
7258 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
7262 gfc_free_expr (init_expr);
7269 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
7270 init_expr->value.logical = 0;
7271 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
7272 init_expr->value.logical = 1;
7275 gfc_free_expr (init_expr);
7281 /* For characters, the length must be constant in order to
7282 create a default initializer. */
7283 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
7284 && sym->ts.cl->length
7285 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
7287 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
7288 init_expr->value.character.length = char_len;
7289 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
7290 for (i = 0; i < char_len; i++)
7291 init_expr->value.character.string[i]
7292 = (unsigned char) gfc_option.flag_init_character_value;
7296 gfc_free_expr (init_expr);
7302 gfc_free_expr (init_expr);
7308 /* Add an initialization expression to a local variable. */
7310 apply_default_init_local (gfc_symbol *sym)
7312 gfc_expr *init = NULL;
7314 /* The symbol should be a variable or a function return value. */
7315 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7316 || (sym->attr.function && sym->result != sym))
7319 /* Try to build the initializer expression. If we can't initialize
7320 this symbol, then init will be NULL. */
7321 init = build_default_init_expr (sym);
7325 /* For saved variables, we don't want to add an initializer at
7326 function entry, so we just add a static initializer. */
7327 if (sym->attr.save || sym->ns->save_all)
7329 /* Don't clobber an existing initializer! */
7330 gcc_assert (sym->value == NULL);
7335 build_init_assign (sym, init);
7338 /* Resolution of common features of flavors variable and procedure. */
7341 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
7343 /* Constraints on deferred shape variable. */
7344 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
7346 if (sym->attr.allocatable)
7348 if (sym->attr.dimension)
7349 gfc_error ("Allocatable array '%s' at %L must have "
7350 "a deferred shape", sym->name, &sym->declared_at);
7352 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7353 sym->name, &sym->declared_at);
7357 if (sym->attr.pointer && sym->attr.dimension)
7359 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7360 sym->name, &sym->declared_at);
7367 if (!mp_flag && !sym->attr.allocatable
7368 && !sym->attr.pointer && !sym->attr.dummy)
7370 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7371 sym->name, &sym->declared_at);
7379 /* Additional checks for symbols with flavor variable and derived
7380 type. To be called from resolve_fl_variable. */
7383 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
7385 gcc_assert (sym->ts.type == BT_DERIVED);
7387 /* Check to see if a derived type is blocked from being host
7388 associated by the presence of another class I symbol in the same
7389 namespace. 14.6.1.3 of the standard and the discussion on
7390 comp.lang.fortran. */
7391 if (sym->ns != sym->ts.derived->ns
7392 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
7395 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
7396 if (s && s->attr.flavor != FL_DERIVED)
7398 gfc_error ("The type '%s' cannot be host associated at %L "
7399 "because it is blocked by an incompatible object "
7400 "of the same name declared at %L",
7401 sym->ts.derived->name, &sym->declared_at,
7407 /* 4th constraint in section 11.3: "If an object of a type for which
7408 component-initialization is specified (R429) appears in the
7409 specification-part of a module and does not have the ALLOCATABLE
7410 or POINTER attribute, the object shall have the SAVE attribute."
7412 The check for initializers is performed with
7413 has_default_initializer because gfc_default_initializer generates
7414 a hidden default for allocatable components. */
7415 if (!(sym->value || no_init_flag) && sym->ns->proc_name
7416 && sym->ns->proc_name->attr.flavor == FL_MODULE
7417 && !sym->ns->save_all && !sym->attr.save
7418 && !sym->attr.pointer && !sym->attr.allocatable
7419 && has_default_initializer (sym->ts.derived))
7421 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7422 "default initialization of a component",
7423 sym->name, &sym->declared_at);
7427 /* Assign default initializer. */
7428 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
7429 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
7431 sym->value = gfc_default_initializer (&sym->ts);
7438 /* Resolve symbols with flavor variable. */
7441 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
7443 int no_init_flag, automatic_flag;
7445 const char *auto_save_msg;
7447 auto_save_msg = "Automatic object '%s' at %L cannot have the "
7450 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7453 /* Set this flag to check that variables are parameters of all entries.
7454 This check is effected by the call to gfc_resolve_expr through
7455 is_non_constant_shape_array. */
7456 specification_expr = 1;
7458 if (sym->ns->proc_name
7459 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7460 || sym->ns->proc_name->attr.is_main_program)
7461 && !sym->attr.use_assoc
7462 && !sym->attr.allocatable
7463 && !sym->attr.pointer
7464 && is_non_constant_shape_array (sym))
7466 /* The shape of a main program or module array needs to be
7468 gfc_error ("The module or main program array '%s' at %L must "
7469 "have constant shape", sym->name, &sym->declared_at);
7470 specification_expr = 0;
7474 if (sym->ts.type == BT_CHARACTER)
7476 /* Make sure that character string variables with assumed length are
7478 e = sym->ts.cl->length;
7479 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
7481 gfc_error ("Entity with assumed character length at %L must be a "
7482 "dummy argument or a PARAMETER", &sym->declared_at);
7486 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7488 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7492 if (!gfc_is_constant_expr (e)
7493 && !(e->expr_type == EXPR_VARIABLE
7494 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7495 && sym->ns->proc_name
7496 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7497 || sym->ns->proc_name->attr.is_main_program)
7498 && !sym->attr.use_assoc)
7500 gfc_error ("'%s' at %L must have constant character length "
7501 "in this context", sym->name, &sym->declared_at);
7506 if (sym->value == NULL && sym->attr.referenced)
7507 apply_default_init_local (sym); /* Try to apply a default initialization. */
7509 /* Determine if the symbol may not have an initializer. */
7510 no_init_flag = automatic_flag = 0;
7511 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7512 || sym->attr.intrinsic || sym->attr.result)
7514 else if (sym->attr.dimension && !sym->attr.pointer
7515 && is_non_constant_shape_array (sym))
7517 no_init_flag = automatic_flag = 1;
7519 /* Also, they must not have the SAVE attribute.
7520 SAVE_IMPLICIT is checked below. */
7521 if (sym->attr.save == SAVE_EXPLICIT)
7523 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7528 /* Reject illegal initializers. */
7529 if (!sym->mark && sym->value)
7531 if (sym->attr.allocatable)
7532 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7533 sym->name, &sym->declared_at);
7534 else if (sym->attr.external)
7535 gfc_error ("External '%s' at %L cannot have an initializer",
7536 sym->name, &sym->declared_at);
7537 else if (sym->attr.dummy
7538 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7539 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7540 sym->name, &sym->declared_at);
7541 else if (sym->attr.intrinsic)
7542 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7543 sym->name, &sym->declared_at);
7544 else if (sym->attr.result)
7545 gfc_error ("Function result '%s' at %L cannot have an initializer",
7546 sym->name, &sym->declared_at);
7547 else if (automatic_flag)
7548 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7549 sym->name, &sym->declared_at);
7556 if (sym->ts.type == BT_DERIVED)
7557 return resolve_fl_variable_derived (sym, no_init_flag);
7563 /* Resolve a procedure. */
7566 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7568 gfc_formal_arglist *arg;
7570 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7571 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7572 "interfaces", sym->name, &sym->declared_at);
7574 if (sym->attr.function
7575 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7578 if (sym->ts.type == BT_CHARACTER)
7580 gfc_charlen *cl = sym->ts.cl;
7582 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7583 && resolve_charlen (cl) == FAILURE)
7586 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7588 if (sym->attr.proc == PROC_ST_FUNCTION)
7590 gfc_error ("Character-valued statement function '%s' at %L must "
7591 "have constant length", sym->name, &sym->declared_at);
7595 if (sym->attr.external && sym->formal == NULL
7596 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7598 gfc_error ("Automatic character length function '%s' at %L must "
7599 "have an explicit interface", sym->name,
7606 /* Ensure that derived type for are not of a private type. Internal
7607 module procedures are excluded by 2.2.3.3 - i.e., they are not
7608 externally accessible and can access all the objects accessible in
7610 if (!(sym->ns->parent
7611 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7612 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7614 gfc_interface *iface;
7616 for (arg = sym->formal; arg; arg = arg->next)
7619 && arg->sym->ts.type == BT_DERIVED
7620 && !arg->sym->ts.derived->attr.use_assoc
7621 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7622 arg->sym->ts.derived->ns->default_access)
7623 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7624 "PRIVATE type and cannot be a dummy argument"
7625 " of '%s', which is PUBLIC at %L",
7626 arg->sym->name, sym->name, &sym->declared_at)
7629 /* Stop this message from recurring. */
7630 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7635 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7636 PRIVATE to the containing module. */
7637 for (iface = sym->generic; iface; iface = iface->next)
7639 for (arg = iface->sym->formal; arg; arg = arg->next)
7642 && arg->sym->ts.type == BT_DERIVED
7643 && !arg->sym->ts.derived->attr.use_assoc
7644 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7645 arg->sym->ts.derived->ns->default_access)
7646 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7647 "'%s' in PUBLIC interface '%s' at %L "
7648 "takes dummy arguments of '%s' which is "
7649 "PRIVATE", iface->sym->name, sym->name,
7650 &iface->sym->declared_at,
7651 gfc_typename (&arg->sym->ts)) == FAILURE)
7653 /* Stop this message from recurring. */
7654 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7660 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7661 PRIVATE to the containing module. */
7662 for (iface = sym->generic; iface; iface = iface->next)
7664 for (arg = iface->sym->formal; arg; arg = arg->next)
7667 && arg->sym->ts.type == BT_DERIVED
7668 && !arg->sym->ts.derived->attr.use_assoc
7669 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7670 arg->sym->ts.derived->ns->default_access)
7671 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7672 "'%s' in PUBLIC interface '%s' at %L "
7673 "takes dummy arguments of '%s' which is "
7674 "PRIVATE", iface->sym->name, sym->name,
7675 &iface->sym->declared_at,
7676 gfc_typename (&arg->sym->ts)) == FAILURE)
7678 /* Stop this message from recurring. */
7679 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7686 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
7687 && !sym->attr.proc_pointer)
7689 gfc_error ("Function '%s' at %L cannot have an initializer",
7690 sym->name, &sym->declared_at);
7694 /* An external symbol may not have an initializer because it is taken to be
7695 a procedure. Exception: Procedure Pointers. */
7696 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
7698 gfc_error ("External object '%s' at %L may not have an initializer",
7699 sym->name, &sym->declared_at);
7703 /* An elemental function is required to return a scalar 12.7.1 */
7704 if (sym->attr.elemental && sym->attr.function && sym->as)
7706 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7707 "result", sym->name, &sym->declared_at);
7708 /* Reset so that the error only occurs once. */
7709 sym->attr.elemental = 0;
7713 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7714 char-len-param shall not be array-valued, pointer-valued, recursive
7715 or pure. ....snip... A character value of * may only be used in the
7716 following ways: (i) Dummy arg of procedure - dummy associates with
7717 actual length; (ii) To declare a named constant; or (iii) External
7718 function - but length must be declared in calling scoping unit. */
7719 if (sym->attr.function
7720 && sym->ts.type == BT_CHARACTER
7721 && sym->ts.cl && sym->ts.cl->length == NULL)
7723 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7724 || (sym->attr.recursive) || (sym->attr.pure))
7726 if (sym->as && sym->as->rank)
7727 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7728 "array-valued", sym->name, &sym->declared_at);
7730 if (sym->attr.pointer)
7731 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7732 "pointer-valued", sym->name, &sym->declared_at);
7735 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7736 "pure", sym->name, &sym->declared_at);
7738 if (sym->attr.recursive)
7739 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7740 "recursive", sym->name, &sym->declared_at);
7745 /* Appendix B.2 of the standard. Contained functions give an
7746 error anyway. Fixed-form is likely to be F77/legacy. */
7747 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7748 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7749 "'%s' at %L is obsolescent in fortran 95",
7750 sym->name, &sym->declared_at);
7753 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7755 gfc_formal_arglist *curr_arg;
7756 int has_non_interop_arg = 0;
7758 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7759 sym->common_block) == FAILURE)
7761 /* Clear these to prevent looking at them again if there was an
7763 sym->attr.is_bind_c = 0;
7764 sym->attr.is_c_interop = 0;
7765 sym->ts.is_c_interop = 0;
7769 /* So far, no errors have been found. */
7770 sym->attr.is_c_interop = 1;
7771 sym->ts.is_c_interop = 1;
7774 curr_arg = sym->formal;
7775 while (curr_arg != NULL)
7777 /* Skip implicitly typed dummy args here. */
7778 if (curr_arg->sym->attr.implicit_type == 0)
7779 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7780 /* If something is found to fail, record the fact so we
7781 can mark the symbol for the procedure as not being
7782 BIND(C) to try and prevent multiple errors being
7784 has_non_interop_arg = 1;
7786 curr_arg = curr_arg->next;
7789 /* See if any of the arguments were not interoperable and if so, clear
7790 the procedure symbol to prevent duplicate error messages. */
7791 if (has_non_interop_arg != 0)
7793 sym->attr.is_c_interop = 0;
7794 sym->ts.is_c_interop = 0;
7795 sym->attr.is_bind_c = 0;
7799 if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
7801 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
7802 "in '%s' at %L", sym->name, &sym->declared_at);
7806 if (sym->attr.intent && !sym->attr.proc_pointer)
7808 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
7809 "in '%s' at %L", sym->name, &sym->declared_at);
7817 /* Resolve a list of finalizer procedures. That is, after they have hopefully
7818 been defined and we now know their defined arguments, check that they fulfill
7819 the requirements of the standard for procedures used as finalizers. */
7822 gfc_resolve_finalizers (gfc_symbol* derived)
7824 gfc_finalizer* list;
7825 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
7826 gfc_try result = SUCCESS;
7827 bool seen_scalar = false;
7829 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
7832 /* Walk over the list of finalizer-procedures, check them, and if any one
7833 does not fit in with the standard's definition, print an error and remove
7834 it from the list. */
7835 prev_link = &derived->f2k_derived->finalizers;
7836 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
7842 /* Skip this finalizer if we already resolved it. */
7843 if (list->proc_tree)
7845 prev_link = &(list->next);
7849 /* Check this exists and is a SUBROUTINE. */
7850 if (!list->proc_sym->attr.subroutine)
7852 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
7853 list->proc_sym->name, &list->where);
7857 /* We should have exactly one argument. */
7858 if (!list->proc_sym->formal || list->proc_sym->formal->next)
7860 gfc_error ("FINAL procedure at %L must have exactly one argument",
7864 arg = list->proc_sym->formal->sym;
7866 /* This argument must be of our type. */
7867 if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
7869 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
7870 &arg->declared_at, derived->name);
7874 /* It must neither be a pointer nor allocatable nor optional. */
7875 if (arg->attr.pointer)
7877 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
7881 if (arg->attr.allocatable)
7883 gfc_error ("Argument of FINAL procedure at %L must not be"
7884 " ALLOCATABLE", &arg->declared_at);
7887 if (arg->attr.optional)
7889 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
7894 /* It must not be INTENT(OUT). */
7895 if (arg->attr.intent == INTENT_OUT)
7897 gfc_error ("Argument of FINAL procedure at %L must not be"
7898 " INTENT(OUT)", &arg->declared_at);
7902 /* Warn if the procedure is non-scalar and not assumed shape. */
7903 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
7904 && arg->as->type != AS_ASSUMED_SHAPE)
7905 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
7906 " shape argument", &arg->declared_at);
7908 /* Check that it does not match in kind and rank with a FINAL procedure
7909 defined earlier. To really loop over the *earlier* declarations,
7910 we need to walk the tail of the list as new ones were pushed at the
7912 /* TODO: Handle kind parameters once they are implemented. */
7913 my_rank = (arg->as ? arg->as->rank : 0);
7914 for (i = list->next; i; i = i->next)
7916 /* Argument list might be empty; that is an error signalled earlier,
7917 but we nevertheless continued resolving. */
7918 if (i->proc_sym->formal)
7920 gfc_symbol* i_arg = i->proc_sym->formal->sym;
7921 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
7922 if (i_rank == my_rank)
7924 gfc_error ("FINAL procedure '%s' declared at %L has the same"
7925 " rank (%d) as '%s'",
7926 list->proc_sym->name, &list->where, my_rank,
7933 /* Is this the/a scalar finalizer procedure? */
7934 if (!arg->as || arg->as->rank == 0)
7937 /* Find the symtree for this procedure. */
7938 gcc_assert (!list->proc_tree);
7939 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
7941 prev_link = &list->next;
7944 /* Remove wrong nodes immediately from the list so we don't risk any
7945 troubles in the future when they might fail later expectations. */
7949 *prev_link = list->next;
7950 gfc_free_finalizer (i);
7953 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
7954 were nodes in the list, must have been for arrays. It is surely a good
7955 idea to have a scalar version there if there's something to finalize. */
7956 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
7957 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
7958 " defined at %L, suggest also scalar one",
7959 derived->name, &derived->declared_at);
7961 /* TODO: Remove this error when finalization is finished. */
7962 gfc_error ("Finalization at %L is not yet implemented",
7963 &derived->declared_at);
7969 /* Check that it is ok for the typebound procedure proc to override the
7973 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
7976 const gfc_symbol* proc_target;
7977 const gfc_symbol* old_target;
7978 unsigned proc_pass_arg, old_pass_arg, argpos;
7979 gfc_formal_arglist* proc_formal;
7980 gfc_formal_arglist* old_formal;
7982 /* This procedure should only be called for non-GENERIC proc. */
7983 gcc_assert (!proc->typebound->is_generic);
7985 /* If the overwritten procedure is GENERIC, this is an error. */
7986 if (old->typebound->is_generic)
7988 gfc_error ("Can't overwrite GENERIC '%s' at %L",
7989 old->name, &proc->typebound->where);
7993 where = proc->typebound->where;
7994 proc_target = proc->typebound->u.specific->n.sym;
7995 old_target = old->typebound->u.specific->n.sym;
7997 /* Check that overridden binding is not NON_OVERRIDABLE. */
7998 if (old->typebound->non_overridable)
8000 gfc_error ("'%s' at %L overrides a procedure binding declared"
8001 " NON_OVERRIDABLE", proc->name, &where);
8005 /* If the overridden binding is PURE, the overriding must be, too. */
8006 if (old_target->attr.pure && !proc_target->attr.pure)
8008 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
8009 proc->name, &where);
8013 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
8014 is not, the overriding must not be either. */
8015 if (old_target->attr.elemental && !proc_target->attr.elemental)
8017 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
8018 " ELEMENTAL", proc->name, &where);
8021 if (!old_target->attr.elemental && proc_target->attr.elemental)
8023 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
8024 " be ELEMENTAL, either", proc->name, &where);
8028 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
8030 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
8032 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
8033 " SUBROUTINE", proc->name, &where);
8037 /* If the overridden binding is a FUNCTION, the overriding must also be a
8038 FUNCTION and have the same characteristics. */
8039 if (old_target->attr.function)
8041 if (!proc_target->attr.function)
8043 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
8044 " FUNCTION", proc->name, &where);
8048 /* FIXME: Do more comprehensive checking (including, for instance, the
8049 rank and array-shape). */
8050 gcc_assert (proc_target->result && old_target->result);
8051 if (!gfc_compare_types (&proc_target->result->ts,
8052 &old_target->result->ts))
8054 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
8055 " matching result types", proc->name, &where);
8060 /* If the overridden binding is PUBLIC, the overriding one must not be
8062 if (old->typebound->access == ACCESS_PUBLIC
8063 && proc->typebound->access == ACCESS_PRIVATE)
8065 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
8066 " PRIVATE", proc->name, &where);
8070 /* Compare the formal argument lists of both procedures. This is also abused
8071 to find the position of the passed-object dummy arguments of both
8072 bindings as at least the overridden one might not yet be resolved and we
8073 need those positions in the check below. */
8074 proc_pass_arg = old_pass_arg = 0;
8075 if (!proc->typebound->nopass && !proc->typebound->pass_arg)
8077 if (!old->typebound->nopass && !old->typebound->pass_arg)
8080 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
8081 proc_formal && old_formal;
8082 proc_formal = proc_formal->next, old_formal = old_formal->next)
8084 if (proc->typebound->pass_arg
8085 && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name))
8086 proc_pass_arg = argpos;
8087 if (old->typebound->pass_arg
8088 && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
8089 old_pass_arg = argpos;
8091 /* Check that the names correspond. */
8092 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
8094 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8095 " to match the corresponding argument of the overridden"
8096 " procedure", proc_formal->sym->name, proc->name, &where,
8097 old_formal->sym->name);
8101 /* Check that the types correspond if neither is the passed-object
8103 /* FIXME: Do more comprehensive testing here. */
8104 if (proc_pass_arg != argpos && old_pass_arg != argpos
8105 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
8107 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8108 " in respect to the overridden procedure",
8109 proc_formal->sym->name, proc->name, &where);
8115 if (proc_formal || old_formal)
8117 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8118 " the overridden procedure", proc->name, &where);
8122 /* If the overridden binding is NOPASS, the overriding one must also be
8124 if (old->typebound->nopass && !proc->typebound->nopass)
8126 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8127 " NOPASS", proc->name, &where);
8131 /* If the overridden binding is PASS(x), the overriding one must also be
8132 PASS and the passed-object dummy arguments must correspond. */
8133 if (!old->typebound->nopass)
8135 if (proc->typebound->nopass)
8137 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8138 " PASS", proc->name, &where);
8142 if (proc_pass_arg != old_pass_arg)
8144 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8145 " the same position as the passed-object dummy argument of"
8146 " the overridden procedure", proc->name, &where);
8155 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8158 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
8159 const char* generic_name, locus where)
8164 gcc_assert (t1->specific && t2->specific);
8165 gcc_assert (!t1->specific->is_generic);
8166 gcc_assert (!t2->specific->is_generic);
8168 sym1 = t1->specific->u.specific->n.sym;
8169 sym2 = t2->specific->u.specific->n.sym;
8171 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8172 if (sym1->attr.subroutine != sym2->attr.subroutine
8173 || sym1->attr.function != sym2->attr.function)
8175 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8176 " GENERIC '%s' at %L",
8177 sym1->name, sym2->name, generic_name, &where);
8181 /* Compare the interfaces. */
8182 if (gfc_compare_interfaces (sym1, sym2, 1))
8184 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8185 sym1->name, sym2->name, generic_name, &where);
8193 /* Resolve a GENERIC procedure binding for a derived type. */
8196 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
8198 gfc_tbp_generic* target;
8199 gfc_symtree* first_target;
8200 gfc_symbol* super_type;
8201 gfc_symtree* inherited;
8204 gcc_assert (st->typebound);
8205 gcc_assert (st->typebound->is_generic);
8207 where = st->typebound->where;
8208 super_type = gfc_get_derived_super_type (derived);
8210 /* Find the overridden binding if any. */
8211 st->typebound->overridden = NULL;
8214 gfc_symtree* overridden;
8215 overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
8217 if (overridden && overridden->typebound)
8218 st->typebound->overridden = overridden->typebound;
8221 /* Try to find the specific bindings for the symtrees in our target-list. */
8222 gcc_assert (st->typebound->u.generic);
8223 for (target = st->typebound->u.generic; target; target = target->next)
8224 if (!target->specific)
8226 gfc_typebound_proc* overridden_tbp;
8228 const char* target_name;
8230 target_name = target->specific_st->name;
8232 /* Defined for this type directly. */
8233 if (target->specific_st->typebound)
8235 target->specific = target->specific_st->typebound;
8236 goto specific_found;
8239 /* Look for an inherited specific binding. */
8242 inherited = gfc_find_typebound_proc (super_type, NULL,
8247 gcc_assert (inherited->typebound);
8248 target->specific = inherited->typebound;
8249 goto specific_found;
8253 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8254 " at %L", target_name, st->name, &where);
8257 /* Once we've found the specific binding, check it is not ambiguous with
8258 other specifics already found or inherited for the same GENERIC. */
8260 gcc_assert (target->specific);
8262 /* This must really be a specific binding! */
8263 if (target->specific->is_generic)
8265 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8266 " '%s' is GENERIC, too", st->name, &where, target_name);
8270 /* Check those already resolved on this type directly. */
8271 for (g = st->typebound->u.generic; g; g = g->next)
8272 if (g != target && g->specific
8273 && check_generic_tbp_ambiguity (target, g, st->name, where)
8277 /* Check for ambiguity with inherited specific targets. */
8278 for (overridden_tbp = st->typebound->overridden; overridden_tbp;
8279 overridden_tbp = overridden_tbp->overridden)
8280 if (overridden_tbp->is_generic)
8282 for (g = overridden_tbp->u.generic; g; g = g->next)
8284 gcc_assert (g->specific);
8285 if (check_generic_tbp_ambiguity (target, g,
8286 st->name, where) == FAILURE)
8292 /* If we attempt to "overwrite" a specific binding, this is an error. */
8293 if (st->typebound->overridden && !st->typebound->overridden->is_generic)
8295 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8296 " the same name", st->name, &where);
8300 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8301 all must have the same attributes here. */
8302 first_target = st->typebound->u.generic->specific->u.specific;
8303 st->typebound->subroutine = first_target->n.sym->attr.subroutine;
8304 st->typebound->function = first_target->n.sym->attr.function;
8310 /* Resolve the type-bound procedures for a derived type. */
8312 static gfc_symbol* resolve_bindings_derived;
8313 static gfc_try resolve_bindings_result;
8316 resolve_typebound_procedure (gfc_symtree* stree)
8321 gfc_symbol* super_type;
8322 gfc_component* comp;
8324 /* If this is no type-bound procedure, just return. */
8325 if (!stree->typebound)
8328 /* If this is a GENERIC binding, use that routine. */
8329 if (stree->typebound->is_generic)
8331 if (resolve_typebound_generic (resolve_bindings_derived, stree)
8337 /* Get the target-procedure to check it. */
8338 gcc_assert (!stree->typebound->is_generic);
8339 gcc_assert (stree->typebound->u.specific);
8340 proc = stree->typebound->u.specific->n.sym;
8341 where = stree->typebound->where;
8343 /* Default access should already be resolved from the parser. */
8344 gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
8346 /* It should be a module procedure or an external procedure with explicit
8348 if ((!proc->attr.subroutine && !proc->attr.function)
8349 || (proc->attr.proc != PROC_MODULE
8350 && proc->attr.if_source != IFSRC_IFBODY)
8351 || proc->attr.abstract)
8353 gfc_error ("'%s' must be a module procedure or an external procedure with"
8354 " an explicit interface at %L", proc->name, &where);
8357 stree->typebound->subroutine = proc->attr.subroutine;
8358 stree->typebound->function = proc->attr.function;
8360 /* Find the super-type of the current derived type. We could do this once and
8361 store in a global if speed is needed, but as long as not I believe this is
8362 more readable and clearer. */
8363 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
8365 /* If PASS, resolve and check arguments if not already resolved / loaded
8366 from a .mod file. */
8367 if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
8369 if (stree->typebound->pass_arg)
8371 gfc_formal_arglist* i;
8373 /* If an explicit passing argument name is given, walk the arg-list
8377 stree->typebound->pass_arg_num = 1;
8378 for (i = proc->formal; i; i = i->next)
8380 if (!strcmp (i->sym->name, stree->typebound->pass_arg))
8385 ++stree->typebound->pass_arg_num;
8390 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8392 proc->name, stree->typebound->pass_arg, &where,
8393 stree->typebound->pass_arg);
8399 /* Otherwise, take the first one; there should in fact be at least
8401 stree->typebound->pass_arg_num = 1;
8404 gfc_error ("Procedure '%s' with PASS at %L must have at"
8405 " least one argument", proc->name, &where);
8408 me_arg = proc->formal->sym;
8411 /* Now check that the argument-type matches. */
8412 gcc_assert (me_arg);
8413 if (me_arg->ts.type != BT_DERIVED
8414 || me_arg->ts.derived != resolve_bindings_derived)
8416 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8417 " the derived-type '%s'", me_arg->name, proc->name,
8418 me_arg->name, &where, resolve_bindings_derived->name);
8422 gfc_warning ("Polymorphic entities are not yet implemented,"
8423 " non-polymorphic passed-object dummy argument of '%s'"
8424 " at %L accepted", proc->name, &where);
8427 /* If we are extending some type, check that we don't override a procedure
8428 flagged NON_OVERRIDABLE. */
8429 stree->typebound->overridden = NULL;
8432 gfc_symtree* overridden;
8433 overridden = gfc_find_typebound_proc (super_type, NULL,
8436 if (overridden && overridden->typebound)
8437 stree->typebound->overridden = overridden->typebound;
8439 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
8443 /* See if there's a name collision with a component directly in this type. */
8444 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
8445 if (!strcmp (comp->name, stree->name))
8447 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8449 stree->name, &where, resolve_bindings_derived->name);
8453 /* Try to find a name collision with an inherited component. */
8454 if (super_type && gfc_find_component (super_type, stree->name, true, true))
8456 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8457 " component of '%s'",
8458 stree->name, &where, resolve_bindings_derived->name);
8462 stree->typebound->error = 0;
8466 resolve_bindings_result = FAILURE;
8467 stree->typebound->error = 1;
8471 resolve_typebound_procedures (gfc_symbol* derived)
8473 if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
8476 resolve_bindings_derived = derived;
8477 resolve_bindings_result = SUCCESS;
8478 gfc_traverse_symtree (derived->f2k_derived->sym_root,
8479 &resolve_typebound_procedure);
8481 return resolve_bindings_result;
8485 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8486 to give all identical derived types the same backend_decl. */
8488 add_dt_to_dt_list (gfc_symbol *derived)
8490 gfc_dt_list *dt_list;
8492 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
8493 if (derived == dt_list->derived)
8496 if (dt_list == NULL)
8498 dt_list = gfc_get_dt_list ();
8499 dt_list->next = gfc_derived_types;
8500 dt_list->derived = derived;
8501 gfc_derived_types = dt_list;
8506 /* Resolve the components of a derived type. */
8509 resolve_fl_derived (gfc_symbol *sym)
8511 gfc_symbol* super_type;
8515 super_type = gfc_get_derived_super_type (sym);
8517 /* Ensure the extended type gets resolved before we do. */
8518 if (super_type && resolve_fl_derived (super_type) == FAILURE)
8521 /* An ABSTRACT type must be extensible. */
8522 if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
8524 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
8525 sym->name, &sym->declared_at);
8529 for (c = sym->components; c != NULL; c = c->next)
8531 /* Check type-spec if this is not the parent-type component. */
8532 if ((!sym->attr.extension || c != sym->components)
8533 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
8536 /* If this type is an extension, see if this component has the same name
8537 as an inherited type-bound procedure. */
8539 && gfc_find_typebound_proc (super_type, NULL, c->name, true))
8541 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
8542 " inherited type-bound procedure",
8543 c->name, sym->name, &c->loc);
8547 if (c->ts.type == BT_CHARACTER)
8549 if (c->ts.cl->length == NULL
8550 || (resolve_charlen (c->ts.cl) == FAILURE)
8551 || !gfc_is_constant_expr (c->ts.cl->length))
8553 gfc_error ("Character length of component '%s' needs to "
8554 "be a constant specification expression at %L",
8556 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
8561 if (c->ts.type == BT_DERIVED
8562 && sym->component_access != ACCESS_PRIVATE
8563 && gfc_check_access (sym->attr.access, sym->ns->default_access)
8564 && !c->ts.derived->attr.use_assoc
8565 && !gfc_check_access (c->ts.derived->attr.access,
8566 c->ts.derived->ns->default_access))
8568 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
8569 "a component of '%s', which is PUBLIC at %L",
8570 c->name, sym->name, &sym->declared_at);
8574 if (sym->attr.sequence)
8576 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
8578 gfc_error ("Component %s of SEQUENCE type declared at %L does "
8579 "not have the SEQUENCE attribute",
8580 c->ts.derived->name, &sym->declared_at);
8585 if (c->ts.type == BT_DERIVED && c->attr.pointer
8586 && c->ts.derived->components == NULL
8587 && !c->ts.derived->attr.zero_comp)
8589 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
8590 "that has not been declared", c->name, sym->name,
8595 /* Ensure that all the derived type components are put on the
8596 derived type list; even in formal namespaces, where derived type
8597 pointer components might not have been declared. */
8598 if (c->ts.type == BT_DERIVED
8600 && c->ts.derived->components
8602 && sym != c->ts.derived)
8603 add_dt_to_dt_list (c->ts.derived);
8605 if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
8608 for (i = 0; i < c->as->rank; i++)
8610 if (c->as->lower[i] == NULL
8611 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
8612 || !gfc_is_constant_expr (c->as->lower[i])
8613 || c->as->upper[i] == NULL
8614 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
8615 || !gfc_is_constant_expr (c->as->upper[i]))
8617 gfc_error ("Component '%s' of '%s' at %L must have "
8618 "constant array bounds",
8619 c->name, sym->name, &c->loc);
8625 /* Resolve the type-bound procedures. */
8626 if (resolve_typebound_procedures (sym) == FAILURE)
8629 /* Resolve the finalizer procedures. */
8630 if (gfc_resolve_finalizers (sym) == FAILURE)
8633 /* Add derived type to the derived type list. */
8634 add_dt_to_dt_list (sym);
8641 resolve_fl_namelist (gfc_symbol *sym)
8646 /* Reject PRIVATE objects in a PUBLIC namelist. */
8647 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
8649 for (nl = sym->namelist; nl; nl = nl->next)
8651 if (!nl->sym->attr.use_assoc
8652 && !(sym->ns->parent == nl->sym->ns)
8653 && !(sym->ns->parent
8654 && sym->ns->parent->parent == nl->sym->ns)
8655 && !gfc_check_access(nl->sym->attr.access,
8656 nl->sym->ns->default_access))
8658 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
8659 "cannot be member of PUBLIC namelist '%s' at %L",
8660 nl->sym->name, sym->name, &sym->declared_at);
8664 /* Types with private components that came here by USE-association. */
8665 if (nl->sym->ts.type == BT_DERIVED
8666 && derived_inaccessible (nl->sym->ts.derived))
8668 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
8669 "components and cannot be member of namelist '%s' at %L",
8670 nl->sym->name, sym->name, &sym->declared_at);
8674 /* Types with private components that are defined in the same module. */
8675 if (nl->sym->ts.type == BT_DERIVED
8676 && !(sym->ns->parent == nl->sym->ts.derived->ns)
8677 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
8678 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
8679 nl->sym->ns->default_access))
8681 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
8682 "cannot be a member of PUBLIC namelist '%s' at %L",
8683 nl->sym->name, sym->name, &sym->declared_at);
8689 for (nl = sym->namelist; nl; nl = nl->next)
8691 /* Reject namelist arrays of assumed shape. */
8692 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
8693 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
8694 "must not have assumed shape in namelist "
8695 "'%s' at %L", nl->sym->name, sym->name,
8696 &sym->declared_at) == FAILURE)
8699 /* Reject namelist arrays that are not constant shape. */
8700 if (is_non_constant_shape_array (nl->sym))
8702 gfc_error ("NAMELIST array object '%s' must have constant "
8703 "shape in namelist '%s' at %L", nl->sym->name,
8704 sym->name, &sym->declared_at);
8708 /* Namelist objects cannot have allocatable or pointer components. */
8709 if (nl->sym->ts.type != BT_DERIVED)
8712 if (nl->sym->ts.derived->attr.alloc_comp)
8714 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8715 "have ALLOCATABLE components",
8716 nl->sym->name, sym->name, &sym->declared_at);
8720 if (nl->sym->ts.derived->attr.pointer_comp)
8722 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8723 "have POINTER components",
8724 nl->sym->name, sym->name, &sym->declared_at);
8730 /* 14.1.2 A module or internal procedure represent local entities
8731 of the same type as a namelist member and so are not allowed. */
8732 for (nl = sym->namelist; nl; nl = nl->next)
8734 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
8737 if (nl->sym->attr.function && nl->sym == nl->sym->result)
8738 if ((nl->sym == sym->ns->proc_name)
8740 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
8744 if (nl->sym && nl->sym->name)
8745 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
8746 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
8748 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
8749 "attribute in '%s' at %L", nlsym->name,
8760 resolve_fl_parameter (gfc_symbol *sym)
8762 /* A parameter array's shape needs to be constant. */
8764 && (sym->as->type == AS_DEFERRED
8765 || is_non_constant_shape_array (sym)))
8767 gfc_error ("Parameter array '%s' at %L cannot be automatic "
8768 "or of deferred shape", sym->name, &sym->declared_at);
8772 /* Make sure a parameter that has been implicitly typed still
8773 matches the implicit type, since PARAMETER statements can precede
8774 IMPLICIT statements. */
8775 if (sym->attr.implicit_type
8776 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
8778 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
8779 "later IMPLICIT type", sym->name, &sym->declared_at);
8783 /* Make sure the types of derived parameters are consistent. This
8784 type checking is deferred until resolution because the type may
8785 refer to a derived type from the host. */
8786 if (sym->ts.type == BT_DERIVED
8787 && !gfc_compare_types (&sym->ts, &sym->value->ts))
8789 gfc_error ("Incompatible derived type in PARAMETER at %L",
8790 &sym->value->where);
8797 /* Do anything necessary to resolve a symbol. Right now, we just
8798 assume that an otherwise unknown symbol is a variable. This sort
8799 of thing commonly happens for symbols in module. */
8802 resolve_symbol (gfc_symbol *sym)
8804 int check_constant, mp_flag;
8805 gfc_symtree *symtree;
8806 gfc_symtree *this_symtree;
8810 if (sym->attr.flavor == FL_UNKNOWN)
8813 /* If we find that a flavorless symbol is an interface in one of the
8814 parent namespaces, find its symtree in this namespace, free the
8815 symbol and set the symtree to point to the interface symbol. */
8816 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
8818 symtree = gfc_find_symtree (ns->sym_root, sym->name);
8819 if (symtree && symtree->n.sym->generic)
8821 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
8825 gfc_free_symbol (sym);
8826 symtree->n.sym->refs++;
8827 this_symtree->n.sym = symtree->n.sym;
8832 /* Otherwise give it a flavor according to such attributes as
8834 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
8835 sym->attr.flavor = FL_VARIABLE;
8838 sym->attr.flavor = FL_PROCEDURE;
8839 if (sym->attr.dimension)
8840 sym->attr.function = 1;
8844 if (sym->attr.procedure && sym->ts.interface
8845 && sym->attr.if_source != IFSRC_DECL)
8847 if (sym->ts.interface->attr.procedure)
8848 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
8849 "in a later PROCEDURE statement", sym->ts.interface->name,
8850 sym->name,&sym->declared_at);
8852 /* Get the attributes from the interface (now resolved). */
8853 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
8855 gfc_symbol *ifc = sym->ts.interface;
8857 sym->ts.interface = ifc;
8858 sym->attr.function = ifc->attr.function;
8859 sym->attr.subroutine = ifc->attr.subroutine;
8860 sym->attr.allocatable = ifc->attr.allocatable;
8861 sym->attr.pointer = ifc->attr.pointer;
8862 sym->attr.pure = ifc->attr.pure;
8863 sym->attr.elemental = ifc->attr.elemental;
8864 sym->attr.dimension = ifc->attr.dimension;
8865 sym->attr.recursive = ifc->attr.recursive;
8866 sym->attr.always_explicit = ifc->attr.always_explicit;
8867 sym->as = gfc_copy_array_spec (ifc->as);
8868 copy_formal_args (sym, ifc);
8870 else if (sym->ts.interface->name[0] != '\0')
8872 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
8873 sym->ts.interface->name, sym->name, &sym->declared_at);
8878 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
8881 /* Symbols that are module procedures with results (functions) have
8882 the types and array specification copied for type checking in
8883 procedures that call them, as well as for saving to a module
8884 file. These symbols can't stand the scrutiny that their results
8886 mp_flag = (sym->result != NULL && sym->result != sym);
8889 /* Make sure that the intrinsic is consistent with its internal
8890 representation. This needs to be done before assigning a default
8891 type to avoid spurious warnings. */
8892 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
8894 gfc_intrinsic_sym* isym;
8897 /* We already know this one is an intrinsic, so we don't call
8898 gfc_is_intrinsic for full checking but rather use gfc_find_function and
8899 gfc_find_subroutine directly to check whether it is a function or
8902 if ((isym = gfc_find_function (sym->name)))
8904 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
8905 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
8906 " ignored", sym->name, &sym->declared_at);
8908 else if ((isym = gfc_find_subroutine (sym->name)))
8910 if (sym->ts.type != BT_UNKNOWN)
8912 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
8913 " specifier", sym->name, &sym->declared_at);
8919 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
8920 sym->name, &sym->declared_at);
8924 /* Check it is actually available in the standard settings. */
8925 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
8928 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
8929 " available in the current standard settings but %s. Use"
8930 " an appropriate -std=* option or enable -fall-intrinsics"
8931 " in order to use it.",
8932 sym->name, &sym->declared_at, symstd);
8937 /* Assign default type to symbols that need one and don't have one. */
8938 if (sym->ts.type == BT_UNKNOWN)
8940 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
8941 gfc_set_default_type (sym, 1, NULL);
8943 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
8945 /* The specific case of an external procedure should emit an error
8946 in the case that there is no implicit type. */
8948 gfc_set_default_type (sym, sym->attr.external, NULL);
8951 /* Result may be in another namespace. */
8952 resolve_symbol (sym->result);
8954 sym->ts = sym->result->ts;
8955 sym->as = gfc_copy_array_spec (sym->result->as);
8956 sym->attr.dimension = sym->result->attr.dimension;
8957 sym->attr.pointer = sym->result->attr.pointer;
8958 sym->attr.allocatable = sym->result->attr.allocatable;
8963 /* Assumed size arrays and assumed shape arrays must be dummy
8967 && (sym->as->type == AS_ASSUMED_SIZE
8968 || sym->as->type == AS_ASSUMED_SHAPE)
8969 && sym->attr.dummy == 0)
8971 if (sym->as->type == AS_ASSUMED_SIZE)
8972 gfc_error ("Assumed size array at %L must be a dummy argument",
8975 gfc_error ("Assumed shape array at %L must be a dummy argument",
8980 /* Make sure symbols with known intent or optional are really dummy
8981 variable. Because of ENTRY statement, this has to be deferred
8982 until resolution time. */
8984 if (!sym->attr.dummy
8985 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
8987 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
8991 if (sym->attr.value && !sym->attr.dummy)
8993 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
8994 "it is not a dummy argument", sym->name, &sym->declared_at);
8998 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
9000 gfc_charlen *cl = sym->ts.cl;
9001 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9003 gfc_error ("Character dummy variable '%s' at %L with VALUE "
9004 "attribute must have constant length",
9005 sym->name, &sym->declared_at);
9009 if (sym->ts.is_c_interop
9010 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
9012 gfc_error ("C interoperable character dummy variable '%s' at %L "
9013 "with VALUE attribute must have length one",
9014 sym->name, &sym->declared_at);
9019 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
9020 do this for something that was implicitly typed because that is handled
9021 in gfc_set_default_type. Handle dummy arguments and procedure
9022 definitions separately. Also, anything that is use associated is not
9023 handled here but instead is handled in the module it is declared in.
9024 Finally, derived type definitions are allowed to be BIND(C) since that
9025 only implies that they're interoperable, and they are checked fully for
9026 interoperability when a variable is declared of that type. */
9027 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
9028 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
9029 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
9031 gfc_try t = SUCCESS;
9033 /* First, make sure the variable is declared at the
9034 module-level scope (J3/04-007, Section 15.3). */
9035 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
9036 sym->attr.in_common == 0)
9038 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
9039 "is neither a COMMON block nor declared at the "
9040 "module level scope", sym->name, &(sym->declared_at));
9043 else if (sym->common_head != NULL)
9045 t = verify_com_block_vars_c_interop (sym->common_head);
9049 /* If type() declaration, we need to verify that the components
9050 of the given type are all C interoperable, etc. */
9051 if (sym->ts.type == BT_DERIVED &&
9052 sym->ts.derived->attr.is_c_interop != 1)
9054 /* Make sure the user marked the derived type as BIND(C). If
9055 not, call the verify routine. This could print an error
9056 for the derived type more than once if multiple variables
9057 of that type are declared. */
9058 if (sym->ts.derived->attr.is_bind_c != 1)
9059 verify_bind_c_derived_type (sym->ts.derived);
9063 /* Verify the variable itself as C interoperable if it
9064 is BIND(C). It is not possible for this to succeed if
9065 the verify_bind_c_derived_type failed, so don't have to handle
9066 any error returned by verify_bind_c_derived_type. */
9067 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9073 /* clear the is_bind_c flag to prevent reporting errors more than
9074 once if something failed. */
9075 sym->attr.is_bind_c = 0;
9080 /* If a derived type symbol has reached this point, without its
9081 type being declared, we have an error. Notice that most
9082 conditions that produce undefined derived types have already
9083 been dealt with. However, the likes of:
9084 implicit type(t) (t) ..... call foo (t) will get us here if
9085 the type is not declared in the scope of the implicit
9086 statement. Change the type to BT_UNKNOWN, both because it is so
9087 and to prevent an ICE. */
9088 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
9089 && !sym->ts.derived->attr.zero_comp)
9091 gfc_error ("The derived type '%s' at %L is of type '%s', "
9092 "which has not been defined", sym->name,
9093 &sym->declared_at, sym->ts.derived->name);
9094 sym->ts.type = BT_UNKNOWN;
9098 /* Make sure that the derived type has been resolved and that the
9099 derived type is visible in the symbol's namespace, if it is a
9100 module function and is not PRIVATE. */
9101 if (sym->ts.type == BT_DERIVED
9102 && sym->ts.derived->attr.use_assoc
9103 && sym->ns->proc_name->attr.flavor == FL_MODULE)
9107 if (resolve_fl_derived (sym->ts.derived) == FAILURE)
9110 gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
9111 if (!ds && sym->attr.function
9112 && gfc_check_access (sym->attr.access, sym->ns->default_access))
9114 symtree = gfc_new_symtree (&sym->ns->sym_root,
9115 sym->ts.derived->name);
9116 symtree->n.sym = sym->ts.derived;
9117 sym->ts.derived->refs++;
9121 /* Unless the derived-type declaration is use associated, Fortran 95
9122 does not allow public entries of private derived types.
9123 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9125 if (sym->ts.type == BT_DERIVED
9126 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
9127 && !sym->ts.derived->attr.use_assoc
9128 && gfc_check_access (sym->attr.access, sym->ns->default_access)
9129 && !gfc_check_access (sym->ts.derived->attr.access,
9130 sym->ts.derived->ns->default_access)
9131 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
9132 "of PRIVATE derived type '%s'",
9133 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
9134 : "variable", sym->name, &sym->declared_at,
9135 sym->ts.derived->name) == FAILURE)
9138 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9139 default initialization is defined (5.1.2.4.4). */
9140 if (sym->ts.type == BT_DERIVED
9142 && sym->attr.intent == INTENT_OUT
9144 && sym->as->type == AS_ASSUMED_SIZE)
9146 for (c = sym->ts.derived->components; c; c = c->next)
9150 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9151 "ASSUMED SIZE and so cannot have a default initializer",
9152 sym->name, &sym->declared_at);
9158 switch (sym->attr.flavor)
9161 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
9166 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
9171 if (resolve_fl_namelist (sym) == FAILURE)
9176 if (resolve_fl_parameter (sym) == FAILURE)
9184 /* Resolve array specifier. Check as well some constraints
9185 on COMMON blocks. */
9187 check_constant = sym->attr.in_common && !sym->attr.pointer;
9189 /* Set the formal_arg_flag so that check_conflict will not throw
9190 an error for host associated variables in the specification
9191 expression for an array_valued function. */
9192 if (sym->attr.function && sym->as)
9193 formal_arg_flag = 1;
9195 gfc_resolve_array_spec (sym->as, check_constant);
9197 formal_arg_flag = 0;
9199 /* Resolve formal namespaces. */
9200 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
9201 gfc_resolve (sym->formal_ns);
9203 /* Check threadprivate restrictions. */
9204 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
9205 && (!sym->attr.in_common
9206 && sym->module == NULL
9207 && (sym->ns->proc_name == NULL
9208 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
9209 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
9211 /* If we have come this far we can apply default-initializers, as
9212 described in 14.7.5, to those variables that have not already
9213 been assigned one. */
9214 if (sym->ts.type == BT_DERIVED
9215 && sym->attr.referenced
9216 && sym->ns == gfc_current_ns
9218 && !sym->attr.allocatable
9219 && !sym->attr.alloc_comp)
9221 symbol_attribute *a = &sym->attr;
9223 if ((!a->save && !a->dummy && !a->pointer
9224 && !a->in_common && !a->use_assoc
9225 && !(a->function && sym != sym->result))
9226 || (a->dummy && a->intent == INTENT_OUT))
9227 apply_default_init (sym);
9230 /* If this symbol has a type-spec, check it. */
9231 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
9232 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
9233 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
9239 /************* Resolve DATA statements *************/
9243 gfc_data_value *vnode;
9249 /* Advance the values structure to point to the next value in the data list. */
9252 next_data_value (void)
9255 while (mpz_cmp_ui (values.left, 0) == 0)
9257 if (values.vnode->next == NULL)
9260 values.vnode = values.vnode->next;
9261 mpz_set (values.left, values.vnode->repeat);
9269 check_data_variable (gfc_data_variable *var, locus *where)
9275 ar_type mark = AR_UNKNOWN;
9277 mpz_t section_index[GFC_MAX_DIMENSIONS];
9281 if (gfc_resolve_expr (var->expr) == FAILURE)
9285 mpz_init_set_si (offset, 0);
9288 if (e->expr_type != EXPR_VARIABLE)
9289 gfc_internal_error ("check_data_variable(): Bad expression");
9291 if (e->symtree->n.sym->ns->is_block_data
9292 && !e->symtree->n.sym->attr.in_common)
9294 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9295 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
9298 if (e->ref == NULL && e->symtree->n.sym->as)
9300 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9301 " declaration", e->symtree->n.sym->name, where);
9307 mpz_init_set_ui (size, 1);
9314 /* Find the array section reference. */
9315 for (ref = e->ref; ref; ref = ref->next)
9317 if (ref->type != REF_ARRAY)
9319 if (ref->u.ar.type == AR_ELEMENT)
9325 /* Set marks according to the reference pattern. */
9326 switch (ref->u.ar.type)
9334 /* Get the start position of array section. */
9335 gfc_get_section_index (ar, section_index, &offset);
9343 if (gfc_array_size (e, &size) == FAILURE)
9345 gfc_error ("Nonconstant array section at %L in DATA statement",
9354 while (mpz_cmp_ui (size, 0) > 0)
9356 if (next_data_value () == FAILURE)
9358 gfc_error ("DATA statement at %L has more variables than values",
9364 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
9368 /* If we have more than one element left in the repeat count,
9369 and we have more than one element left in the target variable,
9370 then create a range assignment. */
9371 /* FIXME: Only done for full arrays for now, since array sections
9373 if (mark == AR_FULL && ref && ref->next == NULL
9374 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
9378 if (mpz_cmp (size, values.left) >= 0)
9380 mpz_init_set (range, values.left);
9381 mpz_sub (size, size, values.left);
9382 mpz_set_ui (values.left, 0);
9386 mpz_init_set (range, size);
9387 mpz_sub (values.left, values.left, size);
9388 mpz_set_ui (size, 0);
9391 gfc_assign_data_value_range (var->expr, values.vnode->expr,
9394 mpz_add (offset, offset, range);
9398 /* Assign initial value to symbol. */
9401 mpz_sub_ui (values.left, values.left, 1);
9402 mpz_sub_ui (size, size, 1);
9404 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
9408 if (mark == AR_FULL)
9409 mpz_add_ui (offset, offset, 1);
9411 /* Modify the array section indexes and recalculate the offset
9412 for next element. */
9413 else if (mark == AR_SECTION)
9414 gfc_advance_section (section_index, ar, &offset);
9418 if (mark == AR_SECTION)
9420 for (i = 0; i < ar->dimen; i++)
9421 mpz_clear (section_index[i]);
9431 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
9433 /* Iterate over a list of elements in a DATA statement. */
9436 traverse_data_list (gfc_data_variable *var, locus *where)
9439 iterator_stack frame;
9440 gfc_expr *e, *start, *end, *step;
9441 gfc_try retval = SUCCESS;
9443 mpz_init (frame.value);
9445 start = gfc_copy_expr (var->iter.start);
9446 end = gfc_copy_expr (var->iter.end);
9447 step = gfc_copy_expr (var->iter.step);
9449 if (gfc_simplify_expr (start, 1) == FAILURE
9450 || start->expr_type != EXPR_CONSTANT)
9452 gfc_error ("iterator start at %L does not simplify", &start->where);
9456 if (gfc_simplify_expr (end, 1) == FAILURE
9457 || end->expr_type != EXPR_CONSTANT)
9459 gfc_error ("iterator end at %L does not simplify", &end->where);
9463 if (gfc_simplify_expr (step, 1) == FAILURE
9464 || step->expr_type != EXPR_CONSTANT)
9466 gfc_error ("iterator step at %L does not simplify", &step->where);
9471 mpz_init_set (trip, end->value.integer);
9472 mpz_sub (trip, trip, start->value.integer);
9473 mpz_add (trip, trip, step->value.integer);
9475 mpz_div (trip, trip, step->value.integer);
9477 mpz_set (frame.value, start->value.integer);
9479 frame.prev = iter_stack;
9480 frame.variable = var->iter.var->symtree;
9481 iter_stack = &frame;
9483 while (mpz_cmp_ui (trip, 0) > 0)
9485 if (traverse_data_var (var->list, where) == FAILURE)
9492 e = gfc_copy_expr (var->expr);
9493 if (gfc_simplify_expr (e, 1) == FAILURE)
9501 mpz_add (frame.value, frame.value, step->value.integer);
9503 mpz_sub_ui (trip, trip, 1);
9508 mpz_clear (frame.value);
9510 gfc_free_expr (start);
9511 gfc_free_expr (end);
9512 gfc_free_expr (step);
9514 iter_stack = frame.prev;
9519 /* Type resolve variables in the variable list of a DATA statement. */
9522 traverse_data_var (gfc_data_variable *var, locus *where)
9526 for (; var; var = var->next)
9528 if (var->expr == NULL)
9529 t = traverse_data_list (var, where);
9531 t = check_data_variable (var, where);
9541 /* Resolve the expressions and iterators associated with a data statement.
9542 This is separate from the assignment checking because data lists should
9543 only be resolved once. */
9546 resolve_data_variables (gfc_data_variable *d)
9548 for (; d; d = d->next)
9550 if (d->list == NULL)
9552 if (gfc_resolve_expr (d->expr) == FAILURE)
9557 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
9560 if (resolve_data_variables (d->list) == FAILURE)
9569 /* Resolve a single DATA statement. We implement this by storing a pointer to
9570 the value list into static variables, and then recursively traversing the
9571 variables list, expanding iterators and such. */
9574 resolve_data (gfc_data *d)
9577 if (resolve_data_variables (d->var) == FAILURE)
9580 values.vnode = d->value;
9581 if (d->value == NULL)
9582 mpz_set_ui (values.left, 0);
9584 mpz_set (values.left, d->value->repeat);
9586 if (traverse_data_var (d->var, &d->where) == FAILURE)
9589 /* At this point, we better not have any values left. */
9591 if (next_data_value () == SUCCESS)
9592 gfc_error ("DATA statement at %L has more values than variables",
9597 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
9598 accessed by host or use association, is a dummy argument to a pure function,
9599 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
9600 is storage associated with any such variable, shall not be used in the
9601 following contexts: (clients of this function). */
9603 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
9604 procedure. Returns zero if assignment is OK, nonzero if there is a
9607 gfc_impure_variable (gfc_symbol *sym)
9611 if (sym->attr.use_assoc || sym->attr.in_common)
9614 if (sym->ns != gfc_current_ns)
9615 return !sym->attr.function;
9617 proc = sym->ns->proc_name;
9618 if (sym->attr.dummy && gfc_pure (proc)
9619 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
9621 proc->attr.function))
9624 /* TODO: Sort out what can be storage associated, if anything, and include
9625 it here. In principle equivalences should be scanned but it does not
9626 seem to be possible to storage associate an impure variable this way. */
9631 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
9632 symbol of the current procedure. */
9635 gfc_pure (gfc_symbol *sym)
9637 symbol_attribute attr;
9640 sym = gfc_current_ns->proc_name;
9646 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
9650 /* Test whether the current procedure is elemental or not. */
9653 gfc_elemental (gfc_symbol *sym)
9655 symbol_attribute attr;
9658 sym = gfc_current_ns->proc_name;
9663 return attr.flavor == FL_PROCEDURE && attr.elemental;
9667 /* Warn about unused labels. */
9670 warn_unused_fortran_label (gfc_st_label *label)
9675 warn_unused_fortran_label (label->left);
9677 if (label->defined == ST_LABEL_UNKNOWN)
9680 switch (label->referenced)
9682 case ST_LABEL_UNKNOWN:
9683 gfc_warning ("Label %d at %L defined but not used", label->value,
9687 case ST_LABEL_BAD_TARGET:
9688 gfc_warning ("Label %d at %L defined but cannot be used",
9689 label->value, &label->where);
9696 warn_unused_fortran_label (label->right);
9700 /* Returns the sequence type of a symbol or sequence. */
9703 sequence_type (gfc_typespec ts)
9712 if (ts.derived->components == NULL)
9713 return SEQ_NONDEFAULT;
9715 result = sequence_type (ts.derived->components->ts);
9716 for (c = ts.derived->components->next; c; c = c->next)
9717 if (sequence_type (c->ts) != result)
9723 if (ts.kind != gfc_default_character_kind)
9724 return SEQ_NONDEFAULT;
9726 return SEQ_CHARACTER;
9729 if (ts.kind != gfc_default_integer_kind)
9730 return SEQ_NONDEFAULT;
9735 if (!(ts.kind == gfc_default_real_kind
9736 || ts.kind == gfc_default_double_kind))
9737 return SEQ_NONDEFAULT;
9742 if (ts.kind != gfc_default_complex_kind)
9743 return SEQ_NONDEFAULT;
9748 if (ts.kind != gfc_default_logical_kind)
9749 return SEQ_NONDEFAULT;
9754 return SEQ_NONDEFAULT;
9759 /* Resolve derived type EQUIVALENCE object. */
9762 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
9765 gfc_component *c = derived->components;
9770 /* Shall not be an object of nonsequence derived type. */
9771 if (!derived->attr.sequence)
9773 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
9774 "attribute to be an EQUIVALENCE object", sym->name,
9779 /* Shall not have allocatable components. */
9780 if (derived->attr.alloc_comp)
9782 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
9783 "components to be an EQUIVALENCE object",sym->name,
9788 if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
9790 gfc_error ("Derived type variable '%s' at %L with default "
9791 "initialization cannot be in EQUIVALENCE with a variable "
9792 "in COMMON", sym->name, &e->where);
9796 for (; c ; c = c->next)
9800 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
9803 /* Shall not be an object of sequence derived type containing a pointer
9804 in the structure. */
9805 if (c->attr.pointer)
9807 gfc_error ("Derived type variable '%s' at %L with pointer "
9808 "component(s) cannot be an EQUIVALENCE object",
9809 sym->name, &e->where);
9817 /* Resolve equivalence object.
9818 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
9819 an allocatable array, an object of nonsequence derived type, an object of
9820 sequence derived type containing a pointer at any level of component
9821 selection, an automatic object, a function name, an entry name, a result
9822 name, a named constant, a structure component, or a subobject of any of
9823 the preceding objects. A substring shall not have length zero. A
9824 derived type shall not have components with default initialization nor
9825 shall two objects of an equivalence group be initialized.
9826 Either all or none of the objects shall have an protected attribute.
9827 The simple constraints are done in symbol.c(check_conflict) and the rest
9828 are implemented here. */
9831 resolve_equivalence (gfc_equiv *eq)
9834 gfc_symbol *derived;
9835 gfc_symbol *first_sym;
9838 locus *last_where = NULL;
9839 seq_type eq_type, last_eq_type;
9840 gfc_typespec *last_ts;
9841 int object, cnt_protected;
9842 const char *value_name;
9846 last_ts = &eq->expr->symtree->n.sym->ts;
9848 first_sym = eq->expr->symtree->n.sym;
9852 for (object = 1; eq; eq = eq->eq, object++)
9856 e->ts = e->symtree->n.sym->ts;
9857 /* match_varspec might not know yet if it is seeing
9858 array reference or substring reference, as it doesn't
9860 if (e->ref && e->ref->type == REF_ARRAY)
9862 gfc_ref *ref = e->ref;
9863 sym = e->symtree->n.sym;
9865 if (sym->attr.dimension)
9867 ref->u.ar.as = sym->as;
9871 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
9872 if (e->ts.type == BT_CHARACTER
9874 && ref->type == REF_ARRAY
9875 && ref->u.ar.dimen == 1
9876 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
9877 && ref->u.ar.stride[0] == NULL)
9879 gfc_expr *start = ref->u.ar.start[0];
9880 gfc_expr *end = ref->u.ar.end[0];
9883 /* Optimize away the (:) reference. */
9884 if (start == NULL && end == NULL)
9889 e->ref->next = ref->next;
9894 ref->type = REF_SUBSTRING;
9896 start = gfc_int_expr (1);
9897 ref->u.ss.start = start;
9898 if (end == NULL && e->ts.cl)
9899 end = gfc_copy_expr (e->ts.cl->length);
9900 ref->u.ss.end = end;
9901 ref->u.ss.length = e->ts.cl;
9908 /* Any further ref is an error. */
9911 gcc_assert (ref->type == REF_ARRAY);
9912 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
9918 if (gfc_resolve_expr (e) == FAILURE)
9921 sym = e->symtree->n.sym;
9923 if (sym->attr.is_protected)
9925 if (cnt_protected > 0 && cnt_protected != object)
9927 gfc_error ("Either all or none of the objects in the "
9928 "EQUIVALENCE set at %L shall have the "
9929 "PROTECTED attribute",
9934 /* Shall not equivalence common block variables in a PURE procedure. */
9935 if (sym->ns->proc_name
9936 && sym->ns->proc_name->attr.pure
9937 && sym->attr.in_common)
9939 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
9940 "object in the pure procedure '%s'",
9941 sym->name, &e->where, sym->ns->proc_name->name);
9945 /* Shall not be a named constant. */
9946 if (e->expr_type == EXPR_CONSTANT)
9948 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
9949 "object", sym->name, &e->where);
9953 derived = e->ts.derived;
9954 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
9957 /* Check that the types correspond correctly:
9959 A numeric sequence structure may be equivalenced to another sequence
9960 structure, an object of default integer type, default real type, double
9961 precision real type, default logical type such that components of the
9962 structure ultimately only become associated to objects of the same
9963 kind. A character sequence structure may be equivalenced to an object
9964 of default character kind or another character sequence structure.
9965 Other objects may be equivalenced only to objects of the same type and
9968 /* Identical types are unconditionally OK. */
9969 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
9970 goto identical_types;
9972 last_eq_type = sequence_type (*last_ts);
9973 eq_type = sequence_type (sym->ts);
9975 /* Since the pair of objects is not of the same type, mixed or
9976 non-default sequences can be rejected. */
9978 msg = "Sequence %s with mixed components in EQUIVALENCE "
9979 "statement at %L with different type objects";
9981 && last_eq_type == SEQ_MIXED
9982 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
9984 || (eq_type == SEQ_MIXED
9985 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
9986 &e->where) == FAILURE))
9989 msg = "Non-default type object or sequence %s in EQUIVALENCE "
9990 "statement at %L with objects of different type";
9992 && last_eq_type == SEQ_NONDEFAULT
9993 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
9994 last_where) == FAILURE)
9995 || (eq_type == SEQ_NONDEFAULT
9996 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
9997 &e->where) == FAILURE))
10000 msg ="Non-CHARACTER object '%s' in default CHARACTER "
10001 "EQUIVALENCE statement at %L";
10002 if (last_eq_type == SEQ_CHARACTER
10003 && eq_type != SEQ_CHARACTER
10004 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10005 &e->where) == FAILURE)
10008 msg ="Non-NUMERIC object '%s' in default NUMERIC "
10009 "EQUIVALENCE statement at %L";
10010 if (last_eq_type == SEQ_NUMERIC
10011 && eq_type != SEQ_NUMERIC
10012 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10013 &e->where) == FAILURE)
10018 last_where = &e->where;
10023 /* Shall not be an automatic array. */
10024 if (e->ref->type == REF_ARRAY
10025 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
10027 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
10028 "an EQUIVALENCE object", sym->name, &e->where);
10035 /* Shall not be a structure component. */
10036 if (r->type == REF_COMPONENT)
10038 gfc_error ("Structure component '%s' at %L cannot be an "
10039 "EQUIVALENCE object",
10040 r->u.c.component->name, &e->where);
10044 /* A substring shall not have length zero. */
10045 if (r->type == REF_SUBSTRING)
10047 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
10049 gfc_error ("Substring at %L has length zero",
10050 &r->u.ss.start->where);
10060 /* Resolve function and ENTRY types, issue diagnostics if needed. */
10063 resolve_fntype (gfc_namespace *ns)
10065 gfc_entry_list *el;
10068 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
10071 /* If there are any entries, ns->proc_name is the entry master
10072 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10074 sym = ns->entries->sym;
10076 sym = ns->proc_name;
10077 if (sym->result == sym
10078 && sym->ts.type == BT_UNKNOWN
10079 && gfc_set_default_type (sym, 0, NULL) == FAILURE
10080 && !sym->attr.untyped)
10082 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10083 sym->name, &sym->declared_at);
10084 sym->attr.untyped = 1;
10087 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
10088 && !gfc_check_access (sym->ts.derived->attr.access,
10089 sym->ts.derived->ns->default_access)
10090 && gfc_check_access (sym->attr.access, sym->ns->default_access))
10092 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
10093 sym->name, &sym->declared_at, sym->ts.derived->name);
10097 for (el = ns->entries->next; el; el = el->next)
10099 if (el->sym->result == el->sym
10100 && el->sym->ts.type == BT_UNKNOWN
10101 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
10102 && !el->sym->attr.untyped)
10104 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10105 el->sym->name, &el->sym->declared_at);
10106 el->sym->attr.untyped = 1;
10111 /* 12.3.2.1.1 Defined operators. */
10114 gfc_resolve_uops (gfc_symtree *symtree)
10116 gfc_interface *itr;
10118 gfc_formal_arglist *formal;
10120 if (symtree == NULL)
10123 gfc_resolve_uops (symtree->left);
10124 gfc_resolve_uops (symtree->right);
10126 for (itr = symtree->n.uop->op; itr; itr = itr->next)
10129 if (!sym->attr.function)
10130 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10131 sym->name, &sym->declared_at);
10133 if (sym->ts.type == BT_CHARACTER
10134 && !(sym->ts.cl && sym->ts.cl->length)
10135 && !(sym->result && sym->result->ts.cl
10136 && sym->result->ts.cl->length))
10137 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10138 "character length", sym->name, &sym->declared_at);
10140 formal = sym->formal;
10141 if (!formal || !formal->sym)
10143 gfc_error ("User operator procedure '%s' at %L must have at least "
10144 "one argument", sym->name, &sym->declared_at);
10148 if (formal->sym->attr.intent != INTENT_IN)
10149 gfc_error ("First argument of operator interface at %L must be "
10150 "INTENT(IN)", &sym->declared_at);
10152 if (formal->sym->attr.optional)
10153 gfc_error ("First argument of operator interface at %L cannot be "
10154 "optional", &sym->declared_at);
10156 formal = formal->next;
10157 if (!formal || !formal->sym)
10160 if (formal->sym->attr.intent != INTENT_IN)
10161 gfc_error ("Second argument of operator interface at %L must be "
10162 "INTENT(IN)", &sym->declared_at);
10164 if (formal->sym->attr.optional)
10165 gfc_error ("Second argument of operator interface at %L cannot be "
10166 "optional", &sym->declared_at);
10169 gfc_error ("Operator interface at %L must have, at most, two "
10170 "arguments", &sym->declared_at);
10175 /* Examine all of the expressions associated with a program unit,
10176 assign types to all intermediate expressions, make sure that all
10177 assignments are to compatible types and figure out which names
10178 refer to which functions or subroutines. It doesn't check code
10179 block, which is handled by resolve_code. */
10182 resolve_types (gfc_namespace *ns)
10188 gfc_namespace* old_ns = gfc_current_ns;
10190 /* Check that all IMPLICIT types are ok. */
10191 if (!ns->seen_implicit_none)
10194 for (letter = 0; letter != GFC_LETTERS; ++letter)
10195 if (ns->set_flag[letter]
10196 && resolve_typespec_used (&ns->default_type[letter],
10197 &ns->implicit_loc[letter],
10202 gfc_current_ns = ns;
10204 resolve_entries (ns);
10206 resolve_common_vars (ns->blank_common.head, false);
10207 resolve_common_blocks (ns->common_root);
10209 resolve_contained_functions (ns);
10211 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
10213 for (cl = ns->cl_list; cl; cl = cl->next)
10214 resolve_charlen (cl);
10216 gfc_traverse_ns (ns, resolve_symbol);
10218 resolve_fntype (ns);
10220 for (n = ns->contained; n; n = n->sibling)
10222 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
10223 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10224 "also be PURE", n->proc_name->name,
10225 &n->proc_name->declared_at);
10231 gfc_check_interfaces (ns);
10233 gfc_traverse_ns (ns, resolve_values);
10239 for (d = ns->data; d; d = d->next)
10243 gfc_traverse_ns (ns, gfc_formalize_init_value);
10245 gfc_traverse_ns (ns, gfc_verify_binding_labels);
10247 if (ns->common_root != NULL)
10248 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
10250 for (eq = ns->equiv; eq; eq = eq->next)
10251 resolve_equivalence (eq);
10253 /* Warn about unused labels. */
10254 if (warn_unused_label)
10255 warn_unused_fortran_label (ns->st_labels);
10257 gfc_resolve_uops (ns->uop_root);
10259 gfc_current_ns = old_ns;
10263 /* Call resolve_code recursively. */
10266 resolve_codes (gfc_namespace *ns)
10270 for (n = ns->contained; n; n = n->sibling)
10273 gfc_current_ns = ns;
10275 /* Set to an out of range value. */
10276 current_entry_id = -1;
10278 bitmap_obstack_initialize (&labels_obstack);
10279 resolve_code (ns->code, ns);
10280 bitmap_obstack_release (&labels_obstack);
10284 /* This function is called after a complete program unit has been compiled.
10285 Its purpose is to examine all of the expressions associated with a program
10286 unit, assign types to all intermediate expressions, make sure that all
10287 assignments are to compatible types and figure out which names refer to
10288 which functions or subroutines. */
10291 gfc_resolve (gfc_namespace *ns)
10293 gfc_namespace *old_ns;
10295 old_ns = gfc_current_ns;
10297 resolve_types (ns);
10298 resolve_codes (ns);
10300 gfc_current_ns = old_ns;