1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
41 /* Stack to keep track of the nesting of blocks as we move through the
42 code. See resolve_branch() and resolve_code(). */
44 typedef struct code_stack
46 struct gfc_code *head, *current;
47 struct code_stack *prev;
49 /* This bitmap keeps track of the targets valid for a branch from
50 inside this block except for END {IF|SELECT}s of enclosing
52 bitmap reachable_labels;
56 static code_stack *cs_base = NULL;
59 /* Nonzero if we're inside a FORALL block. */
61 static int forall_flag;
63 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
65 static int omp_workshare_flag;
67 /* Nonzero if we are processing a formal arglist. The corresponding function
68 resets the flag each time that it is read. */
69 static int formal_arg_flag = 0;
71 /* True if we are resolving a specification expression. */
72 static int specification_expr = 0;
74 /* The id of the last entry seen. */
75 static int current_entry_id;
77 /* We use bitmaps to determine if a branch target is valid. */
78 static bitmap_obstack labels_obstack;
81 gfc_is_formal_arg (void)
83 return formal_arg_flag;
87 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
88 an ABSTRACT derived-type. If where is not NULL, an error message with that
89 locus is printed, optionally using name. */
92 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
94 if (ts->type == BT_DERIVED && ts->derived->attr.abstract)
99 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
100 name, where, ts->derived->name);
102 gfc_error ("ABSTRACT type '%s' used at %L",
103 ts->derived->name, where);
113 /* Resolve types of formal argument lists. These have to be done early so that
114 the formal argument lists of module procedures can be copied to the
115 containing module before the individual procedures are resolved
116 individually. We also resolve argument lists of procedures in interface
117 blocks because they are self-contained scoping units.
119 Since a dummy argument cannot be a non-dummy procedure, the only
120 resort left for untyped names are the IMPLICIT types. */
123 resolve_formal_arglist (gfc_symbol *proc)
125 gfc_formal_arglist *f;
129 if (proc->result != NULL)
134 if (gfc_elemental (proc)
135 || sym->attr.pointer || sym->attr.allocatable
136 || (sym->as && sym->as->rank > 0))
138 proc->attr.always_explicit = 1;
139 sym->attr.always_explicit = 1;
144 for (f = proc->formal; f; f = f->next)
150 /* Alternate return placeholder. */
151 if (gfc_elemental (proc))
152 gfc_error ("Alternate return specifier in elemental subroutine "
153 "'%s' at %L is not allowed", proc->name,
155 if (proc->attr.function)
156 gfc_error ("Alternate return specifier in function "
157 "'%s' at %L is not allowed", proc->name,
162 if (sym->attr.if_source != IFSRC_UNKNOWN)
163 resolve_formal_arglist (sym);
165 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
167 if (gfc_pure (proc) && !gfc_pure (sym))
169 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
170 "also be PURE", sym->name, &sym->declared_at);
174 if (gfc_elemental (proc))
176 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
177 "procedure", &sym->declared_at);
181 if (sym->attr.function
182 && sym->ts.type == BT_UNKNOWN
183 && sym->attr.intrinsic)
185 gfc_intrinsic_sym *isym;
186 isym = gfc_find_function (sym->name);
187 if (isym == NULL || !isym->specific)
189 gfc_error ("Unable to find a specific INTRINSIC procedure "
190 "for the reference '%s' at %L", sym->name,
199 if (sym->ts.type == BT_UNKNOWN)
201 if (!sym->attr.function || sym->result == sym)
202 gfc_set_default_type (sym, 1, sym->ns);
205 gfc_resolve_array_spec (sym->as, 0);
207 /* We can't tell if an array with dimension (:) is assumed or deferred
208 shape until we know if it has the pointer or allocatable attributes.
210 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
211 && !(sym->attr.pointer || sym->attr.allocatable))
213 sym->as->type = AS_ASSUMED_SHAPE;
214 for (i = 0; i < sym->as->rank; i++)
215 sym->as->lower[i] = gfc_int_expr (1);
218 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
219 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
220 || sym->attr.optional)
222 proc->attr.always_explicit = 1;
224 proc->result->attr.always_explicit = 1;
227 /* If the flavor is unknown at this point, it has to be a variable.
228 A procedure specification would have already set the type. */
230 if (sym->attr.flavor == FL_UNKNOWN)
231 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
233 if (gfc_pure (proc) && !sym->attr.pointer
234 && sym->attr.flavor != FL_PROCEDURE)
236 if (proc->attr.function && sym->attr.intent != INTENT_IN)
237 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
238 "INTENT(IN)", sym->name, proc->name,
241 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
242 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
243 "have its INTENT specified", sym->name, proc->name,
247 if (gfc_elemental (proc))
251 gfc_error ("Argument '%s' of elemental procedure at %L must "
252 "be scalar", sym->name, &sym->declared_at);
256 if (sym->attr.pointer)
258 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
259 "have the POINTER attribute", sym->name,
264 if (sym->attr.flavor == FL_PROCEDURE)
266 gfc_error ("Dummy procedure '%s' not allowed in elemental "
267 "procedure '%s' at %L", sym->name, proc->name,
273 /* Each dummy shall be specified to be scalar. */
274 if (proc->attr.proc == PROC_ST_FUNCTION)
278 gfc_error ("Argument '%s' of statement function at %L must "
279 "be scalar", sym->name, &sym->declared_at);
283 if (sym->ts.type == BT_CHARACTER)
285 gfc_charlen *cl = sym->ts.cl;
286 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
288 gfc_error ("Character-valued argument '%s' of statement "
289 "function at %L must have constant length",
290 sym->name, &sym->declared_at);
300 /* Work function called when searching for symbols that have argument lists
301 associated with them. */
304 find_arglists (gfc_symbol *sym)
306 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
309 resolve_formal_arglist (sym);
313 /* Given a namespace, resolve all formal argument lists within the namespace.
317 resolve_formal_arglists (gfc_namespace *ns)
322 gfc_traverse_ns (ns, find_arglists);
327 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
331 /* If this namespace is not a function or an entry master function,
333 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
334 || sym->attr.entry_master)
337 /* Try to find out of what the return type is. */
338 if (sym->result->ts.type == BT_UNKNOWN)
340 t = gfc_set_default_type (sym->result, 0, ns);
342 if (t == FAILURE && !sym->result->attr.untyped)
344 if (sym->result == sym)
345 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
346 sym->name, &sym->declared_at);
348 gfc_error ("Result '%s' of contained function '%s' at %L has "
349 "no IMPLICIT type", sym->result->name, sym->name,
350 &sym->result->declared_at);
351 sym->result->attr.untyped = 1;
355 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
356 type, lists the only ways a character length value of * can be used:
357 dummy arguments of procedures, named constants, and function results
358 in external functions. Internal function results are not on that list;
359 ergo, not permitted. */
361 if (sym->result->ts.type == BT_CHARACTER)
363 gfc_charlen *cl = sym->result->ts.cl;
364 if (!cl || !cl->length)
365 gfc_error ("Character-valued internal function '%s' at %L must "
366 "not be assumed length", sym->name, &sym->declared_at);
371 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
372 introduce duplicates. */
375 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
377 gfc_formal_arglist *f, *new_arglist;
380 for (; new_args != NULL; new_args = new_args->next)
382 new_sym = new_args->sym;
383 /* See if this arg is already in the formal argument list. */
384 for (f = proc->formal; f; f = f->next)
386 if (new_sym == f->sym)
393 /* Add a new argument. Argument order is not important. */
394 new_arglist = gfc_get_formal_arglist ();
395 new_arglist->sym = new_sym;
396 new_arglist->next = proc->formal;
397 proc->formal = new_arglist;
402 /* Flag the arguments that are not present in all entries. */
405 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
407 gfc_formal_arglist *f, *head;
410 for (f = proc->formal; f; f = f->next)
415 for (new_args = head; new_args; new_args = new_args->next)
417 if (new_args->sym == f->sym)
424 f->sym->attr.not_always_present = 1;
429 /* Resolve alternate entry points. If a symbol has multiple entry points we
430 create a new master symbol for the main routine, and turn the existing
431 symbol into an entry point. */
434 resolve_entries (gfc_namespace *ns)
436 gfc_namespace *old_ns;
440 char name[GFC_MAX_SYMBOL_LEN + 1];
441 static int master_count = 0;
443 if (ns->proc_name == NULL)
446 /* No need to do anything if this procedure doesn't have alternate entry
451 /* We may already have resolved alternate entry points. */
452 if (ns->proc_name->attr.entry_master)
455 /* If this isn't a procedure something has gone horribly wrong. */
456 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
458 /* Remember the current namespace. */
459 old_ns = gfc_current_ns;
463 /* Add the main entry point to the list of entry points. */
464 el = gfc_get_entry_list ();
465 el->sym = ns->proc_name;
467 el->next = ns->entries;
469 ns->proc_name->attr.entry = 1;
471 /* If it is a module function, it needs to be in the right namespace
472 so that gfc_get_fake_result_decl can gather up the results. The
473 need for this arose in get_proc_name, where these beasts were
474 left in their own namespace, to keep prior references linked to
475 the entry declaration.*/
476 if (ns->proc_name->attr.function
477 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
480 /* Do the same for entries where the master is not a module
481 procedure. These are retained in the module namespace because
482 of the module procedure declaration. */
483 for (el = el->next; el; el = el->next)
484 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
485 && el->sym->attr.mod_proc)
489 /* Add an entry statement for it. */
496 /* Create a new symbol for the master function. */
497 /* Give the internal function a unique name (within this file).
498 Also include the function name so the user has some hope of figuring
499 out what is going on. */
500 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
501 master_count++, ns->proc_name->name);
502 gfc_get_ha_symbol (name, &proc);
503 gcc_assert (proc != NULL);
505 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
506 if (ns->proc_name->attr.subroutine)
507 gfc_add_subroutine (&proc->attr, proc->name, NULL);
511 gfc_typespec *ts, *fts;
512 gfc_array_spec *as, *fas;
513 gfc_add_function (&proc->attr, proc->name, NULL);
515 fas = ns->entries->sym->as;
516 fas = fas ? fas : ns->entries->sym->result->as;
517 fts = &ns->entries->sym->result->ts;
518 if (fts->type == BT_UNKNOWN)
519 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
520 for (el = ns->entries->next; el; el = el->next)
522 ts = &el->sym->result->ts;
524 as = as ? as : el->sym->result->as;
525 if (ts->type == BT_UNKNOWN)
526 ts = gfc_get_default_type (el->sym->result, NULL);
528 if (! gfc_compare_types (ts, fts)
529 || (el->sym->result->attr.dimension
530 != ns->entries->sym->result->attr.dimension)
531 || (el->sym->result->attr.pointer
532 != ns->entries->sym->result->attr.pointer))
534 else if (as && fas && ns->entries->sym->result != el->sym->result
535 && gfc_compare_array_spec (as, fas) == 0)
536 gfc_error ("Function %s at %L has entries with mismatched "
537 "array specifications", ns->entries->sym->name,
538 &ns->entries->sym->declared_at);
539 /* The characteristics need to match and thus both need to have
540 the same string length, i.e. both len=*, or both len=4.
541 Having both len=<variable> is also possible, but difficult to
542 check at compile time. */
543 else if (ts->type == BT_CHARACTER && ts->cl && fts->cl
544 && (((ts->cl->length && !fts->cl->length)
545 ||(!ts->cl->length && fts->cl->length))
547 && ts->cl->length->expr_type
548 != fts->cl->length->expr_type)
550 && ts->cl->length->expr_type == EXPR_CONSTANT
551 && mpz_cmp (ts->cl->length->value.integer,
552 fts->cl->length->value.integer) != 0)))
553 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
554 "entries returning variables of different "
555 "string lengths", ns->entries->sym->name,
556 &ns->entries->sym->declared_at);
561 sym = ns->entries->sym->result;
562 /* All result types the same. */
564 if (sym->attr.dimension)
565 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
566 if (sym->attr.pointer)
567 gfc_add_pointer (&proc->attr, NULL);
571 /* Otherwise the result will be passed through a union by
573 proc->attr.mixed_entry_master = 1;
574 for (el = ns->entries; el; el = el->next)
576 sym = el->sym->result;
577 if (sym->attr.dimension)
579 if (el == ns->entries)
580 gfc_error ("FUNCTION result %s can't be an array in "
581 "FUNCTION %s at %L", sym->name,
582 ns->entries->sym->name, &sym->declared_at);
584 gfc_error ("ENTRY result %s can't be an array in "
585 "FUNCTION %s at %L", sym->name,
586 ns->entries->sym->name, &sym->declared_at);
588 else if (sym->attr.pointer)
590 if (el == ns->entries)
591 gfc_error ("FUNCTION result %s can't be a POINTER in "
592 "FUNCTION %s at %L", sym->name,
593 ns->entries->sym->name, &sym->declared_at);
595 gfc_error ("ENTRY result %s can't be a POINTER in "
596 "FUNCTION %s at %L", sym->name,
597 ns->entries->sym->name, &sym->declared_at);
602 if (ts->type == BT_UNKNOWN)
603 ts = gfc_get_default_type (sym, NULL);
607 if (ts->kind == gfc_default_integer_kind)
611 if (ts->kind == gfc_default_real_kind
612 || ts->kind == gfc_default_double_kind)
616 if (ts->kind == gfc_default_complex_kind)
620 if (ts->kind == gfc_default_logical_kind)
624 /* We will issue error elsewhere. */
632 if (el == ns->entries)
633 gfc_error ("FUNCTION result %s can't be of type %s "
634 "in FUNCTION %s at %L", sym->name,
635 gfc_typename (ts), ns->entries->sym->name,
638 gfc_error ("ENTRY result %s can't be of type %s "
639 "in FUNCTION %s at %L", sym->name,
640 gfc_typename (ts), ns->entries->sym->name,
647 proc->attr.access = ACCESS_PRIVATE;
648 proc->attr.entry_master = 1;
650 /* Merge all the entry point arguments. */
651 for (el = ns->entries; el; el = el->next)
652 merge_argument_lists (proc, el->sym->formal);
654 /* Check the master formal arguments for any that are not
655 present in all entry points. */
656 for (el = ns->entries; el; el = el->next)
657 check_argument_lists (proc, el->sym->formal);
659 /* Use the master function for the function body. */
660 ns->proc_name = proc;
662 /* Finalize the new symbols. */
663 gfc_commit_symbols ();
665 /* Restore the original namespace. */
666 gfc_current_ns = old_ns;
671 has_default_initializer (gfc_symbol *der)
675 gcc_assert (der->attr.flavor == FL_DERIVED);
676 for (c = der->components; c; c = c->next)
677 if ((c->ts.type != BT_DERIVED && c->initializer)
678 || (c->ts.type == BT_DERIVED
679 && (!c->attr.pointer && has_default_initializer (c->ts.derived))))
685 /* Resolve common variables. */
687 resolve_common_vars (gfc_symbol *sym, bool named_common)
689 gfc_symbol *csym = sym;
691 for (; csym; csym = csym->common_next)
693 if (csym->value || csym->attr.data)
695 if (!csym->ns->is_block_data)
696 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
697 "but only in BLOCK DATA initialization is "
698 "allowed", csym->name, &csym->declared_at);
699 else if (!named_common)
700 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
701 "in a blank COMMON but initialization is only "
702 "allowed in named common blocks", csym->name,
706 if (csym->ts.type != BT_DERIVED)
709 if (!(csym->ts.derived->attr.sequence
710 || csym->ts.derived->attr.is_bind_c))
711 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
712 "has neither the SEQUENCE nor the BIND(C) "
713 "attribute", csym->name, &csym->declared_at);
714 if (csym->ts.derived->attr.alloc_comp)
715 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
716 "has an ultimate component that is "
717 "allocatable", csym->name, &csym->declared_at);
718 if (has_default_initializer (csym->ts.derived))
719 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
720 "may not have default initializer", csym->name,
725 /* Resolve common blocks. */
727 resolve_common_blocks (gfc_symtree *common_root)
731 if (common_root == NULL)
734 if (common_root->left)
735 resolve_common_blocks (common_root->left);
736 if (common_root->right)
737 resolve_common_blocks (common_root->right);
739 resolve_common_vars (common_root->n.common->head, true);
741 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
745 if (sym->attr.flavor == FL_PARAMETER)
746 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
747 sym->name, &common_root->n.common->where, &sym->declared_at);
749 if (sym->attr.intrinsic)
750 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
751 sym->name, &common_root->n.common->where);
752 else if (sym->attr.result
753 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
754 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
755 "that is also a function result", sym->name,
756 &common_root->n.common->where);
757 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
758 && sym->attr.proc != PROC_ST_FUNCTION)
759 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
760 "that is also a global procedure", sym->name,
761 &common_root->n.common->where);
765 /* Resolve contained function types. Because contained functions can call one
766 another, they have to be worked out before any of the contained procedures
769 The good news is that if a function doesn't already have a type, the only
770 way it can get one is through an IMPLICIT type or a RESULT variable, because
771 by definition contained functions are contained namespace they're contained
772 in, not in a sibling or parent namespace. */
775 resolve_contained_functions (gfc_namespace *ns)
777 gfc_namespace *child;
780 resolve_formal_arglists (ns);
782 for (child = ns->contained; child; child = child->sibling)
784 /* Resolve alternate entry points first. */
785 resolve_entries (child);
787 /* Then check function return types. */
788 resolve_contained_fntype (child->proc_name, child);
789 for (el = child->entries; el; el = el->next)
790 resolve_contained_fntype (el->sym, child);
795 /* Resolve all of the elements of a structure constructor and make sure that
796 the types are correct. */
799 resolve_structure_cons (gfc_expr *expr)
801 gfc_constructor *cons;
807 cons = expr->value.constructor;
808 /* A constructor may have references if it is the result of substituting a
809 parameter variable. In this case we just pull out the component we
812 comp = expr->ref->u.c.sym->components;
814 comp = expr->ts.derived->components;
816 /* See if the user is trying to invoke a structure constructor for one of
817 the iso_c_binding derived types. */
818 if (expr->ts.derived && expr->ts.derived->ts.is_iso_c && cons
819 && cons->expr != NULL)
821 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
822 expr->ts.derived->name, &(expr->where));
826 for (; comp; comp = comp->next, cons = cons->next)
833 if (gfc_resolve_expr (cons->expr) == FAILURE)
839 rank = comp->as ? comp->as->rank : 0;
840 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
841 && (comp->attr.allocatable || cons->expr->rank))
843 gfc_error ("The rank of the element in the derived type "
844 "constructor at %L does not match that of the "
845 "component (%d/%d)", &cons->expr->where,
846 cons->expr->rank, rank);
850 /* If we don't have the right type, try to convert it. */
852 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
855 if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
856 gfc_error ("The element in the derived type constructor at %L, "
857 "for pointer component '%s', is %s but should be %s",
858 &cons->expr->where, comp->name,
859 gfc_basic_typename (cons->expr->ts.type),
860 gfc_basic_typename (comp->ts.type));
862 t = gfc_convert_type (cons->expr, &comp->ts, 1);
865 if (cons->expr->expr_type == EXPR_NULL
866 && !(comp->attr.pointer || comp->attr.allocatable))
869 gfc_error ("The NULL in the derived type constructor at %L is "
870 "being applied to component '%s', which is neither "
871 "a POINTER nor ALLOCATABLE", &cons->expr->where,
875 if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
878 a = gfc_expr_attr (cons->expr);
880 if (!a.pointer && !a.target)
883 gfc_error ("The element in the derived type constructor at %L, "
884 "for pointer component '%s' should be a POINTER or "
885 "a TARGET", &cons->expr->where, comp->name);
893 /****************** Expression name resolution ******************/
895 /* Returns 0 if a symbol was not declared with a type or
896 attribute declaration statement, nonzero otherwise. */
899 was_declared (gfc_symbol *sym)
905 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
908 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
909 || a.optional || a.pointer || a.save || a.target || a.volatile_
910 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
917 /* Determine if a symbol is generic or not. */
920 generic_sym (gfc_symbol *sym)
924 if (sym->attr.generic ||
925 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
928 if (was_declared (sym) || sym->ns->parent == NULL)
931 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
938 return generic_sym (s);
945 /* Determine if a symbol is specific or not. */
948 specific_sym (gfc_symbol *sym)
952 if (sym->attr.if_source == IFSRC_IFBODY
953 || sym->attr.proc == PROC_MODULE
954 || sym->attr.proc == PROC_INTERNAL
955 || sym->attr.proc == PROC_ST_FUNCTION
956 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
957 || sym->attr.external)
960 if (was_declared (sym) || sym->ns->parent == NULL)
963 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
965 return (s == NULL) ? 0 : specific_sym (s);
969 /* Figure out if the procedure is specific, generic or unknown. */
972 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
976 procedure_kind (gfc_symbol *sym)
978 if (generic_sym (sym))
979 return PTYPE_GENERIC;
981 if (specific_sym (sym))
982 return PTYPE_SPECIFIC;
984 return PTYPE_UNKNOWN;
987 /* Check references to assumed size arrays. The flag need_full_assumed_size
988 is nonzero when matching actual arguments. */
990 static int need_full_assumed_size = 0;
993 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
995 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
998 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
999 What should it be? */
1000 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1001 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1002 && (e->ref->u.ar.type == AR_FULL))
1004 gfc_error ("The upper bound in the last dimension must "
1005 "appear in the reference to the assumed size "
1006 "array '%s' at %L", sym->name, &e->where);
1013 /* Look for bad assumed size array references in argument expressions
1014 of elemental and array valued intrinsic procedures. Since this is
1015 called from procedure resolution functions, it only recurses at
1019 resolve_assumed_size_actual (gfc_expr *e)
1024 switch (e->expr_type)
1027 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1032 if (resolve_assumed_size_actual (e->value.op.op1)
1033 || resolve_assumed_size_actual (e->value.op.op2))
1044 /* Check a generic procedure, passed as an actual argument, to see if
1045 there is a matching specific name. If none, it is an error, and if
1046 more than one, the reference is ambiguous. */
1048 count_specific_procs (gfc_expr *e)
1055 sym = e->symtree->n.sym;
1057 for (p = sym->generic; p; p = p->next)
1058 if (strcmp (sym->name, p->sym->name) == 0)
1060 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1066 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1070 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1071 "argument at %L", sym->name, &e->where);
1077 /* See if a call to sym could possibly be a not allowed RECURSION because of
1078 a missing RECURIVE declaration. This means that either sym is the current
1079 context itself, or sym is the parent of a contained procedure calling its
1080 non-RECURSIVE containing procedure.
1081 This also works if sym is an ENTRY. */
1084 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1086 gfc_symbol* proc_sym;
1087 gfc_symbol* context_proc;
1089 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1091 /* If we've got an ENTRY, find real procedure. */
1092 if (sym->attr.entry && sym->ns->entries)
1093 proc_sym = sym->ns->entries->sym;
1097 /* If sym is RECURSIVE, all is well of course. */
1098 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1101 /* Find the context procdure's "real" symbol if it has entries. */
1102 context_proc = (context->entries ? context->entries->sym
1103 : context->proc_name);
1107 /* A call from sym's body to itself is recursion, of course. */
1108 if (context_proc == proc_sym)
1111 /* The same is true if context is a contained procedure and sym the
1113 if (context_proc->attr.contained)
1115 gfc_symbol* parent_proc;
1117 gcc_assert (context->parent);
1118 parent_proc = (context->parent->entries ? context->parent->entries->sym
1119 : context->parent->proc_name);
1121 if (parent_proc == proc_sym)
1129 /* Resolve a procedure expression, like passing it to a called procedure or as
1130 RHS for a procedure pointer assignment. */
1133 resolve_procedure_expression (gfc_expr* expr)
1137 if (expr->expr_type != EXPR_VARIABLE)
1139 gcc_assert (expr->symtree);
1141 sym = expr->symtree->n.sym;
1142 if (sym->attr.flavor != FL_PROCEDURE
1143 || (sym->attr.function && sym->result == sym))
1146 /* A non-RECURSIVE procedure that is used as procedure expression within its
1147 own body is in danger of being called recursively. */
1148 if (is_illegal_recursion (sym, gfc_current_ns))
1149 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1150 " itself recursively. Declare it RECURSIVE or use"
1151 " -frecursive", sym->name, &expr->where);
1157 /* Resolve an actual argument list. Most of the time, this is just
1158 resolving the expressions in the list.
1159 The exception is that we sometimes have to decide whether arguments
1160 that look like procedure arguments are really simple variable
1164 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1165 bool no_formal_args)
1168 gfc_symtree *parent_st;
1170 int save_need_full_assumed_size;
1172 for (; arg; arg = arg->next)
1177 /* Check the label is a valid branching target. */
1180 if (arg->label->defined == ST_LABEL_UNKNOWN)
1182 gfc_error ("Label %d referenced at %L is never defined",
1183 arg->label->value, &arg->label->where);
1190 if (e->expr_type == EXPR_VARIABLE
1191 && e->symtree->n.sym->attr.generic
1193 && count_specific_procs (e) != 1)
1196 if (e->ts.type != BT_PROCEDURE)
1198 save_need_full_assumed_size = need_full_assumed_size;
1199 if (e->expr_type != EXPR_VARIABLE)
1200 need_full_assumed_size = 0;
1201 if (gfc_resolve_expr (e) != SUCCESS)
1203 need_full_assumed_size = save_need_full_assumed_size;
1207 /* See if the expression node should really be a variable reference. */
1209 sym = e->symtree->n.sym;
1211 if (sym->attr.flavor == FL_PROCEDURE
1212 || sym->attr.intrinsic
1213 || sym->attr.external)
1217 /* If a procedure is not already determined to be something else
1218 check if it is intrinsic. */
1219 if (!sym->attr.intrinsic
1220 && !(sym->attr.external || sym->attr.use_assoc
1221 || sym->attr.if_source == IFSRC_IFBODY)
1222 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1223 sym->attr.intrinsic = 1;
1225 if (sym->attr.proc == PROC_ST_FUNCTION)
1227 gfc_error ("Statement function '%s' at %L is not allowed as an "
1228 "actual argument", sym->name, &e->where);
1231 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1232 sym->attr.subroutine);
1233 if (sym->attr.intrinsic && actual_ok == 0)
1235 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1236 "actual argument", sym->name, &e->where);
1239 if (sym->attr.contained && !sym->attr.use_assoc
1240 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1242 gfc_error ("Internal procedure '%s' is not allowed as an "
1243 "actual argument at %L", sym->name, &e->where);
1246 if (sym->attr.elemental && !sym->attr.intrinsic)
1248 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1249 "allowed as an actual argument at %L", sym->name,
1253 /* Check if a generic interface has a specific procedure
1254 with the same name before emitting an error. */
1255 if (sym->attr.generic && count_specific_procs (e) != 1)
1258 /* Just in case a specific was found for the expression. */
1259 sym = e->symtree->n.sym;
1261 /* If the symbol is the function that names the current (or
1262 parent) scope, then we really have a variable reference. */
1264 if (sym->attr.function && sym->result == sym
1265 && (sym->ns->proc_name == sym
1266 || (sym->ns->parent != NULL
1267 && sym->ns->parent->proc_name == sym)))
1270 /* If all else fails, see if we have a specific intrinsic. */
1271 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1273 gfc_intrinsic_sym *isym;
1275 isym = gfc_find_function (sym->name);
1276 if (isym == NULL || !isym->specific)
1278 gfc_error ("Unable to find a specific INTRINSIC procedure "
1279 "for the reference '%s' at %L", sym->name,
1284 sym->attr.intrinsic = 1;
1285 sym->attr.function = 1;
1288 if (gfc_resolve_expr (e) == FAILURE)
1293 /* See if the name is a module procedure in a parent unit. */
1295 if (was_declared (sym) || sym->ns->parent == NULL)
1298 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1300 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1304 if (parent_st == NULL)
1307 sym = parent_st->n.sym;
1308 e->symtree = parent_st; /* Point to the right thing. */
1310 if (sym->attr.flavor == FL_PROCEDURE
1311 || sym->attr.intrinsic
1312 || sym->attr.external)
1314 if (gfc_resolve_expr (e) == FAILURE)
1320 e->expr_type = EXPR_VARIABLE;
1322 if (sym->as != NULL)
1324 e->rank = sym->as->rank;
1325 e->ref = gfc_get_ref ();
1326 e->ref->type = REF_ARRAY;
1327 e->ref->u.ar.type = AR_FULL;
1328 e->ref->u.ar.as = sym->as;
1331 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1332 primary.c (match_actual_arg). If above code determines that it
1333 is a variable instead, it needs to be resolved as it was not
1334 done at the beginning of this function. */
1335 save_need_full_assumed_size = need_full_assumed_size;
1336 if (e->expr_type != EXPR_VARIABLE)
1337 need_full_assumed_size = 0;
1338 if (gfc_resolve_expr (e) != SUCCESS)
1340 need_full_assumed_size = save_need_full_assumed_size;
1343 /* Check argument list functions %VAL, %LOC and %REF. There is
1344 nothing to do for %REF. */
1345 if (arg->name && arg->name[0] == '%')
1347 if (strncmp ("%VAL", arg->name, 4) == 0)
1349 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1351 gfc_error ("By-value argument at %L is not of numeric "
1358 gfc_error ("By-value argument at %L cannot be an array or "
1359 "an array section", &e->where);
1363 /* Intrinsics are still PROC_UNKNOWN here. However,
1364 since same file external procedures are not resolvable
1365 in gfortran, it is a good deal easier to leave them to
1367 if (ptype != PROC_UNKNOWN
1368 && ptype != PROC_DUMMY
1369 && ptype != PROC_EXTERNAL
1370 && ptype != PROC_MODULE)
1372 gfc_error ("By-value argument at %L is not allowed "
1373 "in this context", &e->where);
1378 /* Statement functions have already been excluded above. */
1379 else if (strncmp ("%LOC", arg->name, 4) == 0
1380 && e->ts.type == BT_PROCEDURE)
1382 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1384 gfc_error ("Passing internal procedure at %L by location "
1385 "not allowed", &e->where);
1396 /* Do the checks of the actual argument list that are specific to elemental
1397 procedures. If called with c == NULL, we have a function, otherwise if
1398 expr == NULL, we have a subroutine. */
1401 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1403 gfc_actual_arglist *arg0;
1404 gfc_actual_arglist *arg;
1405 gfc_symbol *esym = NULL;
1406 gfc_intrinsic_sym *isym = NULL;
1408 gfc_intrinsic_arg *iformal = NULL;
1409 gfc_formal_arglist *eformal = NULL;
1410 bool formal_optional = false;
1411 bool set_by_optional = false;
1415 /* Is this an elemental procedure? */
1416 if (expr && expr->value.function.actual != NULL)
1418 if (expr->value.function.esym != NULL
1419 && expr->value.function.esym->attr.elemental)
1421 arg0 = expr->value.function.actual;
1422 esym = expr->value.function.esym;
1424 else if (expr->value.function.isym != NULL
1425 && expr->value.function.isym->elemental)
1427 arg0 = expr->value.function.actual;
1428 isym = expr->value.function.isym;
1433 else if (c && c->ext.actual != NULL)
1435 arg0 = c->ext.actual;
1437 if (c->resolved_sym)
1438 esym = c->resolved_sym;
1440 esym = c->symtree->n.sym;
1443 if (!esym->attr.elemental)
1449 /* The rank of an elemental is the rank of its array argument(s). */
1450 for (arg = arg0; arg; arg = arg->next)
1452 if (arg->expr != NULL && arg->expr->rank > 0)
1454 rank = arg->expr->rank;
1455 if (arg->expr->expr_type == EXPR_VARIABLE
1456 && arg->expr->symtree->n.sym->attr.optional)
1457 set_by_optional = true;
1459 /* Function specific; set the result rank and shape. */
1463 if (!expr->shape && arg->expr->shape)
1465 expr->shape = gfc_get_shape (rank);
1466 for (i = 0; i < rank; i++)
1467 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1474 /* If it is an array, it shall not be supplied as an actual argument
1475 to an elemental procedure unless an array of the same rank is supplied
1476 as an actual argument corresponding to a nonoptional dummy argument of
1477 that elemental procedure(12.4.1.5). */
1478 formal_optional = false;
1480 iformal = isym->formal;
1482 eformal = esym->formal;
1484 for (arg = arg0; arg; arg = arg->next)
1488 if (eformal->sym && eformal->sym->attr.optional)
1489 formal_optional = true;
1490 eformal = eformal->next;
1492 else if (isym && iformal)
1494 if (iformal->optional)
1495 formal_optional = true;
1496 iformal = iformal->next;
1499 formal_optional = true;
1501 if (pedantic && arg->expr != NULL
1502 && arg->expr->expr_type == EXPR_VARIABLE
1503 && arg->expr->symtree->n.sym->attr.optional
1506 && (set_by_optional || arg->expr->rank != rank)
1507 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1509 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1510 "MISSING, it cannot be the actual argument of an "
1511 "ELEMENTAL procedure unless there is a non-optional "
1512 "argument with the same rank (12.4.1.5)",
1513 arg->expr->symtree->n.sym->name, &arg->expr->where);
1518 for (arg = arg0; arg; arg = arg->next)
1520 if (arg->expr == NULL || arg->expr->rank == 0)
1523 /* Being elemental, the last upper bound of an assumed size array
1524 argument must be present. */
1525 if (resolve_assumed_size_actual (arg->expr))
1528 /* Elemental procedure's array actual arguments must conform. */
1531 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1539 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1540 is an array, the intent inout/out variable needs to be also an array. */
1541 if (rank > 0 && esym && expr == NULL)
1542 for (eformal = esym->formal, arg = arg0; arg && eformal;
1543 arg = arg->next, eformal = eformal->next)
1544 if ((eformal->sym->attr.intent == INTENT_OUT
1545 || eformal->sym->attr.intent == INTENT_INOUT)
1546 && arg->expr && arg->expr->rank == 0)
1548 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1549 "ELEMENTAL subroutine '%s' is a scalar, but another "
1550 "actual argument is an array", &arg->expr->where,
1551 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1552 : "INOUT", eformal->sym->name, esym->name);
1559 /* Go through each actual argument in ACTUAL and see if it can be
1560 implemented as an inlined, non-copying intrinsic. FNSYM is the
1561 function being called, or NULL if not known. */
1564 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1566 gfc_actual_arglist *ap;
1569 for (ap = actual; ap; ap = ap->next)
1571 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1572 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1574 ap->expr->inline_noncopying_intrinsic = 1;
1578 /* This function does the checking of references to global procedures
1579 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1580 77 and 95 standards. It checks for a gsymbol for the name, making
1581 one if it does not already exist. If it already exists, then the
1582 reference being resolved must correspond to the type of gsymbol.
1583 Otherwise, the new symbol is equipped with the attributes of the
1584 reference. The corresponding code that is called in creating
1585 global entities is parse.c. */
1588 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1593 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1595 gsym = gfc_get_gsymbol (sym->name);
1597 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1598 gfc_global_used (gsym, where);
1600 if (gsym->type == GSYM_UNKNOWN)
1603 gsym->where = *where;
1610 /************* Function resolution *************/
1612 /* Resolve a function call known to be generic.
1613 Section 14.1.2.4.1. */
1616 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1620 if (sym->attr.generic)
1622 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1625 expr->value.function.name = s->name;
1626 expr->value.function.esym = s;
1628 if (s->ts.type != BT_UNKNOWN)
1630 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1631 expr->ts = s->result->ts;
1634 expr->rank = s->as->rank;
1635 else if (s->result != NULL && s->result->as != NULL)
1636 expr->rank = s->result->as->rank;
1638 gfc_set_sym_referenced (expr->value.function.esym);
1643 /* TODO: Need to search for elemental references in generic
1647 if (sym->attr.intrinsic)
1648 return gfc_intrinsic_func_interface (expr, 0);
1655 resolve_generic_f (gfc_expr *expr)
1660 sym = expr->symtree->n.sym;
1664 m = resolve_generic_f0 (expr, sym);
1667 else if (m == MATCH_ERROR)
1671 if (sym->ns->parent == NULL)
1673 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1677 if (!generic_sym (sym))
1681 /* Last ditch attempt. See if the reference is to an intrinsic
1682 that possesses a matching interface. 14.1.2.4 */
1683 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1685 gfc_error ("There is no specific function for the generic '%s' at %L",
1686 expr->symtree->n.sym->name, &expr->where);
1690 m = gfc_intrinsic_func_interface (expr, 0);
1694 gfc_error ("Generic function '%s' at %L is not consistent with a "
1695 "specific intrinsic interface", expr->symtree->n.sym->name,
1702 /* Resolve a function call known to be specific. */
1705 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1709 /* See if we have an intrinsic interface. */
1711 if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
1713 gfc_intrinsic_sym *isym;
1714 isym = gfc_find_function (sym->ts.interface->name);
1716 /* Existence of isym should be checked already. */
1719 sym->ts.type = isym->ts.type;
1720 sym->ts.kind = isym->ts.kind;
1721 sym->attr.function = 1;
1722 sym->attr.proc = PROC_EXTERNAL;
1726 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1728 if (sym->attr.dummy)
1730 sym->attr.proc = PROC_DUMMY;
1734 sym->attr.proc = PROC_EXTERNAL;
1738 if (sym->attr.proc == PROC_MODULE
1739 || sym->attr.proc == PROC_ST_FUNCTION
1740 || sym->attr.proc == PROC_INTERNAL)
1743 if (sym->attr.intrinsic)
1745 m = gfc_intrinsic_func_interface (expr, 1);
1749 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1750 "with an intrinsic", sym->name, &expr->where);
1758 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1761 expr->value.function.name = sym->name;
1762 expr->value.function.esym = sym;
1763 if (sym->as != NULL)
1764 expr->rank = sym->as->rank;
1771 resolve_specific_f (gfc_expr *expr)
1776 sym = expr->symtree->n.sym;
1780 m = resolve_specific_f0 (sym, expr);
1783 if (m == MATCH_ERROR)
1786 if (sym->ns->parent == NULL)
1789 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1795 gfc_error ("Unable to resolve the specific function '%s' at %L",
1796 expr->symtree->n.sym->name, &expr->where);
1802 /* Resolve a procedure call not known to be generic nor specific. */
1805 resolve_unknown_f (gfc_expr *expr)
1810 sym = expr->symtree->n.sym;
1812 if (sym->attr.dummy)
1814 sym->attr.proc = PROC_DUMMY;
1815 expr->value.function.name = sym->name;
1819 /* See if we have an intrinsic function reference. */
1821 if (gfc_is_intrinsic (sym, 0, expr->where))
1823 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1828 /* The reference is to an external name. */
1830 sym->attr.proc = PROC_EXTERNAL;
1831 expr->value.function.name = sym->name;
1832 expr->value.function.esym = expr->symtree->n.sym;
1834 if (sym->as != NULL)
1835 expr->rank = sym->as->rank;
1837 /* Type of the expression is either the type of the symbol or the
1838 default type of the symbol. */
1841 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1843 if (sym->ts.type != BT_UNKNOWN)
1847 ts = gfc_get_default_type (sym, sym->ns);
1849 if (ts->type == BT_UNKNOWN)
1851 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1852 sym->name, &expr->where);
1863 /* Return true, if the symbol is an external procedure. */
1865 is_external_proc (gfc_symbol *sym)
1867 if (!sym->attr.dummy && !sym->attr.contained
1868 && !(sym->attr.intrinsic
1869 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
1870 && sym->attr.proc != PROC_ST_FUNCTION
1871 && !sym->attr.use_assoc
1879 /* Figure out if a function reference is pure or not. Also set the name
1880 of the function for a potential error message. Return nonzero if the
1881 function is PURE, zero if not. */
1883 pure_stmt_function (gfc_expr *, gfc_symbol *);
1886 pure_function (gfc_expr *e, const char **name)
1892 if (e->symtree != NULL
1893 && e->symtree->n.sym != NULL
1894 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1895 return pure_stmt_function (e, e->symtree->n.sym);
1897 if (e->value.function.esym)
1899 pure = gfc_pure (e->value.function.esym);
1900 *name = e->value.function.esym->name;
1902 else if (e->value.function.isym)
1904 pure = e->value.function.isym->pure
1905 || e->value.function.isym->elemental;
1906 *name = e->value.function.isym->name;
1910 /* Implicit functions are not pure. */
1912 *name = e->value.function.name;
1920 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
1921 int *f ATTRIBUTE_UNUSED)
1925 /* Don't bother recursing into other statement functions
1926 since they will be checked individually for purity. */
1927 if (e->expr_type != EXPR_FUNCTION
1929 || e->symtree->n.sym == sym
1930 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1933 return pure_function (e, &name) ? false : true;
1938 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
1940 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
1945 is_scalar_expr_ptr (gfc_expr *expr)
1947 gfc_try retval = SUCCESS;
1952 /* See if we have a gfc_ref, which means we have a substring, array
1953 reference, or a component. */
1954 if (expr->ref != NULL)
1957 while (ref->next != NULL)
1963 if (ref->u.ss.length != NULL
1964 && ref->u.ss.length->length != NULL
1966 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1968 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1970 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1971 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1972 if (end - start + 1 != 1)
1979 if (ref->u.ar.type == AR_ELEMENT)
1981 else if (ref->u.ar.type == AR_FULL)
1983 /* The user can give a full array if the array is of size 1. */
1984 if (ref->u.ar.as != NULL
1985 && ref->u.ar.as->rank == 1
1986 && ref->u.ar.as->type == AS_EXPLICIT
1987 && ref->u.ar.as->lower[0] != NULL
1988 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1989 && ref->u.ar.as->upper[0] != NULL
1990 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1992 /* If we have a character string, we need to check if
1993 its length is one. */
1994 if (expr->ts.type == BT_CHARACTER)
1996 if (expr->ts.cl == NULL
1997 || expr->ts.cl->length == NULL
1998 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
2004 /* We have constant lower and upper bounds. If the
2005 difference between is 1, it can be considered a
2007 start = (int) mpz_get_si
2008 (ref->u.ar.as->lower[0]->value.integer);
2009 end = (int) mpz_get_si
2010 (ref->u.ar.as->upper[0]->value.integer);
2011 if (end - start + 1 != 1)
2026 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2028 /* Character string. Make sure it's of length 1. */
2029 if (expr->ts.cl == NULL
2030 || expr->ts.cl->length == NULL
2031 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
2034 else if (expr->rank != 0)
2041 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2042 and, in the case of c_associated, set the binding label based on
2046 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2047 gfc_symbol **new_sym)
2049 char name[GFC_MAX_SYMBOL_LEN + 1];
2050 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2051 int optional_arg = 0, is_pointer = 0;
2052 gfc_try retval = SUCCESS;
2053 gfc_symbol *args_sym;
2054 gfc_typespec *arg_ts;
2056 if (args->expr->expr_type == EXPR_CONSTANT
2057 || args->expr->expr_type == EXPR_OP
2058 || args->expr->expr_type == EXPR_NULL)
2060 gfc_error ("Argument to '%s' at %L is not a variable",
2061 sym->name, &(args->expr->where));
2065 args_sym = args->expr->symtree->n.sym;
2067 /* The typespec for the actual arg should be that stored in the expr
2068 and not necessarily that of the expr symbol (args_sym), because
2069 the actual expression could be a part-ref of the expr symbol. */
2070 arg_ts = &(args->expr->ts);
2072 is_pointer = gfc_is_data_pointer (args->expr);
2074 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2076 /* If the user gave two args then they are providing something for
2077 the optional arg (the second cptr). Therefore, set the name and
2078 binding label to the c_associated for two cptrs. Otherwise,
2079 set c_associated to expect one cptr. */
2083 sprintf (name, "%s_2", sym->name);
2084 sprintf (binding_label, "%s_2", sym->binding_label);
2090 sprintf (name, "%s_1", sym->name);
2091 sprintf (binding_label, "%s_1", sym->binding_label);
2095 /* Get a new symbol for the version of c_associated that
2097 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2099 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2100 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2102 sprintf (name, "%s", sym->name);
2103 sprintf (binding_label, "%s", sym->binding_label);
2105 /* Error check the call. */
2106 if (args->next != NULL)
2108 gfc_error_now ("More actual than formal arguments in '%s' "
2109 "call at %L", name, &(args->expr->where));
2112 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2114 /* Make sure we have either the target or pointer attribute. */
2115 if (!args_sym->attr.target && !is_pointer)
2117 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2118 "a TARGET or an associated pointer",
2120 sym->name, &(args->expr->where));
2124 /* See if we have interoperable type and type param. */
2125 if (verify_c_interop (arg_ts) == SUCCESS
2126 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2128 if (args_sym->attr.target == 1)
2130 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2131 has the target attribute and is interoperable. */
2132 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2133 allocatable variable that has the TARGET attribute and
2134 is not an array of zero size. */
2135 if (args_sym->attr.allocatable == 1)
2137 if (args_sym->attr.dimension != 0
2138 && (args_sym->as && args_sym->as->rank == 0))
2140 gfc_error_now ("Allocatable variable '%s' used as a "
2141 "parameter to '%s' at %L must not be "
2142 "an array of zero size",
2143 args_sym->name, sym->name,
2144 &(args->expr->where));
2150 /* A non-allocatable target variable with C
2151 interoperable type and type parameters must be
2153 if (args_sym && args_sym->attr.dimension)
2155 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2157 gfc_error ("Assumed-shape array '%s' at %L "
2158 "cannot be an argument to the "
2159 "procedure '%s' because "
2160 "it is not C interoperable",
2162 &(args->expr->where), sym->name);
2165 else if (args_sym->as->type == AS_DEFERRED)
2167 gfc_error ("Deferred-shape array '%s' at %L "
2168 "cannot be an argument to the "
2169 "procedure '%s' because "
2170 "it is not C interoperable",
2172 &(args->expr->where), sym->name);
2177 /* Make sure it's not a character string. Arrays of
2178 any type should be ok if the variable is of a C
2179 interoperable type. */
2180 if (arg_ts->type == BT_CHARACTER)
2181 if (arg_ts->cl != NULL
2182 && (arg_ts->cl->length == NULL
2183 || arg_ts->cl->length->expr_type
2186 (arg_ts->cl->length->value.integer, 1)
2188 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2190 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2191 "at %L must have a length of 1",
2192 args_sym->name, sym->name,
2193 &(args->expr->where));
2199 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2201 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2203 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2204 "associated scalar POINTER", args_sym->name,
2205 sym->name, &(args->expr->where));
2211 /* The parameter is not required to be C interoperable. If it
2212 is not C interoperable, it must be a nonpolymorphic scalar
2213 with no length type parameters. It still must have either
2214 the pointer or target attribute, and it can be
2215 allocatable (but must be allocated when c_loc is called). */
2216 if (args->expr->rank != 0
2217 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2219 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2220 "scalar", args_sym->name, sym->name,
2221 &(args->expr->where));
2224 else if (arg_ts->type == BT_CHARACTER
2225 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2227 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2228 "%L must have a length of 1",
2229 args_sym->name, sym->name,
2230 &(args->expr->where));
2235 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2237 if (args_sym->attr.flavor != FL_PROCEDURE)
2239 /* TODO: Update this error message to allow for procedure
2240 pointers once they are implemented. */
2241 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2243 args_sym->name, sym->name,
2244 &(args->expr->where));
2247 else if (args_sym->attr.is_bind_c != 1)
2249 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2251 args_sym->name, sym->name,
2252 &(args->expr->where));
2257 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2262 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2263 "iso_c_binding function: '%s'!\n", sym->name);
2270 /* Resolve a function call, which means resolving the arguments, then figuring
2271 out which entity the name refers to. */
2272 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2273 to INTENT(OUT) or INTENT(INOUT). */
2276 resolve_function (gfc_expr *expr)
2278 gfc_actual_arglist *arg;
2283 procedure_type p = PROC_INTRINSIC;
2284 bool no_formal_args;
2288 sym = expr->symtree->n.sym;
2290 if (sym && sym->attr.intrinsic
2291 && !gfc_find_function (sym->name)
2292 && gfc_find_subroutine (sym->name)
2293 && sym->attr.function)
2295 gfc_error ("Intrinsic subroutine '%s' used as "
2296 "a function at %L", sym->name, &expr->where);
2300 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2302 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2306 if (sym && sym->attr.abstract)
2308 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2309 sym->name, &expr->where);
2313 /* If the procedure is external, check for usage. */
2314 if (sym && is_external_proc (sym))
2315 resolve_global_procedure (sym, &expr->where, 0);
2317 /* Switch off assumed size checking and do this again for certain kinds
2318 of procedure, once the procedure itself is resolved. */
2319 need_full_assumed_size++;
2321 if (expr->symtree && expr->symtree->n.sym)
2322 p = expr->symtree->n.sym->attr.proc;
2324 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2325 if (resolve_actual_arglist (expr->value.function.actual,
2326 p, no_formal_args) == FAILURE)
2329 /* Need to setup the call to the correct c_associated, depending on
2330 the number of cptrs to user gives to compare. */
2331 if (sym && sym->attr.is_iso_c == 1)
2333 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2337 /* Get the symtree for the new symbol (resolved func).
2338 the old one will be freed later, when it's no longer used. */
2339 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2342 /* Resume assumed_size checking. */
2343 need_full_assumed_size--;
2345 if (sym && sym->ts.type == BT_CHARACTER
2347 && sym->ts.cl->length == NULL
2349 && expr->value.function.esym == NULL
2350 && !sym->attr.contained)
2352 /* Internal procedures are taken care of in resolve_contained_fntype. */
2353 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2354 "be used at %L since it is not a dummy argument",
2355 sym->name, &expr->where);
2359 /* See if function is already resolved. */
2361 if (expr->value.function.name != NULL)
2363 if (expr->ts.type == BT_UNKNOWN)
2369 /* Apply the rules of section 14.1.2. */
2371 switch (procedure_kind (sym))
2374 t = resolve_generic_f (expr);
2377 case PTYPE_SPECIFIC:
2378 t = resolve_specific_f (expr);
2382 t = resolve_unknown_f (expr);
2386 gfc_internal_error ("resolve_function(): bad function type");
2390 /* If the expression is still a function (it might have simplified),
2391 then we check to see if we are calling an elemental function. */
2393 if (expr->expr_type != EXPR_FUNCTION)
2396 temp = need_full_assumed_size;
2397 need_full_assumed_size = 0;
2399 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2402 if (omp_workshare_flag
2403 && expr->value.function.esym
2404 && ! gfc_elemental (expr->value.function.esym))
2406 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2407 "in WORKSHARE construct", expr->value.function.esym->name,
2412 #define GENERIC_ID expr->value.function.isym->id
2413 else if (expr->value.function.actual != NULL
2414 && expr->value.function.isym != NULL
2415 && GENERIC_ID != GFC_ISYM_LBOUND
2416 && GENERIC_ID != GFC_ISYM_LEN
2417 && GENERIC_ID != GFC_ISYM_LOC
2418 && GENERIC_ID != GFC_ISYM_PRESENT)
2420 /* Array intrinsics must also have the last upper bound of an
2421 assumed size array argument. UBOUND and SIZE have to be
2422 excluded from the check if the second argument is anything
2425 for (arg = expr->value.function.actual; arg; arg = arg->next)
2427 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2428 && arg->next != NULL && arg->next->expr)
2430 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2433 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2436 if ((int)mpz_get_si (arg->next->expr->value.integer)
2441 if (arg->expr != NULL
2442 && arg->expr->rank > 0
2443 && resolve_assumed_size_actual (arg->expr))
2449 need_full_assumed_size = temp;
2452 if (!pure_function (expr, &name) && name)
2456 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2457 "FORALL %s", name, &expr->where,
2458 forall_flag == 2 ? "mask" : "block");
2461 else if (gfc_pure (NULL))
2463 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2464 "procedure within a PURE procedure", name, &expr->where);
2469 /* Functions without the RECURSIVE attribution are not allowed to
2470 * call themselves. */
2471 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2474 esym = expr->value.function.esym;
2476 if (is_illegal_recursion (esym, gfc_current_ns))
2478 if (esym->attr.entry && esym->ns->entries)
2479 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2480 " function '%s' is not RECURSIVE",
2481 esym->name, &expr->where, esym->ns->entries->sym->name);
2483 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
2484 " is not RECURSIVE", esym->name, &expr->where);
2490 /* Character lengths of use associated functions may contains references to
2491 symbols not referenced from the current program unit otherwise. Make sure
2492 those symbols are marked as referenced. */
2494 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2495 && expr->value.function.esym->attr.use_assoc)
2497 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2501 && !((expr->value.function.esym
2502 && expr->value.function.esym->attr.elemental)
2504 (expr->value.function.isym
2505 && expr->value.function.isym->elemental)))
2506 find_noncopying_intrinsics (expr->value.function.esym,
2507 expr->value.function.actual);
2509 /* Make sure that the expression has a typespec that works. */
2510 if (expr->ts.type == BT_UNKNOWN)
2512 if (expr->symtree->n.sym->result
2513 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2514 expr->ts = expr->symtree->n.sym->result->ts;
2521 /************* Subroutine resolution *************/
2524 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2530 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2531 sym->name, &c->loc);
2532 else if (gfc_pure (NULL))
2533 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2539 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2543 if (sym->attr.generic)
2545 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2548 c->resolved_sym = s;
2549 pure_subroutine (c, s);
2553 /* TODO: Need to search for elemental references in generic interface. */
2556 if (sym->attr.intrinsic)
2557 return gfc_intrinsic_sub_interface (c, 0);
2564 resolve_generic_s (gfc_code *c)
2569 sym = c->symtree->n.sym;
2573 m = resolve_generic_s0 (c, sym);
2576 else if (m == MATCH_ERROR)
2580 if (sym->ns->parent == NULL)
2582 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2586 if (!generic_sym (sym))
2590 /* Last ditch attempt. See if the reference is to an intrinsic
2591 that possesses a matching interface. 14.1.2.4 */
2592 sym = c->symtree->n.sym;
2594 if (!gfc_is_intrinsic (sym, 1, c->loc))
2596 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2597 sym->name, &c->loc);
2601 m = gfc_intrinsic_sub_interface (c, 0);
2605 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2606 "intrinsic subroutine interface", sym->name, &c->loc);
2612 /* Set the name and binding label of the subroutine symbol in the call
2613 expression represented by 'c' to include the type and kind of the
2614 second parameter. This function is for resolving the appropriate
2615 version of c_f_pointer() and c_f_procpointer(). For example, a
2616 call to c_f_pointer() for a default integer pointer could have a
2617 name of c_f_pointer_i4. If no second arg exists, which is an error
2618 for these two functions, it defaults to the generic symbol's name
2619 and binding label. */
2622 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2623 char *name, char *binding_label)
2625 gfc_expr *arg = NULL;
2629 /* The second arg of c_f_pointer and c_f_procpointer determines
2630 the type and kind for the procedure name. */
2631 arg = c->ext.actual->next->expr;
2635 /* Set up the name to have the given symbol's name,
2636 plus the type and kind. */
2637 /* a derived type is marked with the type letter 'u' */
2638 if (arg->ts.type == BT_DERIVED)
2641 kind = 0; /* set the kind as 0 for now */
2645 type = gfc_type_letter (arg->ts.type);
2646 kind = arg->ts.kind;
2649 if (arg->ts.type == BT_CHARACTER)
2650 /* Kind info for character strings not needed. */
2653 sprintf (name, "%s_%c%d", sym->name, type, kind);
2654 /* Set up the binding label as the given symbol's label plus
2655 the type and kind. */
2656 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2660 /* If the second arg is missing, set the name and label as
2661 was, cause it should at least be found, and the missing
2662 arg error will be caught by compare_parameters(). */
2663 sprintf (name, "%s", sym->name);
2664 sprintf (binding_label, "%s", sym->binding_label);
2671 /* Resolve a generic version of the iso_c_binding procedure given
2672 (sym) to the specific one based on the type and kind of the
2673 argument(s). Currently, this function resolves c_f_pointer() and
2674 c_f_procpointer based on the type and kind of the second argument
2675 (FPTR). Other iso_c_binding procedures aren't specially handled.
2676 Upon successfully exiting, c->resolved_sym will hold the resolved
2677 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2681 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2683 gfc_symbol *new_sym;
2684 /* this is fine, since we know the names won't use the max */
2685 char name[GFC_MAX_SYMBOL_LEN + 1];
2686 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2687 /* default to success; will override if find error */
2688 match m = MATCH_YES;
2690 /* Make sure the actual arguments are in the necessary order (based on the
2691 formal args) before resolving. */
2692 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2694 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2695 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2697 set_name_and_label (c, sym, name, binding_label);
2699 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2701 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2703 /* Make sure we got a third arg if the second arg has non-zero
2704 rank. We must also check that the type and rank are
2705 correct since we short-circuit this check in
2706 gfc_procedure_use() (called above to sort actual args). */
2707 if (c->ext.actual->next->expr->rank != 0)
2709 if(c->ext.actual->next->next == NULL
2710 || c->ext.actual->next->next->expr == NULL)
2713 gfc_error ("Missing SHAPE parameter for call to %s "
2714 "at %L", sym->name, &(c->loc));
2716 else if (c->ext.actual->next->next->expr->ts.type
2718 || c->ext.actual->next->next->expr->rank != 1)
2721 gfc_error ("SHAPE parameter for call to %s at %L must "
2722 "be a rank 1 INTEGER array", sym->name,
2729 if (m != MATCH_ERROR)
2731 /* the 1 means to add the optional arg to formal list */
2732 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2734 /* for error reporting, say it's declared where the original was */
2735 new_sym->declared_at = sym->declared_at;
2740 /* no differences for c_loc or c_funloc */
2744 /* set the resolved symbol */
2745 if (m != MATCH_ERROR)
2746 c->resolved_sym = new_sym;
2748 c->resolved_sym = sym;
2754 /* Resolve a subroutine call known to be specific. */
2757 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2761 /* See if we have an intrinsic interface. */
2762 if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
2763 && !sym->ts.interface->attr.subroutine
2764 && sym->ts.interface->attr.intrinsic)
2766 gfc_intrinsic_sym *isym;
2768 isym = gfc_find_function (sym->ts.interface->name);
2770 /* Existence of isym should be checked already. */
2773 sym->ts.type = isym->ts.type;
2774 sym->ts.kind = isym->ts.kind;
2775 sym->attr.subroutine = 1;
2779 if(sym->attr.is_iso_c)
2781 m = gfc_iso_c_sub_interface (c,sym);
2785 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2787 if (sym->attr.dummy)
2789 sym->attr.proc = PROC_DUMMY;
2793 sym->attr.proc = PROC_EXTERNAL;
2797 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2800 if (sym->attr.intrinsic)
2802 m = gfc_intrinsic_sub_interface (c, 1);
2806 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2807 "with an intrinsic", sym->name, &c->loc);
2815 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2817 c->resolved_sym = sym;
2818 pure_subroutine (c, sym);
2825 resolve_specific_s (gfc_code *c)
2830 sym = c->symtree->n.sym;
2834 m = resolve_specific_s0 (c, sym);
2837 if (m == MATCH_ERROR)
2840 if (sym->ns->parent == NULL)
2843 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2849 sym = c->symtree->n.sym;
2850 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2851 sym->name, &c->loc);
2857 /* Resolve a subroutine call not known to be generic nor specific. */
2860 resolve_unknown_s (gfc_code *c)
2864 sym = c->symtree->n.sym;
2866 if (sym->attr.dummy)
2868 sym->attr.proc = PROC_DUMMY;
2872 /* See if we have an intrinsic function reference. */
2874 if (gfc_is_intrinsic (sym, 1, c->loc))
2876 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2881 /* The reference is to an external name. */
2884 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2886 c->resolved_sym = sym;
2888 pure_subroutine (c, sym);
2894 /* Resolve a subroutine call. Although it was tempting to use the same code
2895 for functions, subroutines and functions are stored differently and this
2896 makes things awkward. */
2899 resolve_call (gfc_code *c)
2902 procedure_type ptype = PROC_INTRINSIC;
2903 gfc_symbol *csym, *sym;
2904 bool no_formal_args;
2906 csym = c->symtree ? c->symtree->n.sym : NULL;
2908 if (csym && csym->ts.type != BT_UNKNOWN)
2910 gfc_error ("'%s' at %L has a type, which is not consistent with "
2911 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
2915 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
2918 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
2919 sym = st ? st->n.sym : NULL;
2920 if (sym && csym != sym
2921 && sym->ns == gfc_current_ns
2922 && sym->attr.flavor == FL_PROCEDURE
2923 && sym->attr.contained)
2926 if (csym->attr.generic)
2927 c->symtree->n.sym = sym;
2930 csym = c->symtree->n.sym;
2934 /* If external, check for usage. */
2935 if (csym && is_external_proc (csym))
2936 resolve_global_procedure (csym, &c->loc, 1);
2938 /* Subroutines without the RECURSIVE attribution are not allowed to
2939 * call themselves. */
2940 if (csym && is_illegal_recursion (csym, gfc_current_ns))
2942 if (csym->attr.entry && csym->ns->entries)
2943 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2944 " subroutine '%s' is not RECURSIVE",
2945 csym->name, &c->loc, csym->ns->entries->sym->name);
2947 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
2948 " is not RECURSIVE", csym->name, &c->loc);
2953 /* Switch off assumed size checking and do this again for certain kinds
2954 of procedure, once the procedure itself is resolved. */
2955 need_full_assumed_size++;
2958 ptype = csym->attr.proc;
2960 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
2961 if (resolve_actual_arglist (c->ext.actual, ptype,
2962 no_formal_args) == FAILURE)
2965 /* Resume assumed_size checking. */
2966 need_full_assumed_size--;
2969 if (c->resolved_sym == NULL)
2971 c->resolved_isym = NULL;
2972 switch (procedure_kind (csym))
2975 t = resolve_generic_s (c);
2978 case PTYPE_SPECIFIC:
2979 t = resolve_specific_s (c);
2983 t = resolve_unknown_s (c);
2987 gfc_internal_error ("resolve_subroutine(): bad function type");
2991 /* Some checks of elemental subroutine actual arguments. */
2992 if (resolve_elemental_actual (NULL, c) == FAILURE)
2995 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
2996 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3001 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3002 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3003 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3004 if their shapes do not match. If either op1->shape or op2->shape is
3005 NULL, return SUCCESS. */
3008 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3015 if (op1->shape != NULL && op2->shape != NULL)
3017 for (i = 0; i < op1->rank; i++)
3019 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3021 gfc_error ("Shapes for operands at %L and %L are not conformable",
3022 &op1->where, &op2->where);
3033 /* Resolve an operator expression node. This can involve replacing the
3034 operation with a user defined function call. */
3037 resolve_operator (gfc_expr *e)
3039 gfc_expr *op1, *op2;
3041 bool dual_locus_error;
3044 /* Resolve all subnodes-- give them types. */
3046 switch (e->value.op.op)
3049 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3052 /* Fall through... */
3055 case INTRINSIC_UPLUS:
3056 case INTRINSIC_UMINUS:
3057 case INTRINSIC_PARENTHESES:
3058 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3063 /* Typecheck the new node. */
3065 op1 = e->value.op.op1;
3066 op2 = e->value.op.op2;
3067 dual_locus_error = false;
3069 if ((op1 && op1->expr_type == EXPR_NULL)
3070 || (op2 && op2->expr_type == EXPR_NULL))
3072 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3076 switch (e->value.op.op)
3078 case INTRINSIC_UPLUS:
3079 case INTRINSIC_UMINUS:
3080 if (op1->ts.type == BT_INTEGER
3081 || op1->ts.type == BT_REAL
3082 || op1->ts.type == BT_COMPLEX)
3088 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3089 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3092 case INTRINSIC_PLUS:
3093 case INTRINSIC_MINUS:
3094 case INTRINSIC_TIMES:
3095 case INTRINSIC_DIVIDE:
3096 case INTRINSIC_POWER:
3097 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3099 gfc_type_convert_binary (e);
3104 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3105 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3106 gfc_typename (&op2->ts));
3109 case INTRINSIC_CONCAT:
3110 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3111 && op1->ts.kind == op2->ts.kind)
3113 e->ts.type = BT_CHARACTER;
3114 e->ts.kind = op1->ts.kind;
3119 _("Operands of string concatenation operator at %%L are %s/%s"),
3120 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3126 case INTRINSIC_NEQV:
3127 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3129 e->ts.type = BT_LOGICAL;
3130 e->ts.kind = gfc_kind_max (op1, op2);
3131 if (op1->ts.kind < e->ts.kind)
3132 gfc_convert_type (op1, &e->ts, 2);
3133 else if (op2->ts.kind < e->ts.kind)
3134 gfc_convert_type (op2, &e->ts, 2);
3138 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3139 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3140 gfc_typename (&op2->ts));
3145 if (op1->ts.type == BT_LOGICAL)
3147 e->ts.type = BT_LOGICAL;
3148 e->ts.kind = op1->ts.kind;
3152 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3153 gfc_typename (&op1->ts));
3157 case INTRINSIC_GT_OS:
3159 case INTRINSIC_GE_OS:
3161 case INTRINSIC_LT_OS:
3163 case INTRINSIC_LE_OS:
3164 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3166 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3170 /* Fall through... */
3173 case INTRINSIC_EQ_OS:
3175 case INTRINSIC_NE_OS:
3176 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3177 && op1->ts.kind == op2->ts.kind)
3179 e->ts.type = BT_LOGICAL;
3180 e->ts.kind = gfc_default_logical_kind;
3184 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3186 gfc_type_convert_binary (e);
3188 e->ts.type = BT_LOGICAL;
3189 e->ts.kind = gfc_default_logical_kind;
3193 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3195 _("Logicals at %%L must be compared with %s instead of %s"),
3196 (e->value.op.op == INTRINSIC_EQ
3197 || e->value.op.op == INTRINSIC_EQ_OS)
3198 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3201 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3202 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3203 gfc_typename (&op2->ts));
3207 case INTRINSIC_USER:
3208 if (e->value.op.uop->op == NULL)
3209 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3210 else if (op2 == NULL)
3211 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3212 e->value.op.uop->name, gfc_typename (&op1->ts));
3214 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3215 e->value.op.uop->name, gfc_typename (&op1->ts),
3216 gfc_typename (&op2->ts));
3220 case INTRINSIC_PARENTHESES:
3222 if (e->ts.type == BT_CHARACTER)
3223 e->ts.cl = op1->ts.cl;
3227 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3230 /* Deal with arrayness of an operand through an operator. */
3234 switch (e->value.op.op)
3236 case INTRINSIC_PLUS:
3237 case INTRINSIC_MINUS:
3238 case INTRINSIC_TIMES:
3239 case INTRINSIC_DIVIDE:
3240 case INTRINSIC_POWER:
3241 case INTRINSIC_CONCAT:
3245 case INTRINSIC_NEQV:
3247 case INTRINSIC_EQ_OS:
3249 case INTRINSIC_NE_OS:
3251 case INTRINSIC_GT_OS:
3253 case INTRINSIC_GE_OS:
3255 case INTRINSIC_LT_OS:
3257 case INTRINSIC_LE_OS:
3259 if (op1->rank == 0 && op2->rank == 0)
3262 if (op1->rank == 0 && op2->rank != 0)
3264 e->rank = op2->rank;
3266 if (e->shape == NULL)
3267 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3270 if (op1->rank != 0 && op2->rank == 0)
3272 e->rank = op1->rank;
3274 if (e->shape == NULL)
3275 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3278 if (op1->rank != 0 && op2->rank != 0)
3280 if (op1->rank == op2->rank)
3282 e->rank = op1->rank;
3283 if (e->shape == NULL)
3285 t = compare_shapes(op1, op2);
3289 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3294 /* Allow higher level expressions to work. */
3297 /* Try user-defined operators, and otherwise throw an error. */
3298 dual_locus_error = true;
3300 _("Inconsistent ranks for operator at %%L and %%L"));
3307 case INTRINSIC_PARENTHESES:
3309 case INTRINSIC_UPLUS:
3310 case INTRINSIC_UMINUS:
3311 /* Simply copy arrayness attribute */
3312 e->rank = op1->rank;
3314 if (e->shape == NULL)
3315 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3323 /* Attempt to simplify the expression. */
3326 t = gfc_simplify_expr (e, 0);
3327 /* Some calls do not succeed in simplification and return FAILURE
3328 even though there is no error; e.g. variable references to
3329 PARAMETER arrays. */
3330 if (!gfc_is_constant_expr (e))
3337 if (gfc_extend_expr (e) == SUCCESS)
3340 if (dual_locus_error)
3341 gfc_error (msg, &op1->where, &op2->where);
3343 gfc_error (msg, &e->where);
3349 /************** Array resolution subroutines **************/
3352 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3355 /* Compare two integer expressions. */
3358 compare_bound (gfc_expr *a, gfc_expr *b)
3362 if (a == NULL || a->expr_type != EXPR_CONSTANT
3363 || b == NULL || b->expr_type != EXPR_CONSTANT)
3366 /* If either of the types isn't INTEGER, we must have
3367 raised an error earlier. */
3369 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3372 i = mpz_cmp (a->value.integer, b->value.integer);
3382 /* Compare an integer expression with an integer. */
3385 compare_bound_int (gfc_expr *a, int b)
3389 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3392 if (a->ts.type != BT_INTEGER)
3393 gfc_internal_error ("compare_bound_int(): Bad expression");
3395 i = mpz_cmp_si (a->value.integer, b);
3405 /* Compare an integer expression with a mpz_t. */
3408 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3412 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3415 if (a->ts.type != BT_INTEGER)
3416 gfc_internal_error ("compare_bound_int(): Bad expression");
3418 i = mpz_cmp (a->value.integer, b);
3428 /* Compute the last value of a sequence given by a triplet.
3429 Return 0 if it wasn't able to compute the last value, or if the
3430 sequence if empty, and 1 otherwise. */
3433 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3434 gfc_expr *stride, mpz_t last)
3438 if (start == NULL || start->expr_type != EXPR_CONSTANT
3439 || end == NULL || end->expr_type != EXPR_CONSTANT
3440 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3443 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3444 || (stride != NULL && stride->ts.type != BT_INTEGER))
3447 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3449 if (compare_bound (start, end) == CMP_GT)
3451 mpz_set (last, end->value.integer);
3455 if (compare_bound_int (stride, 0) == CMP_GT)
3457 /* Stride is positive */
3458 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3463 /* Stride is negative */
3464 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3469 mpz_sub (rem, end->value.integer, start->value.integer);
3470 mpz_tdiv_r (rem, rem, stride->value.integer);
3471 mpz_sub (last, end->value.integer, rem);
3478 /* Compare a single dimension of an array reference to the array
3482 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3486 /* Given start, end and stride values, calculate the minimum and
3487 maximum referenced indexes. */
3489 switch (ar->dimen_type[i])
3495 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3497 gfc_warning ("Array reference at %L is out of bounds "
3498 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3499 mpz_get_si (ar->start[i]->value.integer),
3500 mpz_get_si (as->lower[i]->value.integer), i+1);
3503 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3505 gfc_warning ("Array reference at %L is out of bounds "
3506 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3507 mpz_get_si (ar->start[i]->value.integer),
3508 mpz_get_si (as->upper[i]->value.integer), i+1);
3516 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3517 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3519 comparison comp_start_end = compare_bound (AR_START, AR_END);
3521 /* Check for zero stride, which is not allowed. */
3522 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3524 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3528 /* if start == len || (stride > 0 && start < len)
3529 || (stride < 0 && start > len),
3530 then the array section contains at least one element. In this
3531 case, there is an out-of-bounds access if
3532 (start < lower || start > upper). */
3533 if (compare_bound (AR_START, AR_END) == CMP_EQ
3534 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3535 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3536 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3537 && comp_start_end == CMP_GT))
3539 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3541 gfc_warning ("Lower array reference at %L is out of bounds "
3542 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3543 mpz_get_si (AR_START->value.integer),
3544 mpz_get_si (as->lower[i]->value.integer), i+1);
3547 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3549 gfc_warning ("Lower array reference at %L is out of bounds "
3550 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3551 mpz_get_si (AR_START->value.integer),
3552 mpz_get_si (as->upper[i]->value.integer), i+1);
3557 /* If we can compute the highest index of the array section,
3558 then it also has to be between lower and upper. */
3559 mpz_init (last_value);
3560 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3563 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3565 gfc_warning ("Upper array reference at %L is out of bounds "
3566 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3567 mpz_get_si (last_value),
3568 mpz_get_si (as->lower[i]->value.integer), i+1);
3569 mpz_clear (last_value);
3572 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3574 gfc_warning ("Upper array reference at %L is out of bounds "
3575 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3576 mpz_get_si (last_value),
3577 mpz_get_si (as->upper[i]->value.integer), i+1);
3578 mpz_clear (last_value);
3582 mpz_clear (last_value);
3590 gfc_internal_error ("check_dimension(): Bad array reference");
3597 /* Compare an array reference with an array specification. */
3600 compare_spec_to_ref (gfc_array_ref *ar)
3607 /* TODO: Full array sections are only allowed as actual parameters. */
3608 if (as->type == AS_ASSUMED_SIZE
3609 && (/*ar->type == AR_FULL
3610 ||*/ (ar->type == AR_SECTION
3611 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3613 gfc_error ("Rightmost upper bound of assumed size array section "
3614 "not specified at %L", &ar->where);
3618 if (ar->type == AR_FULL)
3621 if (as->rank != ar->dimen)
3623 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3624 &ar->where, ar->dimen, as->rank);
3628 for (i = 0; i < as->rank; i++)
3629 if (check_dimension (i, ar, as) == FAILURE)
3636 /* Resolve one part of an array index. */
3639 gfc_resolve_index (gfc_expr *index, int check_scalar)
3646 if (gfc_resolve_expr (index) == FAILURE)
3649 if (check_scalar && index->rank != 0)
3651 gfc_error ("Array index at %L must be scalar", &index->where);
3655 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3657 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3658 &index->where, gfc_basic_typename (index->ts.type));
3662 if (index->ts.type == BT_REAL)
3663 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3664 &index->where) == FAILURE)
3667 if (index->ts.kind != gfc_index_integer_kind
3668 || index->ts.type != BT_INTEGER)
3671 ts.type = BT_INTEGER;
3672 ts.kind = gfc_index_integer_kind;
3674 gfc_convert_type_warn (index, &ts, 2, 0);
3680 /* Resolve a dim argument to an intrinsic function. */
3683 gfc_resolve_dim_arg (gfc_expr *dim)
3688 if (gfc_resolve_expr (dim) == FAILURE)
3693 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3698 if (dim->ts.type != BT_INTEGER)
3700 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3704 if (dim->ts.kind != gfc_index_integer_kind)
3708 ts.type = BT_INTEGER;
3709 ts.kind = gfc_index_integer_kind;
3711 gfc_convert_type_warn (dim, &ts, 2, 0);
3717 /* Given an expression that contains array references, update those array
3718 references to point to the right array specifications. While this is
3719 filled in during matching, this information is difficult to save and load
3720 in a module, so we take care of it here.
3722 The idea here is that the original array reference comes from the
3723 base symbol. We traverse the list of reference structures, setting
3724 the stored reference to references. Component references can
3725 provide an additional array specification. */
3728 find_array_spec (gfc_expr *e)
3732 gfc_symbol *derived;
3735 as = e->symtree->n.sym->as;
3738 for (ref = e->ref; ref; ref = ref->next)
3743 gfc_internal_error ("find_array_spec(): Missing spec");
3750 if (derived == NULL)
3751 derived = e->symtree->n.sym->ts.derived;
3753 c = derived->components;
3755 for (; c; c = c->next)
3756 if (c == ref->u.c.component)
3758 /* Track the sequence of component references. */
3759 if (c->ts.type == BT_DERIVED)
3760 derived = c->ts.derived;
3765 gfc_internal_error ("find_array_spec(): Component not found");
3767 if (c->attr.dimension)
3770 gfc_internal_error ("find_array_spec(): unused as(1)");
3781 gfc_internal_error ("find_array_spec(): unused as(2)");
3785 /* Resolve an array reference. */
3788 resolve_array_ref (gfc_array_ref *ar)
3790 int i, check_scalar;
3793 for (i = 0; i < ar->dimen; i++)
3795 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3797 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3799 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3801 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3806 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3810 ar->dimen_type[i] = DIMEN_ELEMENT;
3814 ar->dimen_type[i] = DIMEN_VECTOR;
3815 if (e->expr_type == EXPR_VARIABLE
3816 && e->symtree->n.sym->ts.type == BT_DERIVED)
3817 ar->start[i] = gfc_get_parentheses (e);
3821 gfc_error ("Array index at %L is an array of rank %d",
3822 &ar->c_where[i], e->rank);
3827 /* If the reference type is unknown, figure out what kind it is. */
3829 if (ar->type == AR_UNKNOWN)
3831 ar->type = AR_ELEMENT;
3832 for (i = 0; i < ar->dimen; i++)
3833 if (ar->dimen_type[i] == DIMEN_RANGE
3834 || ar->dimen_type[i] == DIMEN_VECTOR)
3836 ar->type = AR_SECTION;
3841 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3849 resolve_substring (gfc_ref *ref)
3851 if (ref->u.ss.start != NULL)
3853 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3856 if (ref->u.ss.start->ts.type != BT_INTEGER)
3858 gfc_error ("Substring start index at %L must be of type INTEGER",
3859 &ref->u.ss.start->where);
3863 if (ref->u.ss.start->rank != 0)
3865 gfc_error ("Substring start index at %L must be scalar",
3866 &ref->u.ss.start->where);
3870 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3871 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3872 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3874 gfc_error ("Substring start index at %L is less than one",
3875 &ref->u.ss.start->where);
3880 if (ref->u.ss.end != NULL)
3882 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3885 if (ref->u.ss.end->ts.type != BT_INTEGER)
3887 gfc_error ("Substring end index at %L must be of type INTEGER",
3888 &ref->u.ss.end->where);
3892 if (ref->u.ss.end->rank != 0)
3894 gfc_error ("Substring end index at %L must be scalar",
3895 &ref->u.ss.end->where);
3899 if (ref->u.ss.length != NULL
3900 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3901 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3902 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3904 gfc_error ("Substring end index at %L exceeds the string length",
3905 &ref->u.ss.start->where);
3914 /* This function supplies missing substring charlens. */
3917 gfc_resolve_substring_charlen (gfc_expr *e)
3920 gfc_expr *start, *end;
3922 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3923 if (char_ref->type == REF_SUBSTRING)
3929 gcc_assert (char_ref->next == NULL);
3933 if (e->ts.cl->length)
3934 gfc_free_expr (e->ts.cl->length);
3935 else if (e->expr_type == EXPR_VARIABLE
3936 && e->symtree->n.sym->attr.dummy)
3940 e->ts.type = BT_CHARACTER;
3941 e->ts.kind = gfc_default_character_kind;
3945 e->ts.cl = gfc_get_charlen ();
3946 e->ts.cl->next = gfc_current_ns->cl_list;
3947 gfc_current_ns->cl_list = e->ts.cl;
3950 if (char_ref->u.ss.start)
3951 start = gfc_copy_expr (char_ref->u.ss.start);
3953 start = gfc_int_expr (1);
3955 if (char_ref->u.ss.end)
3956 end = gfc_copy_expr (char_ref->u.ss.end);
3957 else if (e->expr_type == EXPR_VARIABLE)
3958 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3965 /* Length = (end - start +1). */
3966 e->ts.cl->length = gfc_subtract (end, start);
3967 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3969 e->ts.cl->length->ts.type = BT_INTEGER;
3970 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3972 /* Make sure that the length is simplified. */
3973 gfc_simplify_expr (e->ts.cl->length, 1);
3974 gfc_resolve_expr (e->ts.cl->length);
3978 /* Resolve subtype references. */
3981 resolve_ref (gfc_expr *expr)
3983 int current_part_dimension, n_components, seen_part_dimension;
3986 for (ref = expr->ref; ref; ref = ref->next)
3987 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3989 find_array_spec (expr);
3993 for (ref = expr->ref; ref; ref = ref->next)
3997 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4005 resolve_substring (ref);
4009 /* Check constraints on part references. */
4011 current_part_dimension = 0;
4012 seen_part_dimension = 0;
4015 for (ref = expr->ref; ref; ref = ref->next)
4020 switch (ref->u.ar.type)
4024 current_part_dimension = 1;
4028 current_part_dimension = 0;
4032 gfc_internal_error ("resolve_ref(): Bad array reference");
4038 if (current_part_dimension || seen_part_dimension)
4040 if (ref->u.c.component->attr.pointer)
4042 gfc_error ("Component to the right of a part reference "
4043 "with nonzero rank must not have the POINTER "
4044 "attribute at %L", &expr->where);
4047 else if (ref->u.c.component->attr.allocatable)
4049 gfc_error ("Component to the right of a part reference "
4050 "with nonzero rank must not have the ALLOCATABLE "
4051 "attribute at %L", &expr->where);
4063 if (((ref->type == REF_COMPONENT && n_components > 1)
4064 || ref->next == NULL)
4065 && current_part_dimension
4066 && seen_part_dimension)
4068 gfc_error ("Two or more part references with nonzero rank must "
4069 "not be specified at %L", &expr->where);
4073 if (ref->type == REF_COMPONENT)
4075 if (current_part_dimension)
4076 seen_part_dimension = 1;
4078 /* reset to make sure */
4079 current_part_dimension = 0;
4087 /* Given an expression, determine its shape. This is easier than it sounds.
4088 Leaves the shape array NULL if it is not possible to determine the shape. */
4091 expression_shape (gfc_expr *e)
4093 mpz_t array[GFC_MAX_DIMENSIONS];
4096 if (e->rank == 0 || e->shape != NULL)
4099 for (i = 0; i < e->rank; i++)
4100 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4103 e->shape = gfc_get_shape (e->rank);
4105 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4110 for (i--; i >= 0; i--)
4111 mpz_clear (array[i]);
4115 /* Given a variable expression node, compute the rank of the expression by
4116 examining the base symbol and any reference structures it may have. */
4119 expression_rank (gfc_expr *e)
4124 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4125 could lead to serious confusion... */
4126 gcc_assert (e->expr_type != EXPR_COMPCALL);
4130 if (e->expr_type == EXPR_ARRAY)
4132 /* Constructors can have a rank different from one via RESHAPE(). */
4134 if (e->symtree == NULL)
4140 e->rank = (e->symtree->n.sym->as == NULL)
4141 ? 0 : e->symtree->n.sym->as->rank;
4147 for (ref = e->ref; ref; ref = ref->next)
4149 if (ref->type != REF_ARRAY)
4152 if (ref->u.ar.type == AR_FULL)
4154 rank = ref->u.ar.as->rank;
4158 if (ref->u.ar.type == AR_SECTION)
4160 /* Figure out the rank of the section. */
4162 gfc_internal_error ("expression_rank(): Two array specs");
4164 for (i = 0; i < ref->u.ar.dimen; i++)
4165 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4166 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4176 expression_shape (e);
4180 /* Resolve a variable expression. */
4183 resolve_variable (gfc_expr *e)
4190 if (e->symtree == NULL)
4193 if (e->ref && resolve_ref (e) == FAILURE)
4196 sym = e->symtree->n.sym;
4197 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
4199 e->ts.type = BT_PROCEDURE;
4200 goto resolve_procedure;
4203 if (sym->ts.type != BT_UNKNOWN)
4204 gfc_variable_attr (e, &e->ts);
4207 /* Must be a simple variable reference. */
4208 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4213 if (check_assumed_size_reference (sym, e))
4216 /* Deal with forward references to entries during resolve_code, to
4217 satisfy, at least partially, 12.5.2.5. */
4218 if (gfc_current_ns->entries
4219 && current_entry_id == sym->entry_id
4222 && cs_base->current->op != EXEC_ENTRY)
4224 gfc_entry_list *entry;
4225 gfc_formal_arglist *formal;
4229 /* If the symbol is a dummy... */
4230 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4232 entry = gfc_current_ns->entries;
4235 /* ...test if the symbol is a parameter of previous entries. */
4236 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4237 for (formal = entry->sym->formal; formal; formal = formal->next)
4239 if (formal->sym && sym->name == formal->sym->name)
4243 /* If it has not been seen as a dummy, this is an error. */
4246 if (specification_expr)
4247 gfc_error ("Variable '%s', used in a specification expression"
4248 ", is referenced at %L before the ENTRY statement "
4249 "in which it is a parameter",
4250 sym->name, &cs_base->current->loc);
4252 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4253 "statement in which it is a parameter",
4254 sym->name, &cs_base->current->loc);
4259 /* Now do the same check on the specification expressions. */
4260 specification_expr = 1;
4261 if (sym->ts.type == BT_CHARACTER
4262 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
4266 for (n = 0; n < sym->as->rank; n++)
4268 specification_expr = 1;
4269 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4271 specification_expr = 1;
4272 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4275 specification_expr = 0;
4278 /* Update the symbol's entry level. */
4279 sym->entry_id = current_entry_id + 1;
4283 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
4290 /* Checks to see that the correct symbol has been host associated.
4291 The only situation where this arises is that in which a twice
4292 contained function is parsed after the host association is made.
4293 Therefore, on detecting this, change the symbol in the expression
4294 and convert the array reference into an actual arglist if the old
4295 symbol is a variable. */
4297 check_host_association (gfc_expr *e)
4299 gfc_symbol *sym, *old_sym;
4303 gfc_actual_arglist *arg, *tail;
4304 bool retval = e->expr_type == EXPR_FUNCTION;
4306 /* If the expression is the result of substitution in
4307 interface.c(gfc_extend_expr) because there is no way in
4308 which the host association can be wrong. */
4309 if (e->symtree == NULL
4310 || e->symtree->n.sym == NULL
4311 || e->user_operator)
4314 old_sym = e->symtree->n.sym;
4316 if (gfc_current_ns->parent
4317 && old_sym->ns != gfc_current_ns)
4319 /* Use the 'USE' name so that renamed module symbols are
4320 correctly handled. */
4321 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
4323 if (sym && old_sym != sym
4324 && sym->ts.type == old_sym->ts.type
4325 && sym->attr.flavor == FL_PROCEDURE
4326 && sym->attr.contained)
4328 /* Clear the shape, since it might not be valid. */
4329 if (e->shape != NULL)
4331 for (n = 0; n < e->rank; n++)
4332 mpz_clear (e->shape[n]);
4334 gfc_free (e->shape);
4337 /* Give the symbol a symtree in the right place! */
4338 gfc_get_sym_tree (sym->name, gfc_current_ns, &st);
4341 if (old_sym->attr.flavor == FL_PROCEDURE)
4343 /* Original was function so point to the new symbol, since
4344 the actual argument list is already attached to the
4346 e->value.function.esym = NULL;
4351 /* Original was variable so convert array references into
4352 an actual arglist. This does not need any checking now
4353 since gfc_resolve_function will take care of it. */
4354 e->value.function.actual = NULL;
4355 e->expr_type = EXPR_FUNCTION;
4358 /* Ambiguity will not arise if the array reference is not
4359 the last reference. */
4360 for (ref = e->ref; ref; ref = ref->next)
4361 if (ref->type == REF_ARRAY && ref->next == NULL)
4364 gcc_assert (ref->type == REF_ARRAY);
4366 /* Grab the start expressions from the array ref and
4367 copy them into actual arguments. */
4368 for (n = 0; n < ref->u.ar.dimen; n++)
4370 arg = gfc_get_actual_arglist ();
4371 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
4372 if (e->value.function.actual == NULL)
4373 tail = e->value.function.actual = arg;
4381 /* Dump the reference list and set the rank. */
4382 gfc_free_ref_list (e->ref);
4384 e->rank = sym->as ? sym->as->rank : 0;
4387 gfc_resolve_expr (e);
4391 /* This might have changed! */
4392 return e->expr_type == EXPR_FUNCTION;
4397 gfc_resolve_character_operator (gfc_expr *e)
4399 gfc_expr *op1 = e->value.op.op1;
4400 gfc_expr *op2 = e->value.op.op2;
4401 gfc_expr *e1 = NULL;
4402 gfc_expr *e2 = NULL;
4404 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
4406 if (op1->ts.cl && op1->ts.cl->length)
4407 e1 = gfc_copy_expr (op1->ts.cl->length);
4408 else if (op1->expr_type == EXPR_CONSTANT)
4409 e1 = gfc_int_expr (op1->value.character.length);
4411 if (op2->ts.cl && op2->ts.cl->length)
4412 e2 = gfc_copy_expr (op2->ts.cl->length);
4413 else if (op2->expr_type == EXPR_CONSTANT)
4414 e2 = gfc_int_expr (op2->value.character.length);
4416 e->ts.cl = gfc_get_charlen ();
4417 e->ts.cl->next = gfc_current_ns->cl_list;
4418 gfc_current_ns->cl_list = e->ts.cl;
4423 e->ts.cl->length = gfc_add (e1, e2);
4424 e->ts.cl->length->ts.type = BT_INTEGER;
4425 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4426 gfc_simplify_expr (e->ts.cl->length, 0);
4427 gfc_resolve_expr (e->ts.cl->length);
4433 /* Ensure that an character expression has a charlen and, if possible, a
4434 length expression. */
4437 fixup_charlen (gfc_expr *e)
4439 /* The cases fall through so that changes in expression type and the need
4440 for multiple fixes are picked up. In all circumstances, a charlen should
4441 be available for the middle end to hang a backend_decl on. */
4442 switch (e->expr_type)
4445 gfc_resolve_character_operator (e);
4448 if (e->expr_type == EXPR_ARRAY)
4449 gfc_resolve_character_array_constructor (e);
4451 case EXPR_SUBSTRING:
4452 if (!e->ts.cl && e->ref)
4453 gfc_resolve_substring_charlen (e);
4458 e->ts.cl = gfc_get_charlen ();
4459 e->ts.cl->next = gfc_current_ns->cl_list;
4460 gfc_current_ns->cl_list = e->ts.cl;
4468 /* Update an actual argument to include the passed-object for type-bound
4469 procedures at the right position. */
4471 static gfc_actual_arglist*
4472 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
4474 gcc_assert (argpos > 0);
4478 gfc_actual_arglist* result;
4480 result = gfc_get_actual_arglist ();
4488 gcc_assert (argpos > 1);
4490 lst->next = update_arglist_pass (lst->next, po, argpos - 1);
4495 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4498 extract_compcall_passed_object (gfc_expr* e)
4502 gcc_assert (e->expr_type == EXPR_COMPCALL);
4504 po = gfc_get_expr ();
4505 po->expr_type = EXPR_VARIABLE;
4506 po->symtree = e->symtree;
4507 po->ref = gfc_copy_ref (e->ref);
4509 if (gfc_resolve_expr (po) == FAILURE)
4516 /* Update the arglist of an EXPR_COMPCALL expression to include the
4520 update_compcall_arglist (gfc_expr* e)
4523 gfc_typebound_proc* tbp;
4525 tbp = e->value.compcall.tbp;
4530 po = extract_compcall_passed_object (e);
4536 gfc_error ("Passed-object at %L must be scalar", &e->where);
4546 gcc_assert (tbp->pass_arg_num > 0);
4547 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4554 /* Check that the object a TBP is called on is valid, i.e. it must not be
4555 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
4558 check_typebound_baseobject (gfc_expr* e)
4562 base = extract_compcall_passed_object (e);
4566 gcc_assert (base->ts.type == BT_DERIVED);
4567 if (base->ts.derived->attr.abstract)
4569 gfc_error ("Base object for type-bound procedure call at %L is of"
4570 " ABSTRACT type '%s'", &e->where, base->ts.derived->name);
4578 /* Resolve a call to a type-bound procedure, either function or subroutine,
4579 statically from the data in an EXPR_COMPCALL expression. The adapted
4580 arglist and the target-procedure symtree are returned. */
4583 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
4584 gfc_actual_arglist** actual)
4586 gcc_assert (e->expr_type == EXPR_COMPCALL);
4587 gcc_assert (!e->value.compcall.tbp->is_generic);
4589 /* Update the actual arglist for PASS. */
4590 if (update_compcall_arglist (e) == FAILURE)
4593 *actual = e->value.compcall.actual;
4594 *target = e->value.compcall.tbp->u.specific;
4596 gfc_free_ref_list (e->ref);
4598 e->value.compcall.actual = NULL;
4604 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4605 which of the specific bindings (if any) matches the arglist and transform
4606 the expression into a call of that binding. */
4609 resolve_typebound_generic_call (gfc_expr* e)
4611 gfc_typebound_proc* genproc;
4612 const char* genname;
4614 gcc_assert (e->expr_type == EXPR_COMPCALL);
4615 genname = e->value.compcall.name;
4616 genproc = e->value.compcall.tbp;
4618 if (!genproc->is_generic)
4621 /* Try the bindings on this type and in the inheritance hierarchy. */
4622 for (; genproc; genproc = genproc->overridden)
4626 gcc_assert (genproc->is_generic);
4627 for (g = genproc->u.generic; g; g = g->next)
4630 gfc_actual_arglist* args;
4633 gcc_assert (g->specific);
4635 if (g->specific->error)
4638 target = g->specific->u.specific->n.sym;
4640 /* Get the right arglist by handling PASS/NOPASS. */
4641 args = gfc_copy_actual_arglist (e->value.compcall.actual);
4642 if (!g->specific->nopass)
4645 po = extract_compcall_passed_object (e);
4649 gcc_assert (g->specific->pass_arg_num > 0);
4650 gcc_assert (!g->specific->error);
4651 args = update_arglist_pass (args, po, g->specific->pass_arg_num);
4653 resolve_actual_arglist (args, target->attr.proc,
4654 is_external_proc (target) && !target->formal);
4656 /* Check if this arglist matches the formal. */
4657 matches = gfc_arglist_matches_symbol (&args, target);
4659 /* Clean up and break out of the loop if we've found it. */
4660 gfc_free_actual_arglist (args);
4663 e->value.compcall.tbp = g->specific;
4669 /* Nothing matching found! */
4670 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4671 " '%s' at %L", genname, &e->where);
4679 /* Resolve a call to a type-bound subroutine. */
4682 resolve_typebound_call (gfc_code* c)
4684 gfc_actual_arglist* newactual;
4685 gfc_symtree* target;
4687 /* Check that's really a SUBROUTINE. */
4688 if (!c->expr->value.compcall.tbp->subroutine)
4690 gfc_error ("'%s' at %L should be a SUBROUTINE",
4691 c->expr->value.compcall.name, &c->loc);
4695 if (check_typebound_baseobject (c->expr) == FAILURE)
4698 if (resolve_typebound_generic_call (c->expr) == FAILURE)
4701 /* Transform into an ordinary EXEC_CALL for now. */
4703 if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
4706 c->ext.actual = newactual;
4707 c->symtree = target;
4710 gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
4711 gfc_free_expr (c->expr);
4714 return resolve_call (c);
4718 /* Resolve a component-call expression. */
4721 resolve_compcall (gfc_expr* e)
4723 gfc_actual_arglist* newactual;
4724 gfc_symtree* target;
4726 /* Check that's really a FUNCTION. */
4727 if (!e->value.compcall.tbp->function)
4729 gfc_error ("'%s' at %L should be a FUNCTION",
4730 e->value.compcall.name, &e->where);
4734 if (check_typebound_baseobject (e) == FAILURE)
4737 if (resolve_typebound_generic_call (e) == FAILURE)
4739 gcc_assert (!e->value.compcall.tbp->is_generic);
4741 /* Take the rank from the function's symbol. */
4742 if (e->value.compcall.tbp->u.specific->n.sym->as)
4743 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
4745 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4746 arglist to the TBP's binding target. */
4748 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
4751 e->value.function.actual = newactual;
4752 e->value.function.name = e->value.compcall.name;
4753 e->value.function.isym = NULL;
4754 e->value.function.esym = NULL;
4755 e->symtree = target;
4756 e->ts = target->n.sym->ts;
4757 e->expr_type = EXPR_FUNCTION;
4759 return gfc_resolve_expr (e);
4763 /* Resolve an expression. That is, make sure that types of operands agree
4764 with their operators, intrinsic operators are converted to function calls
4765 for overloaded types and unresolved function references are resolved. */
4768 gfc_resolve_expr (gfc_expr *e)
4775 switch (e->expr_type)
4778 t = resolve_operator (e);
4784 if (check_host_association (e))
4785 t = resolve_function (e);
4788 t = resolve_variable (e);
4790 expression_rank (e);
4793 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4794 && e->ref->type != REF_SUBSTRING)
4795 gfc_resolve_substring_charlen (e);
4800 t = resolve_compcall (e);
4803 case EXPR_SUBSTRING:
4804 t = resolve_ref (e);
4814 if (resolve_ref (e) == FAILURE)
4817 t = gfc_resolve_array_constructor (e);
4818 /* Also try to expand a constructor. */
4821 expression_rank (e);
4822 gfc_expand_constructor (e);
4825 /* This provides the opportunity for the length of constructors with
4826 character valued function elements to propagate the string length
4827 to the expression. */
4828 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
4829 t = gfc_resolve_character_array_constructor (e);
4833 case EXPR_STRUCTURE:
4834 t = resolve_ref (e);
4838 t = resolve_structure_cons (e);
4842 t = gfc_simplify_expr (e, 0);
4846 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4849 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4856 /* Resolve an expression from an iterator. They must be scalar and have
4857 INTEGER or (optionally) REAL type. */
4860 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4861 const char *name_msgid)
4863 if (gfc_resolve_expr (expr) == FAILURE)
4866 if (expr->rank != 0)
4868 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4872 if (expr->ts.type != BT_INTEGER)
4874 if (expr->ts.type == BT_REAL)
4877 return gfc_notify_std (GFC_STD_F95_DEL,
4878 "Deleted feature: %s at %L must be integer",
4879 _(name_msgid), &expr->where);
4882 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4889 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4897 /* Resolve the expressions in an iterator structure. If REAL_OK is
4898 false allow only INTEGER type iterators, otherwise allow REAL types. */
4901 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4903 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4907 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4909 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4914 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4915 "Start expression in DO loop") == FAILURE)
4918 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4919 "End expression in DO loop") == FAILURE)
4922 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4923 "Step expression in DO loop") == FAILURE)
4926 if (iter->step->expr_type == EXPR_CONSTANT)
4928 if ((iter->step->ts.type == BT_INTEGER
4929 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4930 || (iter->step->ts.type == BT_REAL
4931 && mpfr_sgn (iter->step->value.real) == 0))
4933 gfc_error ("Step expression in DO loop at %L cannot be zero",
4934 &iter->step->where);
4939 /* Convert start, end, and step to the same type as var. */
4940 if (iter->start->ts.kind != iter->var->ts.kind
4941 || iter->start->ts.type != iter->var->ts.type)
4942 gfc_convert_type (iter->start, &iter->var->ts, 2);
4944 if (iter->end->ts.kind != iter->var->ts.kind
4945 || iter->end->ts.type != iter->var->ts.type)
4946 gfc_convert_type (iter->end, &iter->var->ts, 2);
4948 if (iter->step->ts.kind != iter->var->ts.kind
4949 || iter->step->ts.type != iter->var->ts.type)
4950 gfc_convert_type (iter->step, &iter->var->ts, 2);
4952 if (iter->start->expr_type == EXPR_CONSTANT
4953 && iter->end->expr_type == EXPR_CONSTANT
4954 && iter->step->expr_type == EXPR_CONSTANT)
4957 if (iter->start->ts.type == BT_INTEGER)
4959 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
4960 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
4964 sgn = mpfr_sgn (iter->step->value.real);
4965 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
4967 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
4968 gfc_warning ("DO loop at %L will be executed zero times",
4969 &iter->step->where);
4976 /* Traversal function for find_forall_index. f == 2 signals that
4977 that variable itself is not to be checked - only the references. */
4980 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
4982 if (expr->expr_type != EXPR_VARIABLE)
4985 /* A scalar assignment */
4986 if (!expr->ref || *f == 1)
4988 if (expr->symtree->n.sym == sym)
5000 /* Check whether the FORALL index appears in the expression or not.
5001 Returns SUCCESS if SYM is found in EXPR. */
5004 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
5006 if (gfc_traverse_expr (expr, sym, forall_index, f))
5013 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
5014 to be a scalar INTEGER variable. The subscripts and stride are scalar
5015 INTEGERs, and if stride is a constant it must be nonzero.
5016 Furthermore "A subscript or stride in a forall-triplet-spec shall
5017 not contain a reference to any index-name in the
5018 forall-triplet-spec-list in which it appears." (7.5.4.1) */
5021 resolve_forall_iterators (gfc_forall_iterator *it)
5023 gfc_forall_iterator *iter, *iter2;
5025 for (iter = it; iter; iter = iter->next)
5027 if (gfc_resolve_expr (iter->var) == SUCCESS
5028 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
5029 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
5032 if (gfc_resolve_expr (iter->start) == SUCCESS
5033 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
5034 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
5035 &iter->start->where);
5036 if (iter->var->ts.kind != iter->start->ts.kind)
5037 gfc_convert_type (iter->start, &iter->var->ts, 2);
5039 if (gfc_resolve_expr (iter->end) == SUCCESS
5040 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
5041 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
5043 if (iter->var->ts.kind != iter->end->ts.kind)
5044 gfc_convert_type (iter->end, &iter->var->ts, 2);
5046 if (gfc_resolve_expr (iter->stride) == SUCCESS)
5048 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
5049 gfc_error ("FORALL stride expression at %L must be a scalar %s",
5050 &iter->stride->where, "INTEGER");
5052 if (iter->stride->expr_type == EXPR_CONSTANT
5053 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
5054 gfc_error ("FORALL stride expression at %L cannot be zero",
5055 &iter->stride->where);
5057 if (iter->var->ts.kind != iter->stride->ts.kind)
5058 gfc_convert_type (iter->stride, &iter->var->ts, 2);
5061 for (iter = it; iter; iter = iter->next)
5062 for (iter2 = iter; iter2; iter2 = iter2->next)
5064 if (find_forall_index (iter2->start,
5065 iter->var->symtree->n.sym, 0) == SUCCESS
5066 || find_forall_index (iter2->end,
5067 iter->var->symtree->n.sym, 0) == SUCCESS
5068 || find_forall_index (iter2->stride,
5069 iter->var->symtree->n.sym, 0) == SUCCESS)
5070 gfc_error ("FORALL index '%s' may not appear in triplet "
5071 "specification at %L", iter->var->symtree->name,
5072 &iter2->start->where);
5077 /* Given a pointer to a symbol that is a derived type, see if it's
5078 inaccessible, i.e. if it's defined in another module and the components are
5079 PRIVATE. The search is recursive if necessary. Returns zero if no
5080 inaccessible components are found, nonzero otherwise. */
5083 derived_inaccessible (gfc_symbol *sym)
5087 if (sym->attr.use_assoc && sym->attr.private_comp)
5090 for (c = sym->components; c; c = c->next)
5092 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
5100 /* Resolve the argument of a deallocate expression. The expression must be
5101 a pointer or a full array. */
5104 resolve_deallocate_expr (gfc_expr *e)
5106 symbol_attribute attr;
5107 int allocatable, pointer, check_intent_in;
5110 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5111 check_intent_in = 1;
5113 if (gfc_resolve_expr (e) == FAILURE)
5116 if (e->expr_type != EXPR_VARIABLE)
5119 allocatable = e->symtree->n.sym->attr.allocatable;
5120 pointer = e->symtree->n.sym->attr.pointer;
5121 for (ref = e->ref; ref; ref = ref->next)
5124 check_intent_in = 0;
5129 if (ref->u.ar.type != AR_FULL)
5134 allocatable = (ref->u.c.component->as != NULL
5135 && ref->u.c.component->as->type == AS_DEFERRED);
5136 pointer = ref->u.c.component->attr.pointer;
5145 attr = gfc_expr_attr (e);
5147 if (allocatable == 0 && attr.pointer == 0)
5150 gfc_error ("Expression in DEALLOCATE statement at %L must be "
5151 "ALLOCATABLE or a POINTER", &e->where);
5155 && e->symtree->n.sym->attr.intent == INTENT_IN)
5157 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5158 e->symtree->n.sym->name, &e->where);
5166 /* Returns true if the expression e contains a reference to the symbol sym. */
5168 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5170 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
5177 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
5179 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
5183 /* Given the expression node e for an allocatable/pointer of derived type to be
5184 allocated, get the expression node to be initialized afterwards (needed for
5185 derived types with default initializers, and derived types with allocatable
5186 components that need nullification.) */
5189 expr_to_initialize (gfc_expr *e)
5195 result = gfc_copy_expr (e);
5197 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5198 for (ref = result->ref; ref; ref = ref->next)
5199 if (ref->type == REF_ARRAY && ref->next == NULL)
5201 ref->u.ar.type = AR_FULL;
5203 for (i = 0; i < ref->u.ar.dimen; i++)
5204 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
5206 result->rank = ref->u.ar.dimen;
5214 /* Resolve the expression in an ALLOCATE statement, doing the additional
5215 checks to see whether the expression is OK or not. The expression must
5216 have a trailing array reference that gives the size of the array. */
5219 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
5221 int i, pointer, allocatable, dimension, check_intent_in;
5222 symbol_attribute attr;
5223 gfc_ref *ref, *ref2;
5230 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5231 check_intent_in = 1;
5233 if (gfc_resolve_expr (e) == FAILURE)
5236 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
5237 sym = code->expr->symtree->n.sym;
5241 /* Make sure the expression is allocatable or a pointer. If it is
5242 pointer, the next-to-last reference must be a pointer. */
5246 if (e->expr_type != EXPR_VARIABLE)
5249 attr = gfc_expr_attr (e);
5250 pointer = attr.pointer;
5251 dimension = attr.dimension;
5255 allocatable = e->symtree->n.sym->attr.allocatable;
5256 pointer = e->symtree->n.sym->attr.pointer;
5257 dimension = e->symtree->n.sym->attr.dimension;
5259 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
5261 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
5262 "not be allocated in the same statement at %L",
5263 sym->name, &e->where);
5267 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
5270 check_intent_in = 0;
5275 if (ref->next != NULL)
5280 allocatable = (ref->u.c.component->as != NULL
5281 && ref->u.c.component->as->type == AS_DEFERRED);
5283 pointer = ref->u.c.component->attr.pointer;
5284 dimension = ref->u.c.component->attr.dimension;
5295 if (allocatable == 0 && pointer == 0)
5297 gfc_error ("Expression in ALLOCATE statement at %L must be "
5298 "ALLOCATABLE or a POINTER", &e->where);
5303 && e->symtree->n.sym->attr.intent == INTENT_IN)
5305 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5306 e->symtree->n.sym->name, &e->where);
5310 /* Add default initializer for those derived types that need them. */
5311 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
5313 init_st = gfc_get_code ();
5314 init_st->loc = code->loc;
5315 init_st->op = EXEC_INIT_ASSIGN;
5316 init_st->expr = expr_to_initialize (e);
5317 init_st->expr2 = init_e;
5318 init_st->next = code->next;
5319 code->next = init_st;
5322 if (pointer && dimension == 0)
5325 /* Make sure the next-to-last reference node is an array specification. */
5327 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
5329 gfc_error ("Array specification required in ALLOCATE statement "
5330 "at %L", &e->where);
5334 /* Make sure that the array section reference makes sense in the
5335 context of an ALLOCATE specification. */
5339 for (i = 0; i < ar->dimen; i++)
5341 if (ref2->u.ar.type == AR_ELEMENT)
5344 switch (ar->dimen_type[i])
5350 if (ar->start[i] != NULL
5351 && ar->end[i] != NULL
5352 && ar->stride[i] == NULL)
5355 /* Fall Through... */
5359 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5366 for (a = code->ext.alloc_list; a; a = a->next)
5368 sym = a->expr->symtree->n.sym;
5370 /* TODO - check derived type components. */
5371 if (sym->ts.type == BT_DERIVED)
5374 if ((ar->start[i] != NULL
5375 && gfc_find_sym_in_expr (sym, ar->start[i]))
5376 || (ar->end[i] != NULL
5377 && gfc_find_sym_in_expr (sym, ar->end[i])))
5379 gfc_error ("'%s' must not appear in the array specification at "
5380 "%L in the same ALLOCATE statement where it is "
5381 "itself allocated", sym->name, &ar->where);
5391 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
5393 gfc_symbol *s = NULL;
5397 s = code->expr->symtree->n.sym;
5401 if (s->attr.intent == INTENT_IN)
5402 gfc_error ("STAT variable '%s' of %s statement at %C cannot "
5403 "be INTENT(IN)", s->name, fcn);
5405 if (gfc_pure (NULL) && gfc_impure_variable (s))
5406 gfc_error ("Illegal STAT variable in %s statement at %C "
5407 "for a PURE procedure", fcn);
5410 if (s && code->expr->ts.type != BT_INTEGER)
5411 gfc_error ("STAT tag in %s statement at %L must be "
5412 "of type INTEGER", fcn, &code->expr->where);
5414 if (strcmp (fcn, "ALLOCATE") == 0)
5416 for (a = code->ext.alloc_list; a; a = a->next)
5417 resolve_allocate_expr (a->expr, code);
5421 for (a = code->ext.alloc_list; a; a = a->next)
5422 resolve_deallocate_expr (a->expr);
5426 /************ SELECT CASE resolution subroutines ************/
5428 /* Callback function for our mergesort variant. Determines interval
5429 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5430 op1 > op2. Assumes we're not dealing with the default case.
5431 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5432 There are nine situations to check. */
5435 compare_cases (const gfc_case *op1, const gfc_case *op2)
5439 if (op1->low == NULL) /* op1 = (:L) */
5441 /* op2 = (:N), so overlap. */
5443 /* op2 = (M:) or (M:N), L < M */
5444 if (op2->low != NULL
5445 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5448 else if (op1->high == NULL) /* op1 = (K:) */
5450 /* op2 = (M:), so overlap. */
5452 /* op2 = (:N) or (M:N), K > N */
5453 if (op2->high != NULL
5454 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5457 else /* op1 = (K:L) */
5459 if (op2->low == NULL) /* op2 = (:N), K > N */
5460 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5462 else if (op2->high == NULL) /* op2 = (M:), L < M */
5463 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5465 else /* op2 = (M:N) */
5469 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5472 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5481 /* Merge-sort a double linked case list, detecting overlap in the
5482 process. LIST is the head of the double linked case list before it
5483 is sorted. Returns the head of the sorted list if we don't see any
5484 overlap, or NULL otherwise. */
5487 check_case_overlap (gfc_case *list)
5489 gfc_case *p, *q, *e, *tail;
5490 int insize, nmerges, psize, qsize, cmp, overlap_seen;
5492 /* If the passed list was empty, return immediately. */
5499 /* Loop unconditionally. The only exit from this loop is a return
5500 statement, when we've finished sorting the case list. */
5507 /* Count the number of merges we do in this pass. */
5510 /* Loop while there exists a merge to be done. */
5515 /* Count this merge. */
5518 /* Cut the list in two pieces by stepping INSIZE places
5519 forward in the list, starting from P. */
5522 for (i = 0; i < insize; i++)
5531 /* Now we have two lists. Merge them! */
5532 while (psize > 0 || (qsize > 0 && q != NULL))
5534 /* See from which the next case to merge comes from. */
5537 /* P is empty so the next case must come from Q. */
5542 else if (qsize == 0 || q == NULL)
5551 cmp = compare_cases (p, q);
5554 /* The whole case range for P is less than the
5562 /* The whole case range for Q is greater than
5563 the case range for P. */
5570 /* The cases overlap, or they are the same
5571 element in the list. Either way, we must
5572 issue an error and get the next case from P. */
5573 /* FIXME: Sort P and Q by line number. */
5574 gfc_error ("CASE label at %L overlaps with CASE "
5575 "label at %L", &p->where, &q->where);
5583 /* Add the next element to the merged list. */
5592 /* P has now stepped INSIZE places along, and so has Q. So
5593 they're the same. */
5598 /* If we have done only one merge or none at all, we've
5599 finished sorting the cases. */
5608 /* Otherwise repeat, merging lists twice the size. */
5614 /* Check to see if an expression is suitable for use in a CASE statement.
5615 Makes sure that all case expressions are scalar constants of the same
5616 type. Return FAILURE if anything is wrong. */
5619 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5621 if (e == NULL) return SUCCESS;
5623 if (e->ts.type != case_expr->ts.type)
5625 gfc_error ("Expression in CASE statement at %L must be of type %s",
5626 &e->where, gfc_basic_typename (case_expr->ts.type));
5630 /* C805 (R808) For a given case-construct, each case-value shall be of
5631 the same type as case-expr. For character type, length differences
5632 are allowed, but the kind type parameters shall be the same. */
5634 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5636 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5637 &e->where, case_expr->ts.kind);
5641 /* Convert the case value kind to that of case expression kind, if needed.
5642 FIXME: Should a warning be issued? */
5643 if (e->ts.kind != case_expr->ts.kind)
5644 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5648 gfc_error ("Expression in CASE statement at %L must be scalar",
5657 /* Given a completely parsed select statement, we:
5659 - Validate all expressions and code within the SELECT.
5660 - Make sure that the selection expression is not of the wrong type.
5661 - Make sure that no case ranges overlap.
5662 - Eliminate unreachable cases and unreachable code resulting from
5663 removing case labels.
5665 The standard does allow unreachable cases, e.g. CASE (5:3). But
5666 they are a hassle for code generation, and to prevent that, we just
5667 cut them out here. This is not necessary for overlapping cases
5668 because they are illegal and we never even try to generate code.
5670 We have the additional caveat that a SELECT construct could have
5671 been a computed GOTO in the source code. Fortunately we can fairly
5672 easily work around that here: The case_expr for a "real" SELECT CASE
5673 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5674 we have to do is make sure that the case_expr is a scalar integer
5678 resolve_select (gfc_code *code)
5681 gfc_expr *case_expr;
5682 gfc_case *cp, *default_case, *tail, *head;
5683 int seen_unreachable;
5689 if (code->expr == NULL)
5691 /* This was actually a computed GOTO statement. */
5692 case_expr = code->expr2;
5693 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5694 gfc_error ("Selection expression in computed GOTO statement "
5695 "at %L must be a scalar integer expression",
5698 /* Further checking is not necessary because this SELECT was built
5699 by the compiler, so it should always be OK. Just move the
5700 case_expr from expr2 to expr so that we can handle computed
5701 GOTOs as normal SELECTs from here on. */
5702 code->expr = code->expr2;
5707 case_expr = code->expr;
5709 type = case_expr->ts.type;
5710 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5712 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5713 &case_expr->where, gfc_typename (&case_expr->ts));
5715 /* Punt. Going on here just produce more garbage error messages. */
5719 if (case_expr->rank != 0)
5721 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5722 "expression", &case_expr->where);
5728 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5729 of the SELECT CASE expression and its CASE values. Walk the lists
5730 of case values, and if we find a mismatch, promote case_expr to
5731 the appropriate kind. */
5733 if (type == BT_LOGICAL || type == BT_INTEGER)
5735 for (body = code->block; body; body = body->block)
5737 /* Walk the case label list. */
5738 for (cp = body->ext.case_list; cp; cp = cp->next)
5740 /* Intercept the DEFAULT case. It does not have a kind. */
5741 if (cp->low == NULL && cp->high == NULL)
5744 /* Unreachable case ranges are discarded, so ignore. */
5745 if (cp->low != NULL && cp->high != NULL
5746 && cp->low != cp->high
5747 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5750 /* FIXME: Should a warning be issued? */
5752 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5753 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5755 if (cp->high != NULL
5756 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5757 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5762 /* Assume there is no DEFAULT case. */
5763 default_case = NULL;
5768 for (body = code->block; body; body = body->block)
5770 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5772 seen_unreachable = 0;
5774 /* Walk the case label list, making sure that all case labels
5776 for (cp = body->ext.case_list; cp; cp = cp->next)
5778 /* Count the number of cases in the whole construct. */
5781 /* Intercept the DEFAULT case. */
5782 if (cp->low == NULL && cp->high == NULL)
5784 if (default_case != NULL)
5786 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5787 "by a second DEFAULT CASE at %L",
5788 &default_case->where, &cp->where);
5799 /* Deal with single value cases and case ranges. Errors are
5800 issued from the validation function. */
5801 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5802 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5808 if (type == BT_LOGICAL
5809 && ((cp->low == NULL || cp->high == NULL)
5810 || cp->low != cp->high))
5812 gfc_error ("Logical range in CASE statement at %L is not "
5813 "allowed", &cp->low->where);
5818 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5821 value = cp->low->value.logical == 0 ? 2 : 1;
5822 if (value & seen_logical)
5824 gfc_error ("constant logical value in CASE statement "
5825 "is repeated at %L",
5830 seen_logical |= value;
5833 if (cp->low != NULL && cp->high != NULL
5834 && cp->low != cp->high
5835 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5837 if (gfc_option.warn_surprising)
5838 gfc_warning ("Range specification at %L can never "
5839 "be matched", &cp->where);
5841 cp->unreachable = 1;
5842 seen_unreachable = 1;
5846 /* If the case range can be matched, it can also overlap with
5847 other cases. To make sure it does not, we put it in a
5848 double linked list here. We sort that with a merge sort
5849 later on to detect any overlapping cases. */
5853 head->right = head->left = NULL;
5858 tail->right->left = tail;
5865 /* It there was a failure in the previous case label, give up
5866 for this case label list. Continue with the next block. */
5870 /* See if any case labels that are unreachable have been seen.
5871 If so, we eliminate them. This is a bit of a kludge because
5872 the case lists for a single case statement (label) is a
5873 single forward linked lists. */
5874 if (seen_unreachable)
5876 /* Advance until the first case in the list is reachable. */
5877 while (body->ext.case_list != NULL
5878 && body->ext.case_list->unreachable)
5880 gfc_case *n = body->ext.case_list;
5881 body->ext.case_list = body->ext.case_list->next;
5883 gfc_free_case_list (n);
5886 /* Strip all other unreachable cases. */
5887 if (body->ext.case_list)
5889 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5891 if (cp->next->unreachable)
5893 gfc_case *n = cp->next;
5894 cp->next = cp->next->next;
5896 gfc_free_case_list (n);
5903 /* See if there were overlapping cases. If the check returns NULL,
5904 there was overlap. In that case we don't do anything. If head
5905 is non-NULL, we prepend the DEFAULT case. The sorted list can
5906 then used during code generation for SELECT CASE constructs with
5907 a case expression of a CHARACTER type. */
5910 head = check_case_overlap (head);
5912 /* Prepend the default_case if it is there. */
5913 if (head != NULL && default_case)
5915 default_case->left = NULL;
5916 default_case->right = head;
5917 head->left = default_case;
5921 /* Eliminate dead blocks that may be the result if we've seen
5922 unreachable case labels for a block. */
5923 for (body = code; body && body->block; body = body->block)
5925 if (body->block->ext.case_list == NULL)
5927 /* Cut the unreachable block from the code chain. */
5928 gfc_code *c = body->block;
5929 body->block = c->block;
5931 /* Kill the dead block, but not the blocks below it. */
5933 gfc_free_statements (c);
5937 /* More than two cases is legal but insane for logical selects.
5938 Issue a warning for it. */
5939 if (gfc_option.warn_surprising && type == BT_LOGICAL
5941 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5946 /* Resolve a transfer statement. This is making sure that:
5947 -- a derived type being transferred has only non-pointer components
5948 -- a derived type being transferred doesn't have private components, unless
5949 it's being transferred from the module where the type was defined
5950 -- we're not trying to transfer a whole assumed size array. */
5953 resolve_transfer (gfc_code *code)
5962 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5965 sym = exp->symtree->n.sym;
5968 /* Go to actual component transferred. */
5969 for (ref = code->expr->ref; ref; ref = ref->next)
5970 if (ref->type == REF_COMPONENT)
5971 ts = &ref->u.c.component->ts;
5973 if (ts->type == BT_DERIVED)
5975 /* Check that transferred derived type doesn't contain POINTER
5977 if (ts->derived->attr.pointer_comp)
5979 gfc_error ("Data transfer element at %L cannot have "
5980 "POINTER components", &code->loc);
5984 if (ts->derived->attr.alloc_comp)
5986 gfc_error ("Data transfer element at %L cannot have "
5987 "ALLOCATABLE components", &code->loc);
5991 if (derived_inaccessible (ts->derived))
5993 gfc_error ("Data transfer element at %L cannot have "
5994 "PRIVATE components",&code->loc);
5999 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
6000 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
6002 gfc_error ("Data transfer element at %L cannot be a full reference to "
6003 "an assumed-size array", &code->loc);
6009 /*********** Toplevel code resolution subroutines ***********/
6011 /* Find the set of labels that are reachable from this block. We also
6012 record the last statement in each block. */
6015 find_reachable_labels (gfc_code *block)
6022 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
6024 /* Collect labels in this block. We don't keep those corresponding
6025 to END {IF|SELECT}, these are checked in resolve_branch by going
6026 up through the code_stack. */
6027 for (c = block; c; c = c->next)
6029 if (c->here && c->op != EXEC_END_BLOCK)
6030 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
6033 /* Merge with labels from parent block. */
6036 gcc_assert (cs_base->prev->reachable_labels);
6037 bitmap_ior_into (cs_base->reachable_labels,
6038 cs_base->prev->reachable_labels);
6042 /* Given a branch to a label, see if the branch is conforming.
6043 The code node describes where the branch is located. */
6046 resolve_branch (gfc_st_label *label, gfc_code *code)
6053 /* Step one: is this a valid branching target? */
6055 if (label->defined == ST_LABEL_UNKNOWN)
6057 gfc_error ("Label %d referenced at %L is never defined", label->value,
6062 if (label->defined != ST_LABEL_TARGET)
6064 gfc_error ("Statement at %L is not a valid branch target statement "
6065 "for the branch statement at %L", &label->where, &code->loc);
6069 /* Step two: make sure this branch is not a branch to itself ;-) */
6071 if (code->here == label)
6073 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
6077 /* Step three: See if the label is in the same block as the
6078 branching statement. The hard work has been done by setting up
6079 the bitmap reachable_labels. */
6081 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
6084 /* Step four: If we haven't found the label in the bitmap, it may
6085 still be the label of the END of the enclosing block, in which
6086 case we find it by going up the code_stack. */
6088 for (stack = cs_base; stack; stack = stack->prev)
6089 if (stack->current->next && stack->current->next->here == label)
6094 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
6098 /* The label is not in an enclosing block, so illegal. This was
6099 allowed in Fortran 66, so we allow it as extension. No
6100 further checks are necessary in this case. */
6101 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
6102 "as the GOTO statement at %L", &label->where,
6108 /* Check whether EXPR1 has the same shape as EXPR2. */
6111 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
6113 mpz_t shape[GFC_MAX_DIMENSIONS];
6114 mpz_t shape2[GFC_MAX_DIMENSIONS];
6115 gfc_try result = FAILURE;
6118 /* Compare the rank. */
6119 if (expr1->rank != expr2->rank)
6122 /* Compare the size of each dimension. */
6123 for (i=0; i<expr1->rank; i++)
6125 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
6128 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
6131 if (mpz_cmp (shape[i], shape2[i]))
6135 /* When either of the two expression is an assumed size array, we
6136 ignore the comparison of dimension sizes. */
6141 for (i--; i >= 0; i--)
6143 mpz_clear (shape[i]);
6144 mpz_clear (shape2[i]);
6150 /* Check whether a WHERE assignment target or a WHERE mask expression
6151 has the same shape as the outmost WHERE mask expression. */
6154 resolve_where (gfc_code *code, gfc_expr *mask)
6160 cblock = code->block;
6162 /* Store the first WHERE mask-expr of the WHERE statement or construct.
6163 In case of nested WHERE, only the outmost one is stored. */
6164 if (mask == NULL) /* outmost WHERE */
6166 else /* inner WHERE */
6173 /* Check if the mask-expr has a consistent shape with the
6174 outmost WHERE mask-expr. */
6175 if (resolve_where_shape (cblock->expr, e) == FAILURE)
6176 gfc_error ("WHERE mask at %L has inconsistent shape",
6177 &cblock->expr->where);
6180 /* the assignment statement of a WHERE statement, or the first
6181 statement in where-body-construct of a WHERE construct */
6182 cnext = cblock->next;
6187 /* WHERE assignment statement */
6190 /* Check shape consistent for WHERE assignment target. */
6191 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
6192 gfc_error ("WHERE assignment target at %L has "
6193 "inconsistent shape", &cnext->expr->where);
6197 case EXEC_ASSIGN_CALL:
6198 resolve_call (cnext);
6199 if (!cnext->resolved_sym->attr.elemental)
6200 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6201 &cnext->ext.actual->expr->where);
6204 /* WHERE or WHERE construct is part of a where-body-construct */
6206 resolve_where (cnext, e);
6210 gfc_error ("Unsupported statement inside WHERE at %L",
6213 /* the next statement within the same where-body-construct */
6214 cnext = cnext->next;
6216 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6217 cblock = cblock->block;
6222 /* Resolve assignment in FORALL construct.
6223 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6224 FORALL index variables. */
6227 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
6231 for (n = 0; n < nvar; n++)
6233 gfc_symbol *forall_index;
6235 forall_index = var_expr[n]->symtree->n.sym;
6237 /* Check whether the assignment target is one of the FORALL index
6239 if ((code->expr->expr_type == EXPR_VARIABLE)
6240 && (code->expr->symtree->n.sym == forall_index))
6241 gfc_error ("Assignment to a FORALL index variable at %L",
6242 &code->expr->where);
6245 /* If one of the FORALL index variables doesn't appear in the
6246 assignment variable, then there could be a many-to-one
6247 assignment. Emit a warning rather than an error because the
6248 mask could be resolving this problem. */
6249 if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
6250 gfc_warning ("The FORALL with index '%s' is not used on the "
6251 "left side of the assignment at %L and so might "
6252 "cause multiple assignment to this object",
6253 var_expr[n]->symtree->name, &code->expr->where);
6259 /* Resolve WHERE statement in FORALL construct. */
6262 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
6263 gfc_expr **var_expr)
6268 cblock = code->block;
6271 /* the assignment statement of a WHERE statement, or the first
6272 statement in where-body-construct of a WHERE construct */
6273 cnext = cblock->next;
6278 /* WHERE assignment statement */
6280 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
6283 /* WHERE operator assignment statement */
6284 case EXEC_ASSIGN_CALL:
6285 resolve_call (cnext);
6286 if (!cnext->resolved_sym->attr.elemental)
6287 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6288 &cnext->ext.actual->expr->where);
6291 /* WHERE or WHERE construct is part of a where-body-construct */
6293 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
6297 gfc_error ("Unsupported statement inside WHERE at %L",
6300 /* the next statement within the same where-body-construct */
6301 cnext = cnext->next;
6303 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6304 cblock = cblock->block;
6309 /* Traverse the FORALL body to check whether the following errors exist:
6310 1. For assignment, check if a many-to-one assignment happens.
6311 2. For WHERE statement, check the WHERE body to see if there is any
6312 many-to-one assignment. */
6315 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
6319 c = code->block->next;
6325 case EXEC_POINTER_ASSIGN:
6326 gfc_resolve_assign_in_forall (c, nvar, var_expr);
6329 case EXEC_ASSIGN_CALL:
6333 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6334 there is no need to handle it here. */
6338 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
6343 /* The next statement in the FORALL body. */
6349 /* Counts the number of iterators needed inside a forall construct, including
6350 nested forall constructs. This is used to allocate the needed memory
6351 in gfc_resolve_forall. */
6354 gfc_count_forall_iterators (gfc_code *code)
6356 int max_iters, sub_iters, current_iters;
6357 gfc_forall_iterator *fa;
6359 gcc_assert(code->op == EXEC_FORALL);
6363 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6366 code = code->block->next;
6370 if (code->op == EXEC_FORALL)
6372 sub_iters = gfc_count_forall_iterators (code);
6373 if (sub_iters > max_iters)
6374 max_iters = sub_iters;
6379 return current_iters + max_iters;
6383 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6384 gfc_resolve_forall_body to resolve the FORALL body. */
6387 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
6389 static gfc_expr **var_expr;
6390 static int total_var = 0;
6391 static int nvar = 0;
6393 gfc_forall_iterator *fa;
6398 /* Start to resolve a FORALL construct */
6399 if (forall_save == 0)
6401 /* Count the total number of FORALL index in the nested FORALL
6402 construct in order to allocate the VAR_EXPR with proper size. */
6403 total_var = gfc_count_forall_iterators (code);
6405 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6406 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
6409 /* The information about FORALL iterator, including FORALL index start, end
6410 and stride. The FORALL index can not appear in start, end or stride. */
6411 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6413 /* Check if any outer FORALL index name is the same as the current
6415 for (i = 0; i < nvar; i++)
6417 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
6419 gfc_error ("An outer FORALL construct already has an index "
6420 "with this name %L", &fa->var->where);
6424 /* Record the current FORALL index. */
6425 var_expr[nvar] = gfc_copy_expr (fa->var);
6429 /* No memory leak. */
6430 gcc_assert (nvar <= total_var);
6433 /* Resolve the FORALL body. */
6434 gfc_resolve_forall_body (code, nvar, var_expr);
6436 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6437 gfc_resolve_blocks (code->block, ns);
6441 /* Free only the VAR_EXPRs allocated in this frame. */
6442 for (i = nvar; i < tmp; i++)
6443 gfc_free_expr (var_expr[i]);
6447 /* We are in the outermost FORALL construct. */
6448 gcc_assert (forall_save == 0);
6450 /* VAR_EXPR is not needed any more. */
6451 gfc_free (var_expr);
6457 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6460 static void resolve_code (gfc_code *, gfc_namespace *);
6463 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
6467 for (; b; b = b->block)
6469 t = gfc_resolve_expr (b->expr);
6470 if (gfc_resolve_expr (b->expr2) == FAILURE)
6476 if (t == SUCCESS && b->expr != NULL
6477 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
6478 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6485 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
6486 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6491 resolve_branch (b->label, b);
6504 case EXEC_OMP_ATOMIC:
6505 case EXEC_OMP_CRITICAL:
6507 case EXEC_OMP_MASTER:
6508 case EXEC_OMP_ORDERED:
6509 case EXEC_OMP_PARALLEL:
6510 case EXEC_OMP_PARALLEL_DO:
6511 case EXEC_OMP_PARALLEL_SECTIONS:
6512 case EXEC_OMP_PARALLEL_WORKSHARE:
6513 case EXEC_OMP_SECTIONS:
6514 case EXEC_OMP_SINGLE:
6516 case EXEC_OMP_TASKWAIT:
6517 case EXEC_OMP_WORKSHARE:
6521 gfc_internal_error ("resolve_block(): Bad block type");
6524 resolve_code (b->next, ns);
6529 /* Does everything to resolve an ordinary assignment. Returns true
6530 if this is an interface assignment. */
6532 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
6542 if (gfc_extend_assign (code, ns) == SUCCESS)
6544 lhs = code->ext.actual->expr;
6545 rhs = code->ext.actual->next->expr;
6546 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6548 gfc_error ("Subroutine '%s' called instead of assignment at "
6549 "%L must be PURE", code->symtree->n.sym->name,
6554 /* Make a temporary rhs when there is a default initializer
6555 and rhs is the same symbol as the lhs. */
6556 if (rhs->expr_type == EXPR_VARIABLE
6557 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6558 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6559 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6560 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6569 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
6570 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6571 &code->loc) == FAILURE)
6574 /* Handle the case of a BOZ literal on the RHS. */
6575 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
6578 if (gfc_option.warn_surprising)
6579 gfc_warning ("BOZ literal at %L is bitwise transferred "
6580 "non-integer symbol '%s'", &code->loc,
6581 lhs->symtree->n.sym->name);
6583 if (!gfc_convert_boz (rhs, &lhs->ts))
6585 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
6587 if (rc == ARITH_UNDERFLOW)
6588 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6589 ". This check can be disabled with the option "
6590 "-fno-range-check", &rhs->where);
6591 else if (rc == ARITH_OVERFLOW)
6592 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6593 ". This check can be disabled with the option "
6594 "-fno-range-check", &rhs->where);
6595 else if (rc == ARITH_NAN)
6596 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6597 ". This check can be disabled with the option "
6598 "-fno-range-check", &rhs->where);
6604 if (lhs->ts.type == BT_CHARACTER
6605 && gfc_option.warn_character_truncation)
6607 if (lhs->ts.cl != NULL
6608 && lhs->ts.cl->length != NULL
6609 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6610 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
6612 if (rhs->expr_type == EXPR_CONSTANT)
6613 rlen = rhs->value.character.length;
6615 else if (rhs->ts.cl != NULL
6616 && rhs->ts.cl->length != NULL
6617 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6618 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
6620 if (rlen && llen && rlen > llen)
6621 gfc_warning_now ("CHARACTER expression will be truncated "
6622 "in assignment (%d/%d) at %L",
6623 llen, rlen, &code->loc);
6626 /* Ensure that a vector index expression for the lvalue is evaluated
6627 to a temporary if the lvalue symbol is referenced in it. */
6630 for (ref = lhs->ref; ref; ref= ref->next)
6631 if (ref->type == REF_ARRAY)
6633 for (n = 0; n < ref->u.ar.dimen; n++)
6634 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
6635 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
6636 ref->u.ar.start[n]))
6638 = gfc_get_parentheses (ref->u.ar.start[n]);
6642 if (gfc_pure (NULL))
6644 if (gfc_impure_variable (lhs->symtree->n.sym))
6646 gfc_error ("Cannot assign to variable '%s' in PURE "
6648 lhs->symtree->n.sym->name,
6653 if (lhs->ts.type == BT_DERIVED
6654 && lhs->expr_type == EXPR_VARIABLE
6655 && lhs->ts.derived->attr.pointer_comp
6656 && gfc_impure_variable (rhs->symtree->n.sym))
6658 gfc_error ("The impure variable at %L is assigned to "
6659 "a derived type variable with a POINTER "
6660 "component in a PURE procedure (12.6)",
6666 gfc_check_assign (lhs, rhs, 1);
6670 /* Given a block of code, recursively resolve everything pointed to by this
6674 resolve_code (gfc_code *code, gfc_namespace *ns)
6676 int omp_workshare_save;
6681 frame.prev = cs_base;
6685 find_reachable_labels (code);
6687 for (; code; code = code->next)
6689 frame.current = code;
6690 forall_save = forall_flag;
6692 if (code->op == EXEC_FORALL)
6695 gfc_resolve_forall (code, ns, forall_save);
6698 else if (code->block)
6700 omp_workshare_save = -1;
6703 case EXEC_OMP_PARALLEL_WORKSHARE:
6704 omp_workshare_save = omp_workshare_flag;
6705 omp_workshare_flag = 1;
6706 gfc_resolve_omp_parallel_blocks (code, ns);
6708 case EXEC_OMP_PARALLEL:
6709 case EXEC_OMP_PARALLEL_DO:
6710 case EXEC_OMP_PARALLEL_SECTIONS:
6712 omp_workshare_save = omp_workshare_flag;
6713 omp_workshare_flag = 0;
6714 gfc_resolve_omp_parallel_blocks (code, ns);
6717 gfc_resolve_omp_do_blocks (code, ns);
6719 case EXEC_OMP_WORKSHARE:
6720 omp_workshare_save = omp_workshare_flag;
6721 omp_workshare_flag = 1;
6724 gfc_resolve_blocks (code->block, ns);
6728 if (omp_workshare_save != -1)
6729 omp_workshare_flag = omp_workshare_save;
6733 if (code->op != EXEC_COMPCALL)
6734 t = gfc_resolve_expr (code->expr);
6735 forall_flag = forall_save;
6737 if (gfc_resolve_expr (code->expr2) == FAILURE)
6743 case EXEC_END_BLOCK:
6753 /* Keep track of which entry we are up to. */
6754 current_entry_id = code->ext.entry->id;
6758 resolve_where (code, NULL);
6762 if (code->expr != NULL)
6764 if (code->expr->ts.type != BT_INTEGER)
6765 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6766 "INTEGER variable", &code->expr->where);
6767 else if (code->expr->symtree->n.sym->attr.assign != 1)
6768 gfc_error ("Variable '%s' has not been assigned a target "
6769 "label at %L", code->expr->symtree->n.sym->name,
6770 &code->expr->where);
6773 resolve_branch (code->label, code);
6777 if (code->expr != NULL
6778 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6779 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6780 "INTEGER return specifier", &code->expr->where);
6783 case EXEC_INIT_ASSIGN:
6790 if (resolve_ordinary_assign (code, ns))
6795 case EXEC_LABEL_ASSIGN:
6796 if (code->label->defined == ST_LABEL_UNKNOWN)
6797 gfc_error ("Label %d referenced at %L is never defined",
6798 code->label->value, &code->label->where);
6800 && (code->expr->expr_type != EXPR_VARIABLE
6801 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6802 || code->expr->symtree->n.sym->ts.kind
6803 != gfc_default_integer_kind
6804 || code->expr->symtree->n.sym->as != NULL))
6805 gfc_error ("ASSIGN statement at %L requires a scalar "
6806 "default INTEGER variable", &code->expr->where);
6809 case EXEC_POINTER_ASSIGN:
6813 gfc_check_pointer_assign (code->expr, code->expr2);
6816 case EXEC_ARITHMETIC_IF:
6818 && code->expr->ts.type != BT_INTEGER
6819 && code->expr->ts.type != BT_REAL)
6820 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6821 "expression", &code->expr->where);
6823 resolve_branch (code->label, code);
6824 resolve_branch (code->label2, code);
6825 resolve_branch (code->label3, code);
6829 if (t == SUCCESS && code->expr != NULL
6830 && (code->expr->ts.type != BT_LOGICAL
6831 || code->expr->rank != 0))
6832 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6833 &code->expr->where);
6838 resolve_call (code);
6842 resolve_typebound_call (code);
6846 /* Select is complicated. Also, a SELECT construct could be
6847 a transformed computed GOTO. */
6848 resolve_select (code);
6852 if (code->ext.iterator != NULL)
6854 gfc_iterator *iter = code->ext.iterator;
6855 if (gfc_resolve_iterator (iter, true) != FAILURE)
6856 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6861 if (code->expr == NULL)
6862 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6864 && (code->expr->rank != 0
6865 || code->expr->ts.type != BT_LOGICAL))
6866 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6867 "a scalar LOGICAL expression", &code->expr->where);
6872 resolve_allocate_deallocate (code, "ALLOCATE");
6876 case EXEC_DEALLOCATE:
6878 resolve_allocate_deallocate (code, "DEALLOCATE");
6883 if (gfc_resolve_open (code->ext.open) == FAILURE)
6886 resolve_branch (code->ext.open->err, code);
6890 if (gfc_resolve_close (code->ext.close) == FAILURE)
6893 resolve_branch (code->ext.close->err, code);
6896 case EXEC_BACKSPACE:
6900 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6903 resolve_branch (code->ext.filepos->err, code);
6907 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6910 resolve_branch (code->ext.inquire->err, code);
6914 gcc_assert (code->ext.inquire != NULL);
6915 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6918 resolve_branch (code->ext.inquire->err, code);
6922 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
6925 resolve_branch (code->ext.wait->err, code);
6926 resolve_branch (code->ext.wait->end, code);
6927 resolve_branch (code->ext.wait->eor, code);
6932 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6935 resolve_branch (code->ext.dt->err, code);
6936 resolve_branch (code->ext.dt->end, code);
6937 resolve_branch (code->ext.dt->eor, code);
6941 resolve_transfer (code);
6945 resolve_forall_iterators (code->ext.forall_iterator);
6947 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6948 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6949 "expression", &code->expr->where);
6952 case EXEC_OMP_ATOMIC:
6953 case EXEC_OMP_BARRIER:
6954 case EXEC_OMP_CRITICAL:
6955 case EXEC_OMP_FLUSH:
6957 case EXEC_OMP_MASTER:
6958 case EXEC_OMP_ORDERED:
6959 case EXEC_OMP_SECTIONS:
6960 case EXEC_OMP_SINGLE:
6961 case EXEC_OMP_TASKWAIT:
6962 case EXEC_OMP_WORKSHARE:
6963 gfc_resolve_omp_directive (code, ns);
6966 case EXEC_OMP_PARALLEL:
6967 case EXEC_OMP_PARALLEL_DO:
6968 case EXEC_OMP_PARALLEL_SECTIONS:
6969 case EXEC_OMP_PARALLEL_WORKSHARE:
6971 omp_workshare_save = omp_workshare_flag;
6972 omp_workshare_flag = 0;
6973 gfc_resolve_omp_directive (code, ns);
6974 omp_workshare_flag = omp_workshare_save;
6978 gfc_internal_error ("resolve_code(): Bad statement code");
6982 cs_base = frame.prev;
6986 /* Resolve initial values and make sure they are compatible with
6990 resolve_values (gfc_symbol *sym)
6992 if (sym->value == NULL)
6995 if (gfc_resolve_expr (sym->value) == FAILURE)
6998 gfc_check_assign_symbol (sym, sym->value);
7002 /* Verify the binding labels for common blocks that are BIND(C). The label
7003 for a BIND(C) common block must be identical in all scoping units in which
7004 the common block is declared. Further, the binding label can not collide
7005 with any other global entity in the program. */
7008 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
7010 if (comm_block_tree->n.common->is_bind_c == 1)
7012 gfc_gsymbol *binding_label_gsym;
7013 gfc_gsymbol *comm_name_gsym;
7015 /* See if a global symbol exists by the common block's name. It may
7016 be NULL if the common block is use-associated. */
7017 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
7018 comm_block_tree->n.common->name);
7019 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
7020 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
7021 "with the global entity '%s' at %L",
7022 comm_block_tree->n.common->binding_label,
7023 comm_block_tree->n.common->name,
7024 &(comm_block_tree->n.common->where),
7025 comm_name_gsym->name, &(comm_name_gsym->where));
7026 else if (comm_name_gsym != NULL
7027 && strcmp (comm_name_gsym->name,
7028 comm_block_tree->n.common->name) == 0)
7030 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
7032 if (comm_name_gsym->binding_label == NULL)
7033 /* No binding label for common block stored yet; save this one. */
7034 comm_name_gsym->binding_label =
7035 comm_block_tree->n.common->binding_label;
7037 if (strcmp (comm_name_gsym->binding_label,
7038 comm_block_tree->n.common->binding_label) != 0)
7040 /* Common block names match but binding labels do not. */
7041 gfc_error ("Binding label '%s' for common block '%s' at %L "
7042 "does not match the binding label '%s' for common "
7044 comm_block_tree->n.common->binding_label,
7045 comm_block_tree->n.common->name,
7046 &(comm_block_tree->n.common->where),
7047 comm_name_gsym->binding_label,
7048 comm_name_gsym->name,
7049 &(comm_name_gsym->where));
7054 /* There is no binding label (NAME="") so we have nothing further to
7055 check and nothing to add as a global symbol for the label. */
7056 if (comm_block_tree->n.common->binding_label[0] == '\0' )
7059 binding_label_gsym =
7060 gfc_find_gsymbol (gfc_gsym_root,
7061 comm_block_tree->n.common->binding_label);
7062 if (binding_label_gsym == NULL)
7064 /* Need to make a global symbol for the binding label to prevent
7065 it from colliding with another. */
7066 binding_label_gsym =
7067 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
7068 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
7069 binding_label_gsym->type = GSYM_COMMON;
7073 /* If comm_name_gsym is NULL, the name common block is use
7074 associated and the name could be colliding. */
7075 if (binding_label_gsym->type != GSYM_COMMON)
7076 gfc_error ("Binding label '%s' for common block '%s' at %L "
7077 "collides with the global entity '%s' at %L",
7078 comm_block_tree->n.common->binding_label,
7079 comm_block_tree->n.common->name,
7080 &(comm_block_tree->n.common->where),
7081 binding_label_gsym->name,
7082 &(binding_label_gsym->where));
7083 else if (comm_name_gsym != NULL
7084 && (strcmp (binding_label_gsym->name,
7085 comm_name_gsym->binding_label) != 0)
7086 && (strcmp (binding_label_gsym->sym_name,
7087 comm_name_gsym->name) != 0))
7088 gfc_error ("Binding label '%s' for common block '%s' at %L "
7089 "collides with global entity '%s' at %L",
7090 binding_label_gsym->name, binding_label_gsym->sym_name,
7091 &(comm_block_tree->n.common->where),
7092 comm_name_gsym->name, &(comm_name_gsym->where));
7100 /* Verify any BIND(C) derived types in the namespace so we can report errors
7101 for them once, rather than for each variable declared of that type. */
7104 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
7106 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
7107 && derived_sym->attr.is_bind_c == 1)
7108 verify_bind_c_derived_type (derived_sym);
7114 /* Verify that any binding labels used in a given namespace do not collide
7115 with the names or binding labels of any global symbols. */
7118 gfc_verify_binding_labels (gfc_symbol *sym)
7122 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
7123 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
7125 gfc_gsymbol *bind_c_sym;
7127 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
7128 if (bind_c_sym != NULL
7129 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
7131 if (sym->attr.if_source == IFSRC_DECL
7132 && (bind_c_sym->type != GSYM_SUBROUTINE
7133 && bind_c_sym->type != GSYM_FUNCTION)
7134 && ((sym->attr.contained == 1
7135 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
7136 || (sym->attr.use_assoc == 1
7137 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
7139 /* Make sure global procedures don't collide with anything. */
7140 gfc_error ("Binding label '%s' at %L collides with the global "
7141 "entity '%s' at %L", sym->binding_label,
7142 &(sym->declared_at), bind_c_sym->name,
7143 &(bind_c_sym->where));
7146 else if (sym->attr.contained == 0
7147 && (sym->attr.if_source == IFSRC_IFBODY
7148 && sym->attr.flavor == FL_PROCEDURE)
7149 && (bind_c_sym->sym_name != NULL
7150 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
7152 /* Make sure procedures in interface bodies don't collide. */
7153 gfc_error ("Binding label '%s' in interface body at %L collides "
7154 "with the global entity '%s' at %L",
7156 &(sym->declared_at), bind_c_sym->name,
7157 &(bind_c_sym->where));
7160 else if (sym->attr.contained == 0
7161 && sym->attr.if_source == IFSRC_UNKNOWN)
7162 if ((sym->attr.use_assoc && bind_c_sym->mod_name
7163 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
7164 || sym->attr.use_assoc == 0)
7166 gfc_error ("Binding label '%s' at %L collides with global "
7167 "entity '%s' at %L", sym->binding_label,
7168 &(sym->declared_at), bind_c_sym->name,
7169 &(bind_c_sym->where));
7174 /* Clear the binding label to prevent checking multiple times. */
7175 sym->binding_label[0] = '\0';
7177 else if (bind_c_sym == NULL)
7179 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
7180 bind_c_sym->where = sym->declared_at;
7181 bind_c_sym->sym_name = sym->name;
7183 if (sym->attr.use_assoc == 1)
7184 bind_c_sym->mod_name = sym->module;
7186 if (sym->ns->proc_name != NULL)
7187 bind_c_sym->mod_name = sym->ns->proc_name->name;
7189 if (sym->attr.contained == 0)
7191 if (sym->attr.subroutine)
7192 bind_c_sym->type = GSYM_SUBROUTINE;
7193 else if (sym->attr.function)
7194 bind_c_sym->type = GSYM_FUNCTION;
7202 /* Resolve an index expression. */
7205 resolve_index_expr (gfc_expr *e)
7207 if (gfc_resolve_expr (e) == FAILURE)
7210 if (gfc_simplify_expr (e, 0) == FAILURE)
7213 if (gfc_specification_expr (e) == FAILURE)
7219 /* Resolve a charlen structure. */
7222 resolve_charlen (gfc_charlen *cl)
7231 specification_expr = 1;
7233 if (resolve_index_expr (cl->length) == FAILURE)
7235 specification_expr = 0;
7239 /* "If the character length parameter value evaluates to a negative
7240 value, the length of character entities declared is zero." */
7241 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
7243 gfc_warning_now ("CHARACTER variable has zero length at %L",
7244 &cl->length->where);
7245 gfc_replace_expr (cl->length, gfc_int_expr (0));
7252 /* Test for non-constant shape arrays. */
7255 is_non_constant_shape_array (gfc_symbol *sym)
7261 not_constant = false;
7262 if (sym->as != NULL)
7264 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7265 has not been simplified; parameter array references. Do the
7266 simplification now. */
7267 for (i = 0; i < sym->as->rank; i++)
7269 e = sym->as->lower[i];
7270 if (e && (resolve_index_expr (e) == FAILURE
7271 || !gfc_is_constant_expr (e)))
7272 not_constant = true;
7274 e = sym->as->upper[i];
7275 if (e && (resolve_index_expr (e) == FAILURE
7276 || !gfc_is_constant_expr (e)))
7277 not_constant = true;
7280 return not_constant;
7283 /* Given a symbol and an initialization expression, add code to initialize
7284 the symbol to the function entry. */
7286 build_init_assign (gfc_symbol *sym, gfc_expr *init)
7290 gfc_namespace *ns = sym->ns;
7292 /* Search for the function namespace if this is a contained
7293 function without an explicit result. */
7294 if (sym->attr.function && sym == sym->result
7295 && sym->name != sym->ns->proc_name->name)
7298 for (;ns; ns = ns->sibling)
7299 if (strcmp (ns->proc_name->name, sym->name) == 0)
7305 gfc_free_expr (init);
7309 /* Build an l-value expression for the result. */
7310 lval = gfc_lval_expr_from_sym (sym);
7312 /* Add the code at scope entry. */
7313 init_st = gfc_get_code ();
7314 init_st->next = ns->code;
7317 /* Assign the default initializer to the l-value. */
7318 init_st->loc = sym->declared_at;
7319 init_st->op = EXEC_INIT_ASSIGN;
7320 init_st->expr = lval;
7321 init_st->expr2 = init;
7324 /* Assign the default initializer to a derived type variable or result. */
7327 apply_default_init (gfc_symbol *sym)
7329 gfc_expr *init = NULL;
7331 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7334 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
7335 init = gfc_default_initializer (&sym->ts);
7340 build_init_assign (sym, init);
7343 /* Build an initializer for a local integer, real, complex, logical, or
7344 character variable, based on the command line flags finit-local-zero,
7345 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7346 null if the symbol should not have a default initialization. */
7348 build_default_init_expr (gfc_symbol *sym)
7351 gfc_expr *init_expr;
7354 /* These symbols should never have a default initialization. */
7355 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
7356 || sym->attr.external
7358 || sym->attr.pointer
7359 || sym->attr.in_equivalence
7360 || sym->attr.in_common
7363 || sym->attr.cray_pointee
7364 || sym->attr.cray_pointer)
7367 /* Now we'll try to build an initializer expression. */
7368 init_expr = gfc_get_expr ();
7369 init_expr->expr_type = EXPR_CONSTANT;
7370 init_expr->ts.type = sym->ts.type;
7371 init_expr->ts.kind = sym->ts.kind;
7372 init_expr->where = sym->declared_at;
7374 /* We will only initialize integers, reals, complex, logicals, and
7375 characters, and only if the corresponding command-line flags
7376 were set. Otherwise, we free init_expr and return null. */
7377 switch (sym->ts.type)
7380 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
7381 mpz_init_set_si (init_expr->value.integer,
7382 gfc_option.flag_init_integer_value);
7385 gfc_free_expr (init_expr);
7391 mpfr_init (init_expr->value.real);
7392 switch (gfc_option.flag_init_real)
7394 case GFC_INIT_REAL_SNAN:
7395 init_expr->is_snan = 1;
7397 case GFC_INIT_REAL_NAN:
7398 mpfr_set_nan (init_expr->value.real);
7401 case GFC_INIT_REAL_INF:
7402 mpfr_set_inf (init_expr->value.real, 1);
7405 case GFC_INIT_REAL_NEG_INF:
7406 mpfr_set_inf (init_expr->value.real, -1);
7409 case GFC_INIT_REAL_ZERO:
7410 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
7414 gfc_free_expr (init_expr);
7421 mpfr_init (init_expr->value.complex.r);
7422 mpfr_init (init_expr->value.complex.i);
7423 switch (gfc_option.flag_init_real)
7425 case GFC_INIT_REAL_SNAN:
7426 init_expr->is_snan = 1;
7428 case GFC_INIT_REAL_NAN:
7429 mpfr_set_nan (init_expr->value.complex.r);
7430 mpfr_set_nan (init_expr->value.complex.i);
7433 case GFC_INIT_REAL_INF:
7434 mpfr_set_inf (init_expr->value.complex.r, 1);
7435 mpfr_set_inf (init_expr->value.complex.i, 1);
7438 case GFC_INIT_REAL_NEG_INF:
7439 mpfr_set_inf (init_expr->value.complex.r, -1);
7440 mpfr_set_inf (init_expr->value.complex.i, -1);
7443 case GFC_INIT_REAL_ZERO:
7444 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
7445 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
7449 gfc_free_expr (init_expr);
7456 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
7457 init_expr->value.logical = 0;
7458 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
7459 init_expr->value.logical = 1;
7462 gfc_free_expr (init_expr);
7468 /* For characters, the length must be constant in order to
7469 create a default initializer. */
7470 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
7471 && sym->ts.cl->length
7472 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
7474 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
7475 init_expr->value.character.length = char_len;
7476 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
7477 for (i = 0; i < char_len; i++)
7478 init_expr->value.character.string[i]
7479 = (unsigned char) gfc_option.flag_init_character_value;
7483 gfc_free_expr (init_expr);
7489 gfc_free_expr (init_expr);
7495 /* Add an initialization expression to a local variable. */
7497 apply_default_init_local (gfc_symbol *sym)
7499 gfc_expr *init = NULL;
7501 /* The symbol should be a variable or a function return value. */
7502 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7503 || (sym->attr.function && sym->result != sym))
7506 /* Try to build the initializer expression. If we can't initialize
7507 this symbol, then init will be NULL. */
7508 init = build_default_init_expr (sym);
7512 /* For saved variables, we don't want to add an initializer at
7513 function entry, so we just add a static initializer. */
7514 if (sym->attr.save || sym->ns->save_all)
7516 /* Don't clobber an existing initializer! */
7517 gcc_assert (sym->value == NULL);
7522 build_init_assign (sym, init);
7525 /* Resolution of common features of flavors variable and procedure. */
7528 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
7530 /* Constraints on deferred shape variable. */
7531 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
7533 if (sym->attr.allocatable)
7535 if (sym->attr.dimension)
7536 gfc_error ("Allocatable array '%s' at %L must have "
7537 "a deferred shape", sym->name, &sym->declared_at);
7539 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7540 sym->name, &sym->declared_at);
7544 if (sym->attr.pointer && sym->attr.dimension)
7546 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7547 sym->name, &sym->declared_at);
7554 if (!mp_flag && !sym->attr.allocatable
7555 && !sym->attr.pointer && !sym->attr.dummy)
7557 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7558 sym->name, &sym->declared_at);
7566 /* Additional checks for symbols with flavor variable and derived
7567 type. To be called from resolve_fl_variable. */
7570 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
7572 gcc_assert (sym->ts.type == BT_DERIVED);
7574 /* Check to see if a derived type is blocked from being host
7575 associated by the presence of another class I symbol in the same
7576 namespace. 14.6.1.3 of the standard and the discussion on
7577 comp.lang.fortran. */
7578 if (sym->ns != sym->ts.derived->ns
7579 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
7582 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
7583 if (s && s->attr.flavor != FL_DERIVED)
7585 gfc_error ("The type '%s' cannot be host associated at %L "
7586 "because it is blocked by an incompatible object "
7587 "of the same name declared at %L",
7588 sym->ts.derived->name, &sym->declared_at,
7594 /* 4th constraint in section 11.3: "If an object of a type for which
7595 component-initialization is specified (R429) appears in the
7596 specification-part of a module and does not have the ALLOCATABLE
7597 or POINTER attribute, the object shall have the SAVE attribute."
7599 The check for initializers is performed with
7600 has_default_initializer because gfc_default_initializer generates
7601 a hidden default for allocatable components. */
7602 if (!(sym->value || no_init_flag) && sym->ns->proc_name
7603 && sym->ns->proc_name->attr.flavor == FL_MODULE
7604 && !sym->ns->save_all && !sym->attr.save
7605 && !sym->attr.pointer && !sym->attr.allocatable
7606 && has_default_initializer (sym->ts.derived))
7608 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7609 "default initialization of a component",
7610 sym->name, &sym->declared_at);
7614 /* Assign default initializer. */
7615 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
7616 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
7618 sym->value = gfc_default_initializer (&sym->ts);
7625 /* Resolve symbols with flavor variable. */
7628 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
7630 int no_init_flag, automatic_flag;
7632 const char *auto_save_msg;
7634 auto_save_msg = "Automatic object '%s' at %L cannot have the "
7637 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7640 /* Set this flag to check that variables are parameters of all entries.
7641 This check is effected by the call to gfc_resolve_expr through
7642 is_non_constant_shape_array. */
7643 specification_expr = 1;
7645 if (sym->ns->proc_name
7646 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7647 || sym->ns->proc_name->attr.is_main_program)
7648 && !sym->attr.use_assoc
7649 && !sym->attr.allocatable
7650 && !sym->attr.pointer
7651 && is_non_constant_shape_array (sym))
7653 /* The shape of a main program or module array needs to be
7655 gfc_error ("The module or main program array '%s' at %L must "
7656 "have constant shape", sym->name, &sym->declared_at);
7657 specification_expr = 0;
7661 if (sym->ts.type == BT_CHARACTER)
7663 /* Make sure that character string variables with assumed length are
7665 e = sym->ts.cl->length;
7666 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
7668 gfc_error ("Entity with assumed character length at %L must be a "
7669 "dummy argument or a PARAMETER", &sym->declared_at);
7673 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7675 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7679 if (!gfc_is_constant_expr (e)
7680 && !(e->expr_type == EXPR_VARIABLE
7681 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7682 && sym->ns->proc_name
7683 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7684 || sym->ns->proc_name->attr.is_main_program)
7685 && !sym->attr.use_assoc)
7687 gfc_error ("'%s' at %L must have constant character length "
7688 "in this context", sym->name, &sym->declared_at);
7693 if (sym->value == NULL && sym->attr.referenced)
7694 apply_default_init_local (sym); /* Try to apply a default initialization. */
7696 /* Determine if the symbol may not have an initializer. */
7697 no_init_flag = automatic_flag = 0;
7698 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7699 || sym->attr.intrinsic || sym->attr.result)
7701 else if (sym->attr.dimension && !sym->attr.pointer
7702 && is_non_constant_shape_array (sym))
7704 no_init_flag = automatic_flag = 1;
7706 /* Also, they must not have the SAVE attribute.
7707 SAVE_IMPLICIT is checked below. */
7708 if (sym->attr.save == SAVE_EXPLICIT)
7710 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7715 /* Ensure that any initializer is simplified. */
7717 gfc_simplify_expr (sym->value, 1);
7719 /* Reject illegal initializers. */
7720 if (!sym->mark && sym->value)
7722 if (sym->attr.allocatable)
7723 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7724 sym->name, &sym->declared_at);
7725 else if (sym->attr.external)
7726 gfc_error ("External '%s' at %L cannot have an initializer",
7727 sym->name, &sym->declared_at);
7728 else if (sym->attr.dummy
7729 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7730 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7731 sym->name, &sym->declared_at);
7732 else if (sym->attr.intrinsic)
7733 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7734 sym->name, &sym->declared_at);
7735 else if (sym->attr.result)
7736 gfc_error ("Function result '%s' at %L cannot have an initializer",
7737 sym->name, &sym->declared_at);
7738 else if (automatic_flag)
7739 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7740 sym->name, &sym->declared_at);
7747 if (sym->ts.type == BT_DERIVED)
7748 return resolve_fl_variable_derived (sym, no_init_flag);
7754 /* Resolve a procedure. */
7757 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7759 gfc_formal_arglist *arg;
7761 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7762 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7763 "interfaces", sym->name, &sym->declared_at);
7765 if (sym->attr.function
7766 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7769 if (sym->ts.type == BT_CHARACTER)
7771 gfc_charlen *cl = sym->ts.cl;
7773 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7774 && resolve_charlen (cl) == FAILURE)
7777 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7779 if (sym->attr.proc == PROC_ST_FUNCTION)
7781 gfc_error ("Character-valued statement function '%s' at %L must "
7782 "have constant length", sym->name, &sym->declared_at);
7786 if (sym->attr.external && sym->formal == NULL
7787 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7789 gfc_error ("Automatic character length function '%s' at %L must "
7790 "have an explicit interface", sym->name,
7797 /* Ensure that derived type for are not of a private type. Internal
7798 module procedures are excluded by 2.2.3.3 - i.e., they are not
7799 externally accessible and can access all the objects accessible in
7801 if (!(sym->ns->parent
7802 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7803 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7805 gfc_interface *iface;
7807 for (arg = sym->formal; arg; arg = arg->next)
7810 && arg->sym->ts.type == BT_DERIVED
7811 && !arg->sym->ts.derived->attr.use_assoc
7812 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7813 arg->sym->ts.derived->ns->default_access)
7814 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7815 "PRIVATE type and cannot be a dummy argument"
7816 " of '%s', which is PUBLIC at %L",
7817 arg->sym->name, sym->name, &sym->declared_at)
7820 /* Stop this message from recurring. */
7821 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7826 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7827 PRIVATE to the containing module. */
7828 for (iface = sym->generic; iface; iface = iface->next)
7830 for (arg = iface->sym->formal; arg; arg = arg->next)
7833 && arg->sym->ts.type == BT_DERIVED
7834 && !arg->sym->ts.derived->attr.use_assoc
7835 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7836 arg->sym->ts.derived->ns->default_access)
7837 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7838 "'%s' in PUBLIC interface '%s' at %L "
7839 "takes dummy arguments of '%s' which is "
7840 "PRIVATE", iface->sym->name, sym->name,
7841 &iface->sym->declared_at,
7842 gfc_typename (&arg->sym->ts)) == FAILURE)
7844 /* Stop this message from recurring. */
7845 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7851 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7852 PRIVATE to the containing module. */
7853 for (iface = sym->generic; iface; iface = iface->next)
7855 for (arg = iface->sym->formal; arg; arg = arg->next)
7858 && arg->sym->ts.type == BT_DERIVED
7859 && !arg->sym->ts.derived->attr.use_assoc
7860 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7861 arg->sym->ts.derived->ns->default_access)
7862 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7863 "'%s' in PUBLIC interface '%s' at %L "
7864 "takes dummy arguments of '%s' which is "
7865 "PRIVATE", iface->sym->name, sym->name,
7866 &iface->sym->declared_at,
7867 gfc_typename (&arg->sym->ts)) == FAILURE)
7869 /* Stop this message from recurring. */
7870 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7877 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
7878 && !sym->attr.proc_pointer)
7880 gfc_error ("Function '%s' at %L cannot have an initializer",
7881 sym->name, &sym->declared_at);
7885 /* An external symbol may not have an initializer because it is taken to be
7886 a procedure. Exception: Procedure Pointers. */
7887 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
7889 gfc_error ("External object '%s' at %L may not have an initializer",
7890 sym->name, &sym->declared_at);
7894 /* An elemental function is required to return a scalar 12.7.1 */
7895 if (sym->attr.elemental && sym->attr.function && sym->as)
7897 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7898 "result", sym->name, &sym->declared_at);
7899 /* Reset so that the error only occurs once. */
7900 sym->attr.elemental = 0;
7904 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7905 char-len-param shall not be array-valued, pointer-valued, recursive
7906 or pure. ....snip... A character value of * may only be used in the
7907 following ways: (i) Dummy arg of procedure - dummy associates with
7908 actual length; (ii) To declare a named constant; or (iii) External
7909 function - but length must be declared in calling scoping unit. */
7910 if (sym->attr.function
7911 && sym->ts.type == BT_CHARACTER
7912 && sym->ts.cl && sym->ts.cl->length == NULL)
7914 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7915 || (sym->attr.recursive) || (sym->attr.pure))
7917 if (sym->as && sym->as->rank)
7918 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7919 "array-valued", sym->name, &sym->declared_at);
7921 if (sym->attr.pointer)
7922 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7923 "pointer-valued", sym->name, &sym->declared_at);
7926 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7927 "pure", sym->name, &sym->declared_at);
7929 if (sym->attr.recursive)
7930 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7931 "recursive", sym->name, &sym->declared_at);
7936 /* Appendix B.2 of the standard. Contained functions give an
7937 error anyway. Fixed-form is likely to be F77/legacy. */
7938 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7939 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7940 "'%s' at %L is obsolescent in fortran 95",
7941 sym->name, &sym->declared_at);
7944 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7946 gfc_formal_arglist *curr_arg;
7947 int has_non_interop_arg = 0;
7949 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7950 sym->common_block) == FAILURE)
7952 /* Clear these to prevent looking at them again if there was an
7954 sym->attr.is_bind_c = 0;
7955 sym->attr.is_c_interop = 0;
7956 sym->ts.is_c_interop = 0;
7960 /* So far, no errors have been found. */
7961 sym->attr.is_c_interop = 1;
7962 sym->ts.is_c_interop = 1;
7965 curr_arg = sym->formal;
7966 while (curr_arg != NULL)
7968 /* Skip implicitly typed dummy args here. */
7969 if (curr_arg->sym->attr.implicit_type == 0)
7970 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7971 /* If something is found to fail, record the fact so we
7972 can mark the symbol for the procedure as not being
7973 BIND(C) to try and prevent multiple errors being
7975 has_non_interop_arg = 1;
7977 curr_arg = curr_arg->next;
7980 /* See if any of the arguments were not interoperable and if so, clear
7981 the procedure symbol to prevent duplicate error messages. */
7982 if (has_non_interop_arg != 0)
7984 sym->attr.is_c_interop = 0;
7985 sym->ts.is_c_interop = 0;
7986 sym->attr.is_bind_c = 0;
7990 if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
7992 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
7993 "in '%s' at %L", sym->name, &sym->declared_at);
7997 if (sym->attr.intent && !sym->attr.proc_pointer)
7999 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
8000 "in '%s' at %L", sym->name, &sym->declared_at);
8008 /* Resolve a list of finalizer procedures. That is, after they have hopefully
8009 been defined and we now know their defined arguments, check that they fulfill
8010 the requirements of the standard for procedures used as finalizers. */
8013 gfc_resolve_finalizers (gfc_symbol* derived)
8015 gfc_finalizer* list;
8016 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
8017 gfc_try result = SUCCESS;
8018 bool seen_scalar = false;
8020 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
8023 /* Walk over the list of finalizer-procedures, check them, and if any one
8024 does not fit in with the standard's definition, print an error and remove
8025 it from the list. */
8026 prev_link = &derived->f2k_derived->finalizers;
8027 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
8033 /* Skip this finalizer if we already resolved it. */
8034 if (list->proc_tree)
8036 prev_link = &(list->next);
8040 /* Check this exists and is a SUBROUTINE. */
8041 if (!list->proc_sym->attr.subroutine)
8043 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
8044 list->proc_sym->name, &list->where);
8048 /* We should have exactly one argument. */
8049 if (!list->proc_sym->formal || list->proc_sym->formal->next)
8051 gfc_error ("FINAL procedure at %L must have exactly one argument",
8055 arg = list->proc_sym->formal->sym;
8057 /* This argument must be of our type. */
8058 if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
8060 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
8061 &arg->declared_at, derived->name);
8065 /* It must neither be a pointer nor allocatable nor optional. */
8066 if (arg->attr.pointer)
8068 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
8072 if (arg->attr.allocatable)
8074 gfc_error ("Argument of FINAL procedure at %L must not be"
8075 " ALLOCATABLE", &arg->declared_at);
8078 if (arg->attr.optional)
8080 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
8085 /* It must not be INTENT(OUT). */
8086 if (arg->attr.intent == INTENT_OUT)
8088 gfc_error ("Argument of FINAL procedure at %L must not be"
8089 " INTENT(OUT)", &arg->declared_at);
8093 /* Warn if the procedure is non-scalar and not assumed shape. */
8094 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
8095 && arg->as->type != AS_ASSUMED_SHAPE)
8096 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
8097 " shape argument", &arg->declared_at);
8099 /* Check that it does not match in kind and rank with a FINAL procedure
8100 defined earlier. To really loop over the *earlier* declarations,
8101 we need to walk the tail of the list as new ones were pushed at the
8103 /* TODO: Handle kind parameters once they are implemented. */
8104 my_rank = (arg->as ? arg->as->rank : 0);
8105 for (i = list->next; i; i = i->next)
8107 /* Argument list might be empty; that is an error signalled earlier,
8108 but we nevertheless continued resolving. */
8109 if (i->proc_sym->formal)
8111 gfc_symbol* i_arg = i->proc_sym->formal->sym;
8112 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
8113 if (i_rank == my_rank)
8115 gfc_error ("FINAL procedure '%s' declared at %L has the same"
8116 " rank (%d) as '%s'",
8117 list->proc_sym->name, &list->where, my_rank,
8124 /* Is this the/a scalar finalizer procedure? */
8125 if (!arg->as || arg->as->rank == 0)
8128 /* Find the symtree for this procedure. */
8129 gcc_assert (!list->proc_tree);
8130 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
8132 prev_link = &list->next;
8135 /* Remove wrong nodes immediately from the list so we don't risk any
8136 troubles in the future when they might fail later expectations. */
8140 *prev_link = list->next;
8141 gfc_free_finalizer (i);
8144 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
8145 were nodes in the list, must have been for arrays. It is surely a good
8146 idea to have a scalar version there if there's something to finalize. */
8147 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
8148 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
8149 " defined at %L, suggest also scalar one",
8150 derived->name, &derived->declared_at);
8152 /* TODO: Remove this error when finalization is finished. */
8153 gfc_error ("Finalization at %L is not yet implemented",
8154 &derived->declared_at);
8160 /* Check that it is ok for the typebound procedure proc to override the
8164 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
8167 const gfc_symbol* proc_target;
8168 const gfc_symbol* old_target;
8169 unsigned proc_pass_arg, old_pass_arg, argpos;
8170 gfc_formal_arglist* proc_formal;
8171 gfc_formal_arglist* old_formal;
8173 /* This procedure should only be called for non-GENERIC proc. */
8174 gcc_assert (!proc->typebound->is_generic);
8176 /* If the overwritten procedure is GENERIC, this is an error. */
8177 if (old->typebound->is_generic)
8179 gfc_error ("Can't overwrite GENERIC '%s' at %L",
8180 old->name, &proc->typebound->where);
8184 where = proc->typebound->where;
8185 proc_target = proc->typebound->u.specific->n.sym;
8186 old_target = old->typebound->u.specific->n.sym;
8188 /* Check that overridden binding is not NON_OVERRIDABLE. */
8189 if (old->typebound->non_overridable)
8191 gfc_error ("'%s' at %L overrides a procedure binding declared"
8192 " NON_OVERRIDABLE", proc->name, &where);
8196 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
8197 if (!old->typebound->deferred && proc->typebound->deferred)
8199 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
8200 " non-DEFERRED binding", proc->name, &where);
8204 /* If the overridden binding is PURE, the overriding must be, too. */
8205 if (old_target->attr.pure && !proc_target->attr.pure)
8207 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
8208 proc->name, &where);
8212 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
8213 is not, the overriding must not be either. */
8214 if (old_target->attr.elemental && !proc_target->attr.elemental)
8216 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
8217 " ELEMENTAL", proc->name, &where);
8220 if (!old_target->attr.elemental && proc_target->attr.elemental)
8222 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
8223 " be ELEMENTAL, either", proc->name, &where);
8227 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
8229 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
8231 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
8232 " SUBROUTINE", proc->name, &where);
8236 /* If the overridden binding is a FUNCTION, the overriding must also be a
8237 FUNCTION and have the same characteristics. */
8238 if (old_target->attr.function)
8240 if (!proc_target->attr.function)
8242 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
8243 " FUNCTION", proc->name, &where);
8247 /* FIXME: Do more comprehensive checking (including, for instance, the
8248 rank and array-shape). */
8249 gcc_assert (proc_target->result && old_target->result);
8250 if (!gfc_compare_types (&proc_target->result->ts,
8251 &old_target->result->ts))
8253 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
8254 " matching result types", proc->name, &where);
8259 /* If the overridden binding is PUBLIC, the overriding one must not be
8261 if (old->typebound->access == ACCESS_PUBLIC
8262 && proc->typebound->access == ACCESS_PRIVATE)
8264 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
8265 " PRIVATE", proc->name, &where);
8269 /* Compare the formal argument lists of both procedures. This is also abused
8270 to find the position of the passed-object dummy arguments of both
8271 bindings as at least the overridden one might not yet be resolved and we
8272 need those positions in the check below. */
8273 proc_pass_arg = old_pass_arg = 0;
8274 if (!proc->typebound->nopass && !proc->typebound->pass_arg)
8276 if (!old->typebound->nopass && !old->typebound->pass_arg)
8279 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
8280 proc_formal && old_formal;
8281 proc_formal = proc_formal->next, old_formal = old_formal->next)
8283 if (proc->typebound->pass_arg
8284 && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name))
8285 proc_pass_arg = argpos;
8286 if (old->typebound->pass_arg
8287 && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
8288 old_pass_arg = argpos;
8290 /* Check that the names correspond. */
8291 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
8293 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8294 " to match the corresponding argument of the overridden"
8295 " procedure", proc_formal->sym->name, proc->name, &where,
8296 old_formal->sym->name);
8300 /* Check that the types correspond if neither is the passed-object
8302 /* FIXME: Do more comprehensive testing here. */
8303 if (proc_pass_arg != argpos && old_pass_arg != argpos
8304 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
8306 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8307 " in respect to the overridden procedure",
8308 proc_formal->sym->name, proc->name, &where);
8314 if (proc_formal || old_formal)
8316 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8317 " the overridden procedure", proc->name, &where);
8321 /* If the overridden binding is NOPASS, the overriding one must also be
8323 if (old->typebound->nopass && !proc->typebound->nopass)
8325 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8326 " NOPASS", proc->name, &where);
8330 /* If the overridden binding is PASS(x), the overriding one must also be
8331 PASS and the passed-object dummy arguments must correspond. */
8332 if (!old->typebound->nopass)
8334 if (proc->typebound->nopass)
8336 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8337 " PASS", proc->name, &where);
8341 if (proc_pass_arg != old_pass_arg)
8343 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8344 " the same position as the passed-object dummy argument of"
8345 " the overridden procedure", proc->name, &where);
8354 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8357 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
8358 const char* generic_name, locus where)
8363 gcc_assert (t1->specific && t2->specific);
8364 gcc_assert (!t1->specific->is_generic);
8365 gcc_assert (!t2->specific->is_generic);
8367 sym1 = t1->specific->u.specific->n.sym;
8368 sym2 = t2->specific->u.specific->n.sym;
8370 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8371 if (sym1->attr.subroutine != sym2->attr.subroutine
8372 || sym1->attr.function != sym2->attr.function)
8374 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8375 " GENERIC '%s' at %L",
8376 sym1->name, sym2->name, generic_name, &where);
8380 /* Compare the interfaces. */
8381 if (gfc_compare_interfaces (sym1, sym2, 1))
8383 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8384 sym1->name, sym2->name, generic_name, &where);
8392 /* Resolve a GENERIC procedure binding for a derived type. */
8395 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
8397 gfc_tbp_generic* target;
8398 gfc_symtree* first_target;
8399 gfc_symbol* super_type;
8400 gfc_symtree* inherited;
8403 gcc_assert (st->typebound);
8404 gcc_assert (st->typebound->is_generic);
8406 where = st->typebound->where;
8407 super_type = gfc_get_derived_super_type (derived);
8409 /* Find the overridden binding if any. */
8410 st->typebound->overridden = NULL;
8413 gfc_symtree* overridden;
8414 overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
8416 if (overridden && overridden->typebound)
8417 st->typebound->overridden = overridden->typebound;
8420 /* Try to find the specific bindings for the symtrees in our target-list. */
8421 gcc_assert (st->typebound->u.generic);
8422 for (target = st->typebound->u.generic; target; target = target->next)
8423 if (!target->specific)
8425 gfc_typebound_proc* overridden_tbp;
8427 const char* target_name;
8429 target_name = target->specific_st->name;
8431 /* Defined for this type directly. */
8432 if (target->specific_st->typebound)
8434 target->specific = target->specific_st->typebound;
8435 goto specific_found;
8438 /* Look for an inherited specific binding. */
8441 inherited = gfc_find_typebound_proc (super_type, NULL,
8446 gcc_assert (inherited->typebound);
8447 target->specific = inherited->typebound;
8448 goto specific_found;
8452 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8453 " at %L", target_name, st->name, &where);
8456 /* Once we've found the specific binding, check it is not ambiguous with
8457 other specifics already found or inherited for the same GENERIC. */
8459 gcc_assert (target->specific);
8461 /* This must really be a specific binding! */
8462 if (target->specific->is_generic)
8464 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8465 " '%s' is GENERIC, too", st->name, &where, target_name);
8469 /* Check those already resolved on this type directly. */
8470 for (g = st->typebound->u.generic; g; g = g->next)
8471 if (g != target && g->specific
8472 && check_generic_tbp_ambiguity (target, g, st->name, where)
8476 /* Check for ambiguity with inherited specific targets. */
8477 for (overridden_tbp = st->typebound->overridden; overridden_tbp;
8478 overridden_tbp = overridden_tbp->overridden)
8479 if (overridden_tbp->is_generic)
8481 for (g = overridden_tbp->u.generic; g; g = g->next)
8483 gcc_assert (g->specific);
8484 if (check_generic_tbp_ambiguity (target, g,
8485 st->name, where) == FAILURE)
8491 /* If we attempt to "overwrite" a specific binding, this is an error. */
8492 if (st->typebound->overridden && !st->typebound->overridden->is_generic)
8494 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8495 " the same name", st->name, &where);
8499 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8500 all must have the same attributes here. */
8501 first_target = st->typebound->u.generic->specific->u.specific;
8502 st->typebound->subroutine = first_target->n.sym->attr.subroutine;
8503 st->typebound->function = first_target->n.sym->attr.function;
8509 /* Resolve the type-bound procedures for a derived type. */
8511 static gfc_symbol* resolve_bindings_derived;
8512 static gfc_try resolve_bindings_result;
8515 resolve_typebound_procedure (gfc_symtree* stree)
8520 gfc_symbol* super_type;
8521 gfc_component* comp;
8523 /* If this is no type-bound procedure, just return. */
8524 if (!stree->typebound)
8527 /* If this is a GENERIC binding, use that routine. */
8528 if (stree->typebound->is_generic)
8530 if (resolve_typebound_generic (resolve_bindings_derived, stree)
8536 /* Get the target-procedure to check it. */
8537 gcc_assert (!stree->typebound->is_generic);
8538 gcc_assert (stree->typebound->u.specific);
8539 proc = stree->typebound->u.specific->n.sym;
8540 where = stree->typebound->where;
8542 /* Default access should already be resolved from the parser. */
8543 gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
8545 /* It should be a module procedure or an external procedure with explicit
8546 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
8547 if ((!proc->attr.subroutine && !proc->attr.function)
8548 || (proc->attr.proc != PROC_MODULE
8549 && proc->attr.if_source != IFSRC_IFBODY)
8550 || (proc->attr.abstract && !stree->typebound->deferred))
8552 gfc_error ("'%s' must be a module procedure or an external procedure with"
8553 " an explicit interface at %L", proc->name, &where);
8556 stree->typebound->subroutine = proc->attr.subroutine;
8557 stree->typebound->function = proc->attr.function;
8559 /* Find the super-type of the current derived type. We could do this once and
8560 store in a global if speed is needed, but as long as not I believe this is
8561 more readable and clearer. */
8562 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
8564 /* If PASS, resolve and check arguments if not already resolved / loaded
8565 from a .mod file. */
8566 if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
8568 if (stree->typebound->pass_arg)
8570 gfc_formal_arglist* i;
8572 /* If an explicit passing argument name is given, walk the arg-list
8576 stree->typebound->pass_arg_num = 1;
8577 for (i = proc->formal; i; i = i->next)
8579 if (!strcmp (i->sym->name, stree->typebound->pass_arg))
8584 ++stree->typebound->pass_arg_num;
8589 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8591 proc->name, stree->typebound->pass_arg, &where,
8592 stree->typebound->pass_arg);
8598 /* Otherwise, take the first one; there should in fact be at least
8600 stree->typebound->pass_arg_num = 1;
8603 gfc_error ("Procedure '%s' with PASS at %L must have at"
8604 " least one argument", proc->name, &where);
8607 me_arg = proc->formal->sym;
8610 /* Now check that the argument-type matches. */
8611 gcc_assert (me_arg);
8612 if (me_arg->ts.type != BT_DERIVED
8613 || me_arg->ts.derived != resolve_bindings_derived)
8615 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8616 " the derived-type '%s'", me_arg->name, proc->name,
8617 me_arg->name, &where, resolve_bindings_derived->name);
8621 gfc_warning ("Polymorphic entities are not yet implemented,"
8622 " non-polymorphic passed-object dummy argument of '%s'"
8623 " at %L accepted", proc->name, &where);
8626 /* If we are extending some type, check that we don't override a procedure
8627 flagged NON_OVERRIDABLE. */
8628 stree->typebound->overridden = NULL;
8631 gfc_symtree* overridden;
8632 overridden = gfc_find_typebound_proc (super_type, NULL,
8635 if (overridden && overridden->typebound)
8636 stree->typebound->overridden = overridden->typebound;
8638 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
8642 /* See if there's a name collision with a component directly in this type. */
8643 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
8644 if (!strcmp (comp->name, stree->name))
8646 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8648 stree->name, &where, resolve_bindings_derived->name);
8652 /* Try to find a name collision with an inherited component. */
8653 if (super_type && gfc_find_component (super_type, stree->name, true, true))
8655 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8656 " component of '%s'",
8657 stree->name, &where, resolve_bindings_derived->name);
8661 stree->typebound->error = 0;
8665 resolve_bindings_result = FAILURE;
8666 stree->typebound->error = 1;
8670 resolve_typebound_procedures (gfc_symbol* derived)
8672 if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
8675 resolve_bindings_derived = derived;
8676 resolve_bindings_result = SUCCESS;
8677 gfc_traverse_symtree (derived->f2k_derived->sym_root,
8678 &resolve_typebound_procedure);
8680 return resolve_bindings_result;
8684 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8685 to give all identical derived types the same backend_decl. */
8687 add_dt_to_dt_list (gfc_symbol *derived)
8689 gfc_dt_list *dt_list;
8691 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
8692 if (derived == dt_list->derived)
8695 if (dt_list == NULL)
8697 dt_list = gfc_get_dt_list ();
8698 dt_list->next = gfc_derived_types;
8699 dt_list->derived = derived;
8700 gfc_derived_types = dt_list;
8705 /* Ensure that a derived-type is really not abstract, meaning that every
8706 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
8709 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
8714 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
8716 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
8719 if (st->typebound && st->typebound->deferred)
8721 gfc_symtree* overriding;
8722 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true);
8723 gcc_assert (overriding && overriding->typebound);
8724 if (overriding->typebound->deferred)
8726 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
8727 " '%s' is DEFERRED and not overridden",
8728 sub->name, &sub->declared_at, st->name);
8737 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
8739 /* The algorithm used here is to recursively travel up the ancestry of sub
8740 and for each ancestor-type, check all bindings. If any of them is
8741 DEFERRED, look it up starting from sub and see if the found (overriding)
8742 binding is not DEFERRED.
8743 This is not the most efficient way to do this, but it should be ok and is
8744 clearer than something sophisticated. */
8746 gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
8748 /* Walk bindings of this ancestor. */
8749 if (ancestor->f2k_derived)
8752 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->sym_root);
8757 /* Find next ancestor type and recurse on it. */
8758 ancestor = gfc_get_derived_super_type (ancestor);
8760 return ensure_not_abstract (sub, ancestor);
8766 /* Resolve the components of a derived type. */
8769 resolve_fl_derived (gfc_symbol *sym)
8771 gfc_symbol* super_type;
8775 super_type = gfc_get_derived_super_type (sym);
8777 /* Ensure the extended type gets resolved before we do. */
8778 if (super_type && resolve_fl_derived (super_type) == FAILURE)
8781 /* An ABSTRACT type must be extensible. */
8782 if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
8784 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
8785 sym->name, &sym->declared_at);
8789 for (c = sym->components; c != NULL; c = c->next)
8791 /* Check type-spec if this is not the parent-type component. */
8792 if ((!sym->attr.extension || c != sym->components)
8793 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
8796 /* If this type is an extension, see if this component has the same name
8797 as an inherited type-bound procedure. */
8799 && gfc_find_typebound_proc (super_type, NULL, c->name, true))
8801 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
8802 " inherited type-bound procedure",
8803 c->name, sym->name, &c->loc);
8807 if (c->ts.type == BT_CHARACTER)
8809 if (c->ts.cl->length == NULL
8810 || (resolve_charlen (c->ts.cl) == FAILURE)
8811 || !gfc_is_constant_expr (c->ts.cl->length))
8813 gfc_error ("Character length of component '%s' needs to "
8814 "be a constant specification expression at %L",
8816 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
8821 if (c->ts.type == BT_DERIVED
8822 && sym->component_access != ACCESS_PRIVATE
8823 && gfc_check_access (sym->attr.access, sym->ns->default_access)
8824 && !c->ts.derived->attr.use_assoc
8825 && !gfc_check_access (c->ts.derived->attr.access,
8826 c->ts.derived->ns->default_access))
8828 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
8829 "a component of '%s', which is PUBLIC at %L",
8830 c->name, sym->name, &sym->declared_at);
8834 if (sym->attr.sequence)
8836 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
8838 gfc_error ("Component %s of SEQUENCE type declared at %L does "
8839 "not have the SEQUENCE attribute",
8840 c->ts.derived->name, &sym->declared_at);
8845 if (c->ts.type == BT_DERIVED && c->attr.pointer
8846 && c->ts.derived->components == NULL
8847 && !c->ts.derived->attr.zero_comp)
8849 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
8850 "that has not been declared", c->name, sym->name,
8855 /* Ensure that all the derived type components are put on the
8856 derived type list; even in formal namespaces, where derived type
8857 pointer components might not have been declared. */
8858 if (c->ts.type == BT_DERIVED
8860 && c->ts.derived->components
8862 && sym != c->ts.derived)
8863 add_dt_to_dt_list (c->ts.derived);
8865 if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
8868 for (i = 0; i < c->as->rank; i++)
8870 if (c->as->lower[i] == NULL
8871 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
8872 || !gfc_is_constant_expr (c->as->lower[i])
8873 || c->as->upper[i] == NULL
8874 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
8875 || !gfc_is_constant_expr (c->as->upper[i]))
8877 gfc_error ("Component '%s' of '%s' at %L must have "
8878 "constant array bounds",
8879 c->name, sym->name, &c->loc);
8885 /* Resolve the type-bound procedures. */
8886 if (resolve_typebound_procedures (sym) == FAILURE)
8889 /* Resolve the finalizer procedures. */
8890 if (gfc_resolve_finalizers (sym) == FAILURE)
8893 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
8894 all DEFERRED bindings are overridden. */
8895 if (super_type && super_type->attr.abstract && !sym->attr.abstract
8896 && ensure_not_abstract (sym, super_type) == FAILURE)
8899 /* Add derived type to the derived type list. */
8900 add_dt_to_dt_list (sym);
8907 resolve_fl_namelist (gfc_symbol *sym)
8912 /* Reject PRIVATE objects in a PUBLIC namelist. */
8913 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
8915 for (nl = sym->namelist; nl; nl = nl->next)
8917 if (!nl->sym->attr.use_assoc
8918 && !(sym->ns->parent == nl->sym->ns)
8919 && !(sym->ns->parent
8920 && sym->ns->parent->parent == nl->sym->ns)
8921 && !gfc_check_access(nl->sym->attr.access,
8922 nl->sym->ns->default_access))
8924 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
8925 "cannot be member of PUBLIC namelist '%s' at %L",
8926 nl->sym->name, sym->name, &sym->declared_at);
8930 /* Types with private components that came here by USE-association. */
8931 if (nl->sym->ts.type == BT_DERIVED
8932 && derived_inaccessible (nl->sym->ts.derived))
8934 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
8935 "components and cannot be member of namelist '%s' at %L",
8936 nl->sym->name, sym->name, &sym->declared_at);
8940 /* Types with private components that are defined in the same module. */
8941 if (nl->sym->ts.type == BT_DERIVED
8942 && !(sym->ns->parent == nl->sym->ts.derived->ns)
8943 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
8944 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
8945 nl->sym->ns->default_access))
8947 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
8948 "cannot be a member of PUBLIC namelist '%s' at %L",
8949 nl->sym->name, sym->name, &sym->declared_at);
8955 for (nl = sym->namelist; nl; nl = nl->next)
8957 /* Reject namelist arrays of assumed shape. */
8958 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
8959 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
8960 "must not have assumed shape in namelist "
8961 "'%s' at %L", nl->sym->name, sym->name,
8962 &sym->declared_at) == FAILURE)
8965 /* Reject namelist arrays that are not constant shape. */
8966 if (is_non_constant_shape_array (nl->sym))
8968 gfc_error ("NAMELIST array object '%s' must have constant "
8969 "shape in namelist '%s' at %L", nl->sym->name,
8970 sym->name, &sym->declared_at);
8974 /* Namelist objects cannot have allocatable or pointer components. */
8975 if (nl->sym->ts.type != BT_DERIVED)
8978 if (nl->sym->ts.derived->attr.alloc_comp)
8980 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8981 "have ALLOCATABLE components",
8982 nl->sym->name, sym->name, &sym->declared_at);
8986 if (nl->sym->ts.derived->attr.pointer_comp)
8988 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8989 "have POINTER components",
8990 nl->sym->name, sym->name, &sym->declared_at);
8996 /* 14.1.2 A module or internal procedure represent local entities
8997 of the same type as a namelist member and so are not allowed. */
8998 for (nl = sym->namelist; nl; nl = nl->next)
9000 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
9003 if (nl->sym->attr.function && nl->sym == nl->sym->result)
9004 if ((nl->sym == sym->ns->proc_name)
9006 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
9010 if (nl->sym && nl->sym->name)
9011 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
9012 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
9014 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
9015 "attribute in '%s' at %L", nlsym->name,
9026 resolve_fl_parameter (gfc_symbol *sym)
9028 /* A parameter array's shape needs to be constant. */
9030 && (sym->as->type == AS_DEFERRED
9031 || is_non_constant_shape_array (sym)))
9033 gfc_error ("Parameter array '%s' at %L cannot be automatic "
9034 "or of deferred shape", sym->name, &sym->declared_at);
9038 /* Make sure a parameter that has been implicitly typed still
9039 matches the implicit type, since PARAMETER statements can precede
9040 IMPLICIT statements. */
9041 if (sym->attr.implicit_type
9042 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
9044 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
9045 "later IMPLICIT type", sym->name, &sym->declared_at);
9049 /* Make sure the types of derived parameters are consistent. This
9050 type checking is deferred until resolution because the type may
9051 refer to a derived type from the host. */
9052 if (sym->ts.type == BT_DERIVED
9053 && !gfc_compare_types (&sym->ts, &sym->value->ts))
9055 gfc_error ("Incompatible derived type in PARAMETER at %L",
9056 &sym->value->where);
9063 /* Do anything necessary to resolve a symbol. Right now, we just
9064 assume that an otherwise unknown symbol is a variable. This sort
9065 of thing commonly happens for symbols in module. */
9068 resolve_symbol (gfc_symbol *sym)
9070 int check_constant, mp_flag;
9071 gfc_symtree *symtree;
9072 gfc_symtree *this_symtree;
9076 if (sym->attr.flavor == FL_UNKNOWN)
9079 /* If we find that a flavorless symbol is an interface in one of the
9080 parent namespaces, find its symtree in this namespace, free the
9081 symbol and set the symtree to point to the interface symbol. */
9082 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
9084 symtree = gfc_find_symtree (ns->sym_root, sym->name);
9085 if (symtree && symtree->n.sym->generic)
9087 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
9091 gfc_free_symbol (sym);
9092 symtree->n.sym->refs++;
9093 this_symtree->n.sym = symtree->n.sym;
9098 /* Otherwise give it a flavor according to such attributes as
9100 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
9101 sym->attr.flavor = FL_VARIABLE;
9104 sym->attr.flavor = FL_PROCEDURE;
9105 if (sym->attr.dimension)
9106 sym->attr.function = 1;
9110 if (sym->attr.procedure && sym->ts.interface
9111 && sym->attr.if_source != IFSRC_DECL)
9113 if (sym->ts.interface->attr.procedure)
9114 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
9115 "in a later PROCEDURE statement", sym->ts.interface->name,
9116 sym->name,&sym->declared_at);
9118 /* Get the attributes from the interface (now resolved). */
9119 if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
9121 gfc_symbol *ifc = sym->ts.interface;
9123 sym->ts.interface = ifc;
9124 sym->attr.function = ifc->attr.function;
9125 sym->attr.subroutine = ifc->attr.subroutine;
9126 sym->attr.allocatable = ifc->attr.allocatable;
9127 sym->attr.pointer = ifc->attr.pointer;
9128 sym->attr.pure = ifc->attr.pure;
9129 sym->attr.elemental = ifc->attr.elemental;
9130 sym->attr.dimension = ifc->attr.dimension;
9131 sym->attr.recursive = ifc->attr.recursive;
9132 sym->attr.always_explicit = ifc->attr.always_explicit;
9133 copy_formal_args (sym, ifc);
9134 /* Copy array spec. */
9135 sym->as = gfc_copy_array_spec (ifc->as);
9139 for (i = 0; i < sym->as->rank; i++)
9141 gfc_expr_replace_symbols (sym->as->lower[i], sym);
9142 gfc_expr_replace_symbols (sym->as->upper[i], sym);
9145 /* Copy char length. */
9148 sym->ts.cl = gfc_get_charlen();
9149 sym->ts.cl->resolved = ifc->ts.cl->resolved;
9150 sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
9151 gfc_expr_replace_symbols (sym->ts.cl->length, sym);
9152 /* Add charlen to namespace. */
9155 sym->ts.cl->next = sym->formal_ns->cl_list;
9156 sym->formal_ns->cl_list = sym->ts.cl;
9160 else if (sym->ts.interface->name[0] != '\0')
9162 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
9163 sym->ts.interface->name, sym->name, &sym->declared_at);
9168 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
9171 /* Symbols that are module procedures with results (functions) have
9172 the types and array specification copied for type checking in
9173 procedures that call them, as well as for saving to a module
9174 file. These symbols can't stand the scrutiny that their results
9176 mp_flag = (sym->result != NULL && sym->result != sym);
9179 /* Make sure that the intrinsic is consistent with its internal
9180 representation. This needs to be done before assigning a default
9181 type to avoid spurious warnings. */
9182 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
9184 gfc_intrinsic_sym* isym;
9187 /* We already know this one is an intrinsic, so we don't call
9188 gfc_is_intrinsic for full checking but rather use gfc_find_function and
9189 gfc_find_subroutine directly to check whether it is a function or
9192 if ((isym = gfc_find_function (sym->name)))
9194 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
9195 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
9196 " ignored", sym->name, &sym->declared_at);
9198 else if ((isym = gfc_find_subroutine (sym->name)))
9200 if (sym->ts.type != BT_UNKNOWN)
9202 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
9203 " specifier", sym->name, &sym->declared_at);
9209 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
9210 sym->name, &sym->declared_at);
9214 /* Check it is actually available in the standard settings. */
9215 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
9218 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
9219 " available in the current standard settings but %s. Use"
9220 " an appropriate -std=* option or enable -fall-intrinsics"
9221 " in order to use it.",
9222 sym->name, &sym->declared_at, symstd);
9227 /* Assign default type to symbols that need one and don't have one. */
9228 if (sym->ts.type == BT_UNKNOWN)
9230 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
9231 gfc_set_default_type (sym, 1, NULL);
9233 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
9235 /* The specific case of an external procedure should emit an error
9236 in the case that there is no implicit type. */
9238 gfc_set_default_type (sym, sym->attr.external, NULL);
9241 /* Result may be in another namespace. */
9242 resolve_symbol (sym->result);
9244 sym->ts = sym->result->ts;
9245 sym->as = gfc_copy_array_spec (sym->result->as);
9246 sym->attr.dimension = sym->result->attr.dimension;
9247 sym->attr.pointer = sym->result->attr.pointer;
9248 sym->attr.allocatable = sym->result->attr.allocatable;
9253 /* Assumed size arrays and assumed shape arrays must be dummy
9257 && (sym->as->type == AS_ASSUMED_SIZE
9258 || sym->as->type == AS_ASSUMED_SHAPE)
9259 && sym->attr.dummy == 0)
9261 if (sym->as->type == AS_ASSUMED_SIZE)
9262 gfc_error ("Assumed size array at %L must be a dummy argument",
9265 gfc_error ("Assumed shape array at %L must be a dummy argument",
9270 /* Make sure symbols with known intent or optional are really dummy
9271 variable. Because of ENTRY statement, this has to be deferred
9272 until resolution time. */
9274 if (!sym->attr.dummy
9275 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
9277 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
9281 if (sym->attr.value && !sym->attr.dummy)
9283 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
9284 "it is not a dummy argument", sym->name, &sym->declared_at);
9288 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
9290 gfc_charlen *cl = sym->ts.cl;
9291 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9293 gfc_error ("Character dummy variable '%s' at %L with VALUE "
9294 "attribute must have constant length",
9295 sym->name, &sym->declared_at);
9299 if (sym->ts.is_c_interop
9300 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
9302 gfc_error ("C interoperable character dummy variable '%s' at %L "
9303 "with VALUE attribute must have length one",
9304 sym->name, &sym->declared_at);
9309 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
9310 do this for something that was implicitly typed because that is handled
9311 in gfc_set_default_type. Handle dummy arguments and procedure
9312 definitions separately. Also, anything that is use associated is not
9313 handled here but instead is handled in the module it is declared in.
9314 Finally, derived type definitions are allowed to be BIND(C) since that
9315 only implies that they're interoperable, and they are checked fully for
9316 interoperability when a variable is declared of that type. */
9317 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
9318 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
9319 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
9321 gfc_try t = SUCCESS;
9323 /* First, make sure the variable is declared at the
9324 module-level scope (J3/04-007, Section 15.3). */
9325 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
9326 sym->attr.in_common == 0)
9328 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
9329 "is neither a COMMON block nor declared at the "
9330 "module level scope", sym->name, &(sym->declared_at));
9333 else if (sym->common_head != NULL)
9335 t = verify_com_block_vars_c_interop (sym->common_head);
9339 /* If type() declaration, we need to verify that the components
9340 of the given type are all C interoperable, etc. */
9341 if (sym->ts.type == BT_DERIVED &&
9342 sym->ts.derived->attr.is_c_interop != 1)
9344 /* Make sure the user marked the derived type as BIND(C). If
9345 not, call the verify routine. This could print an error
9346 for the derived type more than once if multiple variables
9347 of that type are declared. */
9348 if (sym->ts.derived->attr.is_bind_c != 1)
9349 verify_bind_c_derived_type (sym->ts.derived);
9353 /* Verify the variable itself as C interoperable if it
9354 is BIND(C). It is not possible for this to succeed if
9355 the verify_bind_c_derived_type failed, so don't have to handle
9356 any error returned by verify_bind_c_derived_type. */
9357 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9363 /* clear the is_bind_c flag to prevent reporting errors more than
9364 once if something failed. */
9365 sym->attr.is_bind_c = 0;
9370 /* If a derived type symbol has reached this point, without its
9371 type being declared, we have an error. Notice that most
9372 conditions that produce undefined derived types have already
9373 been dealt with. However, the likes of:
9374 implicit type(t) (t) ..... call foo (t) will get us here if
9375 the type is not declared in the scope of the implicit
9376 statement. Change the type to BT_UNKNOWN, both because it is so
9377 and to prevent an ICE. */
9378 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
9379 && !sym->ts.derived->attr.zero_comp)
9381 gfc_error ("The derived type '%s' at %L is of type '%s', "
9382 "which has not been defined", sym->name,
9383 &sym->declared_at, sym->ts.derived->name);
9384 sym->ts.type = BT_UNKNOWN;
9388 /* Make sure that the derived type has been resolved and that the
9389 derived type is visible in the symbol's namespace, if it is a
9390 module function and is not PRIVATE. */
9391 if (sym->ts.type == BT_DERIVED
9392 && sym->ts.derived->attr.use_assoc
9393 && sym->ns->proc_name
9394 && sym->ns->proc_name->attr.flavor == FL_MODULE)
9398 if (resolve_fl_derived (sym->ts.derived) == FAILURE)
9401 gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
9402 if (!ds && sym->attr.function
9403 && gfc_check_access (sym->attr.access, sym->ns->default_access))
9405 symtree = gfc_new_symtree (&sym->ns->sym_root,
9406 sym->ts.derived->name);
9407 symtree->n.sym = sym->ts.derived;
9408 sym->ts.derived->refs++;
9412 /* Unless the derived-type declaration is use associated, Fortran 95
9413 does not allow public entries of private derived types.
9414 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9416 if (sym->ts.type == BT_DERIVED
9417 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
9418 && !sym->ts.derived->attr.use_assoc
9419 && gfc_check_access (sym->attr.access, sym->ns->default_access)
9420 && !gfc_check_access (sym->ts.derived->attr.access,
9421 sym->ts.derived->ns->default_access)
9422 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
9423 "of PRIVATE derived type '%s'",
9424 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
9425 : "variable", sym->name, &sym->declared_at,
9426 sym->ts.derived->name) == FAILURE)
9429 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9430 default initialization is defined (5.1.2.4.4). */
9431 if (sym->ts.type == BT_DERIVED
9433 && sym->attr.intent == INTENT_OUT
9435 && sym->as->type == AS_ASSUMED_SIZE)
9437 for (c = sym->ts.derived->components; c; c = c->next)
9441 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9442 "ASSUMED SIZE and so cannot have a default initializer",
9443 sym->name, &sym->declared_at);
9449 switch (sym->attr.flavor)
9452 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
9457 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
9462 if (resolve_fl_namelist (sym) == FAILURE)
9467 if (resolve_fl_parameter (sym) == FAILURE)
9475 /* Resolve array specifier. Check as well some constraints
9476 on COMMON blocks. */
9478 check_constant = sym->attr.in_common && !sym->attr.pointer;
9480 /* Set the formal_arg_flag so that check_conflict will not throw
9481 an error for host associated variables in the specification
9482 expression for an array_valued function. */
9483 if (sym->attr.function && sym->as)
9484 formal_arg_flag = 1;
9486 gfc_resolve_array_spec (sym->as, check_constant);
9488 formal_arg_flag = 0;
9490 /* Resolve formal namespaces. */
9491 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
9492 gfc_resolve (sym->formal_ns);
9494 /* Check threadprivate restrictions. */
9495 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
9496 && (!sym->attr.in_common
9497 && sym->module == NULL
9498 && (sym->ns->proc_name == NULL
9499 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
9500 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
9502 /* If we have come this far we can apply default-initializers, as
9503 described in 14.7.5, to those variables that have not already
9504 been assigned one. */
9505 if (sym->ts.type == BT_DERIVED
9506 && sym->attr.referenced
9507 && sym->ns == gfc_current_ns
9509 && !sym->attr.allocatable
9510 && !sym->attr.alloc_comp)
9512 symbol_attribute *a = &sym->attr;
9514 if ((!a->save && !a->dummy && !a->pointer
9515 && !a->in_common && !a->use_assoc
9516 && !(a->function && sym != sym->result))
9517 || (a->dummy && a->intent == INTENT_OUT))
9518 apply_default_init (sym);
9521 /* If this symbol has a type-spec, check it. */
9522 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
9523 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
9524 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
9530 /************* Resolve DATA statements *************/
9534 gfc_data_value *vnode;
9540 /* Advance the values structure to point to the next value in the data list. */
9543 next_data_value (void)
9546 while (mpz_cmp_ui (values.left, 0) == 0)
9548 if (values.vnode->next == NULL)
9551 values.vnode = values.vnode->next;
9552 mpz_set (values.left, values.vnode->repeat);
9560 check_data_variable (gfc_data_variable *var, locus *where)
9566 ar_type mark = AR_UNKNOWN;
9568 mpz_t section_index[GFC_MAX_DIMENSIONS];
9572 if (gfc_resolve_expr (var->expr) == FAILURE)
9576 mpz_init_set_si (offset, 0);
9579 if (e->expr_type != EXPR_VARIABLE)
9580 gfc_internal_error ("check_data_variable(): Bad expression");
9582 if (e->symtree->n.sym->ns->is_block_data
9583 && !e->symtree->n.sym->attr.in_common)
9585 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9586 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
9589 if (e->ref == NULL && e->symtree->n.sym->as)
9591 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9592 " declaration", e->symtree->n.sym->name, where);
9598 mpz_init_set_ui (size, 1);
9605 /* Find the array section reference. */
9606 for (ref = e->ref; ref; ref = ref->next)
9608 if (ref->type != REF_ARRAY)
9610 if (ref->u.ar.type == AR_ELEMENT)
9616 /* Set marks according to the reference pattern. */
9617 switch (ref->u.ar.type)
9625 /* Get the start position of array section. */
9626 gfc_get_section_index (ar, section_index, &offset);
9634 if (gfc_array_size (e, &size) == FAILURE)
9636 gfc_error ("Nonconstant array section at %L in DATA statement",
9645 while (mpz_cmp_ui (size, 0) > 0)
9647 if (next_data_value () == FAILURE)
9649 gfc_error ("DATA statement at %L has more variables than values",
9655 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
9659 /* If we have more than one element left in the repeat count,
9660 and we have more than one element left in the target variable,
9661 then create a range assignment. */
9662 /* FIXME: Only done for full arrays for now, since array sections
9664 if (mark == AR_FULL && ref && ref->next == NULL
9665 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
9669 if (mpz_cmp (size, values.left) >= 0)
9671 mpz_init_set (range, values.left);
9672 mpz_sub (size, size, values.left);
9673 mpz_set_ui (values.left, 0);
9677 mpz_init_set (range, size);
9678 mpz_sub (values.left, values.left, size);
9679 mpz_set_ui (size, 0);
9682 gfc_assign_data_value_range (var->expr, values.vnode->expr,
9685 mpz_add (offset, offset, range);
9689 /* Assign initial value to symbol. */
9692 mpz_sub_ui (values.left, values.left, 1);
9693 mpz_sub_ui (size, size, 1);
9695 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
9699 if (mark == AR_FULL)
9700 mpz_add_ui (offset, offset, 1);
9702 /* Modify the array section indexes and recalculate the offset
9703 for next element. */
9704 else if (mark == AR_SECTION)
9705 gfc_advance_section (section_index, ar, &offset);
9709 if (mark == AR_SECTION)
9711 for (i = 0; i < ar->dimen; i++)
9712 mpz_clear (section_index[i]);
9722 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
9724 /* Iterate over a list of elements in a DATA statement. */
9727 traverse_data_list (gfc_data_variable *var, locus *where)
9730 iterator_stack frame;
9731 gfc_expr *e, *start, *end, *step;
9732 gfc_try retval = SUCCESS;
9734 mpz_init (frame.value);
9736 start = gfc_copy_expr (var->iter.start);
9737 end = gfc_copy_expr (var->iter.end);
9738 step = gfc_copy_expr (var->iter.step);
9740 if (gfc_simplify_expr (start, 1) == FAILURE
9741 || start->expr_type != EXPR_CONSTANT)
9743 gfc_error ("iterator start at %L does not simplify", &start->where);
9747 if (gfc_simplify_expr (end, 1) == FAILURE
9748 || end->expr_type != EXPR_CONSTANT)
9750 gfc_error ("iterator end at %L does not simplify", &end->where);
9754 if (gfc_simplify_expr (step, 1) == FAILURE
9755 || step->expr_type != EXPR_CONSTANT)
9757 gfc_error ("iterator step at %L does not simplify", &step->where);
9762 mpz_init_set (trip, end->value.integer);
9763 mpz_sub (trip, trip, start->value.integer);
9764 mpz_add (trip, trip, step->value.integer);
9766 mpz_div (trip, trip, step->value.integer);
9768 mpz_set (frame.value, start->value.integer);
9770 frame.prev = iter_stack;
9771 frame.variable = var->iter.var->symtree;
9772 iter_stack = &frame;
9774 while (mpz_cmp_ui (trip, 0) > 0)
9776 if (traverse_data_var (var->list, where) == FAILURE)
9783 e = gfc_copy_expr (var->expr);
9784 if (gfc_simplify_expr (e, 1) == FAILURE)
9792 mpz_add (frame.value, frame.value, step->value.integer);
9794 mpz_sub_ui (trip, trip, 1);
9799 mpz_clear (frame.value);
9801 gfc_free_expr (start);
9802 gfc_free_expr (end);
9803 gfc_free_expr (step);
9805 iter_stack = frame.prev;
9810 /* Type resolve variables in the variable list of a DATA statement. */
9813 traverse_data_var (gfc_data_variable *var, locus *where)
9817 for (; var; var = var->next)
9819 if (var->expr == NULL)
9820 t = traverse_data_list (var, where);
9822 t = check_data_variable (var, where);
9832 /* Resolve the expressions and iterators associated with a data statement.
9833 This is separate from the assignment checking because data lists should
9834 only be resolved once. */
9837 resolve_data_variables (gfc_data_variable *d)
9839 for (; d; d = d->next)
9841 if (d->list == NULL)
9843 if (gfc_resolve_expr (d->expr) == FAILURE)
9848 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
9851 if (resolve_data_variables (d->list) == FAILURE)
9860 /* Resolve a single DATA statement. We implement this by storing a pointer to
9861 the value list into static variables, and then recursively traversing the
9862 variables list, expanding iterators and such. */
9865 resolve_data (gfc_data *d)
9868 if (resolve_data_variables (d->var) == FAILURE)
9871 values.vnode = d->value;
9872 if (d->value == NULL)
9873 mpz_set_ui (values.left, 0);
9875 mpz_set (values.left, d->value->repeat);
9877 if (traverse_data_var (d->var, &d->where) == FAILURE)
9880 /* At this point, we better not have any values left. */
9882 if (next_data_value () == SUCCESS)
9883 gfc_error ("DATA statement at %L has more values than variables",
9888 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
9889 accessed by host or use association, is a dummy argument to a pure function,
9890 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
9891 is storage associated with any such variable, shall not be used in the
9892 following contexts: (clients of this function). */
9894 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
9895 procedure. Returns zero if assignment is OK, nonzero if there is a
9898 gfc_impure_variable (gfc_symbol *sym)
9902 if (sym->attr.use_assoc || sym->attr.in_common)
9905 if (sym->ns != gfc_current_ns)
9906 return !sym->attr.function;
9908 proc = sym->ns->proc_name;
9909 if (sym->attr.dummy && gfc_pure (proc)
9910 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
9912 proc->attr.function))
9915 /* TODO: Sort out what can be storage associated, if anything, and include
9916 it here. In principle equivalences should be scanned but it does not
9917 seem to be possible to storage associate an impure variable this way. */
9922 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
9923 symbol of the current procedure. */
9926 gfc_pure (gfc_symbol *sym)
9928 symbol_attribute attr;
9931 sym = gfc_current_ns->proc_name;
9937 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
9941 /* Test whether the current procedure is elemental or not. */
9944 gfc_elemental (gfc_symbol *sym)
9946 symbol_attribute attr;
9949 sym = gfc_current_ns->proc_name;
9954 return attr.flavor == FL_PROCEDURE && attr.elemental;
9958 /* Warn about unused labels. */
9961 warn_unused_fortran_label (gfc_st_label *label)
9966 warn_unused_fortran_label (label->left);
9968 if (label->defined == ST_LABEL_UNKNOWN)
9971 switch (label->referenced)
9973 case ST_LABEL_UNKNOWN:
9974 gfc_warning ("Label %d at %L defined but not used", label->value,
9978 case ST_LABEL_BAD_TARGET:
9979 gfc_warning ("Label %d at %L defined but cannot be used",
9980 label->value, &label->where);
9987 warn_unused_fortran_label (label->right);
9991 /* Returns the sequence type of a symbol or sequence. */
9994 sequence_type (gfc_typespec ts)
10003 if (ts.derived->components == NULL)
10004 return SEQ_NONDEFAULT;
10006 result = sequence_type (ts.derived->components->ts);
10007 for (c = ts.derived->components->next; c; c = c->next)
10008 if (sequence_type (c->ts) != result)
10014 if (ts.kind != gfc_default_character_kind)
10015 return SEQ_NONDEFAULT;
10017 return SEQ_CHARACTER;
10020 if (ts.kind != gfc_default_integer_kind)
10021 return SEQ_NONDEFAULT;
10023 return SEQ_NUMERIC;
10026 if (!(ts.kind == gfc_default_real_kind
10027 || ts.kind == gfc_default_double_kind))
10028 return SEQ_NONDEFAULT;
10030 return SEQ_NUMERIC;
10033 if (ts.kind != gfc_default_complex_kind)
10034 return SEQ_NONDEFAULT;
10036 return SEQ_NUMERIC;
10039 if (ts.kind != gfc_default_logical_kind)
10040 return SEQ_NONDEFAULT;
10042 return SEQ_NUMERIC;
10045 return SEQ_NONDEFAULT;
10050 /* Resolve derived type EQUIVALENCE object. */
10053 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
10056 gfc_component *c = derived->components;
10061 /* Shall not be an object of nonsequence derived type. */
10062 if (!derived->attr.sequence)
10064 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
10065 "attribute to be an EQUIVALENCE object", sym->name,
10070 /* Shall not have allocatable components. */
10071 if (derived->attr.alloc_comp)
10073 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
10074 "components to be an EQUIVALENCE object",sym->name,
10079 if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
10081 gfc_error ("Derived type variable '%s' at %L with default "
10082 "initialization cannot be in EQUIVALENCE with a variable "
10083 "in COMMON", sym->name, &e->where);
10087 for (; c ; c = c->next)
10091 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
10094 /* Shall not be an object of sequence derived type containing a pointer
10095 in the structure. */
10096 if (c->attr.pointer)
10098 gfc_error ("Derived type variable '%s' at %L with pointer "
10099 "component(s) cannot be an EQUIVALENCE object",
10100 sym->name, &e->where);
10108 /* Resolve equivalence object.
10109 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
10110 an allocatable array, an object of nonsequence derived type, an object of
10111 sequence derived type containing a pointer at any level of component
10112 selection, an automatic object, a function name, an entry name, a result
10113 name, a named constant, a structure component, or a subobject of any of
10114 the preceding objects. A substring shall not have length zero. A
10115 derived type shall not have components with default initialization nor
10116 shall two objects of an equivalence group be initialized.
10117 Either all or none of the objects shall have an protected attribute.
10118 The simple constraints are done in symbol.c(check_conflict) and the rest
10119 are implemented here. */
10122 resolve_equivalence (gfc_equiv *eq)
10125 gfc_symbol *derived;
10126 gfc_symbol *first_sym;
10129 locus *last_where = NULL;
10130 seq_type eq_type, last_eq_type;
10131 gfc_typespec *last_ts;
10132 int object, cnt_protected;
10133 const char *value_name;
10137 last_ts = &eq->expr->symtree->n.sym->ts;
10139 first_sym = eq->expr->symtree->n.sym;
10143 for (object = 1; eq; eq = eq->eq, object++)
10147 e->ts = e->symtree->n.sym->ts;
10148 /* match_varspec might not know yet if it is seeing
10149 array reference or substring reference, as it doesn't
10151 if (e->ref && e->ref->type == REF_ARRAY)
10153 gfc_ref *ref = e->ref;
10154 sym = e->symtree->n.sym;
10156 if (sym->attr.dimension)
10158 ref->u.ar.as = sym->as;
10162 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
10163 if (e->ts.type == BT_CHARACTER
10165 && ref->type == REF_ARRAY
10166 && ref->u.ar.dimen == 1
10167 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
10168 && ref->u.ar.stride[0] == NULL)
10170 gfc_expr *start = ref->u.ar.start[0];
10171 gfc_expr *end = ref->u.ar.end[0];
10174 /* Optimize away the (:) reference. */
10175 if (start == NULL && end == NULL)
10178 e->ref = ref->next;
10180 e->ref->next = ref->next;
10185 ref->type = REF_SUBSTRING;
10187 start = gfc_int_expr (1);
10188 ref->u.ss.start = start;
10189 if (end == NULL && e->ts.cl)
10190 end = gfc_copy_expr (e->ts.cl->length);
10191 ref->u.ss.end = end;
10192 ref->u.ss.length = e->ts.cl;
10199 /* Any further ref is an error. */
10202 gcc_assert (ref->type == REF_ARRAY);
10203 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
10209 if (gfc_resolve_expr (e) == FAILURE)
10212 sym = e->symtree->n.sym;
10214 if (sym->attr.is_protected)
10216 if (cnt_protected > 0 && cnt_protected != object)
10218 gfc_error ("Either all or none of the objects in the "
10219 "EQUIVALENCE set at %L shall have the "
10220 "PROTECTED attribute",
10225 /* Shall not equivalence common block variables in a PURE procedure. */
10226 if (sym->ns->proc_name
10227 && sym->ns->proc_name->attr.pure
10228 && sym->attr.in_common)
10230 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
10231 "object in the pure procedure '%s'",
10232 sym->name, &e->where, sym->ns->proc_name->name);
10236 /* Shall not be a named constant. */
10237 if (e->expr_type == EXPR_CONSTANT)
10239 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
10240 "object", sym->name, &e->where);
10244 derived = e->ts.derived;
10245 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
10248 /* Check that the types correspond correctly:
10250 A numeric sequence structure may be equivalenced to another sequence
10251 structure, an object of default integer type, default real type, double
10252 precision real type, default logical type such that components of the
10253 structure ultimately only become associated to objects of the same
10254 kind. A character sequence structure may be equivalenced to an object
10255 of default character kind or another character sequence structure.
10256 Other objects may be equivalenced only to objects of the same type and
10257 kind parameters. */
10259 /* Identical types are unconditionally OK. */
10260 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
10261 goto identical_types;
10263 last_eq_type = sequence_type (*last_ts);
10264 eq_type = sequence_type (sym->ts);
10266 /* Since the pair of objects is not of the same type, mixed or
10267 non-default sequences can be rejected. */
10269 msg = "Sequence %s with mixed components in EQUIVALENCE "
10270 "statement at %L with different type objects";
10272 && last_eq_type == SEQ_MIXED
10273 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
10275 || (eq_type == SEQ_MIXED
10276 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10277 &e->where) == FAILURE))
10280 msg = "Non-default type object or sequence %s in EQUIVALENCE "
10281 "statement at %L with objects of different type";
10283 && last_eq_type == SEQ_NONDEFAULT
10284 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
10285 last_where) == FAILURE)
10286 || (eq_type == SEQ_NONDEFAULT
10287 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10288 &e->where) == FAILURE))
10291 msg ="Non-CHARACTER object '%s' in default CHARACTER "
10292 "EQUIVALENCE statement at %L";
10293 if (last_eq_type == SEQ_CHARACTER
10294 && eq_type != SEQ_CHARACTER
10295 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10296 &e->where) == FAILURE)
10299 msg ="Non-NUMERIC object '%s' in default NUMERIC "
10300 "EQUIVALENCE statement at %L";
10301 if (last_eq_type == SEQ_NUMERIC
10302 && eq_type != SEQ_NUMERIC
10303 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10304 &e->where) == FAILURE)
10309 last_where = &e->where;
10314 /* Shall not be an automatic array. */
10315 if (e->ref->type == REF_ARRAY
10316 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
10318 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
10319 "an EQUIVALENCE object", sym->name, &e->where);
10326 /* Shall not be a structure component. */
10327 if (r->type == REF_COMPONENT)
10329 gfc_error ("Structure component '%s' at %L cannot be an "
10330 "EQUIVALENCE object",
10331 r->u.c.component->name, &e->where);
10335 /* A substring shall not have length zero. */
10336 if (r->type == REF_SUBSTRING)
10338 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
10340 gfc_error ("Substring at %L has length zero",
10341 &r->u.ss.start->where);
10351 /* Resolve function and ENTRY types, issue diagnostics if needed. */
10354 resolve_fntype (gfc_namespace *ns)
10356 gfc_entry_list *el;
10359 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
10362 /* If there are any entries, ns->proc_name is the entry master
10363 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10365 sym = ns->entries->sym;
10367 sym = ns->proc_name;
10368 if (sym->result == sym
10369 && sym->ts.type == BT_UNKNOWN
10370 && gfc_set_default_type (sym, 0, NULL) == FAILURE
10371 && !sym->attr.untyped)
10373 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10374 sym->name, &sym->declared_at);
10375 sym->attr.untyped = 1;
10378 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
10379 && !sym->attr.contained
10380 && !gfc_check_access (sym->ts.derived->attr.access,
10381 sym->ts.derived->ns->default_access)
10382 && gfc_check_access (sym->attr.access, sym->ns->default_access))
10384 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
10385 "%L of PRIVATE type '%s'", sym->name,
10386 &sym->declared_at, sym->ts.derived->name);
10390 for (el = ns->entries->next; el; el = el->next)
10392 if (el->sym->result == el->sym
10393 && el->sym->ts.type == BT_UNKNOWN
10394 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
10395 && !el->sym->attr.untyped)
10397 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10398 el->sym->name, &el->sym->declared_at);
10399 el->sym->attr.untyped = 1;
10404 /* 12.3.2.1.1 Defined operators. */
10407 gfc_resolve_uops (gfc_symtree *symtree)
10409 gfc_interface *itr;
10411 gfc_formal_arglist *formal;
10413 if (symtree == NULL)
10416 gfc_resolve_uops (symtree->left);
10417 gfc_resolve_uops (symtree->right);
10419 for (itr = symtree->n.uop->op; itr; itr = itr->next)
10422 if (!sym->attr.function)
10423 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10424 sym->name, &sym->declared_at);
10426 if (sym->ts.type == BT_CHARACTER
10427 && !(sym->ts.cl && sym->ts.cl->length)
10428 && !(sym->result && sym->result->ts.cl
10429 && sym->result->ts.cl->length))
10430 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10431 "character length", sym->name, &sym->declared_at);
10433 formal = sym->formal;
10434 if (!formal || !formal->sym)
10436 gfc_error ("User operator procedure '%s' at %L must have at least "
10437 "one argument", sym->name, &sym->declared_at);
10441 if (formal->sym->attr.intent != INTENT_IN)
10442 gfc_error ("First argument of operator interface at %L must be "
10443 "INTENT(IN)", &sym->declared_at);
10445 if (formal->sym->attr.optional)
10446 gfc_error ("First argument of operator interface at %L cannot be "
10447 "optional", &sym->declared_at);
10449 formal = formal->next;
10450 if (!formal || !formal->sym)
10453 if (formal->sym->attr.intent != INTENT_IN)
10454 gfc_error ("Second argument of operator interface at %L must be "
10455 "INTENT(IN)", &sym->declared_at);
10457 if (formal->sym->attr.optional)
10458 gfc_error ("Second argument of operator interface at %L cannot be "
10459 "optional", &sym->declared_at);
10462 gfc_error ("Operator interface at %L must have, at most, two "
10463 "arguments", &sym->declared_at);
10468 /* Examine all of the expressions associated with a program unit,
10469 assign types to all intermediate expressions, make sure that all
10470 assignments are to compatible types and figure out which names
10471 refer to which functions or subroutines. It doesn't check code
10472 block, which is handled by resolve_code. */
10475 resolve_types (gfc_namespace *ns)
10481 gfc_namespace* old_ns = gfc_current_ns;
10483 /* Check that all IMPLICIT types are ok. */
10484 if (!ns->seen_implicit_none)
10487 for (letter = 0; letter != GFC_LETTERS; ++letter)
10488 if (ns->set_flag[letter]
10489 && resolve_typespec_used (&ns->default_type[letter],
10490 &ns->implicit_loc[letter],
10495 gfc_current_ns = ns;
10497 resolve_entries (ns);
10499 resolve_common_vars (ns->blank_common.head, false);
10500 resolve_common_blocks (ns->common_root);
10502 resolve_contained_functions (ns);
10504 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
10506 for (cl = ns->cl_list; cl; cl = cl->next)
10507 resolve_charlen (cl);
10509 gfc_traverse_ns (ns, resolve_symbol);
10511 resolve_fntype (ns);
10513 for (n = ns->contained; n; n = n->sibling)
10515 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
10516 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10517 "also be PURE", n->proc_name->name,
10518 &n->proc_name->declared_at);
10524 gfc_check_interfaces (ns);
10526 gfc_traverse_ns (ns, resolve_values);
10532 for (d = ns->data; d; d = d->next)
10536 gfc_traverse_ns (ns, gfc_formalize_init_value);
10538 gfc_traverse_ns (ns, gfc_verify_binding_labels);
10540 if (ns->common_root != NULL)
10541 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
10543 for (eq = ns->equiv; eq; eq = eq->next)
10544 resolve_equivalence (eq);
10546 /* Warn about unused labels. */
10547 if (warn_unused_label)
10548 warn_unused_fortran_label (ns->st_labels);
10550 gfc_resolve_uops (ns->uop_root);
10552 gfc_current_ns = old_ns;
10556 /* Call resolve_code recursively. */
10559 resolve_codes (gfc_namespace *ns)
10563 for (n = ns->contained; n; n = n->sibling)
10566 gfc_current_ns = ns;
10568 /* Set to an out of range value. */
10569 current_entry_id = -1;
10571 bitmap_obstack_initialize (&labels_obstack);
10572 resolve_code (ns->code, ns);
10573 bitmap_obstack_release (&labels_obstack);
10577 /* This function is called after a complete program unit has been compiled.
10578 Its purpose is to examine all of the expressions associated with a program
10579 unit, assign types to all intermediate expressions, make sure that all
10580 assignments are to compatible types and figure out which names refer to
10581 which functions or subroutines. */
10584 gfc_resolve (gfc_namespace *ns)
10586 gfc_namespace *old_ns;
10588 old_ns = gfc_current_ns;
10590 resolve_types (ns);
10591 resolve_codes (ns);
10593 gfc_current_ns = old_ns;