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;
86 /* Is the symbol host associated? */
88 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
90 for (ns = ns->parent; ns; ns = ns->parent)
99 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
100 an ABSTRACT derived-type. If where is not NULL, an error message with that
101 locus is printed, optionally using name. */
104 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
106 if (ts->type == BT_DERIVED && ts->derived->attr.abstract)
111 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
112 name, where, ts->derived->name);
114 gfc_error ("ABSTRACT type '%s' used at %L",
115 ts->derived->name, where);
125 /* Resolve types of formal argument lists. These have to be done early so that
126 the formal argument lists of module procedures can be copied to the
127 containing module before the individual procedures are resolved
128 individually. We also resolve argument lists of procedures in interface
129 blocks because they are self-contained scoping units.
131 Since a dummy argument cannot be a non-dummy procedure, the only
132 resort left for untyped names are the IMPLICIT types. */
135 resolve_formal_arglist (gfc_symbol *proc)
137 gfc_formal_arglist *f;
141 if (proc->result != NULL)
146 if (gfc_elemental (proc)
147 || sym->attr.pointer || sym->attr.allocatable
148 || (sym->as && sym->as->rank > 0))
150 proc->attr.always_explicit = 1;
151 sym->attr.always_explicit = 1;
156 for (f = proc->formal; f; f = f->next)
162 /* Alternate return placeholder. */
163 if (gfc_elemental (proc))
164 gfc_error ("Alternate return specifier in elemental subroutine "
165 "'%s' at %L is not allowed", proc->name,
167 if (proc->attr.function)
168 gfc_error ("Alternate return specifier in function "
169 "'%s' at %L is not allowed", proc->name,
174 if (sym->attr.if_source != IFSRC_UNKNOWN)
175 resolve_formal_arglist (sym);
177 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
179 if (gfc_pure (proc) && !gfc_pure (sym))
181 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
182 "also be PURE", sym->name, &sym->declared_at);
186 if (gfc_elemental (proc))
188 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
189 "procedure", &sym->declared_at);
193 if (sym->attr.function
194 && sym->ts.type == BT_UNKNOWN
195 && sym->attr.intrinsic)
197 gfc_intrinsic_sym *isym;
198 isym = gfc_find_function (sym->name);
199 if (isym == NULL || !isym->specific)
201 gfc_error ("Unable to find a specific INTRINSIC procedure "
202 "for the reference '%s' at %L", sym->name,
211 if (sym->ts.type == BT_UNKNOWN)
213 if (!sym->attr.function || sym->result == sym)
214 gfc_set_default_type (sym, 1, sym->ns);
217 gfc_resolve_array_spec (sym->as, 0);
219 /* We can't tell if an array with dimension (:) is assumed or deferred
220 shape until we know if it has the pointer or allocatable attributes.
222 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
223 && !(sym->attr.pointer || sym->attr.allocatable))
225 sym->as->type = AS_ASSUMED_SHAPE;
226 for (i = 0; i < sym->as->rank; i++)
227 sym->as->lower[i] = gfc_int_expr (1);
230 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
231 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
232 || sym->attr.optional)
234 proc->attr.always_explicit = 1;
236 proc->result->attr.always_explicit = 1;
239 /* If the flavor is unknown at this point, it has to be a variable.
240 A procedure specification would have already set the type. */
242 if (sym->attr.flavor == FL_UNKNOWN)
243 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
245 if (gfc_pure (proc) && !sym->attr.pointer
246 && sym->attr.flavor != FL_PROCEDURE)
248 if (proc->attr.function && sym->attr.intent != INTENT_IN)
249 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
250 "INTENT(IN)", sym->name, proc->name,
253 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
254 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
255 "have its INTENT specified", sym->name, proc->name,
259 if (gfc_elemental (proc))
263 gfc_error ("Argument '%s' of elemental procedure at %L must "
264 "be scalar", sym->name, &sym->declared_at);
268 if (sym->attr.pointer)
270 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
271 "have the POINTER attribute", sym->name,
276 if (sym->attr.flavor == FL_PROCEDURE)
278 gfc_error ("Dummy procedure '%s' not allowed in elemental "
279 "procedure '%s' at %L", sym->name, proc->name,
285 /* Each dummy shall be specified to be scalar. */
286 if (proc->attr.proc == PROC_ST_FUNCTION)
290 gfc_error ("Argument '%s' of statement function at %L must "
291 "be scalar", sym->name, &sym->declared_at);
295 if (sym->ts.type == BT_CHARACTER)
297 gfc_charlen *cl = sym->ts.cl;
298 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
300 gfc_error ("Character-valued argument '%s' of statement "
301 "function at %L must have constant length",
302 sym->name, &sym->declared_at);
312 /* Work function called when searching for symbols that have argument lists
313 associated with them. */
316 find_arglists (gfc_symbol *sym)
318 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
321 resolve_formal_arglist (sym);
325 /* Given a namespace, resolve all formal argument lists within the namespace.
329 resolve_formal_arglists (gfc_namespace *ns)
334 gfc_traverse_ns (ns, find_arglists);
339 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
343 /* If this namespace is not a function or an entry master function,
345 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
346 || sym->attr.entry_master)
349 /* Try to find out of what the return type is. */
350 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
352 t = gfc_set_default_type (sym->result, 0, ns);
354 if (t == FAILURE && !sym->result->attr.untyped)
356 if (sym->result == sym)
357 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
358 sym->name, &sym->declared_at);
359 else if (!sym->result->attr.proc_pointer)
360 gfc_error ("Result '%s' of contained function '%s' at %L has "
361 "no IMPLICIT type", sym->result->name, sym->name,
362 &sym->result->declared_at);
363 sym->result->attr.untyped = 1;
367 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
368 type, lists the only ways a character length value of * can be used:
369 dummy arguments of procedures, named constants, and function results
370 in external functions. Internal function results are not on that list;
371 ergo, not permitted. */
373 if (sym->result->ts.type == BT_CHARACTER)
375 gfc_charlen *cl = sym->result->ts.cl;
376 if (!cl || !cl->length)
377 gfc_error ("Character-valued internal function '%s' at %L must "
378 "not be assumed length", sym->name, &sym->declared_at);
383 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
384 introduce duplicates. */
387 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
389 gfc_formal_arglist *f, *new_arglist;
392 for (; new_args != NULL; new_args = new_args->next)
394 new_sym = new_args->sym;
395 /* See if this arg is already in the formal argument list. */
396 for (f = proc->formal; f; f = f->next)
398 if (new_sym == f->sym)
405 /* Add a new argument. Argument order is not important. */
406 new_arglist = gfc_get_formal_arglist ();
407 new_arglist->sym = new_sym;
408 new_arglist->next = proc->formal;
409 proc->formal = new_arglist;
414 /* Flag the arguments that are not present in all entries. */
417 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
419 gfc_formal_arglist *f, *head;
422 for (f = proc->formal; f; f = f->next)
427 for (new_args = head; new_args; new_args = new_args->next)
429 if (new_args->sym == f->sym)
436 f->sym->attr.not_always_present = 1;
441 /* Resolve alternate entry points. If a symbol has multiple entry points we
442 create a new master symbol for the main routine, and turn the existing
443 symbol into an entry point. */
446 resolve_entries (gfc_namespace *ns)
448 gfc_namespace *old_ns;
452 char name[GFC_MAX_SYMBOL_LEN + 1];
453 static int master_count = 0;
455 if (ns->proc_name == NULL)
458 /* No need to do anything if this procedure doesn't have alternate entry
463 /* We may already have resolved alternate entry points. */
464 if (ns->proc_name->attr.entry_master)
467 /* If this isn't a procedure something has gone horribly wrong. */
468 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
470 /* Remember the current namespace. */
471 old_ns = gfc_current_ns;
475 /* Add the main entry point to the list of entry points. */
476 el = gfc_get_entry_list ();
477 el->sym = ns->proc_name;
479 el->next = ns->entries;
481 ns->proc_name->attr.entry = 1;
483 /* If it is a module function, it needs to be in the right namespace
484 so that gfc_get_fake_result_decl can gather up the results. The
485 need for this arose in get_proc_name, where these beasts were
486 left in their own namespace, to keep prior references linked to
487 the entry declaration.*/
488 if (ns->proc_name->attr.function
489 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
492 /* Do the same for entries where the master is not a module
493 procedure. These are retained in the module namespace because
494 of the module procedure declaration. */
495 for (el = el->next; el; el = el->next)
496 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
497 && el->sym->attr.mod_proc)
501 /* Add an entry statement for it. */
508 /* Create a new symbol for the master function. */
509 /* Give the internal function a unique name (within this file).
510 Also include the function name so the user has some hope of figuring
511 out what is going on. */
512 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
513 master_count++, ns->proc_name->name);
514 gfc_get_ha_symbol (name, &proc);
515 gcc_assert (proc != NULL);
517 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
518 if (ns->proc_name->attr.subroutine)
519 gfc_add_subroutine (&proc->attr, proc->name, NULL);
523 gfc_typespec *ts, *fts;
524 gfc_array_spec *as, *fas;
525 gfc_add_function (&proc->attr, proc->name, NULL);
527 fas = ns->entries->sym->as;
528 fas = fas ? fas : ns->entries->sym->result->as;
529 fts = &ns->entries->sym->result->ts;
530 if (fts->type == BT_UNKNOWN)
531 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
532 for (el = ns->entries->next; el; el = el->next)
534 ts = &el->sym->result->ts;
536 as = as ? as : el->sym->result->as;
537 if (ts->type == BT_UNKNOWN)
538 ts = gfc_get_default_type (el->sym->result->name, NULL);
540 if (! gfc_compare_types (ts, fts)
541 || (el->sym->result->attr.dimension
542 != ns->entries->sym->result->attr.dimension)
543 || (el->sym->result->attr.pointer
544 != ns->entries->sym->result->attr.pointer))
546 else if (as && fas && ns->entries->sym->result != el->sym->result
547 && gfc_compare_array_spec (as, fas) == 0)
548 gfc_error ("Function %s at %L has entries with mismatched "
549 "array specifications", ns->entries->sym->name,
550 &ns->entries->sym->declared_at);
551 /* The characteristics need to match and thus both need to have
552 the same string length, i.e. both len=*, or both len=4.
553 Having both len=<variable> is also possible, but difficult to
554 check at compile time. */
555 else if (ts->type == BT_CHARACTER && ts->cl && fts->cl
556 && (((ts->cl->length && !fts->cl->length)
557 ||(!ts->cl->length && fts->cl->length))
559 && ts->cl->length->expr_type
560 != fts->cl->length->expr_type)
562 && ts->cl->length->expr_type == EXPR_CONSTANT
563 && mpz_cmp (ts->cl->length->value.integer,
564 fts->cl->length->value.integer) != 0)))
565 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
566 "entries returning variables of different "
567 "string lengths", ns->entries->sym->name,
568 &ns->entries->sym->declared_at);
573 sym = ns->entries->sym->result;
574 /* All result types the same. */
576 if (sym->attr.dimension)
577 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
578 if (sym->attr.pointer)
579 gfc_add_pointer (&proc->attr, NULL);
583 /* Otherwise the result will be passed through a union by
585 proc->attr.mixed_entry_master = 1;
586 for (el = ns->entries; el; el = el->next)
588 sym = el->sym->result;
589 if (sym->attr.dimension)
591 if (el == ns->entries)
592 gfc_error ("FUNCTION result %s can't be an array in "
593 "FUNCTION %s at %L", sym->name,
594 ns->entries->sym->name, &sym->declared_at);
596 gfc_error ("ENTRY result %s can't be an array in "
597 "FUNCTION %s at %L", sym->name,
598 ns->entries->sym->name, &sym->declared_at);
600 else if (sym->attr.pointer)
602 if (el == ns->entries)
603 gfc_error ("FUNCTION result %s can't be a POINTER in "
604 "FUNCTION %s at %L", sym->name,
605 ns->entries->sym->name, &sym->declared_at);
607 gfc_error ("ENTRY result %s can't be a POINTER in "
608 "FUNCTION %s at %L", sym->name,
609 ns->entries->sym->name, &sym->declared_at);
614 if (ts->type == BT_UNKNOWN)
615 ts = gfc_get_default_type (sym->name, NULL);
619 if (ts->kind == gfc_default_integer_kind)
623 if (ts->kind == gfc_default_real_kind
624 || ts->kind == gfc_default_double_kind)
628 if (ts->kind == gfc_default_complex_kind)
632 if (ts->kind == gfc_default_logical_kind)
636 /* We will issue error elsewhere. */
644 if (el == ns->entries)
645 gfc_error ("FUNCTION result %s can't be of type %s "
646 "in FUNCTION %s at %L", sym->name,
647 gfc_typename (ts), ns->entries->sym->name,
650 gfc_error ("ENTRY result %s can't be of type %s "
651 "in FUNCTION %s at %L", sym->name,
652 gfc_typename (ts), ns->entries->sym->name,
659 proc->attr.access = ACCESS_PRIVATE;
660 proc->attr.entry_master = 1;
662 /* Merge all the entry point arguments. */
663 for (el = ns->entries; el; el = el->next)
664 merge_argument_lists (proc, el->sym->formal);
666 /* Check the master formal arguments for any that are not
667 present in all entry points. */
668 for (el = ns->entries; el; el = el->next)
669 check_argument_lists (proc, el->sym->formal);
671 /* Use the master function for the function body. */
672 ns->proc_name = proc;
674 /* Finalize the new symbols. */
675 gfc_commit_symbols ();
677 /* Restore the original namespace. */
678 gfc_current_ns = old_ns;
683 has_default_initializer (gfc_symbol *der)
687 gcc_assert (der->attr.flavor == FL_DERIVED);
688 for (c = der->components; c; c = c->next)
689 if ((c->ts.type != BT_DERIVED && c->initializer)
690 || (c->ts.type == BT_DERIVED
691 && (!c->attr.pointer && has_default_initializer (c->ts.derived))))
697 /* Resolve common variables. */
699 resolve_common_vars (gfc_symbol *sym, bool named_common)
701 gfc_symbol *csym = sym;
703 for (; csym; csym = csym->common_next)
705 if (csym->value || csym->attr.data)
707 if (!csym->ns->is_block_data)
708 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
709 "but only in BLOCK DATA initialization is "
710 "allowed", csym->name, &csym->declared_at);
711 else if (!named_common)
712 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
713 "in a blank COMMON but initialization is only "
714 "allowed in named common blocks", csym->name,
718 if (csym->ts.type != BT_DERIVED)
721 if (!(csym->ts.derived->attr.sequence
722 || csym->ts.derived->attr.is_bind_c))
723 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
724 "has neither the SEQUENCE nor the BIND(C) "
725 "attribute", csym->name, &csym->declared_at);
726 if (csym->ts.derived->attr.alloc_comp)
727 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
728 "has an ultimate component that is "
729 "allocatable", csym->name, &csym->declared_at);
730 if (has_default_initializer (csym->ts.derived))
731 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
732 "may not have default initializer", csym->name,
735 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
736 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
740 /* Resolve common blocks. */
742 resolve_common_blocks (gfc_symtree *common_root)
746 if (common_root == NULL)
749 if (common_root->left)
750 resolve_common_blocks (common_root->left);
751 if (common_root->right)
752 resolve_common_blocks (common_root->right);
754 resolve_common_vars (common_root->n.common->head, true);
756 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
760 if (sym->attr.flavor == FL_PARAMETER)
761 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
762 sym->name, &common_root->n.common->where, &sym->declared_at);
764 if (sym->attr.intrinsic)
765 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
766 sym->name, &common_root->n.common->where);
767 else if (sym->attr.result
768 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
769 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
770 "that is also a function result", sym->name,
771 &common_root->n.common->where);
772 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
773 && sym->attr.proc != PROC_ST_FUNCTION)
774 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
775 "that is also a global procedure", sym->name,
776 &common_root->n.common->where);
780 /* Resolve contained function types. Because contained functions can call one
781 another, they have to be worked out before any of the contained procedures
784 The good news is that if a function doesn't already have a type, the only
785 way it can get one is through an IMPLICIT type or a RESULT variable, because
786 by definition contained functions are contained namespace they're contained
787 in, not in a sibling or parent namespace. */
790 resolve_contained_functions (gfc_namespace *ns)
792 gfc_namespace *child;
795 resolve_formal_arglists (ns);
797 for (child = ns->contained; child; child = child->sibling)
799 /* Resolve alternate entry points first. */
800 resolve_entries (child);
802 /* Then check function return types. */
803 resolve_contained_fntype (child->proc_name, child);
804 for (el = child->entries; el; el = el->next)
805 resolve_contained_fntype (el->sym, child);
810 /* Resolve all of the elements of a structure constructor and make sure that
811 the types are correct. */
814 resolve_structure_cons (gfc_expr *expr)
816 gfc_constructor *cons;
822 cons = expr->value.constructor;
823 /* A constructor may have references if it is the result of substituting a
824 parameter variable. In this case we just pull out the component we
827 comp = expr->ref->u.c.sym->components;
829 comp = expr->ts.derived->components;
831 /* See if the user is trying to invoke a structure constructor for one of
832 the iso_c_binding derived types. */
833 if (expr->ts.derived && expr->ts.derived->ts.is_iso_c && cons
834 && cons->expr != NULL)
836 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
837 expr->ts.derived->name, &(expr->where));
841 for (; comp; comp = comp->next, cons = cons->next)
848 if (gfc_resolve_expr (cons->expr) == FAILURE)
854 rank = comp->as ? comp->as->rank : 0;
855 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
856 && (comp->attr.allocatable || cons->expr->rank))
858 gfc_error ("The rank of the element in the derived type "
859 "constructor at %L does not match that of the "
860 "component (%d/%d)", &cons->expr->where,
861 cons->expr->rank, rank);
865 /* If we don't have the right type, try to convert it. */
867 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
870 if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
871 gfc_error ("The element in the derived type constructor at %L, "
872 "for pointer component '%s', is %s but should be %s",
873 &cons->expr->where, comp->name,
874 gfc_basic_typename (cons->expr->ts.type),
875 gfc_basic_typename (comp->ts.type));
877 t = gfc_convert_type (cons->expr, &comp->ts, 1);
880 if (cons->expr->expr_type == EXPR_NULL
881 && !(comp->attr.pointer || comp->attr.allocatable
882 || comp->attr.proc_pointer))
885 gfc_error ("The NULL in the derived type constructor at %L is "
886 "being applied to component '%s', which is neither "
887 "a POINTER nor ALLOCATABLE", &cons->expr->where,
891 if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
894 a = gfc_expr_attr (cons->expr);
896 if (!a.pointer && !a.target)
899 gfc_error ("The element in the derived type constructor at %L, "
900 "for pointer component '%s' should be a POINTER or "
901 "a TARGET", &cons->expr->where, comp->name);
909 /****************** Expression name resolution ******************/
911 /* Returns 0 if a symbol was not declared with a type or
912 attribute declaration statement, nonzero otherwise. */
915 was_declared (gfc_symbol *sym)
921 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
924 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
925 || a.optional || a.pointer || a.save || a.target || a.volatile_
926 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
933 /* Determine if a symbol is generic or not. */
936 generic_sym (gfc_symbol *sym)
940 if (sym->attr.generic ||
941 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
944 if (was_declared (sym) || sym->ns->parent == NULL)
947 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
954 return generic_sym (s);
961 /* Determine if a symbol is specific or not. */
964 specific_sym (gfc_symbol *sym)
968 if (sym->attr.if_source == IFSRC_IFBODY
969 || sym->attr.proc == PROC_MODULE
970 || sym->attr.proc == PROC_INTERNAL
971 || sym->attr.proc == PROC_ST_FUNCTION
972 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
973 || sym->attr.external)
976 if (was_declared (sym) || sym->ns->parent == NULL)
979 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
981 return (s == NULL) ? 0 : specific_sym (s);
985 /* Figure out if the procedure is specific, generic or unknown. */
988 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
992 procedure_kind (gfc_symbol *sym)
994 if (generic_sym (sym))
995 return PTYPE_GENERIC;
997 if (specific_sym (sym))
998 return PTYPE_SPECIFIC;
1000 return PTYPE_UNKNOWN;
1003 /* Check references to assumed size arrays. The flag need_full_assumed_size
1004 is nonzero when matching actual arguments. */
1006 static int need_full_assumed_size = 0;
1009 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1011 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1014 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1015 What should it be? */
1016 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1017 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1018 && (e->ref->u.ar.type == AR_FULL))
1020 gfc_error ("The upper bound in the last dimension must "
1021 "appear in the reference to the assumed size "
1022 "array '%s' at %L", sym->name, &e->where);
1029 /* Look for bad assumed size array references in argument expressions
1030 of elemental and array valued intrinsic procedures. Since this is
1031 called from procedure resolution functions, it only recurses at
1035 resolve_assumed_size_actual (gfc_expr *e)
1040 switch (e->expr_type)
1043 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1048 if (resolve_assumed_size_actual (e->value.op.op1)
1049 || resolve_assumed_size_actual (e->value.op.op2))
1060 /* Check a generic procedure, passed as an actual argument, to see if
1061 there is a matching specific name. If none, it is an error, and if
1062 more than one, the reference is ambiguous. */
1064 count_specific_procs (gfc_expr *e)
1071 sym = e->symtree->n.sym;
1073 for (p = sym->generic; p; p = p->next)
1074 if (strcmp (sym->name, p->sym->name) == 0)
1076 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1082 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1086 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1087 "argument at %L", sym->name, &e->where);
1093 /* See if a call to sym could possibly be a not allowed RECURSION because of
1094 a missing RECURIVE declaration. This means that either sym is the current
1095 context itself, or sym is the parent of a contained procedure calling its
1096 non-RECURSIVE containing procedure.
1097 This also works if sym is an ENTRY. */
1100 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1102 gfc_symbol* proc_sym;
1103 gfc_symbol* context_proc;
1105 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1107 /* If we've got an ENTRY, find real procedure. */
1108 if (sym->attr.entry && sym->ns->entries)
1109 proc_sym = sym->ns->entries->sym;
1113 /* If sym is RECURSIVE, all is well of course. */
1114 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1117 /* Find the context procdure's "real" symbol if it has entries. */
1118 context_proc = (context->entries ? context->entries->sym
1119 : context->proc_name);
1123 /* A call from sym's body to itself is recursion, of course. */
1124 if (context_proc == proc_sym)
1127 /* The same is true if context is a contained procedure and sym the
1129 if (context_proc->attr.contained)
1131 gfc_symbol* parent_proc;
1133 gcc_assert (context->parent);
1134 parent_proc = (context->parent->entries ? context->parent->entries->sym
1135 : context->parent->proc_name);
1137 if (parent_proc == proc_sym)
1145 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1146 its typespec and formal argument list. */
1149 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1151 gfc_intrinsic_sym *isym = gfc_find_function (sym->name);
1154 if (!sym->attr.function &&
1155 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1161 isym = gfc_find_subroutine (sym->name);
1163 if (!sym->attr.subroutine &&
1164 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1168 gfc_copy_formal_args_intr (sym, isym);
1173 /* Resolve a procedure expression, like passing it to a called procedure or as
1174 RHS for a procedure pointer assignment. */
1177 resolve_procedure_expression (gfc_expr* expr)
1181 if (expr->expr_type != EXPR_VARIABLE)
1183 gcc_assert (expr->symtree);
1185 sym = expr->symtree->n.sym;
1187 if (sym->attr.intrinsic)
1188 resolve_intrinsic (sym, &expr->where);
1190 if (sym->attr.flavor != FL_PROCEDURE
1191 || (sym->attr.function && sym->result == sym))
1194 /* A non-RECURSIVE procedure that is used as procedure expression within its
1195 own body is in danger of being called recursively. */
1196 if (is_illegal_recursion (sym, gfc_current_ns))
1197 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1198 " itself recursively. Declare it RECURSIVE or use"
1199 " -frecursive", sym->name, &expr->where);
1205 /* Resolve an actual argument list. Most of the time, this is just
1206 resolving the expressions in the list.
1207 The exception is that we sometimes have to decide whether arguments
1208 that look like procedure arguments are really simple variable
1212 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1213 bool no_formal_args)
1216 gfc_symtree *parent_st;
1218 int save_need_full_assumed_size;
1219 gfc_component *comp;
1221 for (; arg; arg = arg->next)
1226 /* Check the label is a valid branching target. */
1229 if (arg->label->defined == ST_LABEL_UNKNOWN)
1231 gfc_error ("Label %d referenced at %L is never defined",
1232 arg->label->value, &arg->label->where);
1239 if (gfc_is_proc_ptr_comp (e, &comp))
1242 if (e->value.compcall.actual == NULL)
1243 e->expr_type = EXPR_VARIABLE;
1246 if (comp->as != NULL)
1247 e->rank = comp->as->rank;
1248 e->expr_type = EXPR_FUNCTION;
1253 if (e->expr_type == EXPR_VARIABLE
1254 && e->symtree->n.sym->attr.generic
1256 && count_specific_procs (e) != 1)
1259 if (e->ts.type != BT_PROCEDURE)
1261 save_need_full_assumed_size = need_full_assumed_size;
1262 if (e->expr_type != EXPR_VARIABLE)
1263 need_full_assumed_size = 0;
1264 if (gfc_resolve_expr (e) != SUCCESS)
1266 need_full_assumed_size = save_need_full_assumed_size;
1270 /* See if the expression node should really be a variable reference. */
1272 sym = e->symtree->n.sym;
1274 if (sym->attr.flavor == FL_PROCEDURE
1275 || sym->attr.intrinsic
1276 || sym->attr.external)
1280 /* If a procedure is not already determined to be something else
1281 check if it is intrinsic. */
1282 if (!sym->attr.intrinsic
1283 && !(sym->attr.external || sym->attr.use_assoc
1284 || sym->attr.if_source == IFSRC_IFBODY)
1285 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1286 sym->attr.intrinsic = 1;
1288 if (sym->attr.proc == PROC_ST_FUNCTION)
1290 gfc_error ("Statement function '%s' at %L is not allowed as an "
1291 "actual argument", sym->name, &e->where);
1294 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1295 sym->attr.subroutine);
1296 if (sym->attr.intrinsic && actual_ok == 0)
1298 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1299 "actual argument", sym->name, &e->where);
1302 if (sym->attr.contained && !sym->attr.use_assoc
1303 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1305 gfc_error ("Internal procedure '%s' is not allowed as an "
1306 "actual argument at %L", sym->name, &e->where);
1309 if (sym->attr.elemental && !sym->attr.intrinsic)
1311 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1312 "allowed as an actual argument at %L", sym->name,
1316 /* Check if a generic interface has a specific procedure
1317 with the same name before emitting an error. */
1318 if (sym->attr.generic && count_specific_procs (e) != 1)
1321 /* Just in case a specific was found for the expression. */
1322 sym = e->symtree->n.sym;
1324 /* If the symbol is the function that names the current (or
1325 parent) scope, then we really have a variable reference. */
1327 if (sym->attr.function && sym->result == sym
1328 && (sym->ns->proc_name == sym
1329 || (sym->ns->parent != NULL
1330 && sym->ns->parent->proc_name == sym)))
1333 /* If all else fails, see if we have a specific intrinsic. */
1334 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1336 gfc_intrinsic_sym *isym;
1338 isym = gfc_find_function (sym->name);
1339 if (isym == NULL || !isym->specific)
1341 gfc_error ("Unable to find a specific INTRINSIC procedure "
1342 "for the reference '%s' at %L", sym->name,
1347 sym->attr.intrinsic = 1;
1348 sym->attr.function = 1;
1351 if (gfc_resolve_expr (e) == FAILURE)
1356 /* See if the name is a module procedure in a parent unit. */
1358 if (was_declared (sym) || sym->ns->parent == NULL)
1361 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1363 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1367 if (parent_st == NULL)
1370 sym = parent_st->n.sym;
1371 e->symtree = parent_st; /* Point to the right thing. */
1373 if (sym->attr.flavor == FL_PROCEDURE
1374 || sym->attr.intrinsic
1375 || sym->attr.external)
1377 if (gfc_resolve_expr (e) == FAILURE)
1383 e->expr_type = EXPR_VARIABLE;
1385 if (sym->as != NULL)
1387 e->rank = sym->as->rank;
1388 e->ref = gfc_get_ref ();
1389 e->ref->type = REF_ARRAY;
1390 e->ref->u.ar.type = AR_FULL;
1391 e->ref->u.ar.as = sym->as;
1394 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1395 primary.c (match_actual_arg). If above code determines that it
1396 is a variable instead, it needs to be resolved as it was not
1397 done at the beginning of this function. */
1398 save_need_full_assumed_size = need_full_assumed_size;
1399 if (e->expr_type != EXPR_VARIABLE)
1400 need_full_assumed_size = 0;
1401 if (gfc_resolve_expr (e) != SUCCESS)
1403 need_full_assumed_size = save_need_full_assumed_size;
1406 /* Check argument list functions %VAL, %LOC and %REF. There is
1407 nothing to do for %REF. */
1408 if (arg->name && arg->name[0] == '%')
1410 if (strncmp ("%VAL", arg->name, 4) == 0)
1412 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1414 gfc_error ("By-value argument at %L is not of numeric "
1421 gfc_error ("By-value argument at %L cannot be an array or "
1422 "an array section", &e->where);
1426 /* Intrinsics are still PROC_UNKNOWN here. However,
1427 since same file external procedures are not resolvable
1428 in gfortran, it is a good deal easier to leave them to
1430 if (ptype != PROC_UNKNOWN
1431 && ptype != PROC_DUMMY
1432 && ptype != PROC_EXTERNAL
1433 && ptype != PROC_MODULE)
1435 gfc_error ("By-value argument at %L is not allowed "
1436 "in this context", &e->where);
1441 /* Statement functions have already been excluded above. */
1442 else if (strncmp ("%LOC", arg->name, 4) == 0
1443 && e->ts.type == BT_PROCEDURE)
1445 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1447 gfc_error ("Passing internal procedure at %L by location "
1448 "not allowed", &e->where);
1459 /* Do the checks of the actual argument list that are specific to elemental
1460 procedures. If called with c == NULL, we have a function, otherwise if
1461 expr == NULL, we have a subroutine. */
1464 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1466 gfc_actual_arglist *arg0;
1467 gfc_actual_arglist *arg;
1468 gfc_symbol *esym = NULL;
1469 gfc_intrinsic_sym *isym = NULL;
1471 gfc_intrinsic_arg *iformal = NULL;
1472 gfc_formal_arglist *eformal = NULL;
1473 bool formal_optional = false;
1474 bool set_by_optional = false;
1478 /* Is this an elemental procedure? */
1479 if (expr && expr->value.function.actual != NULL)
1481 if (expr->value.function.esym != NULL
1482 && expr->value.function.esym->attr.elemental)
1484 arg0 = expr->value.function.actual;
1485 esym = expr->value.function.esym;
1487 else if (expr->value.function.isym != NULL
1488 && expr->value.function.isym->elemental)
1490 arg0 = expr->value.function.actual;
1491 isym = expr->value.function.isym;
1496 else if (c && c->ext.actual != NULL)
1498 arg0 = c->ext.actual;
1500 if (c->resolved_sym)
1501 esym = c->resolved_sym;
1503 esym = c->symtree->n.sym;
1506 if (!esym->attr.elemental)
1512 /* The rank of an elemental is the rank of its array argument(s). */
1513 for (arg = arg0; arg; arg = arg->next)
1515 if (arg->expr != NULL && arg->expr->rank > 0)
1517 rank = arg->expr->rank;
1518 if (arg->expr->expr_type == EXPR_VARIABLE
1519 && arg->expr->symtree->n.sym->attr.optional)
1520 set_by_optional = true;
1522 /* Function specific; set the result rank and shape. */
1526 if (!expr->shape && arg->expr->shape)
1528 expr->shape = gfc_get_shape (rank);
1529 for (i = 0; i < rank; i++)
1530 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1537 /* If it is an array, it shall not be supplied as an actual argument
1538 to an elemental procedure unless an array of the same rank is supplied
1539 as an actual argument corresponding to a nonoptional dummy argument of
1540 that elemental procedure(12.4.1.5). */
1541 formal_optional = false;
1543 iformal = isym->formal;
1545 eformal = esym->formal;
1547 for (arg = arg0; arg; arg = arg->next)
1551 if (eformal->sym && eformal->sym->attr.optional)
1552 formal_optional = true;
1553 eformal = eformal->next;
1555 else if (isym && iformal)
1557 if (iformal->optional)
1558 formal_optional = true;
1559 iformal = iformal->next;
1562 formal_optional = true;
1564 if (pedantic && arg->expr != NULL
1565 && arg->expr->expr_type == EXPR_VARIABLE
1566 && arg->expr->symtree->n.sym->attr.optional
1569 && (set_by_optional || arg->expr->rank != rank)
1570 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1572 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1573 "MISSING, it cannot be the actual argument of an "
1574 "ELEMENTAL procedure unless there is a non-optional "
1575 "argument with the same rank (12.4.1.5)",
1576 arg->expr->symtree->n.sym->name, &arg->expr->where);
1581 for (arg = arg0; arg; arg = arg->next)
1583 if (arg->expr == NULL || arg->expr->rank == 0)
1586 /* Being elemental, the last upper bound of an assumed size array
1587 argument must be present. */
1588 if (resolve_assumed_size_actual (arg->expr))
1591 /* Elemental procedure's array actual arguments must conform. */
1594 if (gfc_check_conformance (arg->expr, e,
1595 "elemental procedure") == FAILURE)
1602 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1603 is an array, the intent inout/out variable needs to be also an array. */
1604 if (rank > 0 && esym && expr == NULL)
1605 for (eformal = esym->formal, arg = arg0; arg && eformal;
1606 arg = arg->next, eformal = eformal->next)
1607 if ((eformal->sym->attr.intent == INTENT_OUT
1608 || eformal->sym->attr.intent == INTENT_INOUT)
1609 && arg->expr && arg->expr->rank == 0)
1611 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1612 "ELEMENTAL subroutine '%s' is a scalar, but another "
1613 "actual argument is an array", &arg->expr->where,
1614 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1615 : "INOUT", eformal->sym->name, esym->name);
1622 /* Go through each actual argument in ACTUAL and see if it can be
1623 implemented as an inlined, non-copying intrinsic. FNSYM is the
1624 function being called, or NULL if not known. */
1627 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1629 gfc_actual_arglist *ap;
1632 for (ap = actual; ap; ap = ap->next)
1634 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1635 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1637 ap->expr->inline_noncopying_intrinsic = 1;
1641 /* This function does the checking of references to global procedures
1642 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1643 77 and 95 standards. It checks for a gsymbol for the name, making
1644 one if it does not already exist. If it already exists, then the
1645 reference being resolved must correspond to the type of gsymbol.
1646 Otherwise, the new symbol is equipped with the attributes of the
1647 reference. The corresponding code that is called in creating
1648 global entities is parse.c.
1650 In addition, for all but -std=legacy, the gsymbols are used to
1651 check the interfaces of external procedures from the same file.
1652 The namespace of the gsymbol is resolved and then, once this is
1653 done the interface is checked. */
1656 resolve_global_procedure (gfc_symbol *sym, locus *where,
1657 gfc_actual_arglist **actual, int sub)
1661 enum gfc_symbol_type type;
1663 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1665 gsym = gfc_get_gsymbol (sym->name);
1667 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1668 gfc_global_used (gsym, where);
1670 if (gfc_option.flag_whole_file
1671 && gsym->type != GSYM_UNKNOWN
1673 && gsym->ns->proc_name)
1675 /* Make sure that translation for the gsymbol occurs before
1676 the procedure currently being resolved. */
1677 ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
1678 for (; ns && ns != gsym->ns; ns = ns->sibling)
1680 if (ns->sibling == gsym->ns)
1682 ns->sibling = gsym->ns->sibling;
1683 gsym->ns->sibling = gfc_global_ns_list;
1684 gfc_global_ns_list = gsym->ns;
1689 if (!gsym->ns->resolved)
1690 gfc_resolve (gsym->ns);
1692 gfc_procedure_use (gsym->ns->proc_name, actual, where);
1695 if (gsym->type == GSYM_UNKNOWN)
1698 gsym->where = *where;
1705 /************* Function resolution *************/
1707 /* Resolve a function call known to be generic.
1708 Section 14.1.2.4.1. */
1711 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1715 if (sym->attr.generic)
1717 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1720 expr->value.function.name = s->name;
1721 expr->value.function.esym = s;
1723 if (s->ts.type != BT_UNKNOWN)
1725 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1726 expr->ts = s->result->ts;
1729 expr->rank = s->as->rank;
1730 else if (s->result != NULL && s->result->as != NULL)
1731 expr->rank = s->result->as->rank;
1733 gfc_set_sym_referenced (expr->value.function.esym);
1738 /* TODO: Need to search for elemental references in generic
1742 if (sym->attr.intrinsic)
1743 return gfc_intrinsic_func_interface (expr, 0);
1750 resolve_generic_f (gfc_expr *expr)
1755 sym = expr->symtree->n.sym;
1759 m = resolve_generic_f0 (expr, sym);
1762 else if (m == MATCH_ERROR)
1766 if (sym->ns->parent == NULL)
1768 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1772 if (!generic_sym (sym))
1776 /* Last ditch attempt. See if the reference is to an intrinsic
1777 that possesses a matching interface. 14.1.2.4 */
1778 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1780 gfc_error ("There is no specific function for the generic '%s' at %L",
1781 expr->symtree->n.sym->name, &expr->where);
1785 m = gfc_intrinsic_func_interface (expr, 0);
1789 gfc_error ("Generic function '%s' at %L is not consistent with a "
1790 "specific intrinsic interface", expr->symtree->n.sym->name,
1797 /* Resolve a function call known to be specific. */
1800 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1804 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1806 if (sym->attr.dummy)
1808 sym->attr.proc = PROC_DUMMY;
1812 sym->attr.proc = PROC_EXTERNAL;
1816 if (sym->attr.proc == PROC_MODULE
1817 || sym->attr.proc == PROC_ST_FUNCTION
1818 || sym->attr.proc == PROC_INTERNAL)
1821 if (sym->attr.intrinsic)
1823 m = gfc_intrinsic_func_interface (expr, 1);
1827 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1828 "with an intrinsic", sym->name, &expr->where);
1836 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1839 expr->ts = sym->result->ts;
1842 expr->value.function.name = sym->name;
1843 expr->value.function.esym = sym;
1844 if (sym->as != NULL)
1845 expr->rank = sym->as->rank;
1852 resolve_specific_f (gfc_expr *expr)
1857 sym = expr->symtree->n.sym;
1861 m = resolve_specific_f0 (sym, expr);
1864 if (m == MATCH_ERROR)
1867 if (sym->ns->parent == NULL)
1870 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1876 gfc_error ("Unable to resolve the specific function '%s' at %L",
1877 expr->symtree->n.sym->name, &expr->where);
1883 /* Resolve a procedure call not known to be generic nor specific. */
1886 resolve_unknown_f (gfc_expr *expr)
1891 sym = expr->symtree->n.sym;
1893 if (sym->attr.dummy)
1895 sym->attr.proc = PROC_DUMMY;
1896 expr->value.function.name = sym->name;
1900 /* See if we have an intrinsic function reference. */
1902 if (gfc_is_intrinsic (sym, 0, expr->where))
1904 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1909 /* The reference is to an external name. */
1911 sym->attr.proc = PROC_EXTERNAL;
1912 expr->value.function.name = sym->name;
1913 expr->value.function.esym = expr->symtree->n.sym;
1915 if (sym->as != NULL)
1916 expr->rank = sym->as->rank;
1918 /* Type of the expression is either the type of the symbol or the
1919 default type of the symbol. */
1922 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1924 if (sym->ts.type != BT_UNKNOWN)
1928 ts = gfc_get_default_type (sym->name, sym->ns);
1930 if (ts->type == BT_UNKNOWN)
1932 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1933 sym->name, &expr->where);
1944 /* Return true, if the symbol is an external procedure. */
1946 is_external_proc (gfc_symbol *sym)
1948 if (!sym->attr.dummy && !sym->attr.contained
1949 && !(sym->attr.intrinsic
1950 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
1951 && sym->attr.proc != PROC_ST_FUNCTION
1952 && !sym->attr.use_assoc
1960 /* Figure out if a function reference is pure or not. Also set the name
1961 of the function for a potential error message. Return nonzero if the
1962 function is PURE, zero if not. */
1964 pure_stmt_function (gfc_expr *, gfc_symbol *);
1967 pure_function (gfc_expr *e, const char **name)
1973 if (e->symtree != NULL
1974 && e->symtree->n.sym != NULL
1975 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1976 return pure_stmt_function (e, e->symtree->n.sym);
1978 if (e->value.function.esym)
1980 pure = gfc_pure (e->value.function.esym);
1981 *name = e->value.function.esym->name;
1983 else if (e->value.function.isym)
1985 pure = e->value.function.isym->pure
1986 || e->value.function.isym->elemental;
1987 *name = e->value.function.isym->name;
1991 /* Implicit functions are not pure. */
1993 *name = e->value.function.name;
2001 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2002 int *f ATTRIBUTE_UNUSED)
2006 /* Don't bother recursing into other statement functions
2007 since they will be checked individually for purity. */
2008 if (e->expr_type != EXPR_FUNCTION
2010 || e->symtree->n.sym == sym
2011 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2014 return pure_function (e, &name) ? false : true;
2019 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2021 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2026 is_scalar_expr_ptr (gfc_expr *expr)
2028 gfc_try retval = SUCCESS;
2033 /* See if we have a gfc_ref, which means we have a substring, array
2034 reference, or a component. */
2035 if (expr->ref != NULL)
2038 while (ref->next != NULL)
2044 if (ref->u.ss.length != NULL
2045 && ref->u.ss.length->length != NULL
2047 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2049 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2051 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2052 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2053 if (end - start + 1 != 1)
2060 if (ref->u.ar.type == AR_ELEMENT)
2062 else if (ref->u.ar.type == AR_FULL)
2064 /* The user can give a full array if the array is of size 1. */
2065 if (ref->u.ar.as != NULL
2066 && ref->u.ar.as->rank == 1
2067 && ref->u.ar.as->type == AS_EXPLICIT
2068 && ref->u.ar.as->lower[0] != NULL
2069 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2070 && ref->u.ar.as->upper[0] != NULL
2071 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2073 /* If we have a character string, we need to check if
2074 its length is one. */
2075 if (expr->ts.type == BT_CHARACTER)
2077 if (expr->ts.cl == NULL
2078 || expr->ts.cl->length == NULL
2079 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
2085 /* We have constant lower and upper bounds. If the
2086 difference between is 1, it can be considered a
2088 start = (int) mpz_get_si
2089 (ref->u.ar.as->lower[0]->value.integer);
2090 end = (int) mpz_get_si
2091 (ref->u.ar.as->upper[0]->value.integer);
2092 if (end - start + 1 != 1)
2107 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2109 /* Character string. Make sure it's of length 1. */
2110 if (expr->ts.cl == NULL
2111 || expr->ts.cl->length == NULL
2112 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
2115 else if (expr->rank != 0)
2122 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2123 and, in the case of c_associated, set the binding label based on
2127 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2128 gfc_symbol **new_sym)
2130 char name[GFC_MAX_SYMBOL_LEN + 1];
2131 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2132 int optional_arg = 0, is_pointer = 0;
2133 gfc_try retval = SUCCESS;
2134 gfc_symbol *args_sym;
2135 gfc_typespec *arg_ts;
2137 if (args->expr->expr_type == EXPR_CONSTANT
2138 || args->expr->expr_type == EXPR_OP
2139 || args->expr->expr_type == EXPR_NULL)
2141 gfc_error ("Argument to '%s' at %L is not a variable",
2142 sym->name, &(args->expr->where));
2146 args_sym = args->expr->symtree->n.sym;
2148 /* The typespec for the actual arg should be that stored in the expr
2149 and not necessarily that of the expr symbol (args_sym), because
2150 the actual expression could be a part-ref of the expr symbol. */
2151 arg_ts = &(args->expr->ts);
2153 is_pointer = gfc_is_data_pointer (args->expr);
2155 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2157 /* If the user gave two args then they are providing something for
2158 the optional arg (the second cptr). Therefore, set the name and
2159 binding label to the c_associated for two cptrs. Otherwise,
2160 set c_associated to expect one cptr. */
2164 sprintf (name, "%s_2", sym->name);
2165 sprintf (binding_label, "%s_2", sym->binding_label);
2171 sprintf (name, "%s_1", sym->name);
2172 sprintf (binding_label, "%s_1", sym->binding_label);
2176 /* Get a new symbol for the version of c_associated that
2178 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2180 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2181 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2183 sprintf (name, "%s", sym->name);
2184 sprintf (binding_label, "%s", sym->binding_label);
2186 /* Error check the call. */
2187 if (args->next != NULL)
2189 gfc_error_now ("More actual than formal arguments in '%s' "
2190 "call at %L", name, &(args->expr->where));
2193 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2195 /* Make sure we have either the target or pointer attribute. */
2196 if (!args_sym->attr.target && !is_pointer)
2198 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2199 "a TARGET or an associated pointer",
2201 sym->name, &(args->expr->where));
2205 /* See if we have interoperable type and type param. */
2206 if (verify_c_interop (arg_ts) == SUCCESS
2207 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2209 if (args_sym->attr.target == 1)
2211 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2212 has the target attribute and is interoperable. */
2213 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2214 allocatable variable that has the TARGET attribute and
2215 is not an array of zero size. */
2216 if (args_sym->attr.allocatable == 1)
2218 if (args_sym->attr.dimension != 0
2219 && (args_sym->as && args_sym->as->rank == 0))
2221 gfc_error_now ("Allocatable variable '%s' used as a "
2222 "parameter to '%s' at %L must not be "
2223 "an array of zero size",
2224 args_sym->name, sym->name,
2225 &(args->expr->where));
2231 /* A non-allocatable target variable with C
2232 interoperable type and type parameters must be
2234 if (args_sym && args_sym->attr.dimension)
2236 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2238 gfc_error ("Assumed-shape array '%s' at %L "
2239 "cannot be an argument to the "
2240 "procedure '%s' because "
2241 "it is not C interoperable",
2243 &(args->expr->where), sym->name);
2246 else if (args_sym->as->type == AS_DEFERRED)
2248 gfc_error ("Deferred-shape array '%s' at %L "
2249 "cannot be an argument to the "
2250 "procedure '%s' because "
2251 "it is not C interoperable",
2253 &(args->expr->where), sym->name);
2258 /* Make sure it's not a character string. Arrays of
2259 any type should be ok if the variable is of a C
2260 interoperable type. */
2261 if (arg_ts->type == BT_CHARACTER)
2262 if (arg_ts->cl != NULL
2263 && (arg_ts->cl->length == NULL
2264 || arg_ts->cl->length->expr_type
2267 (arg_ts->cl->length->value.integer, 1)
2269 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2271 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2272 "at %L must have a length of 1",
2273 args_sym->name, sym->name,
2274 &(args->expr->where));
2280 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2282 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2284 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2285 "associated scalar POINTER", args_sym->name,
2286 sym->name, &(args->expr->where));
2292 /* The parameter is not required to be C interoperable. If it
2293 is not C interoperable, it must be a nonpolymorphic scalar
2294 with no length type parameters. It still must have either
2295 the pointer or target attribute, and it can be
2296 allocatable (but must be allocated when c_loc is called). */
2297 if (args->expr->rank != 0
2298 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2300 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2301 "scalar", args_sym->name, sym->name,
2302 &(args->expr->where));
2305 else if (arg_ts->type == BT_CHARACTER
2306 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2308 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2309 "%L must have a length of 1",
2310 args_sym->name, sym->name,
2311 &(args->expr->where));
2316 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2318 if (args_sym->attr.flavor != FL_PROCEDURE)
2320 /* TODO: Update this error message to allow for procedure
2321 pointers once they are implemented. */
2322 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2324 args_sym->name, sym->name,
2325 &(args->expr->where));
2328 else if (args_sym->attr.is_bind_c != 1)
2330 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2332 args_sym->name, sym->name,
2333 &(args->expr->where));
2338 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2343 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2344 "iso_c_binding function: '%s'!\n", sym->name);
2351 /* Resolve a function call, which means resolving the arguments, then figuring
2352 out which entity the name refers to. */
2353 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2354 to INTENT(OUT) or INTENT(INOUT). */
2357 resolve_function (gfc_expr *expr)
2359 gfc_actual_arglist *arg;
2364 procedure_type p = PROC_INTRINSIC;
2365 bool no_formal_args;
2369 sym = expr->symtree->n.sym;
2371 if (sym && sym->attr.intrinsic
2372 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2375 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2377 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2381 if (sym && sym->attr.abstract)
2383 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2384 sym->name, &expr->where);
2388 /* Switch off assumed size checking and do this again for certain kinds
2389 of procedure, once the procedure itself is resolved. */
2390 need_full_assumed_size++;
2392 if (expr->symtree && expr->symtree->n.sym)
2393 p = expr->symtree->n.sym->attr.proc;
2395 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2396 if (resolve_actual_arglist (expr->value.function.actual,
2397 p, no_formal_args) == FAILURE)
2400 /* Need to setup the call to the correct c_associated, depending on
2401 the number of cptrs to user gives to compare. */
2402 if (sym && sym->attr.is_iso_c == 1)
2404 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2408 /* Get the symtree for the new symbol (resolved func).
2409 the old one will be freed later, when it's no longer used. */
2410 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2413 /* Resume assumed_size checking. */
2414 need_full_assumed_size--;
2416 /* If the procedure is external, check for usage. */
2417 if (sym && is_external_proc (sym))
2418 resolve_global_procedure (sym, &expr->where,
2419 &expr->value.function.actual, 0);
2421 if (sym && sym->ts.type == BT_CHARACTER
2423 && sym->ts.cl->length == NULL
2425 && expr->value.function.esym == NULL
2426 && !sym->attr.contained)
2428 /* Internal procedures are taken care of in resolve_contained_fntype. */
2429 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2430 "be used at %L since it is not a dummy argument",
2431 sym->name, &expr->where);
2435 /* See if function is already resolved. */
2437 if (expr->value.function.name != NULL)
2439 if (expr->ts.type == BT_UNKNOWN)
2445 /* Apply the rules of section 14.1.2. */
2447 switch (procedure_kind (sym))
2450 t = resolve_generic_f (expr);
2453 case PTYPE_SPECIFIC:
2454 t = resolve_specific_f (expr);
2458 t = resolve_unknown_f (expr);
2462 gfc_internal_error ("resolve_function(): bad function type");
2466 /* If the expression is still a function (it might have simplified),
2467 then we check to see if we are calling an elemental function. */
2469 if (expr->expr_type != EXPR_FUNCTION)
2472 temp = need_full_assumed_size;
2473 need_full_assumed_size = 0;
2475 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2478 if (omp_workshare_flag
2479 && expr->value.function.esym
2480 && ! gfc_elemental (expr->value.function.esym))
2482 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2483 "in WORKSHARE construct", expr->value.function.esym->name,
2488 #define GENERIC_ID expr->value.function.isym->id
2489 else if (expr->value.function.actual != NULL
2490 && expr->value.function.isym != NULL
2491 && GENERIC_ID != GFC_ISYM_LBOUND
2492 && GENERIC_ID != GFC_ISYM_LEN
2493 && GENERIC_ID != GFC_ISYM_LOC
2494 && GENERIC_ID != GFC_ISYM_PRESENT)
2496 /* Array intrinsics must also have the last upper bound of an
2497 assumed size array argument. UBOUND and SIZE have to be
2498 excluded from the check if the second argument is anything
2501 for (arg = expr->value.function.actual; arg; arg = arg->next)
2503 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2504 && arg->next != NULL && arg->next->expr)
2506 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2509 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2512 if ((int)mpz_get_si (arg->next->expr->value.integer)
2517 if (arg->expr != NULL
2518 && arg->expr->rank > 0
2519 && resolve_assumed_size_actual (arg->expr))
2525 need_full_assumed_size = temp;
2528 if (!pure_function (expr, &name) && name)
2532 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2533 "FORALL %s", name, &expr->where,
2534 forall_flag == 2 ? "mask" : "block");
2537 else if (gfc_pure (NULL))
2539 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2540 "procedure within a PURE procedure", name, &expr->where);
2545 /* Functions without the RECURSIVE attribution are not allowed to
2546 * call themselves. */
2547 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2550 esym = expr->value.function.esym;
2552 if (is_illegal_recursion (esym, gfc_current_ns))
2554 if (esym->attr.entry && esym->ns->entries)
2555 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2556 " function '%s' is not RECURSIVE",
2557 esym->name, &expr->where, esym->ns->entries->sym->name);
2559 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
2560 " is not RECURSIVE", esym->name, &expr->where);
2566 /* Character lengths of use associated functions may contains references to
2567 symbols not referenced from the current program unit otherwise. Make sure
2568 those symbols are marked as referenced. */
2570 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2571 && expr->value.function.esym->attr.use_assoc)
2573 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2577 && !((expr->value.function.esym
2578 && expr->value.function.esym->attr.elemental)
2580 (expr->value.function.isym
2581 && expr->value.function.isym->elemental)))
2582 find_noncopying_intrinsics (expr->value.function.esym,
2583 expr->value.function.actual);
2585 /* Make sure that the expression has a typespec that works. */
2586 if (expr->ts.type == BT_UNKNOWN)
2588 if (expr->symtree->n.sym->result
2589 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
2590 && !expr->symtree->n.sym->result->attr.proc_pointer)
2591 expr->ts = expr->symtree->n.sym->result->ts;
2598 /************* Subroutine resolution *************/
2601 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2607 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2608 sym->name, &c->loc);
2609 else if (gfc_pure (NULL))
2610 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2616 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2620 if (sym->attr.generic)
2622 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2625 c->resolved_sym = s;
2626 pure_subroutine (c, s);
2630 /* TODO: Need to search for elemental references in generic interface. */
2633 if (sym->attr.intrinsic)
2634 return gfc_intrinsic_sub_interface (c, 0);
2641 resolve_generic_s (gfc_code *c)
2646 sym = c->symtree->n.sym;
2650 m = resolve_generic_s0 (c, sym);
2653 else if (m == MATCH_ERROR)
2657 if (sym->ns->parent == NULL)
2659 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2663 if (!generic_sym (sym))
2667 /* Last ditch attempt. See if the reference is to an intrinsic
2668 that possesses a matching interface. 14.1.2.4 */
2669 sym = c->symtree->n.sym;
2671 if (!gfc_is_intrinsic (sym, 1, c->loc))
2673 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2674 sym->name, &c->loc);
2678 m = gfc_intrinsic_sub_interface (c, 0);
2682 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2683 "intrinsic subroutine interface", sym->name, &c->loc);
2689 /* Set the name and binding label of the subroutine symbol in the call
2690 expression represented by 'c' to include the type and kind of the
2691 second parameter. This function is for resolving the appropriate
2692 version of c_f_pointer() and c_f_procpointer(). For example, a
2693 call to c_f_pointer() for a default integer pointer could have a
2694 name of c_f_pointer_i4. If no second arg exists, which is an error
2695 for these two functions, it defaults to the generic symbol's name
2696 and binding label. */
2699 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2700 char *name, char *binding_label)
2702 gfc_expr *arg = NULL;
2706 /* The second arg of c_f_pointer and c_f_procpointer determines
2707 the type and kind for the procedure name. */
2708 arg = c->ext.actual->next->expr;
2712 /* Set up the name to have the given symbol's name,
2713 plus the type and kind. */
2714 /* a derived type is marked with the type letter 'u' */
2715 if (arg->ts.type == BT_DERIVED)
2718 kind = 0; /* set the kind as 0 for now */
2722 type = gfc_type_letter (arg->ts.type);
2723 kind = arg->ts.kind;
2726 if (arg->ts.type == BT_CHARACTER)
2727 /* Kind info for character strings not needed. */
2730 sprintf (name, "%s_%c%d", sym->name, type, kind);
2731 /* Set up the binding label as the given symbol's label plus
2732 the type and kind. */
2733 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2737 /* If the second arg is missing, set the name and label as
2738 was, cause it should at least be found, and the missing
2739 arg error will be caught by compare_parameters(). */
2740 sprintf (name, "%s", sym->name);
2741 sprintf (binding_label, "%s", sym->binding_label);
2748 /* Resolve a generic version of the iso_c_binding procedure given
2749 (sym) to the specific one based on the type and kind of the
2750 argument(s). Currently, this function resolves c_f_pointer() and
2751 c_f_procpointer based on the type and kind of the second argument
2752 (FPTR). Other iso_c_binding procedures aren't specially handled.
2753 Upon successfully exiting, c->resolved_sym will hold the resolved
2754 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2758 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2760 gfc_symbol *new_sym;
2761 /* this is fine, since we know the names won't use the max */
2762 char name[GFC_MAX_SYMBOL_LEN + 1];
2763 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2764 /* default to success; will override if find error */
2765 match m = MATCH_YES;
2767 /* Make sure the actual arguments are in the necessary order (based on the
2768 formal args) before resolving. */
2769 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2771 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2772 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2774 set_name_and_label (c, sym, name, binding_label);
2776 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2778 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2780 /* Make sure we got a third arg if the second arg has non-zero
2781 rank. We must also check that the type and rank are
2782 correct since we short-circuit this check in
2783 gfc_procedure_use() (called above to sort actual args). */
2784 if (c->ext.actual->next->expr->rank != 0)
2786 if(c->ext.actual->next->next == NULL
2787 || c->ext.actual->next->next->expr == NULL)
2790 gfc_error ("Missing SHAPE parameter for call to %s "
2791 "at %L", sym->name, &(c->loc));
2793 else if (c->ext.actual->next->next->expr->ts.type
2795 || c->ext.actual->next->next->expr->rank != 1)
2798 gfc_error ("SHAPE parameter for call to %s at %L must "
2799 "be a rank 1 INTEGER array", sym->name,
2806 if (m != MATCH_ERROR)
2808 /* the 1 means to add the optional arg to formal list */
2809 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2811 /* for error reporting, say it's declared where the original was */
2812 new_sym->declared_at = sym->declared_at;
2817 /* no differences for c_loc or c_funloc */
2821 /* set the resolved symbol */
2822 if (m != MATCH_ERROR)
2823 c->resolved_sym = new_sym;
2825 c->resolved_sym = sym;
2831 /* Resolve a subroutine call known to be specific. */
2834 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2838 if(sym->attr.is_iso_c)
2840 m = gfc_iso_c_sub_interface (c,sym);
2844 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2846 if (sym->attr.dummy)
2848 sym->attr.proc = PROC_DUMMY;
2852 sym->attr.proc = PROC_EXTERNAL;
2856 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2859 if (sym->attr.intrinsic)
2861 m = gfc_intrinsic_sub_interface (c, 1);
2865 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2866 "with an intrinsic", sym->name, &c->loc);
2874 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2876 c->resolved_sym = sym;
2877 pure_subroutine (c, sym);
2884 resolve_specific_s (gfc_code *c)
2889 sym = c->symtree->n.sym;
2893 m = resolve_specific_s0 (c, sym);
2896 if (m == MATCH_ERROR)
2899 if (sym->ns->parent == NULL)
2902 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2908 sym = c->symtree->n.sym;
2909 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2910 sym->name, &c->loc);
2916 /* Resolve a subroutine call not known to be generic nor specific. */
2919 resolve_unknown_s (gfc_code *c)
2923 sym = c->symtree->n.sym;
2925 if (sym->attr.dummy)
2927 sym->attr.proc = PROC_DUMMY;
2931 /* See if we have an intrinsic function reference. */
2933 if (gfc_is_intrinsic (sym, 1, c->loc))
2935 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2940 /* The reference is to an external name. */
2943 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2945 c->resolved_sym = sym;
2947 pure_subroutine (c, sym);
2953 /* Resolve a subroutine call. Although it was tempting to use the same code
2954 for functions, subroutines and functions are stored differently and this
2955 makes things awkward. */
2958 resolve_call (gfc_code *c)
2961 procedure_type ptype = PROC_INTRINSIC;
2962 gfc_symbol *csym, *sym;
2963 bool no_formal_args;
2965 csym = c->symtree ? c->symtree->n.sym : NULL;
2967 if (csym && csym->ts.type != BT_UNKNOWN)
2969 gfc_error ("'%s' at %L has a type, which is not consistent with "
2970 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
2974 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
2977 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
2978 sym = st ? st->n.sym : NULL;
2979 if (sym && csym != sym
2980 && sym->ns == gfc_current_ns
2981 && sym->attr.flavor == FL_PROCEDURE
2982 && sym->attr.contained)
2985 if (csym->attr.generic)
2986 c->symtree->n.sym = sym;
2989 csym = c->symtree->n.sym;
2993 /* Subroutines without the RECURSIVE attribution are not allowed to
2994 * call themselves. */
2995 if (csym && is_illegal_recursion (csym, gfc_current_ns))
2997 if (csym->attr.entry && csym->ns->entries)
2998 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2999 " subroutine '%s' is not RECURSIVE",
3000 csym->name, &c->loc, csym->ns->entries->sym->name);
3002 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3003 " is not RECURSIVE", csym->name, &c->loc);
3008 /* Switch off assumed size checking and do this again for certain kinds
3009 of procedure, once the procedure itself is resolved. */
3010 need_full_assumed_size++;
3013 ptype = csym->attr.proc;
3015 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3016 if (resolve_actual_arglist (c->ext.actual, ptype,
3017 no_formal_args) == FAILURE)
3020 /* Resume assumed_size checking. */
3021 need_full_assumed_size--;
3023 /* If external, check for usage. */
3024 if (csym && is_external_proc (csym))
3025 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3028 if (c->resolved_sym == NULL)
3030 c->resolved_isym = NULL;
3031 switch (procedure_kind (csym))
3034 t = resolve_generic_s (c);
3037 case PTYPE_SPECIFIC:
3038 t = resolve_specific_s (c);
3042 t = resolve_unknown_s (c);
3046 gfc_internal_error ("resolve_subroutine(): bad function type");
3050 /* Some checks of elemental subroutine actual arguments. */
3051 if (resolve_elemental_actual (NULL, c) == FAILURE)
3054 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
3055 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3060 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3061 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3062 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3063 if their shapes do not match. If either op1->shape or op2->shape is
3064 NULL, return SUCCESS. */
3067 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3074 if (op1->shape != NULL && op2->shape != NULL)
3076 for (i = 0; i < op1->rank; i++)
3078 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3080 gfc_error ("Shapes for operands at %L and %L are not conformable",
3081 &op1->where, &op2->where);
3092 /* Resolve an operator expression node. This can involve replacing the
3093 operation with a user defined function call. */
3096 resolve_operator (gfc_expr *e)
3098 gfc_expr *op1, *op2;
3100 bool dual_locus_error;
3103 /* Resolve all subnodes-- give them types. */
3105 switch (e->value.op.op)
3108 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3111 /* Fall through... */
3114 case INTRINSIC_UPLUS:
3115 case INTRINSIC_UMINUS:
3116 case INTRINSIC_PARENTHESES:
3117 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3122 /* Typecheck the new node. */
3124 op1 = e->value.op.op1;
3125 op2 = e->value.op.op2;
3126 dual_locus_error = false;
3128 if ((op1 && op1->expr_type == EXPR_NULL)
3129 || (op2 && op2->expr_type == EXPR_NULL))
3131 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3135 switch (e->value.op.op)
3137 case INTRINSIC_UPLUS:
3138 case INTRINSIC_UMINUS:
3139 if (op1->ts.type == BT_INTEGER
3140 || op1->ts.type == BT_REAL
3141 || op1->ts.type == BT_COMPLEX)
3147 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3148 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3151 case INTRINSIC_PLUS:
3152 case INTRINSIC_MINUS:
3153 case INTRINSIC_TIMES:
3154 case INTRINSIC_DIVIDE:
3155 case INTRINSIC_POWER:
3156 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3158 gfc_type_convert_binary (e);
3163 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3164 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3165 gfc_typename (&op2->ts));
3168 case INTRINSIC_CONCAT:
3169 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3170 && op1->ts.kind == op2->ts.kind)
3172 e->ts.type = BT_CHARACTER;
3173 e->ts.kind = op1->ts.kind;
3178 _("Operands of string concatenation operator at %%L are %s/%s"),
3179 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3185 case INTRINSIC_NEQV:
3186 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3188 e->ts.type = BT_LOGICAL;
3189 e->ts.kind = gfc_kind_max (op1, op2);
3190 if (op1->ts.kind < e->ts.kind)
3191 gfc_convert_type (op1, &e->ts, 2);
3192 else if (op2->ts.kind < e->ts.kind)
3193 gfc_convert_type (op2, &e->ts, 2);
3197 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3198 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3199 gfc_typename (&op2->ts));
3204 if (op1->ts.type == BT_LOGICAL)
3206 e->ts.type = BT_LOGICAL;
3207 e->ts.kind = op1->ts.kind;
3211 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3212 gfc_typename (&op1->ts));
3216 case INTRINSIC_GT_OS:
3218 case INTRINSIC_GE_OS:
3220 case INTRINSIC_LT_OS:
3222 case INTRINSIC_LE_OS:
3223 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3225 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3229 /* Fall through... */
3232 case INTRINSIC_EQ_OS:
3234 case INTRINSIC_NE_OS:
3235 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3236 && op1->ts.kind == op2->ts.kind)
3238 e->ts.type = BT_LOGICAL;
3239 e->ts.kind = gfc_default_logical_kind;
3243 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3245 gfc_type_convert_binary (e);
3247 e->ts.type = BT_LOGICAL;
3248 e->ts.kind = gfc_default_logical_kind;
3252 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3254 _("Logicals at %%L must be compared with %s instead of %s"),
3255 (e->value.op.op == INTRINSIC_EQ
3256 || e->value.op.op == INTRINSIC_EQ_OS)
3257 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3260 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3261 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3262 gfc_typename (&op2->ts));
3266 case INTRINSIC_USER:
3267 if (e->value.op.uop->op == NULL)
3268 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3269 else if (op2 == NULL)
3270 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3271 e->value.op.uop->name, gfc_typename (&op1->ts));
3273 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3274 e->value.op.uop->name, gfc_typename (&op1->ts),
3275 gfc_typename (&op2->ts));
3279 case INTRINSIC_PARENTHESES:
3281 if (e->ts.type == BT_CHARACTER)
3282 e->ts.cl = op1->ts.cl;
3286 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3289 /* Deal with arrayness of an operand through an operator. */
3293 switch (e->value.op.op)
3295 case INTRINSIC_PLUS:
3296 case INTRINSIC_MINUS:
3297 case INTRINSIC_TIMES:
3298 case INTRINSIC_DIVIDE:
3299 case INTRINSIC_POWER:
3300 case INTRINSIC_CONCAT:
3304 case INTRINSIC_NEQV:
3306 case INTRINSIC_EQ_OS:
3308 case INTRINSIC_NE_OS:
3310 case INTRINSIC_GT_OS:
3312 case INTRINSIC_GE_OS:
3314 case INTRINSIC_LT_OS:
3316 case INTRINSIC_LE_OS:
3318 if (op1->rank == 0 && op2->rank == 0)
3321 if (op1->rank == 0 && op2->rank != 0)
3323 e->rank = op2->rank;
3325 if (e->shape == NULL)
3326 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3329 if (op1->rank != 0 && op2->rank == 0)
3331 e->rank = op1->rank;
3333 if (e->shape == NULL)
3334 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3337 if (op1->rank != 0 && op2->rank != 0)
3339 if (op1->rank == op2->rank)
3341 e->rank = op1->rank;
3342 if (e->shape == NULL)
3344 t = compare_shapes(op1, op2);
3348 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3353 /* Allow higher level expressions to work. */
3356 /* Try user-defined operators, and otherwise throw an error. */
3357 dual_locus_error = true;
3359 _("Inconsistent ranks for operator at %%L and %%L"));
3366 case INTRINSIC_PARENTHESES:
3368 case INTRINSIC_UPLUS:
3369 case INTRINSIC_UMINUS:
3370 /* Simply copy arrayness attribute */
3371 e->rank = op1->rank;
3373 if (e->shape == NULL)
3374 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3382 /* Attempt to simplify the expression. */
3385 t = gfc_simplify_expr (e, 0);
3386 /* Some calls do not succeed in simplification and return FAILURE
3387 even though there is no error; e.g. variable references to
3388 PARAMETER arrays. */
3389 if (!gfc_is_constant_expr (e))
3396 if (gfc_extend_expr (e) == SUCCESS)
3399 if (dual_locus_error)
3400 gfc_error (msg, &op1->where, &op2->where);
3402 gfc_error (msg, &e->where);
3408 /************** Array resolution subroutines **************/
3411 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3414 /* Compare two integer expressions. */
3417 compare_bound (gfc_expr *a, gfc_expr *b)
3421 if (a == NULL || a->expr_type != EXPR_CONSTANT
3422 || b == NULL || b->expr_type != EXPR_CONSTANT)
3425 /* If either of the types isn't INTEGER, we must have
3426 raised an error earlier. */
3428 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3431 i = mpz_cmp (a->value.integer, b->value.integer);
3441 /* Compare an integer expression with an integer. */
3444 compare_bound_int (gfc_expr *a, int b)
3448 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3451 if (a->ts.type != BT_INTEGER)
3452 gfc_internal_error ("compare_bound_int(): Bad expression");
3454 i = mpz_cmp_si (a->value.integer, b);
3464 /* Compare an integer expression with a mpz_t. */
3467 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3471 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3474 if (a->ts.type != BT_INTEGER)
3475 gfc_internal_error ("compare_bound_int(): Bad expression");
3477 i = mpz_cmp (a->value.integer, b);
3487 /* Compute the last value of a sequence given by a triplet.
3488 Return 0 if it wasn't able to compute the last value, or if the
3489 sequence if empty, and 1 otherwise. */
3492 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3493 gfc_expr *stride, mpz_t last)
3497 if (start == NULL || start->expr_type != EXPR_CONSTANT
3498 || end == NULL || end->expr_type != EXPR_CONSTANT
3499 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3502 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3503 || (stride != NULL && stride->ts.type != BT_INTEGER))
3506 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3508 if (compare_bound (start, end) == CMP_GT)
3510 mpz_set (last, end->value.integer);
3514 if (compare_bound_int (stride, 0) == CMP_GT)
3516 /* Stride is positive */
3517 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3522 /* Stride is negative */
3523 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3528 mpz_sub (rem, end->value.integer, start->value.integer);
3529 mpz_tdiv_r (rem, rem, stride->value.integer);
3530 mpz_sub (last, end->value.integer, rem);
3537 /* Compare a single dimension of an array reference to the array
3541 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3545 /* Given start, end and stride values, calculate the minimum and
3546 maximum referenced indexes. */
3548 switch (ar->dimen_type[i])
3554 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3556 gfc_warning ("Array reference at %L is out of bounds "
3557 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3558 mpz_get_si (ar->start[i]->value.integer),
3559 mpz_get_si (as->lower[i]->value.integer), i+1);
3562 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3564 gfc_warning ("Array reference at %L is out of bounds "
3565 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3566 mpz_get_si (ar->start[i]->value.integer),
3567 mpz_get_si (as->upper[i]->value.integer), i+1);
3575 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3576 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3578 comparison comp_start_end = compare_bound (AR_START, AR_END);
3580 /* Check for zero stride, which is not allowed. */
3581 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3583 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3587 /* if start == len || (stride > 0 && start < len)
3588 || (stride < 0 && start > len),
3589 then the array section contains at least one element. In this
3590 case, there is an out-of-bounds access if
3591 (start < lower || start > upper). */
3592 if (compare_bound (AR_START, AR_END) == CMP_EQ
3593 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3594 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3595 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3596 && comp_start_end == CMP_GT))
3598 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3600 gfc_warning ("Lower array reference at %L is out of bounds "
3601 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3602 mpz_get_si (AR_START->value.integer),
3603 mpz_get_si (as->lower[i]->value.integer), i+1);
3606 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3608 gfc_warning ("Lower array reference at %L is out of bounds "
3609 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3610 mpz_get_si (AR_START->value.integer),
3611 mpz_get_si (as->upper[i]->value.integer), i+1);
3616 /* If we can compute the highest index of the array section,
3617 then it also has to be between lower and upper. */
3618 mpz_init (last_value);
3619 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3622 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3624 gfc_warning ("Upper array reference at %L is out of bounds "
3625 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3626 mpz_get_si (last_value),
3627 mpz_get_si (as->lower[i]->value.integer), i+1);
3628 mpz_clear (last_value);
3631 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3633 gfc_warning ("Upper array reference at %L is out of bounds "
3634 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3635 mpz_get_si (last_value),
3636 mpz_get_si (as->upper[i]->value.integer), i+1);
3637 mpz_clear (last_value);
3641 mpz_clear (last_value);
3649 gfc_internal_error ("check_dimension(): Bad array reference");
3656 /* Compare an array reference with an array specification. */
3659 compare_spec_to_ref (gfc_array_ref *ar)
3666 /* TODO: Full array sections are only allowed as actual parameters. */
3667 if (as->type == AS_ASSUMED_SIZE
3668 && (/*ar->type == AR_FULL
3669 ||*/ (ar->type == AR_SECTION
3670 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3672 gfc_error ("Rightmost upper bound of assumed size array section "
3673 "not specified at %L", &ar->where);
3677 if (ar->type == AR_FULL)
3680 if (as->rank != ar->dimen)
3682 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3683 &ar->where, ar->dimen, as->rank);
3687 for (i = 0; i < as->rank; i++)
3688 if (check_dimension (i, ar, as) == FAILURE)
3695 /* Resolve one part of an array index. */
3698 gfc_resolve_index (gfc_expr *index, int check_scalar)
3705 if (gfc_resolve_expr (index) == FAILURE)
3708 if (check_scalar && index->rank != 0)
3710 gfc_error ("Array index at %L must be scalar", &index->where);
3714 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3716 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3717 &index->where, gfc_basic_typename (index->ts.type));
3721 if (index->ts.type == BT_REAL)
3722 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3723 &index->where) == FAILURE)
3726 if (index->ts.kind != gfc_index_integer_kind
3727 || index->ts.type != BT_INTEGER)
3730 ts.type = BT_INTEGER;
3731 ts.kind = gfc_index_integer_kind;
3733 gfc_convert_type_warn (index, &ts, 2, 0);
3739 /* Resolve a dim argument to an intrinsic function. */
3742 gfc_resolve_dim_arg (gfc_expr *dim)
3747 if (gfc_resolve_expr (dim) == FAILURE)
3752 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3757 if (dim->ts.type != BT_INTEGER)
3759 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3763 if (dim->ts.kind != gfc_index_integer_kind)
3767 ts.type = BT_INTEGER;
3768 ts.kind = gfc_index_integer_kind;
3770 gfc_convert_type_warn (dim, &ts, 2, 0);
3776 /* Given an expression that contains array references, update those array
3777 references to point to the right array specifications. While this is
3778 filled in during matching, this information is difficult to save and load
3779 in a module, so we take care of it here.
3781 The idea here is that the original array reference comes from the
3782 base symbol. We traverse the list of reference structures, setting
3783 the stored reference to references. Component references can
3784 provide an additional array specification. */
3787 find_array_spec (gfc_expr *e)
3791 gfc_symbol *derived;
3794 as = e->symtree->n.sym->as;
3797 for (ref = e->ref; ref; ref = ref->next)
3802 gfc_internal_error ("find_array_spec(): Missing spec");
3809 if (derived == NULL)
3810 derived = e->symtree->n.sym->ts.derived;
3812 c = derived->components;
3814 for (; c; c = c->next)
3815 if (c == ref->u.c.component)
3817 /* Track the sequence of component references. */
3818 if (c->ts.type == BT_DERIVED)
3819 derived = c->ts.derived;
3824 gfc_internal_error ("find_array_spec(): Component not found");
3826 if (c->attr.dimension)
3829 gfc_internal_error ("find_array_spec(): unused as(1)");
3840 gfc_internal_error ("find_array_spec(): unused as(2)");
3844 /* Resolve an array reference. */
3847 resolve_array_ref (gfc_array_ref *ar)
3849 int i, check_scalar;
3852 for (i = 0; i < ar->dimen; i++)
3854 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3856 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3858 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3860 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3865 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3869 ar->dimen_type[i] = DIMEN_ELEMENT;
3873 ar->dimen_type[i] = DIMEN_VECTOR;
3874 if (e->expr_type == EXPR_VARIABLE
3875 && e->symtree->n.sym->ts.type == BT_DERIVED)
3876 ar->start[i] = gfc_get_parentheses (e);
3880 gfc_error ("Array index at %L is an array of rank %d",
3881 &ar->c_where[i], e->rank);
3886 /* If the reference type is unknown, figure out what kind it is. */
3888 if (ar->type == AR_UNKNOWN)
3890 ar->type = AR_ELEMENT;
3891 for (i = 0; i < ar->dimen; i++)
3892 if (ar->dimen_type[i] == DIMEN_RANGE
3893 || ar->dimen_type[i] == DIMEN_VECTOR)
3895 ar->type = AR_SECTION;
3900 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3908 resolve_substring (gfc_ref *ref)
3910 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3912 if (ref->u.ss.start != NULL)
3914 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3917 if (ref->u.ss.start->ts.type != BT_INTEGER)
3919 gfc_error ("Substring start index at %L must be of type INTEGER",
3920 &ref->u.ss.start->where);
3924 if (ref->u.ss.start->rank != 0)
3926 gfc_error ("Substring start index at %L must be scalar",
3927 &ref->u.ss.start->where);
3931 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3932 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3933 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3935 gfc_error ("Substring start index at %L is less than one",
3936 &ref->u.ss.start->where);
3941 if (ref->u.ss.end != NULL)
3943 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3946 if (ref->u.ss.end->ts.type != BT_INTEGER)
3948 gfc_error ("Substring end index at %L must be of type INTEGER",
3949 &ref->u.ss.end->where);
3953 if (ref->u.ss.end->rank != 0)
3955 gfc_error ("Substring end index at %L must be scalar",
3956 &ref->u.ss.end->where);
3960 if (ref->u.ss.length != NULL
3961 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3962 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3963 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3965 gfc_error ("Substring end index at %L exceeds the string length",
3966 &ref->u.ss.start->where);
3970 if (compare_bound_mpz_t (ref->u.ss.end,
3971 gfc_integer_kinds[k].huge) == CMP_GT
3972 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3973 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3975 gfc_error ("Substring end index at %L is too large",
3976 &ref->u.ss.end->where);
3985 /* This function supplies missing substring charlens. */
3988 gfc_resolve_substring_charlen (gfc_expr *e)
3991 gfc_expr *start, *end;
3993 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3994 if (char_ref->type == REF_SUBSTRING)
4000 gcc_assert (char_ref->next == NULL);
4004 if (e->ts.cl->length)
4005 gfc_free_expr (e->ts.cl->length);
4006 else if (e->expr_type == EXPR_VARIABLE
4007 && e->symtree->n.sym->attr.dummy)
4011 e->ts.type = BT_CHARACTER;
4012 e->ts.kind = gfc_default_character_kind;
4016 e->ts.cl = gfc_get_charlen ();
4017 e->ts.cl->next = gfc_current_ns->cl_list;
4018 gfc_current_ns->cl_list = e->ts.cl;
4021 if (char_ref->u.ss.start)
4022 start = gfc_copy_expr (char_ref->u.ss.start);
4024 start = gfc_int_expr (1);
4026 if (char_ref->u.ss.end)
4027 end = gfc_copy_expr (char_ref->u.ss.end);
4028 else if (e->expr_type == EXPR_VARIABLE)
4029 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
4036 /* Length = (end - start +1). */
4037 e->ts.cl->length = gfc_subtract (end, start);
4038 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
4040 e->ts.cl->length->ts.type = BT_INTEGER;
4041 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;
4043 /* Make sure that the length is simplified. */
4044 gfc_simplify_expr (e->ts.cl->length, 1);
4045 gfc_resolve_expr (e->ts.cl->length);
4049 /* Resolve subtype references. */
4052 resolve_ref (gfc_expr *expr)
4054 int current_part_dimension, n_components, seen_part_dimension;
4057 for (ref = expr->ref; ref; ref = ref->next)
4058 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4060 find_array_spec (expr);
4064 for (ref = expr->ref; ref; ref = ref->next)
4068 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4076 resolve_substring (ref);
4080 /* Check constraints on part references. */
4082 current_part_dimension = 0;
4083 seen_part_dimension = 0;
4086 for (ref = expr->ref; ref; ref = ref->next)
4091 switch (ref->u.ar.type)
4095 current_part_dimension = 1;
4099 current_part_dimension = 0;
4103 gfc_internal_error ("resolve_ref(): Bad array reference");
4109 if (current_part_dimension || seen_part_dimension)
4111 if (ref->u.c.component->attr.pointer)
4113 gfc_error ("Component to the right of a part reference "
4114 "with nonzero rank must not have the POINTER "
4115 "attribute at %L", &expr->where);
4118 else if (ref->u.c.component->attr.allocatable)
4120 gfc_error ("Component to the right of a part reference "
4121 "with nonzero rank must not have the ALLOCATABLE "
4122 "attribute at %L", &expr->where);
4134 if (((ref->type == REF_COMPONENT && n_components > 1)
4135 || ref->next == NULL)
4136 && current_part_dimension
4137 && seen_part_dimension)
4139 gfc_error ("Two or more part references with nonzero rank must "
4140 "not be specified at %L", &expr->where);
4144 if (ref->type == REF_COMPONENT)
4146 if (current_part_dimension)
4147 seen_part_dimension = 1;
4149 /* reset to make sure */
4150 current_part_dimension = 0;
4158 /* Given an expression, determine its shape. This is easier than it sounds.
4159 Leaves the shape array NULL if it is not possible to determine the shape. */
4162 expression_shape (gfc_expr *e)
4164 mpz_t array[GFC_MAX_DIMENSIONS];
4167 if (e->rank == 0 || e->shape != NULL)
4170 for (i = 0; i < e->rank; i++)
4171 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4174 e->shape = gfc_get_shape (e->rank);
4176 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4181 for (i--; i >= 0; i--)
4182 mpz_clear (array[i]);
4186 /* Given a variable expression node, compute the rank of the expression by
4187 examining the base symbol and any reference structures it may have. */
4190 expression_rank (gfc_expr *e)
4195 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4196 could lead to serious confusion... */
4197 gcc_assert (e->expr_type != EXPR_COMPCALL);
4201 if (e->expr_type == EXPR_ARRAY)
4203 /* Constructors can have a rank different from one via RESHAPE(). */
4205 if (e->symtree == NULL)
4211 e->rank = (e->symtree->n.sym->as == NULL)
4212 ? 0 : e->symtree->n.sym->as->rank;
4218 for (ref = e->ref; ref; ref = ref->next)
4220 if (ref->type != REF_ARRAY)
4223 if (ref->u.ar.type == AR_FULL)
4225 rank = ref->u.ar.as->rank;
4229 if (ref->u.ar.type == AR_SECTION)
4231 /* Figure out the rank of the section. */
4233 gfc_internal_error ("expression_rank(): Two array specs");
4235 for (i = 0; i < ref->u.ar.dimen; i++)
4236 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4237 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4247 expression_shape (e);
4251 /* Resolve a variable expression. */
4254 resolve_variable (gfc_expr *e)
4261 if (e->symtree == NULL)
4264 if (e->ref && resolve_ref (e) == FAILURE)
4267 sym = e->symtree->n.sym;
4268 if (sym->attr.flavor == FL_PROCEDURE
4269 && (!sym->attr.function
4270 || (sym->attr.function && sym->result
4271 && sym->result->attr.proc_pointer
4272 && !sym->result->attr.function)))
4274 e->ts.type = BT_PROCEDURE;
4275 goto resolve_procedure;
4278 if (sym->ts.type != BT_UNKNOWN)
4279 gfc_variable_attr (e, &e->ts);
4282 /* Must be a simple variable reference. */
4283 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4288 if (check_assumed_size_reference (sym, e))
4291 /* Deal with forward references to entries during resolve_code, to
4292 satisfy, at least partially, 12.5.2.5. */
4293 if (gfc_current_ns->entries
4294 && current_entry_id == sym->entry_id
4297 && cs_base->current->op != EXEC_ENTRY)
4299 gfc_entry_list *entry;
4300 gfc_formal_arglist *formal;
4304 /* If the symbol is a dummy... */
4305 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4307 entry = gfc_current_ns->entries;
4310 /* ...test if the symbol is a parameter of previous entries. */
4311 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4312 for (formal = entry->sym->formal; formal; formal = formal->next)
4314 if (formal->sym && sym->name == formal->sym->name)
4318 /* If it has not been seen as a dummy, this is an error. */
4321 if (specification_expr)
4322 gfc_error ("Variable '%s', used in a specification expression"
4323 ", is referenced at %L before the ENTRY statement "
4324 "in which it is a parameter",
4325 sym->name, &cs_base->current->loc);
4327 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4328 "statement in which it is a parameter",
4329 sym->name, &cs_base->current->loc);
4334 /* Now do the same check on the specification expressions. */
4335 specification_expr = 1;
4336 if (sym->ts.type == BT_CHARACTER
4337 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
4341 for (n = 0; n < sym->as->rank; n++)
4343 specification_expr = 1;
4344 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4346 specification_expr = 1;
4347 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4350 specification_expr = 0;
4353 /* Update the symbol's entry level. */
4354 sym->entry_id = current_entry_id + 1;
4358 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
4365 /* Checks to see that the correct symbol has been host associated.
4366 The only situation where this arises is that in which a twice
4367 contained function is parsed after the host association is made.
4368 Therefore, on detecting this, change the symbol in the expression
4369 and convert the array reference into an actual arglist if the old
4370 symbol is a variable. */
4372 check_host_association (gfc_expr *e)
4374 gfc_symbol *sym, *old_sym;
4378 gfc_actual_arglist *arg, *tail = NULL;
4379 bool retval = e->expr_type == EXPR_FUNCTION;
4381 /* If the expression is the result of substitution in
4382 interface.c(gfc_extend_expr) because there is no way in
4383 which the host association can be wrong. */
4384 if (e->symtree == NULL
4385 || e->symtree->n.sym == NULL
4386 || e->user_operator)
4389 old_sym = e->symtree->n.sym;
4391 if (gfc_current_ns->parent
4392 && old_sym->ns != gfc_current_ns)
4394 /* Use the 'USE' name so that renamed module symbols are
4395 correctly handled. */
4396 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
4398 if (sym && old_sym != sym
4399 && sym->ts.type == old_sym->ts.type
4400 && sym->attr.flavor == FL_PROCEDURE
4401 && sym->attr.contained)
4403 /* Clear the shape, since it might not be valid. */
4404 if (e->shape != NULL)
4406 for (n = 0; n < e->rank; n++)
4407 mpz_clear (e->shape[n]);
4409 gfc_free (e->shape);
4412 /* Give the expression the right symtree! */
4413 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
4414 gcc_assert (st != NULL);
4416 if (old_sym->attr.flavor == FL_PROCEDURE
4417 || e->expr_type == EXPR_FUNCTION)
4419 /* Original was function so point to the new symbol, since
4420 the actual argument list is already attached to the
4422 e->value.function.esym = NULL;
4427 /* Original was variable so convert array references into
4428 an actual arglist. This does not need any checking now
4429 since gfc_resolve_function will take care of it. */
4430 e->value.function.actual = NULL;
4431 e->expr_type = EXPR_FUNCTION;
4434 /* Ambiguity will not arise if the array reference is not
4435 the last reference. */
4436 for (ref = e->ref; ref; ref = ref->next)
4437 if (ref->type == REF_ARRAY && ref->next == NULL)
4440 gcc_assert (ref->type == REF_ARRAY);
4442 /* Grab the start expressions from the array ref and
4443 copy them into actual arguments. */
4444 for (n = 0; n < ref->u.ar.dimen; n++)
4446 arg = gfc_get_actual_arglist ();
4447 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
4448 if (e->value.function.actual == NULL)
4449 tail = e->value.function.actual = arg;
4457 /* Dump the reference list and set the rank. */
4458 gfc_free_ref_list (e->ref);
4460 e->rank = sym->as ? sym->as->rank : 0;
4463 gfc_resolve_expr (e);
4467 /* This might have changed! */
4468 return e->expr_type == EXPR_FUNCTION;
4473 gfc_resolve_character_operator (gfc_expr *e)
4475 gfc_expr *op1 = e->value.op.op1;
4476 gfc_expr *op2 = e->value.op.op2;
4477 gfc_expr *e1 = NULL;
4478 gfc_expr *e2 = NULL;
4480 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
4482 if (op1->ts.cl && op1->ts.cl->length)
4483 e1 = gfc_copy_expr (op1->ts.cl->length);
4484 else if (op1->expr_type == EXPR_CONSTANT)
4485 e1 = gfc_int_expr (op1->value.character.length);
4487 if (op2->ts.cl && op2->ts.cl->length)
4488 e2 = gfc_copy_expr (op2->ts.cl->length);
4489 else if (op2->expr_type == EXPR_CONSTANT)
4490 e2 = gfc_int_expr (op2->value.character.length);
4492 e->ts.cl = gfc_get_charlen ();
4493 e->ts.cl->next = gfc_current_ns->cl_list;
4494 gfc_current_ns->cl_list = e->ts.cl;
4499 e->ts.cl->length = gfc_add (e1, e2);
4500 e->ts.cl->length->ts.type = BT_INTEGER;
4501 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;
4502 gfc_simplify_expr (e->ts.cl->length, 0);
4503 gfc_resolve_expr (e->ts.cl->length);
4509 /* Ensure that an character expression has a charlen and, if possible, a
4510 length expression. */
4513 fixup_charlen (gfc_expr *e)
4515 /* The cases fall through so that changes in expression type and the need
4516 for multiple fixes are picked up. In all circumstances, a charlen should
4517 be available for the middle end to hang a backend_decl on. */
4518 switch (e->expr_type)
4521 gfc_resolve_character_operator (e);
4524 if (e->expr_type == EXPR_ARRAY)
4525 gfc_resolve_character_array_constructor (e);
4527 case EXPR_SUBSTRING:
4528 if (!e->ts.cl && e->ref)
4529 gfc_resolve_substring_charlen (e);
4534 e->ts.cl = gfc_get_charlen ();
4535 e->ts.cl->next = gfc_current_ns->cl_list;
4536 gfc_current_ns->cl_list = e->ts.cl;
4544 /* Update an actual argument to include the passed-object for type-bound
4545 procedures at the right position. */
4547 static gfc_actual_arglist*
4548 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
4550 gcc_assert (argpos > 0);
4554 gfc_actual_arglist* result;
4556 result = gfc_get_actual_arglist ();
4564 gcc_assert (argpos > 1);
4566 lst->next = update_arglist_pass (lst->next, po, argpos - 1);
4571 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4574 extract_compcall_passed_object (gfc_expr* e)
4578 gcc_assert (e->expr_type == EXPR_COMPCALL);
4580 po = gfc_get_expr ();
4581 po->expr_type = EXPR_VARIABLE;
4582 po->symtree = e->symtree;
4583 po->ref = gfc_copy_ref (e->ref);
4585 if (gfc_resolve_expr (po) == FAILURE)
4592 /* Update the arglist of an EXPR_COMPCALL expression to include the
4596 update_compcall_arglist (gfc_expr* e)
4599 gfc_typebound_proc* tbp;
4601 tbp = e->value.compcall.tbp;
4606 po = extract_compcall_passed_object (e);
4612 gfc_error ("Passed-object at %L must be scalar", &e->where);
4622 gcc_assert (tbp->pass_arg_num > 0);
4623 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4630 /* Check that the object a TBP is called on is valid, i.e. it must not be
4631 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
4634 check_typebound_baseobject (gfc_expr* e)
4638 base = extract_compcall_passed_object (e);
4642 gcc_assert (base->ts.type == BT_DERIVED);
4643 if (base->ts.derived->attr.abstract)
4645 gfc_error ("Base object for type-bound procedure call at %L is of"
4646 " ABSTRACT type '%s'", &e->where, base->ts.derived->name);
4654 /* Resolve a call to a type-bound procedure, either function or subroutine,
4655 statically from the data in an EXPR_COMPCALL expression. The adapted
4656 arglist and the target-procedure symtree are returned. */
4659 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
4660 gfc_actual_arglist** actual)
4662 gcc_assert (e->expr_type == EXPR_COMPCALL);
4663 gcc_assert (!e->value.compcall.tbp->is_generic);
4665 /* Update the actual arglist for PASS. */
4666 if (update_compcall_arglist (e) == FAILURE)
4669 *actual = e->value.compcall.actual;
4670 *target = e->value.compcall.tbp->u.specific;
4672 gfc_free_ref_list (e->ref);
4674 e->value.compcall.actual = NULL;
4680 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4681 which of the specific bindings (if any) matches the arglist and transform
4682 the expression into a call of that binding. */
4685 resolve_typebound_generic_call (gfc_expr* e)
4687 gfc_typebound_proc* genproc;
4688 const char* genname;
4690 gcc_assert (e->expr_type == EXPR_COMPCALL);
4691 genname = e->value.compcall.name;
4692 genproc = e->value.compcall.tbp;
4694 if (!genproc->is_generic)
4697 /* Try the bindings on this type and in the inheritance hierarchy. */
4698 for (; genproc; genproc = genproc->overridden)
4702 gcc_assert (genproc->is_generic);
4703 for (g = genproc->u.generic; g; g = g->next)
4706 gfc_actual_arglist* args;
4709 gcc_assert (g->specific);
4711 if (g->specific->error)
4714 target = g->specific->u.specific->n.sym;
4716 /* Get the right arglist by handling PASS/NOPASS. */
4717 args = gfc_copy_actual_arglist (e->value.compcall.actual);
4718 if (!g->specific->nopass)
4721 po = extract_compcall_passed_object (e);
4725 gcc_assert (g->specific->pass_arg_num > 0);
4726 gcc_assert (!g->specific->error);
4727 args = update_arglist_pass (args, po, g->specific->pass_arg_num);
4729 resolve_actual_arglist (args, target->attr.proc,
4730 is_external_proc (target) && !target->formal);
4732 /* Check if this arglist matches the formal. */
4733 matches = gfc_arglist_matches_symbol (&args, target);
4735 /* Clean up and break out of the loop if we've found it. */
4736 gfc_free_actual_arglist (args);
4739 e->value.compcall.tbp = g->specific;
4745 /* Nothing matching found! */
4746 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4747 " '%s' at %L", genname, &e->where);
4755 /* Resolve a call to a type-bound subroutine. */
4758 resolve_typebound_call (gfc_code* c)
4760 gfc_actual_arglist* newactual;
4761 gfc_symtree* target;
4763 /* Check that's really a SUBROUTINE. */
4764 if (!c->expr1->value.compcall.tbp->subroutine)
4766 gfc_error ("'%s' at %L should be a SUBROUTINE",
4767 c->expr1->value.compcall.name, &c->loc);
4771 if (check_typebound_baseobject (c->expr1) == FAILURE)
4774 if (resolve_typebound_generic_call (c->expr1) == FAILURE)
4777 /* Transform into an ordinary EXEC_CALL for now. */
4779 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
4782 c->ext.actual = newactual;
4783 c->symtree = target;
4786 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
4787 gfc_free_expr (c->expr1);
4790 return resolve_call (c);
4794 /* Resolve a component-call expression. */
4797 resolve_compcall (gfc_expr* e)
4799 gfc_actual_arglist* newactual;
4800 gfc_symtree* target;
4802 /* Check that's really a FUNCTION. */
4803 if (!e->value.compcall.tbp->function)
4805 gfc_error ("'%s' at %L should be a FUNCTION",
4806 e->value.compcall.name, &e->where);
4810 if (check_typebound_baseobject (e) == FAILURE)
4813 if (resolve_typebound_generic_call (e) == FAILURE)
4815 gcc_assert (!e->value.compcall.tbp->is_generic);
4817 /* Take the rank from the function's symbol. */
4818 if (e->value.compcall.tbp->u.specific->n.sym->as)
4819 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
4821 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4822 arglist to the TBP's binding target. */
4824 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
4827 e->value.function.actual = newactual;
4828 e->value.function.name = e->value.compcall.name;
4829 e->value.function.esym = target->n.sym;
4830 e->value.function.isym = NULL;
4831 e->symtree = target;
4832 e->ts = target->n.sym->ts;
4833 e->expr_type = EXPR_FUNCTION;
4835 return gfc_resolve_expr (e);
4839 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
4842 resolve_ppc_call (gfc_code* c)
4844 gfc_component *comp;
4845 gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp));
4847 c->resolved_sym = c->expr1->symtree->n.sym;
4848 c->expr1->expr_type = EXPR_VARIABLE;
4849 c->ext.actual = c->expr1->value.compcall.actual;
4851 if (!comp->attr.subroutine)
4852 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
4854 if (resolve_ref (c->expr1) == FAILURE)
4857 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
4858 comp->formal == NULL) == FAILURE)
4861 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
4867 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
4870 resolve_expr_ppc (gfc_expr* e)
4872 gfc_component *comp;
4873 gcc_assert (gfc_is_proc_ptr_comp (e, &comp));
4875 /* Convert to EXPR_FUNCTION. */
4876 e->expr_type = EXPR_FUNCTION;
4877 e->value.function.isym = NULL;
4878 e->value.function.actual = e->value.compcall.actual;
4880 if (comp->as != NULL)
4881 e->rank = comp->as->rank;
4883 if (!comp->attr.function)
4884 gfc_add_function (&comp->attr, comp->name, &e->where);
4886 if (resolve_ref (e) == FAILURE)
4889 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
4890 comp->formal == NULL) == FAILURE)
4893 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
4899 /* Resolve an expression. That is, make sure that types of operands agree
4900 with their operators, intrinsic operators are converted to function calls
4901 for overloaded types and unresolved function references are resolved. */
4904 gfc_resolve_expr (gfc_expr *e)
4911 switch (e->expr_type)
4914 t = resolve_operator (e);
4920 if (check_host_association (e))
4921 t = resolve_function (e);
4924 t = resolve_variable (e);
4926 expression_rank (e);
4929 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4930 && e->ref->type != REF_SUBSTRING)
4931 gfc_resolve_substring_charlen (e);
4936 t = resolve_compcall (e);
4939 case EXPR_SUBSTRING:
4940 t = resolve_ref (e);
4949 t = resolve_expr_ppc (e);
4954 if (resolve_ref (e) == FAILURE)
4957 t = gfc_resolve_array_constructor (e);
4958 /* Also try to expand a constructor. */
4961 expression_rank (e);
4962 gfc_expand_constructor (e);
4965 /* This provides the opportunity for the length of constructors with
4966 character valued function elements to propagate the string length
4967 to the expression. */
4968 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
4969 t = gfc_resolve_character_array_constructor (e);
4973 case EXPR_STRUCTURE:
4974 t = resolve_ref (e);
4978 t = resolve_structure_cons (e);
4982 t = gfc_simplify_expr (e, 0);
4986 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4989 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4996 /* Resolve an expression from an iterator. They must be scalar and have
4997 INTEGER or (optionally) REAL type. */
5000 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
5001 const char *name_msgid)
5003 if (gfc_resolve_expr (expr) == FAILURE)
5006 if (expr->rank != 0)
5008 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
5012 if (expr->ts.type != BT_INTEGER)
5014 if (expr->ts.type == BT_REAL)
5017 return gfc_notify_std (GFC_STD_F95_DEL,
5018 "Deleted feature: %s at %L must be integer",
5019 _(name_msgid), &expr->where);
5022 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
5029 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
5037 /* Resolve the expressions in an iterator structure. If REAL_OK is
5038 false allow only INTEGER type iterators, otherwise allow REAL types. */
5041 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
5043 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
5047 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
5049 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
5054 if (gfc_resolve_iterator_expr (iter->start, real_ok,
5055 "Start expression in DO loop") == FAILURE)
5058 if (gfc_resolve_iterator_expr (iter->end, real_ok,
5059 "End expression in DO loop") == FAILURE)
5062 if (gfc_resolve_iterator_expr (iter->step, real_ok,
5063 "Step expression in DO loop") == FAILURE)
5066 if (iter->step->expr_type == EXPR_CONSTANT)
5068 if ((iter->step->ts.type == BT_INTEGER
5069 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
5070 || (iter->step->ts.type == BT_REAL
5071 && mpfr_sgn (iter->step->value.real) == 0))
5073 gfc_error ("Step expression in DO loop at %L cannot be zero",
5074 &iter->step->where);
5079 /* Convert start, end, and step to the same type as var. */
5080 if (iter->start->ts.kind != iter->var->ts.kind
5081 || iter->start->ts.type != iter->var->ts.type)
5082 gfc_convert_type (iter->start, &iter->var->ts, 2);
5084 if (iter->end->ts.kind != iter->var->ts.kind
5085 || iter->end->ts.type != iter->var->ts.type)
5086 gfc_convert_type (iter->end, &iter->var->ts, 2);
5088 if (iter->step->ts.kind != iter->var->ts.kind
5089 || iter->step->ts.type != iter->var->ts.type)
5090 gfc_convert_type (iter->step, &iter->var->ts, 2);
5092 if (iter->start->expr_type == EXPR_CONSTANT
5093 && iter->end->expr_type == EXPR_CONSTANT
5094 && iter->step->expr_type == EXPR_CONSTANT)
5097 if (iter->start->ts.type == BT_INTEGER)
5099 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
5100 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
5104 sgn = mpfr_sgn (iter->step->value.real);
5105 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
5107 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
5108 gfc_warning ("DO loop at %L will be executed zero times",
5109 &iter->step->where);
5116 /* Traversal function for find_forall_index. f == 2 signals that
5117 that variable itself is not to be checked - only the references. */
5120 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
5122 if (expr->expr_type != EXPR_VARIABLE)
5125 /* A scalar assignment */
5126 if (!expr->ref || *f == 1)
5128 if (expr->symtree->n.sym == sym)
5140 /* Check whether the FORALL index appears in the expression or not.
5141 Returns SUCCESS if SYM is found in EXPR. */
5144 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
5146 if (gfc_traverse_expr (expr, sym, forall_index, f))
5153 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
5154 to be a scalar INTEGER variable. The subscripts and stride are scalar
5155 INTEGERs, and if stride is a constant it must be nonzero.
5156 Furthermore "A subscript or stride in a forall-triplet-spec shall
5157 not contain a reference to any index-name in the
5158 forall-triplet-spec-list in which it appears." (7.5.4.1) */
5161 resolve_forall_iterators (gfc_forall_iterator *it)
5163 gfc_forall_iterator *iter, *iter2;
5165 for (iter = it; iter; iter = iter->next)
5167 if (gfc_resolve_expr (iter->var) == SUCCESS
5168 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
5169 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
5172 if (gfc_resolve_expr (iter->start) == SUCCESS
5173 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
5174 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
5175 &iter->start->where);
5176 if (iter->var->ts.kind != iter->start->ts.kind)
5177 gfc_convert_type (iter->start, &iter->var->ts, 2);
5179 if (gfc_resolve_expr (iter->end) == SUCCESS
5180 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
5181 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
5183 if (iter->var->ts.kind != iter->end->ts.kind)
5184 gfc_convert_type (iter->end, &iter->var->ts, 2);
5186 if (gfc_resolve_expr (iter->stride) == SUCCESS)
5188 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
5189 gfc_error ("FORALL stride expression at %L must be a scalar %s",
5190 &iter->stride->where, "INTEGER");
5192 if (iter->stride->expr_type == EXPR_CONSTANT
5193 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
5194 gfc_error ("FORALL stride expression at %L cannot be zero",
5195 &iter->stride->where);
5197 if (iter->var->ts.kind != iter->stride->ts.kind)
5198 gfc_convert_type (iter->stride, &iter->var->ts, 2);
5201 for (iter = it; iter; iter = iter->next)
5202 for (iter2 = iter; iter2; iter2 = iter2->next)
5204 if (find_forall_index (iter2->start,
5205 iter->var->symtree->n.sym, 0) == SUCCESS
5206 || find_forall_index (iter2->end,
5207 iter->var->symtree->n.sym, 0) == SUCCESS
5208 || find_forall_index (iter2->stride,
5209 iter->var->symtree->n.sym, 0) == SUCCESS)
5210 gfc_error ("FORALL index '%s' may not appear in triplet "
5211 "specification at %L", iter->var->symtree->name,
5212 &iter2->start->where);
5217 /* Given a pointer to a symbol that is a derived type, see if it's
5218 inaccessible, i.e. if it's defined in another module and the components are
5219 PRIVATE. The search is recursive if necessary. Returns zero if no
5220 inaccessible components are found, nonzero otherwise. */
5223 derived_inaccessible (gfc_symbol *sym)
5227 if (sym->attr.use_assoc && sym->attr.private_comp)
5230 for (c = sym->components; c; c = c->next)
5232 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
5240 /* Resolve the argument of a deallocate expression. The expression must be
5241 a pointer or a full array. */
5244 resolve_deallocate_expr (gfc_expr *e)
5246 symbol_attribute attr;
5247 int allocatable, pointer, check_intent_in;
5250 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5251 check_intent_in = 1;
5253 if (gfc_resolve_expr (e) == FAILURE)
5256 if (e->expr_type != EXPR_VARIABLE)
5259 allocatable = e->symtree->n.sym->attr.allocatable;
5260 pointer = e->symtree->n.sym->attr.pointer;
5261 for (ref = e->ref; ref; ref = ref->next)
5264 check_intent_in = 0;
5269 if (ref->u.ar.type != AR_FULL)
5274 allocatable = (ref->u.c.component->as != NULL
5275 && ref->u.c.component->as->type == AS_DEFERRED);
5276 pointer = ref->u.c.component->attr.pointer;
5285 attr = gfc_expr_attr (e);
5287 if (allocatable == 0 && attr.pointer == 0)
5290 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
5295 && e->symtree->n.sym->attr.intent == INTENT_IN)
5297 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5298 e->symtree->n.sym->name, &e->where);
5306 /* Returns true if the expression e contains a reference to the symbol sym. */
5308 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5310 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
5317 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
5319 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
5323 /* Given the expression node e for an allocatable/pointer of derived type to be
5324 allocated, get the expression node to be initialized afterwards (needed for
5325 derived types with default initializers, and derived types with allocatable
5326 components that need nullification.) */
5329 expr_to_initialize (gfc_expr *e)
5335 result = gfc_copy_expr (e);
5337 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5338 for (ref = result->ref; ref; ref = ref->next)
5339 if (ref->type == REF_ARRAY && ref->next == NULL)
5341 ref->u.ar.type = AR_FULL;
5343 for (i = 0; i < ref->u.ar.dimen; i++)
5344 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
5346 result->rank = ref->u.ar.dimen;
5354 /* Resolve the expression in an ALLOCATE statement, doing the additional
5355 checks to see whether the expression is OK or not. The expression must
5356 have a trailing array reference that gives the size of the array. */
5359 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
5361 int i, pointer, allocatable, dimension, check_intent_in;
5362 symbol_attribute attr;
5363 gfc_ref *ref, *ref2;
5370 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5371 check_intent_in = 1;
5373 if (gfc_resolve_expr (e) == FAILURE)
5376 /* Make sure the expression is allocatable or a pointer. If it is
5377 pointer, the next-to-last reference must be a pointer. */
5381 if (e->expr_type != EXPR_VARIABLE)
5384 attr = gfc_expr_attr (e);
5385 pointer = attr.pointer;
5386 dimension = attr.dimension;
5390 allocatable = e->symtree->n.sym->attr.allocatable;
5391 pointer = e->symtree->n.sym->attr.pointer;
5392 dimension = e->symtree->n.sym->attr.dimension;
5394 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
5397 check_intent_in = 0;
5402 if (ref->next != NULL)
5407 allocatable = (ref->u.c.component->as != NULL
5408 && ref->u.c.component->as->type == AS_DEFERRED);
5410 pointer = ref->u.c.component->attr.pointer;
5411 dimension = ref->u.c.component->attr.dimension;
5422 if (allocatable == 0 && pointer == 0)
5424 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
5430 && e->symtree->n.sym->attr.intent == INTENT_IN)
5432 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5433 e->symtree->n.sym->name, &e->where);
5437 /* Add default initializer for those derived types that need them. */
5438 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
5440 init_st = gfc_get_code ();
5441 init_st->loc = code->loc;
5442 init_st->op = EXEC_INIT_ASSIGN;
5443 init_st->expr1 = expr_to_initialize (e);
5444 init_st->expr2 = init_e;
5445 init_st->next = code->next;
5446 code->next = init_st;
5449 if (pointer && dimension == 0)
5452 /* Make sure the next-to-last reference node is an array specification. */
5454 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
5456 gfc_error ("Array specification required in ALLOCATE statement "
5457 "at %L", &e->where);
5461 /* Make sure that the array section reference makes sense in the
5462 context of an ALLOCATE specification. */
5466 for (i = 0; i < ar->dimen; i++)
5468 if (ref2->u.ar.type == AR_ELEMENT)
5471 switch (ar->dimen_type[i])
5477 if (ar->start[i] != NULL
5478 && ar->end[i] != NULL
5479 && ar->stride[i] == NULL)
5482 /* Fall Through... */
5486 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5493 for (a = code->ext.alloc_list; a; a = a->next)
5495 sym = a->expr->symtree->n.sym;
5497 /* TODO - check derived type components. */
5498 if (sym->ts.type == BT_DERIVED)
5501 if ((ar->start[i] != NULL
5502 && gfc_find_sym_in_expr (sym, ar->start[i]))
5503 || (ar->end[i] != NULL
5504 && gfc_find_sym_in_expr (sym, ar->end[i])))
5506 gfc_error ("'%s' must not appear in the array specification at "
5507 "%L in the same ALLOCATE statement where it is "
5508 "itself allocated", sym->name, &ar->where);
5518 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
5520 gfc_expr *stat, *errmsg, *pe, *qe;
5521 gfc_alloc *a, *p, *q;
5523 stat = code->expr1 ? code->expr1 : NULL;
5525 errmsg = code->expr2 ? code->expr2 : NULL;
5527 /* Check the stat variable. */
5530 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
5531 gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
5532 stat->symtree->n.sym->name, &stat->where);
5534 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
5535 gfc_error ("Illegal stat-variable at %L for a PURE procedure",
5538 if (stat->ts.type != BT_INTEGER
5539 && !(stat->ref && (stat->ref->type == REF_ARRAY
5540 || stat->ref->type == REF_COMPONENT)))
5541 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
5542 "variable", &stat->where);
5544 for (p = code->ext.alloc_list; p; p = p->next)
5545 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
5546 gfc_error ("Stat-variable at %L shall not be %sd within "
5547 "the same %s statement", &stat->where, fcn, fcn);
5550 /* Check the errmsg variable. */
5554 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
5557 if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
5558 gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
5559 errmsg->symtree->n.sym->name, &errmsg->where);
5561 if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
5562 gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
5565 if (errmsg->ts.type != BT_CHARACTER
5567 && (errmsg->ref->type == REF_ARRAY
5568 || errmsg->ref->type == REF_COMPONENT)))
5569 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
5570 "variable", &errmsg->where);
5572 for (p = code->ext.alloc_list; p; p = p->next)
5573 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
5574 gfc_error ("Errmsg-variable at %L shall not be %sd within "
5575 "the same %s statement", &errmsg->where, fcn, fcn);
5578 /* Check that an allocate-object appears only once in the statement.
5579 FIXME: Checking derived types is disabled. */
5580 for (p = code->ext.alloc_list; p; p = p->next)
5583 if ((pe->ref && pe->ref->type != REF_COMPONENT)
5584 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
5586 for (q = p->next; q; q = q->next)
5589 if ((qe->ref && qe->ref->type != REF_COMPONENT)
5590 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
5591 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
5592 gfc_error ("Allocate-object at %L also appears at %L",
5593 &pe->where, &qe->where);
5598 if (strcmp (fcn, "ALLOCATE") == 0)
5600 for (a = code->ext.alloc_list; a; a = a->next)
5601 resolve_allocate_expr (a->expr, code);
5605 for (a = code->ext.alloc_list; a; a = a->next)
5606 resolve_deallocate_expr (a->expr);
5611 /************ SELECT CASE resolution subroutines ************/
5613 /* Callback function for our mergesort variant. Determines interval
5614 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5615 op1 > op2. Assumes we're not dealing with the default case.
5616 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5617 There are nine situations to check. */
5620 compare_cases (const gfc_case *op1, const gfc_case *op2)
5624 if (op1->low == NULL) /* op1 = (:L) */
5626 /* op2 = (:N), so overlap. */
5628 /* op2 = (M:) or (M:N), L < M */
5629 if (op2->low != NULL
5630 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5633 else if (op1->high == NULL) /* op1 = (K:) */
5635 /* op2 = (M:), so overlap. */
5637 /* op2 = (:N) or (M:N), K > N */
5638 if (op2->high != NULL
5639 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5642 else /* op1 = (K:L) */
5644 if (op2->low == NULL) /* op2 = (:N), K > N */
5645 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5647 else if (op2->high == NULL) /* op2 = (M:), L < M */
5648 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5650 else /* op2 = (M:N) */
5654 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
5657 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
5666 /* Merge-sort a double linked case list, detecting overlap in the
5667 process. LIST is the head of the double linked case list before it
5668 is sorted. Returns the head of the sorted list if we don't see any
5669 overlap, or NULL otherwise. */
5672 check_case_overlap (gfc_case *list)
5674 gfc_case *p, *q, *e, *tail;
5675 int insize, nmerges, psize, qsize, cmp, overlap_seen;
5677 /* If the passed list was empty, return immediately. */
5684 /* Loop unconditionally. The only exit from this loop is a return
5685 statement, when we've finished sorting the case list. */
5692 /* Count the number of merges we do in this pass. */
5695 /* Loop while there exists a merge to be done. */
5700 /* Count this merge. */
5703 /* Cut the list in two pieces by stepping INSIZE places
5704 forward in the list, starting from P. */
5707 for (i = 0; i < insize; i++)
5716 /* Now we have two lists. Merge them! */
5717 while (psize > 0 || (qsize > 0 && q != NULL))
5719 /* See from which the next case to merge comes from. */
5722 /* P is empty so the next case must come from Q. */
5727 else if (qsize == 0 || q == NULL)
5736 cmp = compare_cases (p, q);
5739 /* The whole case range for P is less than the
5747 /* The whole case range for Q is greater than
5748 the case range for P. */
5755 /* The cases overlap, or they are the same
5756 element in the list. Either way, we must
5757 issue an error and get the next case from P. */
5758 /* FIXME: Sort P and Q by line number. */
5759 gfc_error ("CASE label at %L overlaps with CASE "
5760 "label at %L", &p->where, &q->where);
5768 /* Add the next element to the merged list. */
5777 /* P has now stepped INSIZE places along, and so has Q. So
5778 they're the same. */
5783 /* If we have done only one merge or none at all, we've
5784 finished sorting the cases. */
5793 /* Otherwise repeat, merging lists twice the size. */
5799 /* Check to see if an expression is suitable for use in a CASE statement.
5800 Makes sure that all case expressions are scalar constants of the same
5801 type. Return FAILURE if anything is wrong. */
5804 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5806 if (e == NULL) return SUCCESS;
5808 if (e->ts.type != case_expr->ts.type)
5810 gfc_error ("Expression in CASE statement at %L must be of type %s",
5811 &e->where, gfc_basic_typename (case_expr->ts.type));
5815 /* C805 (R808) For a given case-construct, each case-value shall be of
5816 the same type as case-expr. For character type, length differences
5817 are allowed, but the kind type parameters shall be the same. */
5819 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5821 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5822 &e->where, case_expr->ts.kind);
5826 /* Convert the case value kind to that of case expression kind, if needed.
5827 FIXME: Should a warning be issued? */
5828 if (e->ts.kind != case_expr->ts.kind)
5829 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5833 gfc_error ("Expression in CASE statement at %L must be scalar",
5842 /* Given a completely parsed select statement, we:
5844 - Validate all expressions and code within the SELECT.
5845 - Make sure that the selection expression is not of the wrong type.
5846 - Make sure that no case ranges overlap.
5847 - Eliminate unreachable cases and unreachable code resulting from
5848 removing case labels.
5850 The standard does allow unreachable cases, e.g. CASE (5:3). But
5851 they are a hassle for code generation, and to prevent that, we just
5852 cut them out here. This is not necessary for overlapping cases
5853 because they are illegal and we never even try to generate code.
5855 We have the additional caveat that a SELECT construct could have
5856 been a computed GOTO in the source code. Fortunately we can fairly
5857 easily work around that here: The case_expr for a "real" SELECT CASE
5858 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5859 we have to do is make sure that the case_expr is a scalar integer
5863 resolve_select (gfc_code *code)
5866 gfc_expr *case_expr;
5867 gfc_case *cp, *default_case, *tail, *head;
5868 int seen_unreachable;
5874 if (code->expr1 == NULL)
5876 /* This was actually a computed GOTO statement. */
5877 case_expr = code->expr2;
5878 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5879 gfc_error ("Selection expression in computed GOTO statement "
5880 "at %L must be a scalar integer expression",
5883 /* Further checking is not necessary because this SELECT was built
5884 by the compiler, so it should always be OK. Just move the
5885 case_expr from expr2 to expr so that we can handle computed
5886 GOTOs as normal SELECTs from here on. */
5887 code->expr1 = code->expr2;
5892 case_expr = code->expr1;
5894 type = case_expr->ts.type;
5895 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5897 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5898 &case_expr->where, gfc_typename (&case_expr->ts));
5900 /* Punt. Going on here just produce more garbage error messages. */
5904 if (case_expr->rank != 0)
5906 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5907 "expression", &case_expr->where);
5913 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5914 of the SELECT CASE expression and its CASE values. Walk the lists
5915 of case values, and if we find a mismatch, promote case_expr to
5916 the appropriate kind. */
5918 if (type == BT_LOGICAL || type == BT_INTEGER)
5920 for (body = code->block; body; body = body->block)
5922 /* Walk the case label list. */
5923 for (cp = body->ext.case_list; cp; cp = cp->next)
5925 /* Intercept the DEFAULT case. It does not have a kind. */
5926 if (cp->low == NULL && cp->high == NULL)
5929 /* Unreachable case ranges are discarded, so ignore. */
5930 if (cp->low != NULL && cp->high != NULL
5931 && cp->low != cp->high
5932 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
5935 /* FIXME: Should a warning be issued? */
5937 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5938 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5940 if (cp->high != NULL
5941 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5942 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5947 /* Assume there is no DEFAULT case. */
5948 default_case = NULL;
5953 for (body = code->block; body; body = body->block)
5955 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5957 seen_unreachable = 0;
5959 /* Walk the case label list, making sure that all case labels
5961 for (cp = body->ext.case_list; cp; cp = cp->next)
5963 /* Count the number of cases in the whole construct. */
5966 /* Intercept the DEFAULT case. */
5967 if (cp->low == NULL && cp->high == NULL)
5969 if (default_case != NULL)
5971 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5972 "by a second DEFAULT CASE at %L",
5973 &default_case->where, &cp->where);
5984 /* Deal with single value cases and case ranges. Errors are
5985 issued from the validation function. */
5986 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5987 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5993 if (type == BT_LOGICAL
5994 && ((cp->low == NULL || cp->high == NULL)
5995 || cp->low != cp->high))
5997 gfc_error ("Logical range in CASE statement at %L is not "
5998 "allowed", &cp->low->where);
6003 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
6006 value = cp->low->value.logical == 0 ? 2 : 1;
6007 if (value & seen_logical)
6009 gfc_error ("constant logical value in CASE statement "
6010 "is repeated at %L",
6015 seen_logical |= value;
6018 if (cp->low != NULL && cp->high != NULL
6019 && cp->low != cp->high
6020 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
6022 if (gfc_option.warn_surprising)
6023 gfc_warning ("Range specification at %L can never "
6024 "be matched", &cp->where);
6026 cp->unreachable = 1;
6027 seen_unreachable = 1;
6031 /* If the case range can be matched, it can also overlap with
6032 other cases. To make sure it does not, we put it in a
6033 double linked list here. We sort that with a merge sort
6034 later on to detect any overlapping cases. */
6038 head->right = head->left = NULL;
6043 tail->right->left = tail;
6050 /* It there was a failure in the previous case label, give up
6051 for this case label list. Continue with the next block. */
6055 /* See if any case labels that are unreachable have been seen.
6056 If so, we eliminate them. This is a bit of a kludge because
6057 the case lists for a single case statement (label) is a
6058 single forward linked lists. */
6059 if (seen_unreachable)
6061 /* Advance until the first case in the list is reachable. */
6062 while (body->ext.case_list != NULL
6063 && body->ext.case_list->unreachable)
6065 gfc_case *n = body->ext.case_list;
6066 body->ext.case_list = body->ext.case_list->next;
6068 gfc_free_case_list (n);
6071 /* Strip all other unreachable cases. */
6072 if (body->ext.case_list)
6074 for (cp = body->ext.case_list; cp->next; cp = cp->next)
6076 if (cp->next->unreachable)
6078 gfc_case *n = cp->next;
6079 cp->next = cp->next->next;
6081 gfc_free_case_list (n);
6088 /* See if there were overlapping cases. If the check returns NULL,
6089 there was overlap. In that case we don't do anything. If head
6090 is non-NULL, we prepend the DEFAULT case. The sorted list can
6091 then used during code generation for SELECT CASE constructs with
6092 a case expression of a CHARACTER type. */
6095 head = check_case_overlap (head);
6097 /* Prepend the default_case if it is there. */
6098 if (head != NULL && default_case)
6100 default_case->left = NULL;
6101 default_case->right = head;
6102 head->left = default_case;
6106 /* Eliminate dead blocks that may be the result if we've seen
6107 unreachable case labels for a block. */
6108 for (body = code; body && body->block; body = body->block)
6110 if (body->block->ext.case_list == NULL)
6112 /* Cut the unreachable block from the code chain. */
6113 gfc_code *c = body->block;
6114 body->block = c->block;
6116 /* Kill the dead block, but not the blocks below it. */
6118 gfc_free_statements (c);
6122 /* More than two cases is legal but insane for logical selects.
6123 Issue a warning for it. */
6124 if (gfc_option.warn_surprising && type == BT_LOGICAL
6126 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
6131 /* Resolve a transfer statement. This is making sure that:
6132 -- a derived type being transferred has only non-pointer components
6133 -- a derived type being transferred doesn't have private components, unless
6134 it's being transferred from the module where the type was defined
6135 -- we're not trying to transfer a whole assumed size array. */
6138 resolve_transfer (gfc_code *code)
6147 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
6150 sym = exp->symtree->n.sym;
6153 /* Go to actual component transferred. */
6154 for (ref = code->expr1->ref; ref; ref = ref->next)
6155 if (ref->type == REF_COMPONENT)
6156 ts = &ref->u.c.component->ts;
6158 if (ts->type == BT_DERIVED)
6160 /* Check that transferred derived type doesn't contain POINTER
6162 if (ts->derived->attr.pointer_comp)
6164 gfc_error ("Data transfer element at %L cannot have "
6165 "POINTER components", &code->loc);
6169 if (ts->derived->attr.alloc_comp)
6171 gfc_error ("Data transfer element at %L cannot have "
6172 "ALLOCATABLE components", &code->loc);
6176 if (derived_inaccessible (ts->derived))
6178 gfc_error ("Data transfer element at %L cannot have "
6179 "PRIVATE components",&code->loc);
6184 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
6185 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
6187 gfc_error ("Data transfer element at %L cannot be a full reference to "
6188 "an assumed-size array", &code->loc);
6194 /*********** Toplevel code resolution subroutines ***********/
6196 /* Find the set of labels that are reachable from this block. We also
6197 record the last statement in each block. */
6200 find_reachable_labels (gfc_code *block)
6207 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
6209 /* Collect labels in this block. We don't keep those corresponding
6210 to END {IF|SELECT}, these are checked in resolve_branch by going
6211 up through the code_stack. */
6212 for (c = block; c; c = c->next)
6214 if (c->here && c->op != EXEC_END_BLOCK)
6215 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
6218 /* Merge with labels from parent block. */
6221 gcc_assert (cs_base->prev->reachable_labels);
6222 bitmap_ior_into (cs_base->reachable_labels,
6223 cs_base->prev->reachable_labels);
6227 /* Given a branch to a label, see if the branch is conforming.
6228 The code node describes where the branch is located. */
6231 resolve_branch (gfc_st_label *label, gfc_code *code)
6238 /* Step one: is this a valid branching target? */
6240 if (label->defined == ST_LABEL_UNKNOWN)
6242 gfc_error ("Label %d referenced at %L is never defined", label->value,
6247 if (label->defined != ST_LABEL_TARGET)
6249 gfc_error ("Statement at %L is not a valid branch target statement "
6250 "for the branch statement at %L", &label->where, &code->loc);
6254 /* Step two: make sure this branch is not a branch to itself ;-) */
6256 if (code->here == label)
6258 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
6262 /* Step three: See if the label is in the same block as the
6263 branching statement. The hard work has been done by setting up
6264 the bitmap reachable_labels. */
6266 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
6269 /* Step four: If we haven't found the label in the bitmap, it may
6270 still be the label of the END of the enclosing block, in which
6271 case we find it by going up the code_stack. */
6273 for (stack = cs_base; stack; stack = stack->prev)
6274 if (stack->current->next && stack->current->next->here == label)
6279 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
6283 /* The label is not in an enclosing block, so illegal. This was
6284 allowed in Fortran 66, so we allow it as extension. No
6285 further checks are necessary in this case. */
6286 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
6287 "as the GOTO statement at %L", &label->where,
6293 /* Check whether EXPR1 has the same shape as EXPR2. */
6296 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
6298 mpz_t shape[GFC_MAX_DIMENSIONS];
6299 mpz_t shape2[GFC_MAX_DIMENSIONS];
6300 gfc_try result = FAILURE;
6303 /* Compare the rank. */
6304 if (expr1->rank != expr2->rank)
6307 /* Compare the size of each dimension. */
6308 for (i=0; i<expr1->rank; i++)
6310 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
6313 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
6316 if (mpz_cmp (shape[i], shape2[i]))
6320 /* When either of the two expression is an assumed size array, we
6321 ignore the comparison of dimension sizes. */
6326 for (i--; i >= 0; i--)
6328 mpz_clear (shape[i]);
6329 mpz_clear (shape2[i]);
6335 /* Check whether a WHERE assignment target or a WHERE mask expression
6336 has the same shape as the outmost WHERE mask expression. */
6339 resolve_where (gfc_code *code, gfc_expr *mask)
6345 cblock = code->block;
6347 /* Store the first WHERE mask-expr of the WHERE statement or construct.
6348 In case of nested WHERE, only the outmost one is stored. */
6349 if (mask == NULL) /* outmost WHERE */
6351 else /* inner WHERE */
6358 /* Check if the mask-expr has a consistent shape with the
6359 outmost WHERE mask-expr. */
6360 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
6361 gfc_error ("WHERE mask at %L has inconsistent shape",
6362 &cblock->expr1->where);
6365 /* the assignment statement of a WHERE statement, or the first
6366 statement in where-body-construct of a WHERE construct */
6367 cnext = cblock->next;
6372 /* WHERE assignment statement */
6375 /* Check shape consistent for WHERE assignment target. */
6376 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
6377 gfc_error ("WHERE assignment target at %L has "
6378 "inconsistent shape", &cnext->expr1->where);
6382 case EXEC_ASSIGN_CALL:
6383 resolve_call (cnext);
6384 if (!cnext->resolved_sym->attr.elemental)
6385 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6386 &cnext->ext.actual->expr->where);
6389 /* WHERE or WHERE construct is part of a where-body-construct */
6391 resolve_where (cnext, e);
6395 gfc_error ("Unsupported statement inside WHERE at %L",
6398 /* the next statement within the same where-body-construct */
6399 cnext = cnext->next;
6401 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6402 cblock = cblock->block;
6407 /* Resolve assignment in FORALL construct.
6408 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6409 FORALL index variables. */
6412 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
6416 for (n = 0; n < nvar; n++)
6418 gfc_symbol *forall_index;
6420 forall_index = var_expr[n]->symtree->n.sym;
6422 /* Check whether the assignment target is one of the FORALL index
6424 if ((code->expr1->expr_type == EXPR_VARIABLE)
6425 && (code->expr1->symtree->n.sym == forall_index))
6426 gfc_error ("Assignment to a FORALL index variable at %L",
6427 &code->expr1->where);
6430 /* If one of the FORALL index variables doesn't appear in the
6431 assignment variable, then there could be a many-to-one
6432 assignment. Emit a warning rather than an error because the
6433 mask could be resolving this problem. */
6434 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
6435 gfc_warning ("The FORALL with index '%s' is not used on the "
6436 "left side of the assignment at %L and so might "
6437 "cause multiple assignment to this object",
6438 var_expr[n]->symtree->name, &code->expr1->where);
6444 /* Resolve WHERE statement in FORALL construct. */
6447 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
6448 gfc_expr **var_expr)
6453 cblock = code->block;
6456 /* the assignment statement of a WHERE statement, or the first
6457 statement in where-body-construct of a WHERE construct */
6458 cnext = cblock->next;
6463 /* WHERE assignment statement */
6465 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
6468 /* WHERE operator assignment statement */
6469 case EXEC_ASSIGN_CALL:
6470 resolve_call (cnext);
6471 if (!cnext->resolved_sym->attr.elemental)
6472 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6473 &cnext->ext.actual->expr->where);
6476 /* WHERE or WHERE construct is part of a where-body-construct */
6478 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
6482 gfc_error ("Unsupported statement inside WHERE at %L",
6485 /* the next statement within the same where-body-construct */
6486 cnext = cnext->next;
6488 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6489 cblock = cblock->block;
6494 /* Traverse the FORALL body to check whether the following errors exist:
6495 1. For assignment, check if a many-to-one assignment happens.
6496 2. For WHERE statement, check the WHERE body to see if there is any
6497 many-to-one assignment. */
6500 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
6504 c = code->block->next;
6510 case EXEC_POINTER_ASSIGN:
6511 gfc_resolve_assign_in_forall (c, nvar, var_expr);
6514 case EXEC_ASSIGN_CALL:
6518 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6519 there is no need to handle it here. */
6523 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
6528 /* The next statement in the FORALL body. */
6534 /* Counts the number of iterators needed inside a forall construct, including
6535 nested forall constructs. This is used to allocate the needed memory
6536 in gfc_resolve_forall. */
6539 gfc_count_forall_iterators (gfc_code *code)
6541 int max_iters, sub_iters, current_iters;
6542 gfc_forall_iterator *fa;
6544 gcc_assert(code->op == EXEC_FORALL);
6548 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6551 code = code->block->next;
6555 if (code->op == EXEC_FORALL)
6557 sub_iters = gfc_count_forall_iterators (code);
6558 if (sub_iters > max_iters)
6559 max_iters = sub_iters;
6564 return current_iters + max_iters;
6568 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6569 gfc_resolve_forall_body to resolve the FORALL body. */
6572 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
6574 static gfc_expr **var_expr;
6575 static int total_var = 0;
6576 static int nvar = 0;
6578 gfc_forall_iterator *fa;
6583 /* Start to resolve a FORALL construct */
6584 if (forall_save == 0)
6586 /* Count the total number of FORALL index in the nested FORALL
6587 construct in order to allocate the VAR_EXPR with proper size. */
6588 total_var = gfc_count_forall_iterators (code);
6590 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6591 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
6594 /* The information about FORALL iterator, including FORALL index start, end
6595 and stride. The FORALL index can not appear in start, end or stride. */
6596 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
6598 /* Check if any outer FORALL index name is the same as the current
6600 for (i = 0; i < nvar; i++)
6602 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
6604 gfc_error ("An outer FORALL construct already has an index "
6605 "with this name %L", &fa->var->where);
6609 /* Record the current FORALL index. */
6610 var_expr[nvar] = gfc_copy_expr (fa->var);
6614 /* No memory leak. */
6615 gcc_assert (nvar <= total_var);
6618 /* Resolve the FORALL body. */
6619 gfc_resolve_forall_body (code, nvar, var_expr);
6621 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6622 gfc_resolve_blocks (code->block, ns);
6626 /* Free only the VAR_EXPRs allocated in this frame. */
6627 for (i = nvar; i < tmp; i++)
6628 gfc_free_expr (var_expr[i]);
6632 /* We are in the outermost FORALL construct. */
6633 gcc_assert (forall_save == 0);
6635 /* VAR_EXPR is not needed any more. */
6636 gfc_free (var_expr);
6642 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6645 static void resolve_code (gfc_code *, gfc_namespace *);
6648 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
6652 for (; b; b = b->block)
6654 t = gfc_resolve_expr (b->expr1);
6655 if (gfc_resolve_expr (b->expr2) == FAILURE)
6661 if (t == SUCCESS && b->expr1 != NULL
6662 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
6663 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6670 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
6671 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6676 resolve_branch (b->label1, b);
6689 case EXEC_OMP_ATOMIC:
6690 case EXEC_OMP_CRITICAL:
6692 case EXEC_OMP_MASTER:
6693 case EXEC_OMP_ORDERED:
6694 case EXEC_OMP_PARALLEL:
6695 case EXEC_OMP_PARALLEL_DO:
6696 case EXEC_OMP_PARALLEL_SECTIONS:
6697 case EXEC_OMP_PARALLEL_WORKSHARE:
6698 case EXEC_OMP_SECTIONS:
6699 case EXEC_OMP_SINGLE:
6701 case EXEC_OMP_TASKWAIT:
6702 case EXEC_OMP_WORKSHARE:
6706 gfc_internal_error ("resolve_block(): Bad block type");
6709 resolve_code (b->next, ns);
6714 /* Does everything to resolve an ordinary assignment. Returns true
6715 if this is an interface assignment. */
6717 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
6727 if (gfc_extend_assign (code, ns) == SUCCESS)
6729 lhs = code->ext.actual->expr;
6730 rhs = code->ext.actual->next->expr;
6731 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6733 gfc_error ("Subroutine '%s' called instead of assignment at "
6734 "%L must be PURE", code->symtree->n.sym->name,
6739 /* Make a temporary rhs when there is a default initializer
6740 and rhs is the same symbol as the lhs. */
6741 if (rhs->expr_type == EXPR_VARIABLE
6742 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6743 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6744 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6745 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6754 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
6755 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6756 &code->loc) == FAILURE)
6759 /* Handle the case of a BOZ literal on the RHS. */
6760 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
6763 if (gfc_option.warn_surprising)
6764 gfc_warning ("BOZ literal at %L is bitwise transferred "
6765 "non-integer symbol '%s'", &code->loc,
6766 lhs->symtree->n.sym->name);
6768 if (!gfc_convert_boz (rhs, &lhs->ts))
6770 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
6772 if (rc == ARITH_UNDERFLOW)
6773 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6774 ". This check can be disabled with the option "
6775 "-fno-range-check", &rhs->where);
6776 else if (rc == ARITH_OVERFLOW)
6777 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6778 ". This check can be disabled with the option "
6779 "-fno-range-check", &rhs->where);
6780 else if (rc == ARITH_NAN)
6781 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6782 ". This check can be disabled with the option "
6783 "-fno-range-check", &rhs->where);
6789 if (lhs->ts.type == BT_CHARACTER
6790 && gfc_option.warn_character_truncation)
6792 if (lhs->ts.cl != NULL
6793 && lhs->ts.cl->length != NULL
6794 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6795 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
6797 if (rhs->expr_type == EXPR_CONSTANT)
6798 rlen = rhs->value.character.length;
6800 else if (rhs->ts.cl != NULL
6801 && rhs->ts.cl->length != NULL
6802 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
6803 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
6805 if (rlen && llen && rlen > llen)
6806 gfc_warning_now ("CHARACTER expression will be truncated "
6807 "in assignment (%d/%d) at %L",
6808 llen, rlen, &code->loc);
6811 /* Ensure that a vector index expression for the lvalue is evaluated
6812 to a temporary if the lvalue symbol is referenced in it. */
6815 for (ref = lhs->ref; ref; ref= ref->next)
6816 if (ref->type == REF_ARRAY)
6818 for (n = 0; n < ref->u.ar.dimen; n++)
6819 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
6820 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
6821 ref->u.ar.start[n]))
6823 = gfc_get_parentheses (ref->u.ar.start[n]);
6827 if (gfc_pure (NULL))
6829 if (gfc_impure_variable (lhs->symtree->n.sym))
6831 gfc_error ("Cannot assign to variable '%s' in PURE "
6833 lhs->symtree->n.sym->name,
6838 if (lhs->ts.type == BT_DERIVED
6839 && lhs->expr_type == EXPR_VARIABLE
6840 && lhs->ts.derived->attr.pointer_comp
6841 && gfc_impure_variable (rhs->symtree->n.sym))
6843 gfc_error ("The impure variable at %L is assigned to "
6844 "a derived type variable with a POINTER "
6845 "component in a PURE procedure (12.6)",
6851 gfc_check_assign (lhs, rhs, 1);
6855 /* Given a block of code, recursively resolve everything pointed to by this
6859 resolve_code (gfc_code *code, gfc_namespace *ns)
6861 int omp_workshare_save;
6866 frame.prev = cs_base;
6870 find_reachable_labels (code);
6872 for (; code; code = code->next)
6874 frame.current = code;
6875 forall_save = forall_flag;
6877 if (code->op == EXEC_FORALL)
6880 gfc_resolve_forall (code, ns, forall_save);
6883 else if (code->block)
6885 omp_workshare_save = -1;
6888 case EXEC_OMP_PARALLEL_WORKSHARE:
6889 omp_workshare_save = omp_workshare_flag;
6890 omp_workshare_flag = 1;
6891 gfc_resolve_omp_parallel_blocks (code, ns);
6893 case EXEC_OMP_PARALLEL:
6894 case EXEC_OMP_PARALLEL_DO:
6895 case EXEC_OMP_PARALLEL_SECTIONS:
6897 omp_workshare_save = omp_workshare_flag;
6898 omp_workshare_flag = 0;
6899 gfc_resolve_omp_parallel_blocks (code, ns);
6902 gfc_resolve_omp_do_blocks (code, ns);
6904 case EXEC_OMP_WORKSHARE:
6905 omp_workshare_save = omp_workshare_flag;
6906 omp_workshare_flag = 1;
6909 gfc_resolve_blocks (code->block, ns);
6913 if (omp_workshare_save != -1)
6914 omp_workshare_flag = omp_workshare_save;
6918 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
6919 t = gfc_resolve_expr (code->expr1);
6920 forall_flag = forall_save;
6922 if (gfc_resolve_expr (code->expr2) == FAILURE)
6928 case EXEC_END_BLOCK:
6938 /* Keep track of which entry we are up to. */
6939 current_entry_id = code->ext.entry->id;
6943 resolve_where (code, NULL);
6947 if (code->expr1 != NULL)
6949 if (code->expr1->ts.type != BT_INTEGER)
6950 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6951 "INTEGER variable", &code->expr1->where);
6952 else if (code->expr1->symtree->n.sym->attr.assign != 1)
6953 gfc_error ("Variable '%s' has not been assigned a target "
6954 "label at %L", code->expr1->symtree->n.sym->name,
6955 &code->expr1->where);
6958 resolve_branch (code->label1, code);
6962 if (code->expr1 != NULL
6963 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
6964 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6965 "INTEGER return specifier", &code->expr1->where);
6968 case EXEC_INIT_ASSIGN:
6969 case EXEC_END_PROCEDURE:
6976 if (resolve_ordinary_assign (code, ns))
6981 case EXEC_LABEL_ASSIGN:
6982 if (code->label1->defined == ST_LABEL_UNKNOWN)
6983 gfc_error ("Label %d referenced at %L is never defined",
6984 code->label1->value, &code->label1->where);
6986 && (code->expr1->expr_type != EXPR_VARIABLE
6987 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
6988 || code->expr1->symtree->n.sym->ts.kind
6989 != gfc_default_integer_kind
6990 || code->expr1->symtree->n.sym->as != NULL))
6991 gfc_error ("ASSIGN statement at %L requires a scalar "
6992 "default INTEGER variable", &code->expr1->where);
6995 case EXEC_POINTER_ASSIGN:
6999 gfc_check_pointer_assign (code->expr1, code->expr2);
7002 case EXEC_ARITHMETIC_IF:
7004 && code->expr1->ts.type != BT_INTEGER
7005 && code->expr1->ts.type != BT_REAL)
7006 gfc_error ("Arithmetic IF statement at %L requires a numeric "
7007 "expression", &code->expr1->where);
7009 resolve_branch (code->label1, code);
7010 resolve_branch (code->label2, code);
7011 resolve_branch (code->label3, code);
7015 if (t == SUCCESS && code->expr1 != NULL
7016 && (code->expr1->ts.type != BT_LOGICAL
7017 || code->expr1->rank != 0))
7018 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7019 &code->expr1->where);
7024 resolve_call (code);
7028 resolve_typebound_call (code);
7032 resolve_ppc_call (code);
7036 /* Select is complicated. Also, a SELECT construct could be
7037 a transformed computed GOTO. */
7038 resolve_select (code);
7042 if (code->ext.iterator != NULL)
7044 gfc_iterator *iter = code->ext.iterator;
7045 if (gfc_resolve_iterator (iter, true) != FAILURE)
7046 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
7051 if (code->expr1 == NULL)
7052 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
7054 && (code->expr1->rank != 0
7055 || code->expr1->ts.type != BT_LOGICAL))
7056 gfc_error ("Exit condition of DO WHILE loop at %L must be "
7057 "a scalar LOGICAL expression", &code->expr1->where);
7062 resolve_allocate_deallocate (code, "ALLOCATE");
7066 case EXEC_DEALLOCATE:
7068 resolve_allocate_deallocate (code, "DEALLOCATE");
7073 if (gfc_resolve_open (code->ext.open) == FAILURE)
7076 resolve_branch (code->ext.open->err, code);
7080 if (gfc_resolve_close (code->ext.close) == FAILURE)
7083 resolve_branch (code->ext.close->err, code);
7086 case EXEC_BACKSPACE:
7090 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
7093 resolve_branch (code->ext.filepos->err, code);
7097 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
7100 resolve_branch (code->ext.inquire->err, code);
7104 gcc_assert (code->ext.inquire != NULL);
7105 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
7108 resolve_branch (code->ext.inquire->err, code);
7112 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
7115 resolve_branch (code->ext.wait->err, code);
7116 resolve_branch (code->ext.wait->end, code);
7117 resolve_branch (code->ext.wait->eor, code);
7122 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
7125 resolve_branch (code->ext.dt->err, code);
7126 resolve_branch (code->ext.dt->end, code);
7127 resolve_branch (code->ext.dt->eor, code);
7131 resolve_transfer (code);
7135 resolve_forall_iterators (code->ext.forall_iterator);
7137 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
7138 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
7139 "expression", &code->expr1->where);
7142 case EXEC_OMP_ATOMIC:
7143 case EXEC_OMP_BARRIER:
7144 case EXEC_OMP_CRITICAL:
7145 case EXEC_OMP_FLUSH:
7147 case EXEC_OMP_MASTER:
7148 case EXEC_OMP_ORDERED:
7149 case EXEC_OMP_SECTIONS:
7150 case EXEC_OMP_SINGLE:
7151 case EXEC_OMP_TASKWAIT:
7152 case EXEC_OMP_WORKSHARE:
7153 gfc_resolve_omp_directive (code, ns);
7156 case EXEC_OMP_PARALLEL:
7157 case EXEC_OMP_PARALLEL_DO:
7158 case EXEC_OMP_PARALLEL_SECTIONS:
7159 case EXEC_OMP_PARALLEL_WORKSHARE:
7161 omp_workshare_save = omp_workshare_flag;
7162 omp_workshare_flag = 0;
7163 gfc_resolve_omp_directive (code, ns);
7164 omp_workshare_flag = omp_workshare_save;
7168 gfc_internal_error ("resolve_code(): Bad statement code");
7172 cs_base = frame.prev;
7176 /* Resolve initial values and make sure they are compatible with
7180 resolve_values (gfc_symbol *sym)
7182 if (sym->value == NULL)
7185 if (gfc_resolve_expr (sym->value) == FAILURE)
7188 gfc_check_assign_symbol (sym, sym->value);
7192 /* Verify the binding labels for common blocks that are BIND(C). The label
7193 for a BIND(C) common block must be identical in all scoping units in which
7194 the common block is declared. Further, the binding label can not collide
7195 with any other global entity in the program. */
7198 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
7200 if (comm_block_tree->n.common->is_bind_c == 1)
7202 gfc_gsymbol *binding_label_gsym;
7203 gfc_gsymbol *comm_name_gsym;
7205 /* See if a global symbol exists by the common block's name. It may
7206 be NULL if the common block is use-associated. */
7207 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
7208 comm_block_tree->n.common->name);
7209 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
7210 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
7211 "with the global entity '%s' at %L",
7212 comm_block_tree->n.common->binding_label,
7213 comm_block_tree->n.common->name,
7214 &(comm_block_tree->n.common->where),
7215 comm_name_gsym->name, &(comm_name_gsym->where));
7216 else if (comm_name_gsym != NULL
7217 && strcmp (comm_name_gsym->name,
7218 comm_block_tree->n.common->name) == 0)
7220 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
7222 if (comm_name_gsym->binding_label == NULL)
7223 /* No binding label for common block stored yet; save this one. */
7224 comm_name_gsym->binding_label =
7225 comm_block_tree->n.common->binding_label;
7227 if (strcmp (comm_name_gsym->binding_label,
7228 comm_block_tree->n.common->binding_label) != 0)
7230 /* Common block names match but binding labels do not. */
7231 gfc_error ("Binding label '%s' for common block '%s' at %L "
7232 "does not match the binding label '%s' for common "
7234 comm_block_tree->n.common->binding_label,
7235 comm_block_tree->n.common->name,
7236 &(comm_block_tree->n.common->where),
7237 comm_name_gsym->binding_label,
7238 comm_name_gsym->name,
7239 &(comm_name_gsym->where));
7244 /* There is no binding label (NAME="") so we have nothing further to
7245 check and nothing to add as a global symbol for the label. */
7246 if (comm_block_tree->n.common->binding_label[0] == '\0' )
7249 binding_label_gsym =
7250 gfc_find_gsymbol (gfc_gsym_root,
7251 comm_block_tree->n.common->binding_label);
7252 if (binding_label_gsym == NULL)
7254 /* Need to make a global symbol for the binding label to prevent
7255 it from colliding with another. */
7256 binding_label_gsym =
7257 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
7258 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
7259 binding_label_gsym->type = GSYM_COMMON;
7263 /* If comm_name_gsym is NULL, the name common block is use
7264 associated and the name could be colliding. */
7265 if (binding_label_gsym->type != GSYM_COMMON)
7266 gfc_error ("Binding label '%s' for common block '%s' at %L "
7267 "collides with the global entity '%s' at %L",
7268 comm_block_tree->n.common->binding_label,
7269 comm_block_tree->n.common->name,
7270 &(comm_block_tree->n.common->where),
7271 binding_label_gsym->name,
7272 &(binding_label_gsym->where));
7273 else if (comm_name_gsym != NULL
7274 && (strcmp (binding_label_gsym->name,
7275 comm_name_gsym->binding_label) != 0)
7276 && (strcmp (binding_label_gsym->sym_name,
7277 comm_name_gsym->name) != 0))
7278 gfc_error ("Binding label '%s' for common block '%s' at %L "
7279 "collides with global entity '%s' at %L",
7280 binding_label_gsym->name, binding_label_gsym->sym_name,
7281 &(comm_block_tree->n.common->where),
7282 comm_name_gsym->name, &(comm_name_gsym->where));
7290 /* Verify any BIND(C) derived types in the namespace so we can report errors
7291 for them once, rather than for each variable declared of that type. */
7294 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
7296 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
7297 && derived_sym->attr.is_bind_c == 1)
7298 verify_bind_c_derived_type (derived_sym);
7304 /* Verify that any binding labels used in a given namespace do not collide
7305 with the names or binding labels of any global symbols. */
7308 gfc_verify_binding_labels (gfc_symbol *sym)
7312 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
7313 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
7315 gfc_gsymbol *bind_c_sym;
7317 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
7318 if (bind_c_sym != NULL
7319 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
7321 if (sym->attr.if_source == IFSRC_DECL
7322 && (bind_c_sym->type != GSYM_SUBROUTINE
7323 && bind_c_sym->type != GSYM_FUNCTION)
7324 && ((sym->attr.contained == 1
7325 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
7326 || (sym->attr.use_assoc == 1
7327 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
7329 /* Make sure global procedures don't collide with anything. */
7330 gfc_error ("Binding label '%s' at %L collides with the global "
7331 "entity '%s' at %L", sym->binding_label,
7332 &(sym->declared_at), bind_c_sym->name,
7333 &(bind_c_sym->where));
7336 else if (sym->attr.contained == 0
7337 && (sym->attr.if_source == IFSRC_IFBODY
7338 && sym->attr.flavor == FL_PROCEDURE)
7339 && (bind_c_sym->sym_name != NULL
7340 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
7342 /* Make sure procedures in interface bodies don't collide. */
7343 gfc_error ("Binding label '%s' in interface body at %L collides "
7344 "with the global entity '%s' at %L",
7346 &(sym->declared_at), bind_c_sym->name,
7347 &(bind_c_sym->where));
7350 else if (sym->attr.contained == 0
7351 && sym->attr.if_source == IFSRC_UNKNOWN)
7352 if ((sym->attr.use_assoc && bind_c_sym->mod_name
7353 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
7354 || sym->attr.use_assoc == 0)
7356 gfc_error ("Binding label '%s' at %L collides with global "
7357 "entity '%s' at %L", sym->binding_label,
7358 &(sym->declared_at), bind_c_sym->name,
7359 &(bind_c_sym->where));
7364 /* Clear the binding label to prevent checking multiple times. */
7365 sym->binding_label[0] = '\0';
7367 else if (bind_c_sym == NULL)
7369 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
7370 bind_c_sym->where = sym->declared_at;
7371 bind_c_sym->sym_name = sym->name;
7373 if (sym->attr.use_assoc == 1)
7374 bind_c_sym->mod_name = sym->module;
7376 if (sym->ns->proc_name != NULL)
7377 bind_c_sym->mod_name = sym->ns->proc_name->name;
7379 if (sym->attr.contained == 0)
7381 if (sym->attr.subroutine)
7382 bind_c_sym->type = GSYM_SUBROUTINE;
7383 else if (sym->attr.function)
7384 bind_c_sym->type = GSYM_FUNCTION;
7392 /* Resolve an index expression. */
7395 resolve_index_expr (gfc_expr *e)
7397 if (gfc_resolve_expr (e) == FAILURE)
7400 if (gfc_simplify_expr (e, 0) == FAILURE)
7403 if (gfc_specification_expr (e) == FAILURE)
7409 /* Resolve a charlen structure. */
7412 resolve_charlen (gfc_charlen *cl)
7421 specification_expr = 1;
7423 if (resolve_index_expr (cl->length) == FAILURE)
7425 specification_expr = 0;
7429 /* "If the character length parameter value evaluates to a negative
7430 value, the length of character entities declared is zero." */
7431 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
7433 gfc_warning_now ("CHARACTER variable has zero length at %L",
7434 &cl->length->where);
7435 gfc_replace_expr (cl->length, gfc_int_expr (0));
7438 /* Check that the character length is not too large. */
7439 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
7440 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
7441 && cl->length->ts.type == BT_INTEGER
7442 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
7444 gfc_error ("String length at %L is too large", &cl->length->where);
7452 /* Test for non-constant shape arrays. */
7455 is_non_constant_shape_array (gfc_symbol *sym)
7461 not_constant = false;
7462 if (sym->as != NULL)
7464 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7465 has not been simplified; parameter array references. Do the
7466 simplification now. */
7467 for (i = 0; i < sym->as->rank; i++)
7469 e = sym->as->lower[i];
7470 if (e && (resolve_index_expr (e) == FAILURE
7471 || !gfc_is_constant_expr (e)))
7472 not_constant = true;
7474 e = sym->as->upper[i];
7475 if (e && (resolve_index_expr (e) == FAILURE
7476 || !gfc_is_constant_expr (e)))
7477 not_constant = true;
7480 return not_constant;
7483 /* Given a symbol and an initialization expression, add code to initialize
7484 the symbol to the function entry. */
7486 build_init_assign (gfc_symbol *sym, gfc_expr *init)
7490 gfc_namespace *ns = sym->ns;
7492 /* Search for the function namespace if this is a contained
7493 function without an explicit result. */
7494 if (sym->attr.function && sym == sym->result
7495 && sym->name != sym->ns->proc_name->name)
7498 for (;ns; ns = ns->sibling)
7499 if (strcmp (ns->proc_name->name, sym->name) == 0)
7505 gfc_free_expr (init);
7509 /* Build an l-value expression for the result. */
7510 lval = gfc_lval_expr_from_sym (sym);
7512 /* Add the code at scope entry. */
7513 init_st = gfc_get_code ();
7514 init_st->next = ns->code;
7517 /* Assign the default initializer to the l-value. */
7518 init_st->loc = sym->declared_at;
7519 init_st->op = EXEC_INIT_ASSIGN;
7520 init_st->expr1 = lval;
7521 init_st->expr2 = init;
7524 /* Assign the default initializer to a derived type variable or result. */
7527 apply_default_init (gfc_symbol *sym)
7529 gfc_expr *init = NULL;
7531 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7534 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
7535 init = gfc_default_initializer (&sym->ts);
7540 build_init_assign (sym, init);
7543 /* Build an initializer for a local integer, real, complex, logical, or
7544 character variable, based on the command line flags finit-local-zero,
7545 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7546 null if the symbol should not have a default initialization. */
7548 build_default_init_expr (gfc_symbol *sym)
7551 gfc_expr *init_expr;
7554 /* These symbols should never have a default initialization. */
7555 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
7556 || sym->attr.external
7558 || sym->attr.pointer
7559 || sym->attr.in_equivalence
7560 || sym->attr.in_common
7563 || sym->attr.cray_pointee
7564 || sym->attr.cray_pointer)
7567 /* Now we'll try to build an initializer expression. */
7568 init_expr = gfc_get_expr ();
7569 init_expr->expr_type = EXPR_CONSTANT;
7570 init_expr->ts.type = sym->ts.type;
7571 init_expr->ts.kind = sym->ts.kind;
7572 init_expr->where = sym->declared_at;
7574 /* We will only initialize integers, reals, complex, logicals, and
7575 characters, and only if the corresponding command-line flags
7576 were set. Otherwise, we free init_expr and return null. */
7577 switch (sym->ts.type)
7580 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
7581 mpz_init_set_si (init_expr->value.integer,
7582 gfc_option.flag_init_integer_value);
7585 gfc_free_expr (init_expr);
7591 mpfr_init (init_expr->value.real);
7592 switch (gfc_option.flag_init_real)
7594 case GFC_INIT_REAL_SNAN:
7595 init_expr->is_snan = 1;
7597 case GFC_INIT_REAL_NAN:
7598 mpfr_set_nan (init_expr->value.real);
7601 case GFC_INIT_REAL_INF:
7602 mpfr_set_inf (init_expr->value.real, 1);
7605 case GFC_INIT_REAL_NEG_INF:
7606 mpfr_set_inf (init_expr->value.real, -1);
7609 case GFC_INIT_REAL_ZERO:
7610 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
7614 gfc_free_expr (init_expr);
7622 mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
7624 mpfr_init (init_expr->value.complex.r);
7625 mpfr_init (init_expr->value.complex.i);
7627 switch (gfc_option.flag_init_real)
7629 case GFC_INIT_REAL_SNAN:
7630 init_expr->is_snan = 1;
7632 case GFC_INIT_REAL_NAN:
7633 mpfr_set_nan (mpc_realref (init_expr->value.complex));
7634 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
7637 case GFC_INIT_REAL_INF:
7638 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
7639 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
7642 case GFC_INIT_REAL_NEG_INF:
7643 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
7644 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
7647 case GFC_INIT_REAL_ZERO:
7649 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
7651 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
7652 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
7657 gfc_free_expr (init_expr);
7664 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
7665 init_expr->value.logical = 0;
7666 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
7667 init_expr->value.logical = 1;
7670 gfc_free_expr (init_expr);
7676 /* For characters, the length must be constant in order to
7677 create a default initializer. */
7678 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
7679 && sym->ts.cl->length
7680 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
7682 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
7683 init_expr->value.character.length = char_len;
7684 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
7685 for (i = 0; i < char_len; i++)
7686 init_expr->value.character.string[i]
7687 = (unsigned char) gfc_option.flag_init_character_value;
7691 gfc_free_expr (init_expr);
7697 gfc_free_expr (init_expr);
7703 /* Add an initialization expression to a local variable. */
7705 apply_default_init_local (gfc_symbol *sym)
7707 gfc_expr *init = NULL;
7709 /* The symbol should be a variable or a function return value. */
7710 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
7711 || (sym->attr.function && sym->result != sym))
7714 /* Try to build the initializer expression. If we can't initialize
7715 this symbol, then init will be NULL. */
7716 init = build_default_init_expr (sym);
7720 /* For saved variables, we don't want to add an initializer at
7721 function entry, so we just add a static initializer. */
7722 if (sym->attr.save || sym->ns->save_all)
7724 /* Don't clobber an existing initializer! */
7725 gcc_assert (sym->value == NULL);
7730 build_init_assign (sym, init);
7733 /* Resolution of common features of flavors variable and procedure. */
7736 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
7738 /* Constraints on deferred shape variable. */
7739 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
7741 if (sym->attr.allocatable)
7743 if (sym->attr.dimension)
7744 gfc_error ("Allocatable array '%s' at %L must have "
7745 "a deferred shape", sym->name, &sym->declared_at);
7747 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7748 sym->name, &sym->declared_at);
7752 if (sym->attr.pointer && sym->attr.dimension)
7754 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7755 sym->name, &sym->declared_at);
7762 if (!mp_flag && !sym->attr.allocatable
7763 && !sym->attr.pointer && !sym->attr.dummy)
7765 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7766 sym->name, &sym->declared_at);
7774 /* Additional checks for symbols with flavor variable and derived
7775 type. To be called from resolve_fl_variable. */
7778 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
7780 gcc_assert (sym->ts.type == BT_DERIVED);
7782 /* Check to see if a derived type is blocked from being host
7783 associated by the presence of another class I symbol in the same
7784 namespace. 14.6.1.3 of the standard and the discussion on
7785 comp.lang.fortran. */
7786 if (sym->ns != sym->ts.derived->ns
7787 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
7790 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
7791 if (s && s->attr.flavor != FL_DERIVED)
7793 gfc_error ("The type '%s' cannot be host associated at %L "
7794 "because it is blocked by an incompatible object "
7795 "of the same name declared at %L",
7796 sym->ts.derived->name, &sym->declared_at,
7802 /* 4th constraint in section 11.3: "If an object of a type for which
7803 component-initialization is specified (R429) appears in the
7804 specification-part of a module and does not have the ALLOCATABLE
7805 or POINTER attribute, the object shall have the SAVE attribute."
7807 The check for initializers is performed with
7808 has_default_initializer because gfc_default_initializer generates
7809 a hidden default for allocatable components. */
7810 if (!(sym->value || no_init_flag) && sym->ns->proc_name
7811 && sym->ns->proc_name->attr.flavor == FL_MODULE
7812 && !sym->ns->save_all && !sym->attr.save
7813 && !sym->attr.pointer && !sym->attr.allocatable
7814 && has_default_initializer (sym->ts.derived))
7816 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7817 "default initialization of a component",
7818 sym->name, &sym->declared_at);
7822 /* Assign default initializer. */
7823 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
7824 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
7826 sym->value = gfc_default_initializer (&sym->ts);
7833 /* Resolve symbols with flavor variable. */
7836 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
7838 int no_init_flag, automatic_flag;
7840 const char *auto_save_msg;
7842 auto_save_msg = "Automatic object '%s' at %L cannot have the "
7845 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7848 /* Set this flag to check that variables are parameters of all entries.
7849 This check is effected by the call to gfc_resolve_expr through
7850 is_non_constant_shape_array. */
7851 specification_expr = 1;
7853 if (sym->ns->proc_name
7854 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7855 || sym->ns->proc_name->attr.is_main_program)
7856 && !sym->attr.use_assoc
7857 && !sym->attr.allocatable
7858 && !sym->attr.pointer
7859 && is_non_constant_shape_array (sym))
7861 /* The shape of a main program or module array needs to be
7863 gfc_error ("The module or main program array '%s' at %L must "
7864 "have constant shape", sym->name, &sym->declared_at);
7865 specification_expr = 0;
7869 if (sym->ts.type == BT_CHARACTER)
7871 /* Make sure that character string variables with assumed length are
7873 e = sym->ts.cl->length;
7874 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
7876 gfc_error ("Entity with assumed character length at %L must be a "
7877 "dummy argument or a PARAMETER", &sym->declared_at);
7881 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7883 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7887 if (!gfc_is_constant_expr (e)
7888 && !(e->expr_type == EXPR_VARIABLE
7889 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7890 && sym->ns->proc_name
7891 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7892 || sym->ns->proc_name->attr.is_main_program)
7893 && !sym->attr.use_assoc)
7895 gfc_error ("'%s' at %L must have constant character length "
7896 "in this context", sym->name, &sym->declared_at);
7901 if (sym->value == NULL && sym->attr.referenced)
7902 apply_default_init_local (sym); /* Try to apply a default initialization. */
7904 /* Determine if the symbol may not have an initializer. */
7905 no_init_flag = automatic_flag = 0;
7906 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7907 || sym->attr.intrinsic || sym->attr.result)
7909 else if (sym->attr.dimension && !sym->attr.pointer
7910 && is_non_constant_shape_array (sym))
7912 no_init_flag = automatic_flag = 1;
7914 /* Also, they must not have the SAVE attribute.
7915 SAVE_IMPLICIT is checked below. */
7916 if (sym->attr.save == SAVE_EXPLICIT)
7918 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7923 /* Ensure that any initializer is simplified. */
7925 gfc_simplify_expr (sym->value, 1);
7927 /* Reject illegal initializers. */
7928 if (!sym->mark && sym->value)
7930 if (sym->attr.allocatable)
7931 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7932 sym->name, &sym->declared_at);
7933 else if (sym->attr.external)
7934 gfc_error ("External '%s' at %L cannot have an initializer",
7935 sym->name, &sym->declared_at);
7936 else if (sym->attr.dummy
7937 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7938 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7939 sym->name, &sym->declared_at);
7940 else if (sym->attr.intrinsic)
7941 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7942 sym->name, &sym->declared_at);
7943 else if (sym->attr.result)
7944 gfc_error ("Function result '%s' at %L cannot have an initializer",
7945 sym->name, &sym->declared_at);
7946 else if (automatic_flag)
7947 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7948 sym->name, &sym->declared_at);
7955 if (sym->ts.type == BT_DERIVED)
7956 return resolve_fl_variable_derived (sym, no_init_flag);
7962 /* Resolve a procedure. */
7965 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7967 gfc_formal_arglist *arg;
7969 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7970 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7971 "interfaces", sym->name, &sym->declared_at);
7973 if (sym->attr.function
7974 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7977 if (sym->ts.type == BT_CHARACTER)
7979 gfc_charlen *cl = sym->ts.cl;
7981 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7982 && resolve_charlen (cl) == FAILURE)
7985 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7987 if (sym->attr.proc == PROC_ST_FUNCTION)
7989 gfc_error ("Character-valued statement function '%s' at %L must "
7990 "have constant length", sym->name, &sym->declared_at);
7994 if (sym->attr.external && sym->formal == NULL
7995 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7997 gfc_error ("Automatic character length function '%s' at %L must "
7998 "have an explicit interface", sym->name,
8005 /* Ensure that derived type for are not of a private type. Internal
8006 module procedures are excluded by 2.2.3.3 - i.e., they are not
8007 externally accessible and can access all the objects accessible in
8009 if (!(sym->ns->parent
8010 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
8011 && gfc_check_access(sym->attr.access, sym->ns->default_access))
8013 gfc_interface *iface;
8015 for (arg = sym->formal; arg; arg = arg->next)
8018 && arg->sym->ts.type == BT_DERIVED
8019 && !arg->sym->ts.derived->attr.use_assoc
8020 && !gfc_check_access (arg->sym->ts.derived->attr.access,
8021 arg->sym->ts.derived->ns->default_access)
8022 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
8023 "PRIVATE type and cannot be a dummy argument"
8024 " of '%s', which is PUBLIC at %L",
8025 arg->sym->name, sym->name, &sym->declared_at)
8028 /* Stop this message from recurring. */
8029 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
8034 /* PUBLIC interfaces may expose PRIVATE procedures that take types
8035 PRIVATE to the containing module. */
8036 for (iface = sym->generic; iface; iface = iface->next)
8038 for (arg = iface->sym->formal; arg; arg = arg->next)
8041 && arg->sym->ts.type == BT_DERIVED
8042 && !arg->sym->ts.derived->attr.use_assoc
8043 && !gfc_check_access (arg->sym->ts.derived->attr.access,
8044 arg->sym->ts.derived->ns->default_access)
8045 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
8046 "'%s' in PUBLIC interface '%s' at %L "
8047 "takes dummy arguments of '%s' which is "
8048 "PRIVATE", iface->sym->name, sym->name,
8049 &iface->sym->declared_at,
8050 gfc_typename (&arg->sym->ts)) == FAILURE)
8052 /* Stop this message from recurring. */
8053 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
8059 /* PUBLIC interfaces may expose PRIVATE procedures that take types
8060 PRIVATE to the containing module. */
8061 for (iface = sym->generic; iface; iface = iface->next)
8063 for (arg = iface->sym->formal; arg; arg = arg->next)
8066 && arg->sym->ts.type == BT_DERIVED
8067 && !arg->sym->ts.derived->attr.use_assoc
8068 && !gfc_check_access (arg->sym->ts.derived->attr.access,
8069 arg->sym->ts.derived->ns->default_access)
8070 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
8071 "'%s' in PUBLIC interface '%s' at %L "
8072 "takes dummy arguments of '%s' which is "
8073 "PRIVATE", iface->sym->name, sym->name,
8074 &iface->sym->declared_at,
8075 gfc_typename (&arg->sym->ts)) == FAILURE)
8077 /* Stop this message from recurring. */
8078 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
8085 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
8086 && !sym->attr.proc_pointer)
8088 gfc_error ("Function '%s' at %L cannot have an initializer",
8089 sym->name, &sym->declared_at);
8093 /* An external symbol may not have an initializer because it is taken to be
8094 a procedure. Exception: Procedure Pointers. */
8095 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
8097 gfc_error ("External object '%s' at %L may not have an initializer",
8098 sym->name, &sym->declared_at);
8102 /* An elemental function is required to return a scalar 12.7.1 */
8103 if (sym->attr.elemental && sym->attr.function && sym->as)
8105 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
8106 "result", sym->name, &sym->declared_at);
8107 /* Reset so that the error only occurs once. */
8108 sym->attr.elemental = 0;
8112 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
8113 char-len-param shall not be array-valued, pointer-valued, recursive
8114 or pure. ....snip... A character value of * may only be used in the
8115 following ways: (i) Dummy arg of procedure - dummy associates with
8116 actual length; (ii) To declare a named constant; or (iii) External
8117 function - but length must be declared in calling scoping unit. */
8118 if (sym->attr.function
8119 && sym->ts.type == BT_CHARACTER
8120 && sym->ts.cl && sym->ts.cl->length == NULL)
8122 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
8123 || (sym->attr.recursive) || (sym->attr.pure))
8125 if (sym->as && sym->as->rank)
8126 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
8127 "array-valued", sym->name, &sym->declared_at);
8129 if (sym->attr.pointer)
8130 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
8131 "pointer-valued", sym->name, &sym->declared_at);
8134 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
8135 "pure", sym->name, &sym->declared_at);
8137 if (sym->attr.recursive)
8138 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
8139 "recursive", sym->name, &sym->declared_at);
8144 /* Appendix B.2 of the standard. Contained functions give an
8145 error anyway. Fixed-form is likely to be F77/legacy. */
8146 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
8147 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
8148 "'%s' at %L is obsolescent in fortran 95",
8149 sym->name, &sym->declared_at);
8152 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
8154 gfc_formal_arglist *curr_arg;
8155 int has_non_interop_arg = 0;
8157 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
8158 sym->common_block) == FAILURE)
8160 /* Clear these to prevent looking at them again if there was an
8162 sym->attr.is_bind_c = 0;
8163 sym->attr.is_c_interop = 0;
8164 sym->ts.is_c_interop = 0;
8168 /* So far, no errors have been found. */
8169 sym->attr.is_c_interop = 1;
8170 sym->ts.is_c_interop = 1;
8173 curr_arg = sym->formal;
8174 while (curr_arg != NULL)
8176 /* Skip implicitly typed dummy args here. */
8177 if (curr_arg->sym->attr.implicit_type == 0)
8178 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
8179 /* If something is found to fail, record the fact so we
8180 can mark the symbol for the procedure as not being
8181 BIND(C) to try and prevent multiple errors being
8183 has_non_interop_arg = 1;
8185 curr_arg = curr_arg->next;
8188 /* See if any of the arguments were not interoperable and if so, clear
8189 the procedure symbol to prevent duplicate error messages. */
8190 if (has_non_interop_arg != 0)
8192 sym->attr.is_c_interop = 0;
8193 sym->ts.is_c_interop = 0;
8194 sym->attr.is_bind_c = 0;
8198 if (!sym->attr.proc_pointer)
8200 if (sym->attr.save == SAVE_EXPLICIT)
8202 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
8203 "in '%s' at %L", sym->name, &sym->declared_at);
8206 if (sym->attr.intent)
8208 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
8209 "in '%s' at %L", sym->name, &sym->declared_at);
8212 if (sym->attr.subroutine && sym->attr.result)
8214 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
8215 "in '%s' at %L", sym->name, &sym->declared_at);
8218 if (sym->attr.external && sym->attr.function
8219 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
8220 || sym->attr.contained))
8222 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
8223 "in '%s' at %L", sym->name, &sym->declared_at);
8226 if (strcmp ("ppr@", sym->name) == 0)
8228 gfc_error ("Procedure pointer result '%s' at %L "
8229 "is missing the pointer attribute",
8230 sym->ns->proc_name->name, &sym->declared_at);
8239 /* Resolve a list of finalizer procedures. That is, after they have hopefully
8240 been defined and we now know their defined arguments, check that they fulfill
8241 the requirements of the standard for procedures used as finalizers. */
8244 gfc_resolve_finalizers (gfc_symbol* derived)
8246 gfc_finalizer* list;
8247 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
8248 gfc_try result = SUCCESS;
8249 bool seen_scalar = false;
8251 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
8254 /* Walk over the list of finalizer-procedures, check them, and if any one
8255 does not fit in with the standard's definition, print an error and remove
8256 it from the list. */
8257 prev_link = &derived->f2k_derived->finalizers;
8258 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
8264 /* Skip this finalizer if we already resolved it. */
8265 if (list->proc_tree)
8267 prev_link = &(list->next);
8271 /* Check this exists and is a SUBROUTINE. */
8272 if (!list->proc_sym->attr.subroutine)
8274 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
8275 list->proc_sym->name, &list->where);
8279 /* We should have exactly one argument. */
8280 if (!list->proc_sym->formal || list->proc_sym->formal->next)
8282 gfc_error ("FINAL procedure at %L must have exactly one argument",
8286 arg = list->proc_sym->formal->sym;
8288 /* This argument must be of our type. */
8289 if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
8291 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
8292 &arg->declared_at, derived->name);
8296 /* It must neither be a pointer nor allocatable nor optional. */
8297 if (arg->attr.pointer)
8299 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
8303 if (arg->attr.allocatable)
8305 gfc_error ("Argument of FINAL procedure at %L must not be"
8306 " ALLOCATABLE", &arg->declared_at);
8309 if (arg->attr.optional)
8311 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
8316 /* It must not be INTENT(OUT). */
8317 if (arg->attr.intent == INTENT_OUT)
8319 gfc_error ("Argument of FINAL procedure at %L must not be"
8320 " INTENT(OUT)", &arg->declared_at);
8324 /* Warn if the procedure is non-scalar and not assumed shape. */
8325 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
8326 && arg->as->type != AS_ASSUMED_SHAPE)
8327 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
8328 " shape argument", &arg->declared_at);
8330 /* Check that it does not match in kind and rank with a FINAL procedure
8331 defined earlier. To really loop over the *earlier* declarations,
8332 we need to walk the tail of the list as new ones were pushed at the
8334 /* TODO: Handle kind parameters once they are implemented. */
8335 my_rank = (arg->as ? arg->as->rank : 0);
8336 for (i = list->next; i; i = i->next)
8338 /* Argument list might be empty; that is an error signalled earlier,
8339 but we nevertheless continued resolving. */
8340 if (i->proc_sym->formal)
8342 gfc_symbol* i_arg = i->proc_sym->formal->sym;
8343 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
8344 if (i_rank == my_rank)
8346 gfc_error ("FINAL procedure '%s' declared at %L has the same"
8347 " rank (%d) as '%s'",
8348 list->proc_sym->name, &list->where, my_rank,
8355 /* Is this the/a scalar finalizer procedure? */
8356 if (!arg->as || arg->as->rank == 0)
8359 /* Find the symtree for this procedure. */
8360 gcc_assert (!list->proc_tree);
8361 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
8363 prev_link = &list->next;
8366 /* Remove wrong nodes immediately from the list so we don't risk any
8367 troubles in the future when they might fail later expectations. */
8371 *prev_link = list->next;
8372 gfc_free_finalizer (i);
8375 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
8376 were nodes in the list, must have been for arrays. It is surely a good
8377 idea to have a scalar version there if there's something to finalize. */
8378 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
8379 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
8380 " defined at %L, suggest also scalar one",
8381 derived->name, &derived->declared_at);
8383 /* TODO: Remove this error when finalization is finished. */
8384 gfc_error ("Finalization at %L is not yet implemented",
8385 &derived->declared_at);
8391 /* Check that it is ok for the typebound procedure proc to override the
8395 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
8398 const gfc_symbol* proc_target;
8399 const gfc_symbol* old_target;
8400 unsigned proc_pass_arg, old_pass_arg, argpos;
8401 gfc_formal_arglist* proc_formal;
8402 gfc_formal_arglist* old_formal;
8404 /* This procedure should only be called for non-GENERIC proc. */
8405 gcc_assert (!proc->n.tb->is_generic);
8407 /* If the overwritten procedure is GENERIC, this is an error. */
8408 if (old->n.tb->is_generic)
8410 gfc_error ("Can't overwrite GENERIC '%s' at %L",
8411 old->name, &proc->n.tb->where);
8415 where = proc->n.tb->where;
8416 proc_target = proc->n.tb->u.specific->n.sym;
8417 old_target = old->n.tb->u.specific->n.sym;
8419 /* Check that overridden binding is not NON_OVERRIDABLE. */
8420 if (old->n.tb->non_overridable)
8422 gfc_error ("'%s' at %L overrides a procedure binding declared"
8423 " NON_OVERRIDABLE", proc->name, &where);
8427 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
8428 if (!old->n.tb->deferred && proc->n.tb->deferred)
8430 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
8431 " non-DEFERRED binding", proc->name, &where);
8435 /* If the overridden binding is PURE, the overriding must be, too. */
8436 if (old_target->attr.pure && !proc_target->attr.pure)
8438 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
8439 proc->name, &where);
8443 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
8444 is not, the overriding must not be either. */
8445 if (old_target->attr.elemental && !proc_target->attr.elemental)
8447 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
8448 " ELEMENTAL", proc->name, &where);
8451 if (!old_target->attr.elemental && proc_target->attr.elemental)
8453 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
8454 " be ELEMENTAL, either", proc->name, &where);
8458 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
8460 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
8462 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
8463 " SUBROUTINE", proc->name, &where);
8467 /* If the overridden binding is a FUNCTION, the overriding must also be a
8468 FUNCTION and have the same characteristics. */
8469 if (old_target->attr.function)
8471 if (!proc_target->attr.function)
8473 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
8474 " FUNCTION", proc->name, &where);
8478 /* FIXME: Do more comprehensive checking (including, for instance, the
8479 rank and array-shape). */
8480 gcc_assert (proc_target->result && old_target->result);
8481 if (!gfc_compare_types (&proc_target->result->ts,
8482 &old_target->result->ts))
8484 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
8485 " matching result types", proc->name, &where);
8490 /* If the overridden binding is PUBLIC, the overriding one must not be
8492 if (old->n.tb->access == ACCESS_PUBLIC
8493 && proc->n.tb->access == ACCESS_PRIVATE)
8495 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
8496 " PRIVATE", proc->name, &where);
8500 /* Compare the formal argument lists of both procedures. This is also abused
8501 to find the position of the passed-object dummy arguments of both
8502 bindings as at least the overridden one might not yet be resolved and we
8503 need those positions in the check below. */
8504 proc_pass_arg = old_pass_arg = 0;
8505 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
8507 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
8510 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
8511 proc_formal && old_formal;
8512 proc_formal = proc_formal->next, old_formal = old_formal->next)
8514 if (proc->n.tb->pass_arg
8515 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
8516 proc_pass_arg = argpos;
8517 if (old->n.tb->pass_arg
8518 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
8519 old_pass_arg = argpos;
8521 /* Check that the names correspond. */
8522 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
8524 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8525 " to match the corresponding argument of the overridden"
8526 " procedure", proc_formal->sym->name, proc->name, &where,
8527 old_formal->sym->name);
8531 /* Check that the types correspond if neither is the passed-object
8533 /* FIXME: Do more comprehensive testing here. */
8534 if (proc_pass_arg != argpos && old_pass_arg != argpos
8535 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
8537 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8538 " in respect to the overridden procedure",
8539 proc_formal->sym->name, proc->name, &where);
8545 if (proc_formal || old_formal)
8547 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8548 " the overridden procedure", proc->name, &where);
8552 /* If the overridden binding is NOPASS, the overriding one must also be
8554 if (old->n.tb->nopass && !proc->n.tb->nopass)
8556 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8557 " NOPASS", proc->name, &where);
8561 /* If the overridden binding is PASS(x), the overriding one must also be
8562 PASS and the passed-object dummy arguments must correspond. */
8563 if (!old->n.tb->nopass)
8565 if (proc->n.tb->nopass)
8567 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8568 " PASS", proc->name, &where);
8572 if (proc_pass_arg != old_pass_arg)
8574 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8575 " the same position as the passed-object dummy argument of"
8576 " the overridden procedure", proc->name, &where);
8585 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8588 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
8589 const char* generic_name, locus where)
8594 gcc_assert (t1->specific && t2->specific);
8595 gcc_assert (!t1->specific->is_generic);
8596 gcc_assert (!t2->specific->is_generic);
8598 sym1 = t1->specific->u.specific->n.sym;
8599 sym2 = t2->specific->u.specific->n.sym;
8601 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8602 if (sym1->attr.subroutine != sym2->attr.subroutine
8603 || sym1->attr.function != sym2->attr.function)
8605 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8606 " GENERIC '%s' at %L",
8607 sym1->name, sym2->name, generic_name, &where);
8611 /* Compare the interfaces. */
8612 if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0))
8614 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8615 sym1->name, sym2->name, generic_name, &where);
8623 /* Resolve a GENERIC procedure binding for a derived type. */
8626 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
8628 gfc_tbp_generic* target;
8629 gfc_symtree* first_target;
8630 gfc_symbol* super_type;
8631 gfc_symtree* inherited;
8634 gcc_assert (st->n.tb);
8635 gcc_assert (st->n.tb->is_generic);
8637 where = st->n.tb->where;
8638 super_type = gfc_get_derived_super_type (derived);
8640 /* Find the overridden binding if any. */
8641 st->n.tb->overridden = NULL;
8644 gfc_symtree* overridden;
8645 overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
8647 if (overridden && overridden->n.tb)
8648 st->n.tb->overridden = overridden->n.tb;
8651 /* Try to find the specific bindings for the symtrees in our target-list. */
8652 gcc_assert (st->n.tb->u.generic);
8653 for (target = st->n.tb->u.generic; target; target = target->next)
8654 if (!target->specific)
8656 gfc_typebound_proc* overridden_tbp;
8658 const char* target_name;
8660 target_name = target->specific_st->name;
8662 /* Defined for this type directly. */
8663 if (target->specific_st->n.tb)
8665 target->specific = target->specific_st->n.tb;
8666 goto specific_found;
8669 /* Look for an inherited specific binding. */
8672 inherited = gfc_find_typebound_proc (super_type, NULL,
8677 gcc_assert (inherited->n.tb);
8678 target->specific = inherited->n.tb;
8679 goto specific_found;
8683 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8684 " at %L", target_name, st->name, &where);
8687 /* Once we've found the specific binding, check it is not ambiguous with
8688 other specifics already found or inherited for the same GENERIC. */
8690 gcc_assert (target->specific);
8692 /* This must really be a specific binding! */
8693 if (target->specific->is_generic)
8695 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8696 " '%s' is GENERIC, too", st->name, &where, target_name);
8700 /* Check those already resolved on this type directly. */
8701 for (g = st->n.tb->u.generic; g; g = g->next)
8702 if (g != target && g->specific
8703 && check_generic_tbp_ambiguity (target, g, st->name, where)
8707 /* Check for ambiguity with inherited specific targets. */
8708 for (overridden_tbp = st->n.tb->overridden; overridden_tbp;
8709 overridden_tbp = overridden_tbp->overridden)
8710 if (overridden_tbp->is_generic)
8712 for (g = overridden_tbp->u.generic; g; g = g->next)
8714 gcc_assert (g->specific);
8715 if (check_generic_tbp_ambiguity (target, g,
8716 st->name, where) == FAILURE)
8722 /* If we attempt to "overwrite" a specific binding, this is an error. */
8723 if (st->n.tb->overridden && !st->n.tb->overridden->is_generic)
8725 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8726 " the same name", st->name, &where);
8730 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8731 all must have the same attributes here. */
8732 first_target = st->n.tb->u.generic->specific->u.specific;
8733 gcc_assert (first_target);
8734 st->n.tb->subroutine = first_target->n.sym->attr.subroutine;
8735 st->n.tb->function = first_target->n.sym->attr.function;
8741 /* Resolve the type-bound procedures for a derived type. */
8743 static gfc_symbol* resolve_bindings_derived;
8744 static gfc_try resolve_bindings_result;
8747 resolve_typebound_procedure (gfc_symtree* stree)
8752 gfc_symbol* super_type;
8753 gfc_component* comp;
8757 /* Undefined specific symbol from GENERIC target definition. */
8761 if (stree->n.tb->error)
8764 /* If this is a GENERIC binding, use that routine. */
8765 if (stree->n.tb->is_generic)
8767 if (resolve_typebound_generic (resolve_bindings_derived, stree)
8773 /* Get the target-procedure to check it. */
8774 gcc_assert (!stree->n.tb->is_generic);
8775 gcc_assert (stree->n.tb->u.specific);
8776 proc = stree->n.tb->u.specific->n.sym;
8777 where = stree->n.tb->where;
8779 /* Default access should already be resolved from the parser. */
8780 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
8782 /* It should be a module procedure or an external procedure with explicit
8783 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
8784 if ((!proc->attr.subroutine && !proc->attr.function)
8785 || (proc->attr.proc != PROC_MODULE
8786 && proc->attr.if_source != IFSRC_IFBODY)
8787 || (proc->attr.abstract && !stree->n.tb->deferred))
8789 gfc_error ("'%s' must be a module procedure or an external procedure with"
8790 " an explicit interface at %L", proc->name, &where);
8793 stree->n.tb->subroutine = proc->attr.subroutine;
8794 stree->n.tb->function = proc->attr.function;
8796 /* Find the super-type of the current derived type. We could do this once and
8797 store in a global if speed is needed, but as long as not I believe this is
8798 more readable and clearer. */
8799 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
8801 /* If PASS, resolve and check arguments if not already resolved / loaded
8802 from a .mod file. */
8803 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
8805 if (stree->n.tb->pass_arg)
8807 gfc_formal_arglist* i;
8809 /* If an explicit passing argument name is given, walk the arg-list
8813 stree->n.tb->pass_arg_num = 1;
8814 for (i = proc->formal; i; i = i->next)
8816 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
8821 ++stree->n.tb->pass_arg_num;
8826 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8828 proc->name, stree->n.tb->pass_arg, &where,
8829 stree->n.tb->pass_arg);
8835 /* Otherwise, take the first one; there should in fact be at least
8837 stree->n.tb->pass_arg_num = 1;
8840 gfc_error ("Procedure '%s' with PASS at %L must have at"
8841 " least one argument", proc->name, &where);
8844 me_arg = proc->formal->sym;
8847 /* Now check that the argument-type matches. */
8848 gcc_assert (me_arg);
8849 if (me_arg->ts.type != BT_DERIVED
8850 || me_arg->ts.derived != resolve_bindings_derived)
8852 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8853 " the derived-type '%s'", me_arg->name, proc->name,
8854 me_arg->name, &where, resolve_bindings_derived->name);
8858 gfc_warning ("Polymorphic entities are not yet implemented,"
8859 " non-polymorphic passed-object dummy argument of '%s'"
8860 " at %L accepted", proc->name, &where);
8863 /* If we are extending some type, check that we don't override a procedure
8864 flagged NON_OVERRIDABLE. */
8865 stree->n.tb->overridden = NULL;
8868 gfc_symtree* overridden;
8869 overridden = gfc_find_typebound_proc (super_type, NULL,
8872 if (overridden && overridden->n.tb)
8873 stree->n.tb->overridden = overridden->n.tb;
8875 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
8879 /* See if there's a name collision with a component directly in this type. */
8880 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
8881 if (!strcmp (comp->name, stree->name))
8883 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8885 stree->name, &where, resolve_bindings_derived->name);
8889 /* Try to find a name collision with an inherited component. */
8890 if (super_type && gfc_find_component (super_type, stree->name, true, true))
8892 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8893 " component of '%s'",
8894 stree->name, &where, resolve_bindings_derived->name);
8898 stree->n.tb->error = 0;
8902 resolve_bindings_result = FAILURE;
8903 stree->n.tb->error = 1;
8907 resolve_typebound_procedures (gfc_symbol* derived)
8909 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
8912 resolve_bindings_derived = derived;
8913 resolve_bindings_result = SUCCESS;
8914 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
8915 &resolve_typebound_procedure);
8917 return resolve_bindings_result;
8921 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8922 to give all identical derived types the same backend_decl. */
8924 add_dt_to_dt_list (gfc_symbol *derived)
8926 gfc_dt_list *dt_list;
8928 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
8929 if (derived == dt_list->derived)
8932 if (dt_list == NULL)
8934 dt_list = gfc_get_dt_list ();
8935 dt_list->next = gfc_derived_types;
8936 dt_list->derived = derived;
8937 gfc_derived_types = dt_list;
8942 /* Ensure that a derived-type is really not abstract, meaning that every
8943 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
8946 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
8951 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
8953 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
8956 if (st->n.tb && st->n.tb->deferred)
8958 gfc_symtree* overriding;
8959 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true);
8960 gcc_assert (overriding && overriding->n.tb);
8961 if (overriding->n.tb->deferred)
8963 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
8964 " '%s' is DEFERRED and not overridden",
8965 sub->name, &sub->declared_at, st->name);
8974 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
8976 /* The algorithm used here is to recursively travel up the ancestry of sub
8977 and for each ancestor-type, check all bindings. If any of them is
8978 DEFERRED, look it up starting from sub and see if the found (overriding)
8979 binding is not DEFERRED.
8980 This is not the most efficient way to do this, but it should be ok and is
8981 clearer than something sophisticated. */
8983 gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
8985 /* Walk bindings of this ancestor. */
8986 if (ancestor->f2k_derived)
8989 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
8994 /* Find next ancestor type and recurse on it. */
8995 ancestor = gfc_get_derived_super_type (ancestor);
8997 return ensure_not_abstract (sub, ancestor);
9003 static void resolve_symbol (gfc_symbol *sym);
9006 /* Resolve the components of a derived type. */
9009 resolve_fl_derived (gfc_symbol *sym)
9011 gfc_symbol* super_type;
9015 super_type = gfc_get_derived_super_type (sym);
9017 /* Ensure the extended type gets resolved before we do. */
9018 if (super_type && resolve_fl_derived (super_type) == FAILURE)
9021 /* An ABSTRACT type must be extensible. */
9022 if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
9024 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
9025 sym->name, &sym->declared_at);
9029 for (c = sym->components; c != NULL; c = c->next)
9031 if (c->attr.proc_pointer && c->ts.interface)
9033 if (c->ts.interface->attr.procedure)
9034 gfc_error ("Interface '%s', used by procedure pointer component "
9035 "'%s' at %L, is declared in a later PROCEDURE statement",
9036 c->ts.interface->name, c->name, &c->loc);
9038 /* Get the attributes from the interface (now resolved). */
9039 if (c->ts.interface->attr.if_source
9040 || c->ts.interface->attr.intrinsic)
9042 gfc_symbol *ifc = c->ts.interface;
9044 if (ifc->formal && !ifc->formal_ns)
9045 resolve_symbol (ifc);
9047 if (ifc->attr.intrinsic)
9048 resolve_intrinsic (ifc, &ifc->declared_at);
9052 c->ts = ifc->result->ts;
9053 c->attr.allocatable = ifc->result->attr.allocatable;
9054 c->attr.pointer = ifc->result->attr.pointer;
9055 c->attr.dimension = ifc->result->attr.dimension;
9056 c->as = gfc_copy_array_spec (ifc->result->as);
9061 c->attr.allocatable = ifc->attr.allocatable;
9062 c->attr.pointer = ifc->attr.pointer;
9063 c->attr.dimension = ifc->attr.dimension;
9064 c->as = gfc_copy_array_spec (ifc->as);
9066 c->ts.interface = ifc;
9067 c->attr.function = ifc->attr.function;
9068 c->attr.subroutine = ifc->attr.subroutine;
9069 gfc_copy_formal_args_ppc (c, ifc);
9071 c->attr.pure = ifc->attr.pure;
9072 c->attr.elemental = ifc->attr.elemental;
9073 c->attr.recursive = ifc->attr.recursive;
9074 c->attr.always_explicit = ifc->attr.always_explicit;
9075 /* Replace symbols in array spec. */
9079 for (i = 0; i < c->as->rank; i++)
9081 gfc_expr_replace_comp (c->as->lower[i], c);
9082 gfc_expr_replace_comp (c->as->upper[i], c);
9085 /* Copy char length. */
9088 c->ts.cl = gfc_get_charlen();
9089 c->ts.cl->resolved = ifc->ts.cl->resolved;
9090 c->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
9091 /* TODO: gfc_expr_replace_symbols (c->ts.cl->length, c);*/
9092 /* Add charlen to namespace. */
9095 c->ts.cl->next = c->formal_ns->cl_list;
9096 c->formal_ns->cl_list = c->ts.cl;
9100 else if (c->ts.interface->name[0] != '\0')
9102 gfc_error ("Interface '%s' of procedure pointer component "
9103 "'%s' at %L must be explicit", c->ts.interface->name,
9108 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
9110 c->ts = *gfc_get_default_type (c->name, NULL);
9111 c->attr.implicit_type = 1;
9114 /* Check type-spec if this is not the parent-type component. */
9115 if ((!sym->attr.extension || c != sym->components)
9116 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
9119 /* If this type is an extension, see if this component has the same name
9120 as an inherited type-bound procedure. */
9122 && gfc_find_typebound_proc (super_type, NULL, c->name, true))
9124 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
9125 " inherited type-bound procedure",
9126 c->name, sym->name, &c->loc);
9130 if (c->ts.type == BT_CHARACTER)
9132 if (c->ts.cl->length == NULL
9133 || (resolve_charlen (c->ts.cl) == FAILURE)
9134 || !gfc_is_constant_expr (c->ts.cl->length))
9136 gfc_error ("Character length of component '%s' needs to "
9137 "be a constant specification expression at %L",
9139 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
9144 if (c->ts.type == BT_DERIVED
9145 && sym->component_access != ACCESS_PRIVATE
9146 && gfc_check_access (sym->attr.access, sym->ns->default_access)
9147 && !is_sym_host_assoc (c->ts.derived, sym->ns)
9148 && !c->ts.derived->attr.use_assoc
9149 && !gfc_check_access (c->ts.derived->attr.access,
9150 c->ts.derived->ns->default_access)
9151 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
9152 "is a PRIVATE type and cannot be a component of "
9153 "'%s', which is PUBLIC at %L", c->name,
9154 sym->name, &sym->declared_at) == FAILURE)
9157 if (sym->attr.sequence)
9159 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
9161 gfc_error ("Component %s of SEQUENCE type declared at %L does "
9162 "not have the SEQUENCE attribute",
9163 c->ts.derived->name, &sym->declared_at);
9168 if (c->ts.type == BT_DERIVED && c->attr.pointer
9169 && c->ts.derived->components == NULL
9170 && !c->ts.derived->attr.zero_comp)
9172 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
9173 "that has not been declared", c->name, sym->name,
9178 /* Ensure that all the derived type components are put on the
9179 derived type list; even in formal namespaces, where derived type
9180 pointer components might not have been declared. */
9181 if (c->ts.type == BT_DERIVED
9183 && c->ts.derived->components
9185 && sym != c->ts.derived)
9186 add_dt_to_dt_list (c->ts.derived);
9188 if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
9192 for (i = 0; i < c->as->rank; i++)
9194 if (c->as->lower[i] == NULL
9195 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
9196 || !gfc_is_constant_expr (c->as->lower[i])
9197 || c->as->upper[i] == NULL
9198 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
9199 || !gfc_is_constant_expr (c->as->upper[i]))
9201 gfc_error ("Component '%s' of '%s' at %L must have "
9202 "constant array bounds",
9203 c->name, sym->name, &c->loc);
9209 /* Resolve the type-bound procedures. */
9210 if (resolve_typebound_procedures (sym) == FAILURE)
9213 /* Resolve the finalizer procedures. */
9214 if (gfc_resolve_finalizers (sym) == FAILURE)
9217 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
9218 all DEFERRED bindings are overridden. */
9219 if (super_type && super_type->attr.abstract && !sym->attr.abstract
9220 && ensure_not_abstract (sym, super_type) == FAILURE)
9223 /* Add derived type to the derived type list. */
9224 add_dt_to_dt_list (sym);
9231 resolve_fl_namelist (gfc_symbol *sym)
9236 /* Reject PRIVATE objects in a PUBLIC namelist. */
9237 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
9239 for (nl = sym->namelist; nl; nl = nl->next)
9241 if (!nl->sym->attr.use_assoc
9242 && !is_sym_host_assoc (nl->sym, sym->ns)
9243 && !gfc_check_access(nl->sym->attr.access,
9244 nl->sym->ns->default_access))
9246 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
9247 "cannot be member of PUBLIC namelist '%s' at %L",
9248 nl->sym->name, sym->name, &sym->declared_at);
9252 /* Types with private components that came here by USE-association. */
9253 if (nl->sym->ts.type == BT_DERIVED
9254 && derived_inaccessible (nl->sym->ts.derived))
9256 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
9257 "components and cannot be member of namelist '%s' at %L",
9258 nl->sym->name, sym->name, &sym->declared_at);
9262 /* Types with private components that are defined in the same module. */
9263 if (nl->sym->ts.type == BT_DERIVED
9264 && !is_sym_host_assoc (nl->sym->ts.derived, sym->ns)
9265 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
9266 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
9267 nl->sym->ns->default_access))
9269 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
9270 "cannot be a member of PUBLIC namelist '%s' at %L",
9271 nl->sym->name, sym->name, &sym->declared_at);
9277 for (nl = sym->namelist; nl; nl = nl->next)
9279 /* Reject namelist arrays of assumed shape. */
9280 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
9281 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
9282 "must not have assumed shape in namelist "
9283 "'%s' at %L", nl->sym->name, sym->name,
9284 &sym->declared_at) == FAILURE)
9287 /* Reject namelist arrays that are not constant shape. */
9288 if (is_non_constant_shape_array (nl->sym))
9290 gfc_error ("NAMELIST array object '%s' must have constant "
9291 "shape in namelist '%s' at %L", nl->sym->name,
9292 sym->name, &sym->declared_at);
9296 /* Namelist objects cannot have allocatable or pointer components. */
9297 if (nl->sym->ts.type != BT_DERIVED)
9300 if (nl->sym->ts.derived->attr.alloc_comp)
9302 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
9303 "have ALLOCATABLE components",
9304 nl->sym->name, sym->name, &sym->declared_at);
9308 if (nl->sym->ts.derived->attr.pointer_comp)
9310 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
9311 "have POINTER components",
9312 nl->sym->name, sym->name, &sym->declared_at);
9318 /* 14.1.2 A module or internal procedure represent local entities
9319 of the same type as a namelist member and so are not allowed. */
9320 for (nl = sym->namelist; nl; nl = nl->next)
9322 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
9325 if (nl->sym->attr.function && nl->sym == nl->sym->result)
9326 if ((nl->sym == sym->ns->proc_name)
9328 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
9332 if (nl->sym && nl->sym->name)
9333 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
9334 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
9336 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
9337 "attribute in '%s' at %L", nlsym->name,
9348 resolve_fl_parameter (gfc_symbol *sym)
9350 /* A parameter array's shape needs to be constant. */
9352 && (sym->as->type == AS_DEFERRED
9353 || is_non_constant_shape_array (sym)))
9355 gfc_error ("Parameter array '%s' at %L cannot be automatic "
9356 "or of deferred shape", sym->name, &sym->declared_at);
9360 /* Make sure a parameter that has been implicitly typed still
9361 matches the implicit type, since PARAMETER statements can precede
9362 IMPLICIT statements. */
9363 if (sym->attr.implicit_type
9364 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
9367 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
9368 "later IMPLICIT type", sym->name, &sym->declared_at);
9372 /* Make sure the types of derived parameters are consistent. This
9373 type checking is deferred until resolution because the type may
9374 refer to a derived type from the host. */
9375 if (sym->ts.type == BT_DERIVED
9376 && !gfc_compare_types (&sym->ts, &sym->value->ts))
9378 gfc_error ("Incompatible derived type in PARAMETER at %L",
9379 &sym->value->where);
9386 /* Do anything necessary to resolve a symbol. Right now, we just
9387 assume that an otherwise unknown symbol is a variable. This sort
9388 of thing commonly happens for symbols in module. */
9391 resolve_symbol (gfc_symbol *sym)
9393 int check_constant, mp_flag;
9394 gfc_symtree *symtree;
9395 gfc_symtree *this_symtree;
9399 if (sym->attr.flavor == FL_UNKNOWN)
9402 /* If we find that a flavorless symbol is an interface in one of the
9403 parent namespaces, find its symtree in this namespace, free the
9404 symbol and set the symtree to point to the interface symbol. */
9405 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
9407 symtree = gfc_find_symtree (ns->sym_root, sym->name);
9408 if (symtree && symtree->n.sym->generic)
9410 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
9414 gfc_free_symbol (sym);
9415 symtree->n.sym->refs++;
9416 this_symtree->n.sym = symtree->n.sym;
9421 /* Otherwise give it a flavor according to such attributes as
9423 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
9424 sym->attr.flavor = FL_VARIABLE;
9427 sym->attr.flavor = FL_PROCEDURE;
9428 if (sym->attr.dimension)
9429 sym->attr.function = 1;
9433 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
9434 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
9436 if (sym->attr.procedure && sym->ts.interface
9437 && sym->attr.if_source != IFSRC_DECL)
9439 if (sym->ts.interface == sym)
9441 gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
9442 "interface", sym->name, &sym->declared_at);
9445 if (sym->ts.interface->attr.procedure)
9447 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
9448 " in a later PROCEDURE statement", sym->ts.interface->name,
9449 sym->name,&sym->declared_at);
9453 /* Get the attributes from the interface (now resolved). */
9454 if (sym->ts.interface->attr.if_source
9455 || sym->ts.interface->attr.intrinsic)
9457 gfc_symbol *ifc = sym->ts.interface;
9458 resolve_symbol (ifc);
9460 if (ifc->attr.intrinsic)
9461 resolve_intrinsic (ifc, &ifc->declared_at);
9464 sym->ts = ifc->result->ts;
9467 sym->ts.interface = ifc;
9468 sym->attr.function = ifc->attr.function;
9469 sym->attr.subroutine = ifc->attr.subroutine;
9470 gfc_copy_formal_args (sym, ifc);
9472 sym->attr.allocatable = ifc->attr.allocatable;
9473 sym->attr.pointer = ifc->attr.pointer;
9474 sym->attr.pure = ifc->attr.pure;
9475 sym->attr.elemental = ifc->attr.elemental;
9476 sym->attr.dimension = ifc->attr.dimension;
9477 sym->attr.recursive = ifc->attr.recursive;
9478 sym->attr.always_explicit = ifc->attr.always_explicit;
9479 /* Copy array spec. */
9480 sym->as = gfc_copy_array_spec (ifc->as);
9484 for (i = 0; i < sym->as->rank; i++)
9486 gfc_expr_replace_symbols (sym->as->lower[i], sym);
9487 gfc_expr_replace_symbols (sym->as->upper[i], sym);
9490 /* Copy char length. */
9493 sym->ts.cl = gfc_get_charlen();
9494 sym->ts.cl->resolved = ifc->ts.cl->resolved;
9495 sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
9496 gfc_expr_replace_symbols (sym->ts.cl->length, sym);
9497 /* Add charlen to namespace. */
9500 sym->ts.cl->next = sym->formal_ns->cl_list;
9501 sym->formal_ns->cl_list = sym->ts.cl;
9505 else if (sym->ts.interface->name[0] != '\0')
9507 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
9508 sym->ts.interface->name, sym->name, &sym->declared_at);
9513 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
9516 /* Symbols that are module procedures with results (functions) have
9517 the types and array specification copied for type checking in
9518 procedures that call them, as well as for saving to a module
9519 file. These symbols can't stand the scrutiny that their results
9521 mp_flag = (sym->result != NULL && sym->result != sym);
9524 /* Make sure that the intrinsic is consistent with its internal
9525 representation. This needs to be done before assigning a default
9526 type to avoid spurious warnings. */
9527 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
9529 gfc_intrinsic_sym* isym;
9532 /* We already know this one is an intrinsic, so we don't call
9533 gfc_is_intrinsic for full checking but rather use gfc_find_function and
9534 gfc_find_subroutine directly to check whether it is a function or
9537 if ((isym = gfc_find_function (sym->name)))
9539 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
9540 && !sym->attr.implicit_type)
9541 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
9542 " ignored", sym->name, &sym->declared_at);
9544 else if ((isym = gfc_find_subroutine (sym->name)))
9546 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
9548 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
9549 " specifier", sym->name, &sym->declared_at);
9555 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
9556 sym->name, &sym->declared_at);
9560 /* Check it is actually available in the standard settings. */
9561 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
9564 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
9565 " available in the current standard settings but %s. Use"
9566 " an appropriate -std=* option or enable -fall-intrinsics"
9567 " in order to use it.",
9568 sym->name, &sym->declared_at, symstd);
9573 /* Assign default type to symbols that need one and don't have one. */
9574 if (sym->ts.type == BT_UNKNOWN)
9576 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
9577 gfc_set_default_type (sym, 1, NULL);
9579 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
9580 && !sym->attr.function && !sym->attr.subroutine
9581 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
9582 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
9584 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
9586 /* The specific case of an external procedure should emit an error
9587 in the case that there is no implicit type. */
9589 gfc_set_default_type (sym, sym->attr.external, NULL);
9592 /* Result may be in another namespace. */
9593 resolve_symbol (sym->result);
9595 if (!sym->result->attr.proc_pointer)
9597 sym->ts = sym->result->ts;
9598 sym->as = gfc_copy_array_spec (sym->result->as);
9599 sym->attr.dimension = sym->result->attr.dimension;
9600 sym->attr.pointer = sym->result->attr.pointer;
9601 sym->attr.allocatable = sym->result->attr.allocatable;
9607 /* Assumed size arrays and assumed shape arrays must be dummy
9611 && (sym->as->type == AS_ASSUMED_SIZE
9612 || sym->as->type == AS_ASSUMED_SHAPE)
9613 && sym->attr.dummy == 0)
9615 if (sym->as->type == AS_ASSUMED_SIZE)
9616 gfc_error ("Assumed size array at %L must be a dummy argument",
9619 gfc_error ("Assumed shape array at %L must be a dummy argument",
9624 /* Make sure symbols with known intent or optional are really dummy
9625 variable. Because of ENTRY statement, this has to be deferred
9626 until resolution time. */
9628 if (!sym->attr.dummy
9629 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
9631 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
9635 if (sym->attr.value && !sym->attr.dummy)
9637 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
9638 "it is not a dummy argument", sym->name, &sym->declared_at);
9642 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
9644 gfc_charlen *cl = sym->ts.cl;
9645 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9647 gfc_error ("Character dummy variable '%s' at %L with VALUE "
9648 "attribute must have constant length",
9649 sym->name, &sym->declared_at);
9653 if (sym->ts.is_c_interop
9654 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
9656 gfc_error ("C interoperable character dummy variable '%s' at %L "
9657 "with VALUE attribute must have length one",
9658 sym->name, &sym->declared_at);
9663 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
9664 do this for something that was implicitly typed because that is handled
9665 in gfc_set_default_type. Handle dummy arguments and procedure
9666 definitions separately. Also, anything that is use associated is not
9667 handled here but instead is handled in the module it is declared in.
9668 Finally, derived type definitions are allowed to be BIND(C) since that
9669 only implies that they're interoperable, and they are checked fully for
9670 interoperability when a variable is declared of that type. */
9671 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
9672 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
9673 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
9675 gfc_try t = SUCCESS;
9677 /* First, make sure the variable is declared at the
9678 module-level scope (J3/04-007, Section 15.3). */
9679 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
9680 sym->attr.in_common == 0)
9682 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
9683 "is neither a COMMON block nor declared at the "
9684 "module level scope", sym->name, &(sym->declared_at));
9687 else if (sym->common_head != NULL)
9689 t = verify_com_block_vars_c_interop (sym->common_head);
9693 /* If type() declaration, we need to verify that the components
9694 of the given type are all C interoperable, etc. */
9695 if (sym->ts.type == BT_DERIVED &&
9696 sym->ts.derived->attr.is_c_interop != 1)
9698 /* Make sure the user marked the derived type as BIND(C). If
9699 not, call the verify routine. This could print an error
9700 for the derived type more than once if multiple variables
9701 of that type are declared. */
9702 if (sym->ts.derived->attr.is_bind_c != 1)
9703 verify_bind_c_derived_type (sym->ts.derived);
9707 /* Verify the variable itself as C interoperable if it
9708 is BIND(C). It is not possible for this to succeed if
9709 the verify_bind_c_derived_type failed, so don't have to handle
9710 any error returned by verify_bind_c_derived_type. */
9711 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9717 /* clear the is_bind_c flag to prevent reporting errors more than
9718 once if something failed. */
9719 sym->attr.is_bind_c = 0;
9724 /* If a derived type symbol has reached this point, without its
9725 type being declared, we have an error. Notice that most
9726 conditions that produce undefined derived types have already
9727 been dealt with. However, the likes of:
9728 implicit type(t) (t) ..... call foo (t) will get us here if
9729 the type is not declared in the scope of the implicit
9730 statement. Change the type to BT_UNKNOWN, both because it is so
9731 and to prevent an ICE. */
9732 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
9733 && !sym->ts.derived->attr.zero_comp)
9735 gfc_error ("The derived type '%s' at %L is of type '%s', "
9736 "which has not been defined", sym->name,
9737 &sym->declared_at, sym->ts.derived->name);
9738 sym->ts.type = BT_UNKNOWN;
9742 /* Make sure that the derived type has been resolved and that the
9743 derived type is visible in the symbol's namespace, if it is a
9744 module function and is not PRIVATE. */
9745 if (sym->ts.type == BT_DERIVED
9746 && sym->ts.derived->attr.use_assoc
9747 && sym->ns->proc_name
9748 && sym->ns->proc_name->attr.flavor == FL_MODULE)
9752 if (resolve_fl_derived (sym->ts.derived) == FAILURE)
9755 gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
9756 if (!ds && sym->attr.function
9757 && gfc_check_access (sym->attr.access, sym->ns->default_access))
9759 symtree = gfc_new_symtree (&sym->ns->sym_root,
9760 sym->ts.derived->name);
9761 symtree->n.sym = sym->ts.derived;
9762 sym->ts.derived->refs++;
9766 /* Unless the derived-type declaration is use associated, Fortran 95
9767 does not allow public entries of private derived types.
9768 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9770 if (sym->ts.type == BT_DERIVED
9771 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
9772 && !sym->ts.derived->attr.use_assoc
9773 && gfc_check_access (sym->attr.access, sym->ns->default_access)
9774 && !gfc_check_access (sym->ts.derived->attr.access,
9775 sym->ts.derived->ns->default_access)
9776 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
9777 "of PRIVATE derived type '%s'",
9778 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
9779 : "variable", sym->name, &sym->declared_at,
9780 sym->ts.derived->name) == FAILURE)
9783 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9784 default initialization is defined (5.1.2.4.4). */
9785 if (sym->ts.type == BT_DERIVED
9787 && sym->attr.intent == INTENT_OUT
9789 && sym->as->type == AS_ASSUMED_SIZE)
9791 for (c = sym->ts.derived->components; c; c = c->next)
9795 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9796 "ASSUMED SIZE and so cannot have a default initializer",
9797 sym->name, &sym->declared_at);
9803 switch (sym->attr.flavor)
9806 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
9811 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
9816 if (resolve_fl_namelist (sym) == FAILURE)
9821 if (resolve_fl_parameter (sym) == FAILURE)
9829 /* Resolve array specifier. Check as well some constraints
9830 on COMMON blocks. */
9832 check_constant = sym->attr.in_common && !sym->attr.pointer;
9834 /* Set the formal_arg_flag so that check_conflict will not throw
9835 an error for host associated variables in the specification
9836 expression for an array_valued function. */
9837 if (sym->attr.function && sym->as)
9838 formal_arg_flag = 1;
9840 gfc_resolve_array_spec (sym->as, check_constant);
9842 formal_arg_flag = 0;
9844 /* Resolve formal namespaces. */
9845 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
9846 gfc_resolve (sym->formal_ns);
9848 /* Make sure the formal namespace is present. */
9849 if (sym->formal && !sym->formal_ns)
9851 gfc_formal_arglist *formal = sym->formal;
9852 while (formal && !formal->sym)
9853 formal = formal->next;
9857 sym->formal_ns = formal->sym->ns;
9858 sym->formal_ns->refs++;
9862 /* Check threadprivate restrictions. */
9863 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
9864 && (!sym->attr.in_common
9865 && sym->module == NULL
9866 && (sym->ns->proc_name == NULL
9867 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
9868 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
9870 /* If we have come this far we can apply default-initializers, as
9871 described in 14.7.5, to those variables that have not already
9872 been assigned one. */
9873 if (sym->ts.type == BT_DERIVED
9874 && sym->attr.referenced
9875 && sym->ns == gfc_current_ns
9877 && !sym->attr.allocatable
9878 && !sym->attr.alloc_comp)
9880 symbol_attribute *a = &sym->attr;
9882 if ((!a->save && !a->dummy && !a->pointer
9883 && !a->in_common && !a->use_assoc
9884 && !(a->function && sym != sym->result))
9885 || (a->dummy && a->intent == INTENT_OUT))
9886 apply_default_init (sym);
9889 /* If this symbol has a type-spec, check it. */
9890 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
9891 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
9892 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
9898 /************* Resolve DATA statements *************/
9902 gfc_data_value *vnode;
9908 /* Advance the values structure to point to the next value in the data list. */
9911 next_data_value (void)
9913 while (mpz_cmp_ui (values.left, 0) == 0)
9915 if (!gfc_is_constant_expr (values.vnode->expr))
9916 gfc_error ("non-constant DATA value at %L",
9917 &values.vnode->expr->where);
9919 if (values.vnode->next == NULL)
9922 values.vnode = values.vnode->next;
9923 mpz_set (values.left, values.vnode->repeat);
9931 check_data_variable (gfc_data_variable *var, locus *where)
9937 ar_type mark = AR_UNKNOWN;
9939 mpz_t section_index[GFC_MAX_DIMENSIONS];
9945 if (gfc_resolve_expr (var->expr) == FAILURE)
9949 mpz_init_set_si (offset, 0);
9952 if (e->expr_type != EXPR_VARIABLE)
9953 gfc_internal_error ("check_data_variable(): Bad expression");
9955 sym = e->symtree->n.sym;
9957 if (sym->ns->is_block_data && !sym->attr.in_common)
9959 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9960 sym->name, &sym->declared_at);
9963 if (e->ref == NULL && sym->as)
9965 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9966 " declaration", sym->name, where);
9970 has_pointer = sym->attr.pointer;
9972 for (ref = e->ref; ref; ref = ref->next)
9974 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
9978 && ref->type == REF_ARRAY
9979 && ref->u.ar.type != AR_FULL)
9981 gfc_error ("DATA element '%s' at %L is a pointer and so must "
9982 "be a full array", sym->name, where);
9987 if (e->rank == 0 || has_pointer)
9989 mpz_init_set_ui (size, 1);
9996 /* Find the array section reference. */
9997 for (ref = e->ref; ref; ref = ref->next)
9999 if (ref->type != REF_ARRAY)
10001 if (ref->u.ar.type == AR_ELEMENT)
10007 /* Set marks according to the reference pattern. */
10008 switch (ref->u.ar.type)
10016 /* Get the start position of array section. */
10017 gfc_get_section_index (ar, section_index, &offset);
10022 gcc_unreachable ();
10025 if (gfc_array_size (e, &size) == FAILURE)
10027 gfc_error ("Nonconstant array section at %L in DATA statement",
10029 mpz_clear (offset);
10036 while (mpz_cmp_ui (size, 0) > 0)
10038 if (next_data_value () == FAILURE)
10040 gfc_error ("DATA statement at %L has more variables than values",
10046 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
10050 /* If we have more than one element left in the repeat count,
10051 and we have more than one element left in the target variable,
10052 then create a range assignment. */
10053 /* FIXME: Only done for full arrays for now, since array sections
10055 if (mark == AR_FULL && ref && ref->next == NULL
10056 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
10060 if (mpz_cmp (size, values.left) >= 0)
10062 mpz_init_set (range, values.left);
10063 mpz_sub (size, size, values.left);
10064 mpz_set_ui (values.left, 0);
10068 mpz_init_set (range, size);
10069 mpz_sub (values.left, values.left, size);
10070 mpz_set_ui (size, 0);
10073 gfc_assign_data_value_range (var->expr, values.vnode->expr,
10076 mpz_add (offset, offset, range);
10080 /* Assign initial value to symbol. */
10083 mpz_sub_ui (values.left, values.left, 1);
10084 mpz_sub_ui (size, size, 1);
10086 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
10090 if (mark == AR_FULL)
10091 mpz_add_ui (offset, offset, 1);
10093 /* Modify the array section indexes and recalculate the offset
10094 for next element. */
10095 else if (mark == AR_SECTION)
10096 gfc_advance_section (section_index, ar, &offset);
10100 if (mark == AR_SECTION)
10102 for (i = 0; i < ar->dimen; i++)
10103 mpz_clear (section_index[i]);
10107 mpz_clear (offset);
10113 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
10115 /* Iterate over a list of elements in a DATA statement. */
10118 traverse_data_list (gfc_data_variable *var, locus *where)
10121 iterator_stack frame;
10122 gfc_expr *e, *start, *end, *step;
10123 gfc_try retval = SUCCESS;
10125 mpz_init (frame.value);
10127 start = gfc_copy_expr (var->iter.start);
10128 end = gfc_copy_expr (var->iter.end);
10129 step = gfc_copy_expr (var->iter.step);
10131 if (gfc_simplify_expr (start, 1) == FAILURE
10132 || start->expr_type != EXPR_CONSTANT)
10134 gfc_error ("iterator start at %L does not simplify", &start->where);
10138 if (gfc_simplify_expr (end, 1) == FAILURE
10139 || end->expr_type != EXPR_CONSTANT)
10141 gfc_error ("iterator end at %L does not simplify", &end->where);
10145 if (gfc_simplify_expr (step, 1) == FAILURE
10146 || step->expr_type != EXPR_CONSTANT)
10148 gfc_error ("iterator step at %L does not simplify", &step->where);
10153 mpz_init_set (trip, end->value.integer);
10154 mpz_sub (trip, trip, start->value.integer);
10155 mpz_add (trip, trip, step->value.integer);
10157 mpz_div (trip, trip, step->value.integer);
10159 mpz_set (frame.value, start->value.integer);
10161 frame.prev = iter_stack;
10162 frame.variable = var->iter.var->symtree;
10163 iter_stack = &frame;
10165 while (mpz_cmp_ui (trip, 0) > 0)
10167 if (traverse_data_var (var->list, where) == FAILURE)
10174 e = gfc_copy_expr (var->expr);
10175 if (gfc_simplify_expr (e, 1) == FAILURE)
10183 mpz_add (frame.value, frame.value, step->value.integer);
10185 mpz_sub_ui (trip, trip, 1);
10190 mpz_clear (frame.value);
10192 gfc_free_expr (start);
10193 gfc_free_expr (end);
10194 gfc_free_expr (step);
10196 iter_stack = frame.prev;
10201 /* Type resolve variables in the variable list of a DATA statement. */
10204 traverse_data_var (gfc_data_variable *var, locus *where)
10208 for (; var; var = var->next)
10210 if (var->expr == NULL)
10211 t = traverse_data_list (var, where);
10213 t = check_data_variable (var, where);
10223 /* Resolve the expressions and iterators associated with a data statement.
10224 This is separate from the assignment checking because data lists should
10225 only be resolved once. */
10228 resolve_data_variables (gfc_data_variable *d)
10230 for (; d; d = d->next)
10232 if (d->list == NULL)
10234 if (gfc_resolve_expr (d->expr) == FAILURE)
10239 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
10242 if (resolve_data_variables (d->list) == FAILURE)
10251 /* Resolve a single DATA statement. We implement this by storing a pointer to
10252 the value list into static variables, and then recursively traversing the
10253 variables list, expanding iterators and such. */
10256 resolve_data (gfc_data *d)
10259 if (resolve_data_variables (d->var) == FAILURE)
10262 values.vnode = d->value;
10263 if (d->value == NULL)
10264 mpz_set_ui (values.left, 0);
10266 mpz_set (values.left, d->value->repeat);
10268 if (traverse_data_var (d->var, &d->where) == FAILURE)
10271 /* At this point, we better not have any values left. */
10273 if (next_data_value () == SUCCESS)
10274 gfc_error ("DATA statement at %L has more values than variables",
10279 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
10280 accessed by host or use association, is a dummy argument to a pure function,
10281 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
10282 is storage associated with any such variable, shall not be used in the
10283 following contexts: (clients of this function). */
10285 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
10286 procedure. Returns zero if assignment is OK, nonzero if there is a
10289 gfc_impure_variable (gfc_symbol *sym)
10293 if (sym->attr.use_assoc || sym->attr.in_common)
10296 if (sym->ns != gfc_current_ns)
10297 return !sym->attr.function;
10299 proc = sym->ns->proc_name;
10300 if (sym->attr.dummy && gfc_pure (proc)
10301 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
10303 proc->attr.function))
10306 /* TODO: Sort out what can be storage associated, if anything, and include
10307 it here. In principle equivalences should be scanned but it does not
10308 seem to be possible to storage associate an impure variable this way. */
10313 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
10314 symbol of the current procedure. */
10317 gfc_pure (gfc_symbol *sym)
10319 symbol_attribute attr;
10322 sym = gfc_current_ns->proc_name;
10328 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
10332 /* Test whether the current procedure is elemental or not. */
10335 gfc_elemental (gfc_symbol *sym)
10337 symbol_attribute attr;
10340 sym = gfc_current_ns->proc_name;
10345 return attr.flavor == FL_PROCEDURE && attr.elemental;
10349 /* Warn about unused labels. */
10352 warn_unused_fortran_label (gfc_st_label *label)
10357 warn_unused_fortran_label (label->left);
10359 if (label->defined == ST_LABEL_UNKNOWN)
10362 switch (label->referenced)
10364 case ST_LABEL_UNKNOWN:
10365 gfc_warning ("Label %d at %L defined but not used", label->value,
10369 case ST_LABEL_BAD_TARGET:
10370 gfc_warning ("Label %d at %L defined but cannot be used",
10371 label->value, &label->where);
10378 warn_unused_fortran_label (label->right);
10382 /* Returns the sequence type of a symbol or sequence. */
10385 sequence_type (gfc_typespec ts)
10394 if (ts.derived->components == NULL)
10395 return SEQ_NONDEFAULT;
10397 result = sequence_type (ts.derived->components->ts);
10398 for (c = ts.derived->components->next; c; c = c->next)
10399 if (sequence_type (c->ts) != result)
10405 if (ts.kind != gfc_default_character_kind)
10406 return SEQ_NONDEFAULT;
10408 return SEQ_CHARACTER;
10411 if (ts.kind != gfc_default_integer_kind)
10412 return SEQ_NONDEFAULT;
10414 return SEQ_NUMERIC;
10417 if (!(ts.kind == gfc_default_real_kind
10418 || ts.kind == gfc_default_double_kind))
10419 return SEQ_NONDEFAULT;
10421 return SEQ_NUMERIC;
10424 if (ts.kind != gfc_default_complex_kind)
10425 return SEQ_NONDEFAULT;
10427 return SEQ_NUMERIC;
10430 if (ts.kind != gfc_default_logical_kind)
10431 return SEQ_NONDEFAULT;
10433 return SEQ_NUMERIC;
10436 return SEQ_NONDEFAULT;
10441 /* Resolve derived type EQUIVALENCE object. */
10444 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
10447 gfc_component *c = derived->components;
10452 /* Shall not be an object of nonsequence derived type. */
10453 if (!derived->attr.sequence)
10455 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
10456 "attribute to be an EQUIVALENCE object", sym->name,
10461 /* Shall not have allocatable components. */
10462 if (derived->attr.alloc_comp)
10464 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
10465 "components to be an EQUIVALENCE object",sym->name,
10470 if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
10472 gfc_error ("Derived type variable '%s' at %L with default "
10473 "initialization cannot be in EQUIVALENCE with a variable "
10474 "in COMMON", sym->name, &e->where);
10478 for (; c ; c = c->next)
10482 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
10485 /* Shall not be an object of sequence derived type containing a pointer
10486 in the structure. */
10487 if (c->attr.pointer)
10489 gfc_error ("Derived type variable '%s' at %L with pointer "
10490 "component(s) cannot be an EQUIVALENCE object",
10491 sym->name, &e->where);
10499 /* Resolve equivalence object.
10500 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
10501 an allocatable array, an object of nonsequence derived type, an object of
10502 sequence derived type containing a pointer at any level of component
10503 selection, an automatic object, a function name, an entry name, a result
10504 name, a named constant, a structure component, or a subobject of any of
10505 the preceding objects. A substring shall not have length zero. A
10506 derived type shall not have components with default initialization nor
10507 shall two objects of an equivalence group be initialized.
10508 Either all or none of the objects shall have an protected attribute.
10509 The simple constraints are done in symbol.c(check_conflict) and the rest
10510 are implemented here. */
10513 resolve_equivalence (gfc_equiv *eq)
10516 gfc_symbol *derived;
10517 gfc_symbol *first_sym;
10520 locus *last_where = NULL;
10521 seq_type eq_type, last_eq_type;
10522 gfc_typespec *last_ts;
10523 int object, cnt_protected;
10524 const char *value_name;
10528 last_ts = &eq->expr->symtree->n.sym->ts;
10530 first_sym = eq->expr->symtree->n.sym;
10534 for (object = 1; eq; eq = eq->eq, object++)
10538 e->ts = e->symtree->n.sym->ts;
10539 /* match_varspec might not know yet if it is seeing
10540 array reference or substring reference, as it doesn't
10542 if (e->ref && e->ref->type == REF_ARRAY)
10544 gfc_ref *ref = e->ref;
10545 sym = e->symtree->n.sym;
10547 if (sym->attr.dimension)
10549 ref->u.ar.as = sym->as;
10553 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
10554 if (e->ts.type == BT_CHARACTER
10556 && ref->type == REF_ARRAY
10557 && ref->u.ar.dimen == 1
10558 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
10559 && ref->u.ar.stride[0] == NULL)
10561 gfc_expr *start = ref->u.ar.start[0];
10562 gfc_expr *end = ref->u.ar.end[0];
10565 /* Optimize away the (:) reference. */
10566 if (start == NULL && end == NULL)
10569 e->ref = ref->next;
10571 e->ref->next = ref->next;
10576 ref->type = REF_SUBSTRING;
10578 start = gfc_int_expr (1);
10579 ref->u.ss.start = start;
10580 if (end == NULL && e->ts.cl)
10581 end = gfc_copy_expr (e->ts.cl->length);
10582 ref->u.ss.end = end;
10583 ref->u.ss.length = e->ts.cl;
10590 /* Any further ref is an error. */
10593 gcc_assert (ref->type == REF_ARRAY);
10594 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
10600 if (gfc_resolve_expr (e) == FAILURE)
10603 sym = e->symtree->n.sym;
10605 if (sym->attr.is_protected)
10607 if (cnt_protected > 0 && cnt_protected != object)
10609 gfc_error ("Either all or none of the objects in the "
10610 "EQUIVALENCE set at %L shall have the "
10611 "PROTECTED attribute",
10616 /* Shall not equivalence common block variables in a PURE procedure. */
10617 if (sym->ns->proc_name
10618 && sym->ns->proc_name->attr.pure
10619 && sym->attr.in_common)
10621 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
10622 "object in the pure procedure '%s'",
10623 sym->name, &e->where, sym->ns->proc_name->name);
10627 /* Shall not be a named constant. */
10628 if (e->expr_type == EXPR_CONSTANT)
10630 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
10631 "object", sym->name, &e->where);
10635 derived = e->ts.derived;
10636 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
10639 /* Check that the types correspond correctly:
10641 A numeric sequence structure may be equivalenced to another sequence
10642 structure, an object of default integer type, default real type, double
10643 precision real type, default logical type such that components of the
10644 structure ultimately only become associated to objects of the same
10645 kind. A character sequence structure may be equivalenced to an object
10646 of default character kind or another character sequence structure.
10647 Other objects may be equivalenced only to objects of the same type and
10648 kind parameters. */
10650 /* Identical types are unconditionally OK. */
10651 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
10652 goto identical_types;
10654 last_eq_type = sequence_type (*last_ts);
10655 eq_type = sequence_type (sym->ts);
10657 /* Since the pair of objects is not of the same type, mixed or
10658 non-default sequences can be rejected. */
10660 msg = "Sequence %s with mixed components in EQUIVALENCE "
10661 "statement at %L with different type objects";
10663 && last_eq_type == SEQ_MIXED
10664 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
10666 || (eq_type == SEQ_MIXED
10667 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10668 &e->where) == FAILURE))
10671 msg = "Non-default type object or sequence %s in EQUIVALENCE "
10672 "statement at %L with objects of different type";
10674 && last_eq_type == SEQ_NONDEFAULT
10675 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
10676 last_where) == FAILURE)
10677 || (eq_type == SEQ_NONDEFAULT
10678 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10679 &e->where) == FAILURE))
10682 msg ="Non-CHARACTER object '%s' in default CHARACTER "
10683 "EQUIVALENCE statement at %L";
10684 if (last_eq_type == SEQ_CHARACTER
10685 && eq_type != SEQ_CHARACTER
10686 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10687 &e->where) == FAILURE)
10690 msg ="Non-NUMERIC object '%s' in default NUMERIC "
10691 "EQUIVALENCE statement at %L";
10692 if (last_eq_type == SEQ_NUMERIC
10693 && eq_type != SEQ_NUMERIC
10694 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
10695 &e->where) == FAILURE)
10700 last_where = &e->where;
10705 /* Shall not be an automatic array. */
10706 if (e->ref->type == REF_ARRAY
10707 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
10709 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
10710 "an EQUIVALENCE object", sym->name, &e->where);
10717 /* Shall not be a structure component. */
10718 if (r->type == REF_COMPONENT)
10720 gfc_error ("Structure component '%s' at %L cannot be an "
10721 "EQUIVALENCE object",
10722 r->u.c.component->name, &e->where);
10726 /* A substring shall not have length zero. */
10727 if (r->type == REF_SUBSTRING)
10729 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
10731 gfc_error ("Substring at %L has length zero",
10732 &r->u.ss.start->where);
10742 /* Resolve function and ENTRY types, issue diagnostics if needed. */
10745 resolve_fntype (gfc_namespace *ns)
10747 gfc_entry_list *el;
10750 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
10753 /* If there are any entries, ns->proc_name is the entry master
10754 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10756 sym = ns->entries->sym;
10758 sym = ns->proc_name;
10759 if (sym->result == sym
10760 && sym->ts.type == BT_UNKNOWN
10761 && gfc_set_default_type (sym, 0, NULL) == FAILURE
10762 && !sym->attr.untyped)
10764 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10765 sym->name, &sym->declared_at);
10766 sym->attr.untyped = 1;
10769 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
10770 && !sym->attr.contained
10771 && !gfc_check_access (sym->ts.derived->attr.access,
10772 sym->ts.derived->ns->default_access)
10773 && gfc_check_access (sym->attr.access, sym->ns->default_access))
10775 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
10776 "%L of PRIVATE type '%s'", sym->name,
10777 &sym->declared_at, sym->ts.derived->name);
10781 for (el = ns->entries->next; el; el = el->next)
10783 if (el->sym->result == el->sym
10784 && el->sym->ts.type == BT_UNKNOWN
10785 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
10786 && !el->sym->attr.untyped)
10788 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10789 el->sym->name, &el->sym->declared_at);
10790 el->sym->attr.untyped = 1;
10795 /* 12.3.2.1.1 Defined operators. */
10798 gfc_resolve_uops (gfc_symtree *symtree)
10800 gfc_interface *itr;
10802 gfc_formal_arglist *formal;
10804 if (symtree == NULL)
10807 gfc_resolve_uops (symtree->left);
10808 gfc_resolve_uops (symtree->right);
10810 for (itr = symtree->n.uop->op; itr; itr = itr->next)
10813 if (!sym->attr.function)
10814 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10815 sym->name, &sym->declared_at);
10817 if (sym->ts.type == BT_CHARACTER
10818 && !(sym->ts.cl && sym->ts.cl->length)
10819 && !(sym->result && sym->result->ts.cl
10820 && sym->result->ts.cl->length))
10821 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10822 "character length", sym->name, &sym->declared_at);
10824 formal = sym->formal;
10825 if (!formal || !formal->sym)
10827 gfc_error ("User operator procedure '%s' at %L must have at least "
10828 "one argument", sym->name, &sym->declared_at);
10832 if (formal->sym->attr.intent != INTENT_IN)
10833 gfc_error ("First argument of operator interface at %L must be "
10834 "INTENT(IN)", &sym->declared_at);
10836 if (formal->sym->attr.optional)
10837 gfc_error ("First argument of operator interface at %L cannot be "
10838 "optional", &sym->declared_at);
10840 formal = formal->next;
10841 if (!formal || !formal->sym)
10844 if (formal->sym->attr.intent != INTENT_IN)
10845 gfc_error ("Second argument of operator interface at %L must be "
10846 "INTENT(IN)", &sym->declared_at);
10848 if (formal->sym->attr.optional)
10849 gfc_error ("Second argument of operator interface at %L cannot be "
10850 "optional", &sym->declared_at);
10853 gfc_error ("Operator interface at %L must have, at most, two "
10854 "arguments", &sym->declared_at);
10859 /* Examine all of the expressions associated with a program unit,
10860 assign types to all intermediate expressions, make sure that all
10861 assignments are to compatible types and figure out which names
10862 refer to which functions or subroutines. It doesn't check code
10863 block, which is handled by resolve_code. */
10866 resolve_types (gfc_namespace *ns)
10872 gfc_namespace* old_ns = gfc_current_ns;
10874 /* Check that all IMPLICIT types are ok. */
10875 if (!ns->seen_implicit_none)
10878 for (letter = 0; letter != GFC_LETTERS; ++letter)
10879 if (ns->set_flag[letter]
10880 && resolve_typespec_used (&ns->default_type[letter],
10881 &ns->implicit_loc[letter],
10886 gfc_current_ns = ns;
10888 resolve_entries (ns);
10890 resolve_common_vars (ns->blank_common.head, false);
10891 resolve_common_blocks (ns->common_root);
10893 resolve_contained_functions (ns);
10895 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
10897 for (cl = ns->cl_list; cl; cl = cl->next)
10898 resolve_charlen (cl);
10900 gfc_traverse_ns (ns, resolve_symbol);
10902 resolve_fntype (ns);
10904 for (n = ns->contained; n; n = n->sibling)
10906 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
10907 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10908 "also be PURE", n->proc_name->name,
10909 &n->proc_name->declared_at);
10915 gfc_check_interfaces (ns);
10917 gfc_traverse_ns (ns, resolve_values);
10923 for (d = ns->data; d; d = d->next)
10927 gfc_traverse_ns (ns, gfc_formalize_init_value);
10929 gfc_traverse_ns (ns, gfc_verify_binding_labels);
10931 if (ns->common_root != NULL)
10932 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
10934 for (eq = ns->equiv; eq; eq = eq->next)
10935 resolve_equivalence (eq);
10937 /* Warn about unused labels. */
10938 if (warn_unused_label)
10939 warn_unused_fortran_label (ns->st_labels);
10941 gfc_resolve_uops (ns->uop_root);
10943 gfc_current_ns = old_ns;
10947 /* Call resolve_code recursively. */
10950 resolve_codes (gfc_namespace *ns)
10953 bitmap_obstack old_obstack;
10955 for (n = ns->contained; n; n = n->sibling)
10958 gfc_current_ns = ns;
10960 /* Set to an out of range value. */
10961 current_entry_id = -1;
10963 old_obstack = labels_obstack;
10964 bitmap_obstack_initialize (&labels_obstack);
10966 resolve_code (ns->code, ns);
10968 bitmap_obstack_release (&labels_obstack);
10969 labels_obstack = old_obstack;
10973 /* This function is called after a complete program unit has been compiled.
10974 Its purpose is to examine all of the expressions associated with a program
10975 unit, assign types to all intermediate expressions, make sure that all
10976 assignments are to compatible types and figure out which names refer to
10977 which functions or subroutines. */
10980 gfc_resolve (gfc_namespace *ns)
10982 gfc_namespace *old_ns;
10987 old_ns = gfc_current_ns;
10989 resolve_types (ns);
10990 resolve_codes (ns);
10992 gfc_current_ns = old_ns;