1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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 */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code *head, *current;
48 struct code_stack *prev;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels;
57 static code_stack *cs_base = NULL;
60 /* Nonzero if we're inside a FORALL block. */
62 static int forall_flag;
64 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
66 static int omp_workshare_flag;
68 /* Nonzero if we are processing a formal arglist. The corresponding function
69 resets the flag each time that it is read. */
70 static int formal_arg_flag = 0;
72 /* True if we are resolving a specification expression. */
73 static int specification_expr = 0;
75 /* The id of the last entry seen. */
76 static int current_entry_id;
78 /* We use bitmaps to determine if a branch target is valid. */
79 static bitmap_obstack labels_obstack;
81 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
82 static bool inquiry_argument = false;
85 gfc_is_formal_arg (void)
87 return formal_arg_flag;
90 /* Is the symbol host associated? */
92 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
94 for (ns = ns->parent; ns; ns = ns->parent)
103 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
104 an ABSTRACT derived-type. If where is not NULL, an error message with that
105 locus is printed, optionally using name. */
108 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
110 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
115 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
116 name, where, ts->u.derived->name);
118 gfc_error ("ABSTRACT type '%s' used at %L",
119 ts->u.derived->name, where);
129 /* Resolve types of formal argument lists. These have to be done early so that
130 the formal argument lists of module procedures can be copied to the
131 containing module before the individual procedures are resolved
132 individually. We also resolve argument lists of procedures in interface
133 blocks because they are self-contained scoping units.
135 Since a dummy argument cannot be a non-dummy procedure, the only
136 resort left for untyped names are the IMPLICIT types. */
139 resolve_formal_arglist (gfc_symbol *proc)
141 gfc_formal_arglist *f;
145 if (proc->result != NULL)
150 if (gfc_elemental (proc)
151 || sym->attr.pointer || sym->attr.allocatable
152 || (sym->as && sym->as->rank > 0))
154 proc->attr.always_explicit = 1;
155 sym->attr.always_explicit = 1;
160 for (f = proc->formal; f; f = f->next)
166 /* Alternate return placeholder. */
167 if (gfc_elemental (proc))
168 gfc_error ("Alternate return specifier in elemental subroutine "
169 "'%s' at %L is not allowed", proc->name,
171 if (proc->attr.function)
172 gfc_error ("Alternate return specifier in function "
173 "'%s' at %L is not allowed", proc->name,
178 if (sym->attr.if_source != IFSRC_UNKNOWN)
179 resolve_formal_arglist (sym);
181 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
183 if (gfc_pure (proc) && !gfc_pure (sym))
185 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
186 "also be PURE", sym->name, &sym->declared_at);
190 if (gfc_elemental (proc))
192 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
193 "procedure", &sym->declared_at);
197 if (sym->attr.function
198 && sym->ts.type == BT_UNKNOWN
199 && sym->attr.intrinsic)
201 gfc_intrinsic_sym *isym;
202 isym = gfc_find_function (sym->name);
203 if (isym == NULL || !isym->specific)
205 gfc_error ("Unable to find a specific INTRINSIC procedure "
206 "for the reference '%s' at %L", sym->name,
215 if (sym->ts.type == BT_UNKNOWN)
217 if (!sym->attr.function || sym->result == sym)
218 gfc_set_default_type (sym, 1, sym->ns);
221 gfc_resolve_array_spec (sym->as, 0);
223 /* We can't tell if an array with dimension (:) is assumed or deferred
224 shape until we know if it has the pointer or allocatable attributes.
226 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
227 && !(sym->attr.pointer || sym->attr.allocatable))
229 sym->as->type = AS_ASSUMED_SHAPE;
230 for (i = 0; i < sym->as->rank; i++)
231 sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
235 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
236 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
237 || sym->attr.optional)
239 proc->attr.always_explicit = 1;
241 proc->result->attr.always_explicit = 1;
244 /* If the flavor is unknown at this point, it has to be a variable.
245 A procedure specification would have already set the type. */
247 if (sym->attr.flavor == FL_UNKNOWN)
248 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
250 if (gfc_pure (proc) && !sym->attr.pointer
251 && sym->attr.flavor != FL_PROCEDURE)
253 if (proc->attr.function && sym->attr.intent != INTENT_IN)
254 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
255 "INTENT(IN)", sym->name, proc->name,
258 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
259 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
260 "have its INTENT specified", sym->name, proc->name,
264 if (gfc_elemental (proc))
267 if (sym->attr.codimension)
269 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
270 "procedure", sym->name, &sym->declared_at);
276 gfc_error ("Argument '%s' of elemental procedure at %L must "
277 "be scalar", sym->name, &sym->declared_at);
281 if (sym->attr.allocatable)
283 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
284 "have the ALLOCATABLE attribute", sym->name,
289 if (sym->attr.pointer)
291 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
292 "have the POINTER attribute", sym->name,
297 if (sym->attr.flavor == FL_PROCEDURE)
299 gfc_error ("Dummy procedure '%s' not allowed in elemental "
300 "procedure '%s' at %L", sym->name, proc->name,
305 if (sym->attr.intent == INTENT_UNKNOWN)
307 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
308 "have its INTENT specified", sym->name, proc->name,
314 /* Each dummy shall be specified to be scalar. */
315 if (proc->attr.proc == PROC_ST_FUNCTION)
319 gfc_error ("Argument '%s' of statement function at %L must "
320 "be scalar", sym->name, &sym->declared_at);
324 if (sym->ts.type == BT_CHARACTER)
326 gfc_charlen *cl = sym->ts.u.cl;
327 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
329 gfc_error ("Character-valued argument '%s' of statement "
330 "function at %L must have constant length",
331 sym->name, &sym->declared_at);
341 /* Work function called when searching for symbols that have argument lists
342 associated with them. */
345 find_arglists (gfc_symbol *sym)
347 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
350 resolve_formal_arglist (sym);
354 /* Given a namespace, resolve all formal argument lists within the namespace.
358 resolve_formal_arglists (gfc_namespace *ns)
363 gfc_traverse_ns (ns, find_arglists);
368 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
372 /* If this namespace is not a function or an entry master function,
374 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
375 || sym->attr.entry_master)
378 /* Try to find out of what the return type is. */
379 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
381 t = gfc_set_default_type (sym->result, 0, ns);
383 if (t == FAILURE && !sym->result->attr.untyped)
385 if (sym->result == sym)
386 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
387 sym->name, &sym->declared_at);
388 else if (!sym->result->attr.proc_pointer)
389 gfc_error ("Result '%s' of contained function '%s' at %L has "
390 "no IMPLICIT type", sym->result->name, sym->name,
391 &sym->result->declared_at);
392 sym->result->attr.untyped = 1;
396 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
397 type, lists the only ways a character length value of * can be used:
398 dummy arguments of procedures, named constants, and function results
399 in external functions. Internal function results and results of module
400 procedures are not on this list, ergo, not permitted. */
402 if (sym->result->ts.type == BT_CHARACTER)
404 gfc_charlen *cl = sym->result->ts.u.cl;
405 if (!cl || !cl->length)
407 /* See if this is a module-procedure and adapt error message
410 gcc_assert (ns->parent && ns->parent->proc_name);
411 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
413 gfc_error ("Character-valued %s '%s' at %L must not be"
415 module_proc ? _("module procedure")
416 : _("internal function"),
417 sym->name, &sym->declared_at);
423 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
424 introduce duplicates. */
427 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
429 gfc_formal_arglist *f, *new_arglist;
432 for (; new_args != NULL; new_args = new_args->next)
434 new_sym = new_args->sym;
435 /* See if this arg is already in the formal argument list. */
436 for (f = proc->formal; f; f = f->next)
438 if (new_sym == f->sym)
445 /* Add a new argument. Argument order is not important. */
446 new_arglist = gfc_get_formal_arglist ();
447 new_arglist->sym = new_sym;
448 new_arglist->next = proc->formal;
449 proc->formal = new_arglist;
454 /* Flag the arguments that are not present in all entries. */
457 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
459 gfc_formal_arglist *f, *head;
462 for (f = proc->formal; f; f = f->next)
467 for (new_args = head; new_args; new_args = new_args->next)
469 if (new_args->sym == f->sym)
476 f->sym->attr.not_always_present = 1;
481 /* Resolve alternate entry points. If a symbol has multiple entry points we
482 create a new master symbol for the main routine, and turn the existing
483 symbol into an entry point. */
486 resolve_entries (gfc_namespace *ns)
488 gfc_namespace *old_ns;
492 char name[GFC_MAX_SYMBOL_LEN + 1];
493 static int master_count = 0;
495 if (ns->proc_name == NULL)
498 /* No need to do anything if this procedure doesn't have alternate entry
503 /* We may already have resolved alternate entry points. */
504 if (ns->proc_name->attr.entry_master)
507 /* If this isn't a procedure something has gone horribly wrong. */
508 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
510 /* Remember the current namespace. */
511 old_ns = gfc_current_ns;
515 /* Add the main entry point to the list of entry points. */
516 el = gfc_get_entry_list ();
517 el->sym = ns->proc_name;
519 el->next = ns->entries;
521 ns->proc_name->attr.entry = 1;
523 /* If it is a module function, it needs to be in the right namespace
524 so that gfc_get_fake_result_decl can gather up the results. The
525 need for this arose in get_proc_name, where these beasts were
526 left in their own namespace, to keep prior references linked to
527 the entry declaration.*/
528 if (ns->proc_name->attr.function
529 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
532 /* Do the same for entries where the master is not a module
533 procedure. These are retained in the module namespace because
534 of the module procedure declaration. */
535 for (el = el->next; el; el = el->next)
536 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
537 && el->sym->attr.mod_proc)
541 /* Add an entry statement for it. */
548 /* Create a new symbol for the master function. */
549 /* Give the internal function a unique name (within this file).
550 Also include the function name so the user has some hope of figuring
551 out what is going on. */
552 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
553 master_count++, ns->proc_name->name);
554 gfc_get_ha_symbol (name, &proc);
555 gcc_assert (proc != NULL);
557 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
558 if (ns->proc_name->attr.subroutine)
559 gfc_add_subroutine (&proc->attr, proc->name, NULL);
563 gfc_typespec *ts, *fts;
564 gfc_array_spec *as, *fas;
565 gfc_add_function (&proc->attr, proc->name, NULL);
567 fas = ns->entries->sym->as;
568 fas = fas ? fas : ns->entries->sym->result->as;
569 fts = &ns->entries->sym->result->ts;
570 if (fts->type == BT_UNKNOWN)
571 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
572 for (el = ns->entries->next; el; el = el->next)
574 ts = &el->sym->result->ts;
576 as = as ? as : el->sym->result->as;
577 if (ts->type == BT_UNKNOWN)
578 ts = gfc_get_default_type (el->sym->result->name, NULL);
580 if (! gfc_compare_types (ts, fts)
581 || (el->sym->result->attr.dimension
582 != ns->entries->sym->result->attr.dimension)
583 || (el->sym->result->attr.pointer
584 != ns->entries->sym->result->attr.pointer))
586 else if (as && fas && ns->entries->sym->result != el->sym->result
587 && gfc_compare_array_spec (as, fas) == 0)
588 gfc_error ("Function %s at %L has entries with mismatched "
589 "array specifications", ns->entries->sym->name,
590 &ns->entries->sym->declared_at);
591 /* The characteristics need to match and thus both need to have
592 the same string length, i.e. both len=*, or both len=4.
593 Having both len=<variable> is also possible, but difficult to
594 check at compile time. */
595 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
596 && (((ts->u.cl->length && !fts->u.cl->length)
597 ||(!ts->u.cl->length && fts->u.cl->length))
599 && ts->u.cl->length->expr_type
600 != fts->u.cl->length->expr_type)
602 && ts->u.cl->length->expr_type == EXPR_CONSTANT
603 && mpz_cmp (ts->u.cl->length->value.integer,
604 fts->u.cl->length->value.integer) != 0)))
605 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
606 "entries returning variables of different "
607 "string lengths", ns->entries->sym->name,
608 &ns->entries->sym->declared_at);
613 sym = ns->entries->sym->result;
614 /* All result types the same. */
616 if (sym->attr.dimension)
617 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
618 if (sym->attr.pointer)
619 gfc_add_pointer (&proc->attr, NULL);
623 /* Otherwise the result will be passed through a union by
625 proc->attr.mixed_entry_master = 1;
626 for (el = ns->entries; el; el = el->next)
628 sym = el->sym->result;
629 if (sym->attr.dimension)
631 if (el == ns->entries)
632 gfc_error ("FUNCTION result %s can't be an array in "
633 "FUNCTION %s at %L", sym->name,
634 ns->entries->sym->name, &sym->declared_at);
636 gfc_error ("ENTRY result %s can't be an array in "
637 "FUNCTION %s at %L", sym->name,
638 ns->entries->sym->name, &sym->declared_at);
640 else if (sym->attr.pointer)
642 if (el == ns->entries)
643 gfc_error ("FUNCTION result %s can't be a POINTER in "
644 "FUNCTION %s at %L", sym->name,
645 ns->entries->sym->name, &sym->declared_at);
647 gfc_error ("ENTRY result %s can't be a POINTER in "
648 "FUNCTION %s at %L", sym->name,
649 ns->entries->sym->name, &sym->declared_at);
654 if (ts->type == BT_UNKNOWN)
655 ts = gfc_get_default_type (sym->name, NULL);
659 if (ts->kind == gfc_default_integer_kind)
663 if (ts->kind == gfc_default_real_kind
664 || ts->kind == gfc_default_double_kind)
668 if (ts->kind == gfc_default_complex_kind)
672 if (ts->kind == gfc_default_logical_kind)
676 /* We will issue error elsewhere. */
684 if (el == ns->entries)
685 gfc_error ("FUNCTION result %s can't be of type %s "
686 "in FUNCTION %s at %L", sym->name,
687 gfc_typename (ts), ns->entries->sym->name,
690 gfc_error ("ENTRY result %s can't be of type %s "
691 "in FUNCTION %s at %L", sym->name,
692 gfc_typename (ts), ns->entries->sym->name,
699 proc->attr.access = ACCESS_PRIVATE;
700 proc->attr.entry_master = 1;
702 /* Merge all the entry point arguments. */
703 for (el = ns->entries; el; el = el->next)
704 merge_argument_lists (proc, el->sym->formal);
706 /* Check the master formal arguments for any that are not
707 present in all entry points. */
708 for (el = ns->entries; el; el = el->next)
709 check_argument_lists (proc, el->sym->formal);
711 /* Use the master function for the function body. */
712 ns->proc_name = proc;
714 /* Finalize the new symbols. */
715 gfc_commit_symbols ();
717 /* Restore the original namespace. */
718 gfc_current_ns = old_ns;
722 /* Resolve common variables. */
724 resolve_common_vars (gfc_symbol *sym, bool named_common)
726 gfc_symbol *csym = sym;
728 for (; csym; csym = csym->common_next)
730 if (csym->value || csym->attr.data)
732 if (!csym->ns->is_block_data)
733 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
734 "but only in BLOCK DATA initialization is "
735 "allowed", csym->name, &csym->declared_at);
736 else if (!named_common)
737 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
738 "in a blank COMMON but initialization is only "
739 "allowed in named common blocks", csym->name,
743 if (csym->ts.type != BT_DERIVED)
746 if (!(csym->ts.u.derived->attr.sequence
747 || csym->ts.u.derived->attr.is_bind_c))
748 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
749 "has neither the SEQUENCE nor the BIND(C) "
750 "attribute", csym->name, &csym->declared_at);
751 if (csym->ts.u.derived->attr.alloc_comp)
752 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
753 "has an ultimate component that is "
754 "allocatable", csym->name, &csym->declared_at);
755 if (gfc_has_default_initializer (csym->ts.u.derived))
756 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
757 "may not have default initializer", csym->name,
760 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
761 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
765 /* Resolve common blocks. */
767 resolve_common_blocks (gfc_symtree *common_root)
771 if (common_root == NULL)
774 if (common_root->left)
775 resolve_common_blocks (common_root->left);
776 if (common_root->right)
777 resolve_common_blocks (common_root->right);
779 resolve_common_vars (common_root->n.common->head, true);
781 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
785 if (sym->attr.flavor == FL_PARAMETER)
786 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
787 sym->name, &common_root->n.common->where, &sym->declared_at);
789 if (sym->attr.intrinsic)
790 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
791 sym->name, &common_root->n.common->where);
792 else if (sym->attr.result
793 || gfc_is_function_return_value (sym, gfc_current_ns))
794 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
795 "that is also a function result", sym->name,
796 &common_root->n.common->where);
797 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
798 && sym->attr.proc != PROC_ST_FUNCTION)
799 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
800 "that is also a global procedure", sym->name,
801 &common_root->n.common->where);
805 /* Resolve contained function types. Because contained functions can call one
806 another, they have to be worked out before any of the contained procedures
809 The good news is that if a function doesn't already have a type, the only
810 way it can get one is through an IMPLICIT type or a RESULT variable, because
811 by definition contained functions are contained namespace they're contained
812 in, not in a sibling or parent namespace. */
815 resolve_contained_functions (gfc_namespace *ns)
817 gfc_namespace *child;
820 resolve_formal_arglists (ns);
822 for (child = ns->contained; child; child = child->sibling)
824 /* Resolve alternate entry points first. */
825 resolve_entries (child);
827 /* Then check function return types. */
828 resolve_contained_fntype (child->proc_name, child);
829 for (el = child->entries; el; el = el->next)
830 resolve_contained_fntype (el->sym, child);
835 /* Resolve all of the elements of a structure constructor and make sure that
836 the types are correct. The 'init' flag indicates that the given
837 constructor is an initializer. */
840 resolve_structure_cons (gfc_expr *expr, int init)
842 gfc_constructor *cons;
848 cons = gfc_constructor_first (expr->value.constructor);
849 /* A constructor may have references if it is the result of substituting a
850 parameter variable. In this case we just pull out the component we
853 comp = expr->ref->u.c.sym->components;
855 comp = expr->ts.u.derived->components;
857 /* See if the user is trying to invoke a structure constructor for one of
858 the iso_c_binding derived types. */
859 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
860 && expr->ts.u.derived->ts.is_iso_c && cons
861 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
863 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
864 expr->ts.u.derived->name, &(expr->where));
868 /* Return if structure constructor is c_null_(fun)prt. */
869 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
870 && expr->ts.u.derived->ts.is_iso_c && cons
871 && cons->expr && cons->expr->expr_type == EXPR_NULL)
874 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
881 if (gfc_resolve_expr (cons->expr) == FAILURE)
887 rank = comp->as ? comp->as->rank : 0;
888 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
889 && (comp->attr.allocatable || cons->expr->rank))
891 gfc_error ("The rank of the element in the derived type "
892 "constructor at %L does not match that of the "
893 "component (%d/%d)", &cons->expr->where,
894 cons->expr->rank, rank);
898 /* If we don't have the right type, try to convert it. */
900 if (!comp->attr.proc_pointer &&
901 !gfc_compare_types (&cons->expr->ts, &comp->ts))
904 if (strcmp (comp->name, "$extends") == 0)
906 /* Can afford to be brutal with the $extends initializer.
907 The derived type can get lost because it is PRIVATE
908 but it is not usage constrained by the standard. */
909 cons->expr->ts = comp->ts;
912 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
913 gfc_error ("The element in the derived type constructor at %L, "
914 "for pointer component '%s', is %s but should be %s",
915 &cons->expr->where, comp->name,
916 gfc_basic_typename (cons->expr->ts.type),
917 gfc_basic_typename (comp->ts.type));
919 t = gfc_convert_type (cons->expr, &comp->ts, 1);
922 /* For strings, the length of the constructor should be the same as
923 the one of the structure, ensure this if the lengths are known at
924 compile time and when we are dealing with PARAMETER or structure
926 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
927 && comp->ts.u.cl->length
928 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
929 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
930 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
931 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
932 comp->ts.u.cl->length->value.integer) != 0)
934 if (cons->expr->expr_type == EXPR_VARIABLE
935 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
937 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
938 to make use of the gfc_resolve_character_array_constructor
939 machinery. The expression is later simplified away to
940 an array of string literals. */
941 gfc_expr *para = cons->expr;
942 cons->expr = gfc_get_expr ();
943 cons->expr->ts = para->ts;
944 cons->expr->where = para->where;
945 cons->expr->expr_type = EXPR_ARRAY;
946 cons->expr->rank = para->rank;
947 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
948 gfc_constructor_append_expr (&cons->expr->value.constructor,
949 para, &cons->expr->where);
951 if (cons->expr->expr_type == EXPR_ARRAY)
954 p = gfc_constructor_first (cons->expr->value.constructor);
955 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
957 gfc_charlen *cl, *cl2;
960 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
962 if (cl == cons->expr->ts.u.cl)
970 cl2->next = cl->next;
972 gfc_free_expr (cl->length);
976 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
977 cons->expr->ts.u.cl->length_from_typespec = true;
978 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
979 gfc_resolve_character_array_constructor (cons->expr);
983 if (cons->expr->expr_type == EXPR_NULL
984 && !(comp->attr.pointer || comp->attr.allocatable
985 || comp->attr.proc_pointer
986 || (comp->ts.type == BT_CLASS
987 && (CLASS_DATA (comp)->attr.class_pointer
988 || CLASS_DATA (comp)->attr.allocatable))))
991 gfc_error ("The NULL in the derived type constructor at %L is "
992 "being applied to component '%s', which is neither "
993 "a POINTER nor ALLOCATABLE", &cons->expr->where,
997 if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
1000 a = gfc_expr_attr (cons->expr);
1002 if (!a.pointer && !a.target)
1005 gfc_error ("The element in the derived type constructor at %L, "
1006 "for pointer component '%s' should be a POINTER or "
1007 "a TARGET", &cons->expr->where, comp->name);
1012 /* F08:C461. Additional checks for pointer initialization. */
1016 gfc_error ("Pointer initialization target at %L "
1017 "must not be ALLOCATABLE ", &cons->expr->where);
1022 gfc_error ("Pointer initialization target at %L "
1023 "must have the SAVE attribute", &cons->expr->where);
1027 /* F2003, C1272 (3). */
1028 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1029 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1030 || gfc_is_coindexed (cons->expr)))
1033 gfc_error ("Invalid expression in the derived type constructor for "
1034 "pointer component '%s' at %L in PURE procedure",
1035 comp->name, &cons->expr->where);
1044 /****************** Expression name resolution ******************/
1046 /* Returns 0 if a symbol was not declared with a type or
1047 attribute declaration statement, nonzero otherwise. */
1050 was_declared (gfc_symbol *sym)
1056 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1059 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1060 || a.optional || a.pointer || a.save || a.target || a.volatile_
1061 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1062 || a.asynchronous || a.codimension)
1069 /* Determine if a symbol is generic or not. */
1072 generic_sym (gfc_symbol *sym)
1076 if (sym->attr.generic ||
1077 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1080 if (was_declared (sym) || sym->ns->parent == NULL)
1083 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1090 return generic_sym (s);
1097 /* Determine if a symbol is specific or not. */
1100 specific_sym (gfc_symbol *sym)
1104 if (sym->attr.if_source == IFSRC_IFBODY
1105 || sym->attr.proc == PROC_MODULE
1106 || sym->attr.proc == PROC_INTERNAL
1107 || sym->attr.proc == PROC_ST_FUNCTION
1108 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1109 || sym->attr.external)
1112 if (was_declared (sym) || sym->ns->parent == NULL)
1115 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1117 return (s == NULL) ? 0 : specific_sym (s);
1121 /* Figure out if the procedure is specific, generic or unknown. */
1124 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1128 procedure_kind (gfc_symbol *sym)
1130 if (generic_sym (sym))
1131 return PTYPE_GENERIC;
1133 if (specific_sym (sym))
1134 return PTYPE_SPECIFIC;
1136 return PTYPE_UNKNOWN;
1139 /* Check references to assumed size arrays. The flag need_full_assumed_size
1140 is nonzero when matching actual arguments. */
1142 static int need_full_assumed_size = 0;
1145 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1147 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1150 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1151 What should it be? */
1152 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1153 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1154 && (e->ref->u.ar.type == AR_FULL))
1156 gfc_error ("The upper bound in the last dimension must "
1157 "appear in the reference to the assumed size "
1158 "array '%s' at %L", sym->name, &e->where);
1165 /* Look for bad assumed size array references in argument expressions
1166 of elemental and array valued intrinsic procedures. Since this is
1167 called from procedure resolution functions, it only recurses at
1171 resolve_assumed_size_actual (gfc_expr *e)
1176 switch (e->expr_type)
1179 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1184 if (resolve_assumed_size_actual (e->value.op.op1)
1185 || resolve_assumed_size_actual (e->value.op.op2))
1196 /* Check a generic procedure, passed as an actual argument, to see if
1197 there is a matching specific name. If none, it is an error, and if
1198 more than one, the reference is ambiguous. */
1200 count_specific_procs (gfc_expr *e)
1207 sym = e->symtree->n.sym;
1209 for (p = sym->generic; p; p = p->next)
1210 if (strcmp (sym->name, p->sym->name) == 0)
1212 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1218 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1222 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1223 "argument at %L", sym->name, &e->where);
1229 /* See if a call to sym could possibly be a not allowed RECURSION because of
1230 a missing RECURIVE declaration. This means that either sym is the current
1231 context itself, or sym is the parent of a contained procedure calling its
1232 non-RECURSIVE containing procedure.
1233 This also works if sym is an ENTRY. */
1236 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1238 gfc_symbol* proc_sym;
1239 gfc_symbol* context_proc;
1240 gfc_namespace* real_context;
1242 if (sym->attr.flavor == FL_PROGRAM)
1245 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1247 /* If we've got an ENTRY, find real procedure. */
1248 if (sym->attr.entry && sym->ns->entries)
1249 proc_sym = sym->ns->entries->sym;
1253 /* If sym is RECURSIVE, all is well of course. */
1254 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1257 /* Find the context procedure's "real" symbol if it has entries.
1258 We look for a procedure symbol, so recurse on the parents if we don't
1259 find one (like in case of a BLOCK construct). */
1260 for (real_context = context; ; real_context = real_context->parent)
1262 /* We should find something, eventually! */
1263 gcc_assert (real_context);
1265 context_proc = (real_context->entries ? real_context->entries->sym
1266 : real_context->proc_name);
1268 /* In some special cases, there may not be a proc_name, like for this
1270 real(bad_kind()) function foo () ...
1271 when checking the call to bad_kind ().
1272 In these cases, we simply return here and assume that the
1277 if (context_proc->attr.flavor != FL_LABEL)
1281 /* A call from sym's body to itself is recursion, of course. */
1282 if (context_proc == proc_sym)
1285 /* The same is true if context is a contained procedure and sym the
1287 if (context_proc->attr.contained)
1289 gfc_symbol* parent_proc;
1291 gcc_assert (context->parent);
1292 parent_proc = (context->parent->entries ? context->parent->entries->sym
1293 : context->parent->proc_name);
1295 if (parent_proc == proc_sym)
1303 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1304 its typespec and formal argument list. */
1307 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1309 gfc_intrinsic_sym* isym;
1315 /* We already know this one is an intrinsic, so we don't call
1316 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1317 gfc_find_subroutine directly to check whether it is a function or
1320 if ((isym = gfc_find_function (sym->name)))
1322 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1323 && !sym->attr.implicit_type)
1324 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1325 " ignored", sym->name, &sym->declared_at);
1327 if (!sym->attr.function &&
1328 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1333 else if ((isym = gfc_find_subroutine (sym->name)))
1335 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1337 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1338 " specifier", sym->name, &sym->declared_at);
1342 if (!sym->attr.subroutine &&
1343 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1348 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1353 gfc_copy_formal_args_intr (sym, isym);
1355 /* Check it is actually available in the standard settings. */
1356 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1359 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1360 " available in the current standard settings but %s. Use"
1361 " an appropriate -std=* option or enable -fall-intrinsics"
1362 " in order to use it.",
1363 sym->name, &sym->declared_at, symstd);
1371 /* Resolve a procedure expression, like passing it to a called procedure or as
1372 RHS for a procedure pointer assignment. */
1375 resolve_procedure_expression (gfc_expr* expr)
1379 if (expr->expr_type != EXPR_VARIABLE)
1381 gcc_assert (expr->symtree);
1383 sym = expr->symtree->n.sym;
1385 if (sym->attr.intrinsic)
1386 resolve_intrinsic (sym, &expr->where);
1388 if (sym->attr.flavor != FL_PROCEDURE
1389 || (sym->attr.function && sym->result == sym))
1392 /* A non-RECURSIVE procedure that is used as procedure expression within its
1393 own body is in danger of being called recursively. */
1394 if (is_illegal_recursion (sym, gfc_current_ns))
1395 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1396 " itself recursively. Declare it RECURSIVE or use"
1397 " -frecursive", sym->name, &expr->where);
1403 /* Resolve an actual argument list. Most of the time, this is just
1404 resolving the expressions in the list.
1405 The exception is that we sometimes have to decide whether arguments
1406 that look like procedure arguments are really simple variable
1410 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1411 bool no_formal_args)
1414 gfc_symtree *parent_st;
1416 int save_need_full_assumed_size;
1417 gfc_component *comp;
1419 for (; arg; arg = arg->next)
1424 /* Check the label is a valid branching target. */
1427 if (arg->label->defined == ST_LABEL_UNKNOWN)
1429 gfc_error ("Label %d referenced at %L is never defined",
1430 arg->label->value, &arg->label->where);
1437 if (gfc_is_proc_ptr_comp (e, &comp))
1440 if (e->expr_type == EXPR_PPC)
1442 if (comp->as != NULL)
1443 e->rank = comp->as->rank;
1444 e->expr_type = EXPR_FUNCTION;
1446 if (gfc_resolve_expr (e) == FAILURE)
1451 if (e->expr_type == EXPR_VARIABLE
1452 && e->symtree->n.sym->attr.generic
1454 && count_specific_procs (e) != 1)
1457 if (e->ts.type != BT_PROCEDURE)
1459 save_need_full_assumed_size = need_full_assumed_size;
1460 if (e->expr_type != EXPR_VARIABLE)
1461 need_full_assumed_size = 0;
1462 if (gfc_resolve_expr (e) != SUCCESS)
1464 need_full_assumed_size = save_need_full_assumed_size;
1468 /* See if the expression node should really be a variable reference. */
1470 sym = e->symtree->n.sym;
1472 if (sym->attr.flavor == FL_PROCEDURE
1473 || sym->attr.intrinsic
1474 || sym->attr.external)
1478 /* If a procedure is not already determined to be something else
1479 check if it is intrinsic. */
1480 if (!sym->attr.intrinsic
1481 && !(sym->attr.external || sym->attr.use_assoc
1482 || sym->attr.if_source == IFSRC_IFBODY)
1483 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1484 sym->attr.intrinsic = 1;
1486 if (sym->attr.proc == PROC_ST_FUNCTION)
1488 gfc_error ("Statement function '%s' at %L is not allowed as an "
1489 "actual argument", sym->name, &e->where);
1492 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1493 sym->attr.subroutine);
1494 if (sym->attr.intrinsic && actual_ok == 0)
1496 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1497 "actual argument", sym->name, &e->where);
1500 if (sym->attr.contained && !sym->attr.use_assoc
1501 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1503 gfc_error ("Internal procedure '%s' is not allowed as an "
1504 "actual argument at %L", sym->name, &e->where);
1507 if (sym->attr.elemental && !sym->attr.intrinsic)
1509 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1510 "allowed as an actual argument at %L", sym->name,
1514 /* Check if a generic interface has a specific procedure
1515 with the same name before emitting an error. */
1516 if (sym->attr.generic && count_specific_procs (e) != 1)
1519 /* Just in case a specific was found for the expression. */
1520 sym = e->symtree->n.sym;
1522 /* If the symbol is the function that names the current (or
1523 parent) scope, then we really have a variable reference. */
1525 if (gfc_is_function_return_value (sym, sym->ns))
1528 /* If all else fails, see if we have a specific intrinsic. */
1529 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1531 gfc_intrinsic_sym *isym;
1533 isym = gfc_find_function (sym->name);
1534 if (isym == NULL || !isym->specific)
1536 gfc_error ("Unable to find a specific INTRINSIC procedure "
1537 "for the reference '%s' at %L", sym->name,
1542 sym->attr.intrinsic = 1;
1543 sym->attr.function = 1;
1546 if (gfc_resolve_expr (e) == FAILURE)
1551 /* See if the name is a module procedure in a parent unit. */
1553 if (was_declared (sym) || sym->ns->parent == NULL)
1556 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1558 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1562 if (parent_st == NULL)
1565 sym = parent_st->n.sym;
1566 e->symtree = parent_st; /* Point to the right thing. */
1568 if (sym->attr.flavor == FL_PROCEDURE
1569 || sym->attr.intrinsic
1570 || sym->attr.external)
1572 if (gfc_resolve_expr (e) == FAILURE)
1578 e->expr_type = EXPR_VARIABLE;
1580 if (sym->as != NULL)
1582 e->rank = sym->as->rank;
1583 e->ref = gfc_get_ref ();
1584 e->ref->type = REF_ARRAY;
1585 e->ref->u.ar.type = AR_FULL;
1586 e->ref->u.ar.as = sym->as;
1589 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1590 primary.c (match_actual_arg). If above code determines that it
1591 is a variable instead, it needs to be resolved as it was not
1592 done at the beginning of this function. */
1593 save_need_full_assumed_size = need_full_assumed_size;
1594 if (e->expr_type != EXPR_VARIABLE)
1595 need_full_assumed_size = 0;
1596 if (gfc_resolve_expr (e) != SUCCESS)
1598 need_full_assumed_size = save_need_full_assumed_size;
1601 /* Check argument list functions %VAL, %LOC and %REF. There is
1602 nothing to do for %REF. */
1603 if (arg->name && arg->name[0] == '%')
1605 if (strncmp ("%VAL", arg->name, 4) == 0)
1607 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1609 gfc_error ("By-value argument at %L is not of numeric "
1616 gfc_error ("By-value argument at %L cannot be an array or "
1617 "an array section", &e->where);
1621 /* Intrinsics are still PROC_UNKNOWN here. However,
1622 since same file external procedures are not resolvable
1623 in gfortran, it is a good deal easier to leave them to
1625 if (ptype != PROC_UNKNOWN
1626 && ptype != PROC_DUMMY
1627 && ptype != PROC_EXTERNAL
1628 && ptype != PROC_MODULE)
1630 gfc_error ("By-value argument at %L is not allowed "
1631 "in this context", &e->where);
1636 /* Statement functions have already been excluded above. */
1637 else if (strncmp ("%LOC", arg->name, 4) == 0
1638 && e->ts.type == BT_PROCEDURE)
1640 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1642 gfc_error ("Passing internal procedure at %L by location "
1643 "not allowed", &e->where);
1649 /* Fortran 2008, C1237. */
1650 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1651 && gfc_has_ultimate_pointer (e))
1653 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1654 "component", &e->where);
1663 /* Do the checks of the actual argument list that are specific to elemental
1664 procedures. If called with c == NULL, we have a function, otherwise if
1665 expr == NULL, we have a subroutine. */
1668 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1670 gfc_actual_arglist *arg0;
1671 gfc_actual_arglist *arg;
1672 gfc_symbol *esym = NULL;
1673 gfc_intrinsic_sym *isym = NULL;
1675 gfc_intrinsic_arg *iformal = NULL;
1676 gfc_formal_arglist *eformal = NULL;
1677 bool formal_optional = false;
1678 bool set_by_optional = false;
1682 /* Is this an elemental procedure? */
1683 if (expr && expr->value.function.actual != NULL)
1685 if (expr->value.function.esym != NULL
1686 && expr->value.function.esym->attr.elemental)
1688 arg0 = expr->value.function.actual;
1689 esym = expr->value.function.esym;
1691 else if (expr->value.function.isym != NULL
1692 && expr->value.function.isym->elemental)
1694 arg0 = expr->value.function.actual;
1695 isym = expr->value.function.isym;
1700 else if (c && c->ext.actual != NULL)
1702 arg0 = c->ext.actual;
1704 if (c->resolved_sym)
1705 esym = c->resolved_sym;
1707 esym = c->symtree->n.sym;
1710 if (!esym->attr.elemental)
1716 /* The rank of an elemental is the rank of its array argument(s). */
1717 for (arg = arg0; arg; arg = arg->next)
1719 if (arg->expr != NULL && arg->expr->rank > 0)
1721 rank = arg->expr->rank;
1722 if (arg->expr->expr_type == EXPR_VARIABLE
1723 && arg->expr->symtree->n.sym->attr.optional)
1724 set_by_optional = true;
1726 /* Function specific; set the result rank and shape. */
1730 if (!expr->shape && arg->expr->shape)
1732 expr->shape = gfc_get_shape (rank);
1733 for (i = 0; i < rank; i++)
1734 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1741 /* If it is an array, it shall not be supplied as an actual argument
1742 to an elemental procedure unless an array of the same rank is supplied
1743 as an actual argument corresponding to a nonoptional dummy argument of
1744 that elemental procedure(12.4.1.5). */
1745 formal_optional = false;
1747 iformal = isym->formal;
1749 eformal = esym->formal;
1751 for (arg = arg0; arg; arg = arg->next)
1755 if (eformal->sym && eformal->sym->attr.optional)
1756 formal_optional = true;
1757 eformal = eformal->next;
1759 else if (isym && iformal)
1761 if (iformal->optional)
1762 formal_optional = true;
1763 iformal = iformal->next;
1766 formal_optional = true;
1768 if (pedantic && arg->expr != NULL
1769 && arg->expr->expr_type == EXPR_VARIABLE
1770 && arg->expr->symtree->n.sym->attr.optional
1773 && (set_by_optional || arg->expr->rank != rank)
1774 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1776 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1777 "MISSING, it cannot be the actual argument of an "
1778 "ELEMENTAL procedure unless there is a non-optional "
1779 "argument with the same rank (12.4.1.5)",
1780 arg->expr->symtree->n.sym->name, &arg->expr->where);
1785 for (arg = arg0; arg; arg = arg->next)
1787 if (arg->expr == NULL || arg->expr->rank == 0)
1790 /* Being elemental, the last upper bound of an assumed size array
1791 argument must be present. */
1792 if (resolve_assumed_size_actual (arg->expr))
1795 /* Elemental procedure's array actual arguments must conform. */
1798 if (gfc_check_conformance (arg->expr, e,
1799 "elemental procedure") == FAILURE)
1806 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1807 is an array, the intent inout/out variable needs to be also an array. */
1808 if (rank > 0 && esym && expr == NULL)
1809 for (eformal = esym->formal, arg = arg0; arg && eformal;
1810 arg = arg->next, eformal = eformal->next)
1811 if ((eformal->sym->attr.intent == INTENT_OUT
1812 || eformal->sym->attr.intent == INTENT_INOUT)
1813 && arg->expr && arg->expr->rank == 0)
1815 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1816 "ELEMENTAL subroutine '%s' is a scalar, but another "
1817 "actual argument is an array", &arg->expr->where,
1818 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1819 : "INOUT", eformal->sym->name, esym->name);
1826 /* Go through each actual argument in ACTUAL and see if it can be
1827 implemented as an inlined, non-copying intrinsic. FNSYM is the
1828 function being called, or NULL if not known. */
1831 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1833 gfc_actual_arglist *ap;
1836 for (ap = actual; ap; ap = ap->next)
1838 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1839 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1841 ap->expr->inline_noncopying_intrinsic = 1;
1845 /* This function does the checking of references to global procedures
1846 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1847 77 and 95 standards. It checks for a gsymbol for the name, making
1848 one if it does not already exist. If it already exists, then the
1849 reference being resolved must correspond to the type of gsymbol.
1850 Otherwise, the new symbol is equipped with the attributes of the
1851 reference. The corresponding code that is called in creating
1852 global entities is parse.c.
1854 In addition, for all but -std=legacy, the gsymbols are used to
1855 check the interfaces of external procedures from the same file.
1856 The namespace of the gsymbol is resolved and then, once this is
1857 done the interface is checked. */
1861 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1863 if (!gsym_ns->proc_name->attr.recursive)
1866 if (sym->ns == gsym_ns)
1869 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1876 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1878 if (gsym_ns->entries)
1880 gfc_entry_list *entry = gsym_ns->entries;
1882 for (; entry; entry = entry->next)
1884 if (strcmp (sym->name, entry->sym->name) == 0)
1886 if (strcmp (gsym_ns->proc_name->name,
1887 sym->ns->proc_name->name) == 0)
1891 && strcmp (gsym_ns->proc_name->name,
1892 sym->ns->parent->proc_name->name) == 0)
1901 resolve_global_procedure (gfc_symbol *sym, locus *where,
1902 gfc_actual_arglist **actual, int sub)
1906 enum gfc_symbol_type type;
1908 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1910 gsym = gfc_get_gsymbol (sym->name);
1912 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1913 gfc_global_used (gsym, where);
1915 if (gfc_option.flag_whole_file
1916 && (sym->attr.if_source == IFSRC_UNKNOWN
1917 || sym->attr.if_source == IFSRC_IFBODY)
1918 && gsym->type != GSYM_UNKNOWN
1920 && gsym->ns->resolved != -1
1921 && gsym->ns->proc_name
1922 && not_in_recursive (sym, gsym->ns)
1923 && not_entry_self_reference (sym, gsym->ns))
1925 gfc_symbol *def_sym;
1927 /* Resolve the gsymbol namespace if needed. */
1928 if (!gsym->ns->resolved)
1930 gfc_dt_list *old_dt_list;
1932 /* Stash away derived types so that the backend_decls do not
1934 old_dt_list = gfc_derived_types;
1935 gfc_derived_types = NULL;
1937 gfc_resolve (gsym->ns);
1939 /* Store the new derived types with the global namespace. */
1940 if (gfc_derived_types)
1941 gsym->ns->derived_types = gfc_derived_types;
1943 /* Restore the derived types of this namespace. */
1944 gfc_derived_types = old_dt_list;
1947 /* Make sure that translation for the gsymbol occurs before
1948 the procedure currently being resolved. */
1949 ns = gfc_global_ns_list;
1950 for (; ns && ns != gsym->ns; ns = ns->sibling)
1952 if (ns->sibling == gsym->ns)
1954 ns->sibling = gsym->ns->sibling;
1955 gsym->ns->sibling = gfc_global_ns_list;
1956 gfc_global_ns_list = gsym->ns;
1961 def_sym = gsym->ns->proc_name;
1962 if (def_sym->attr.entry_master)
1964 gfc_entry_list *entry;
1965 for (entry = gsym->ns->entries; entry; entry = entry->next)
1966 if (strcmp (entry->sym->name, sym->name) == 0)
1968 def_sym = entry->sym;
1973 /* Differences in constant character lengths. */
1974 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
1976 long int l1 = 0, l2 = 0;
1977 gfc_charlen *cl1 = sym->ts.u.cl;
1978 gfc_charlen *cl2 = def_sym->ts.u.cl;
1981 && cl1->length != NULL
1982 && cl1->length->expr_type == EXPR_CONSTANT)
1983 l1 = mpz_get_si (cl1->length->value.integer);
1986 && cl2->length != NULL
1987 && cl2->length->expr_type == EXPR_CONSTANT)
1988 l2 = mpz_get_si (cl2->length->value.integer);
1990 if (l1 && l2 && l1 != l2)
1991 gfc_error ("Character length mismatch in return type of "
1992 "function '%s' at %L (%ld/%ld)", sym->name,
1993 &sym->declared_at, l1, l2);
1996 /* Type mismatch of function return type and expected type. */
1997 if (sym->attr.function
1998 && !gfc_compare_types (&sym->ts, &def_sym->ts))
1999 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2000 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2001 gfc_typename (&def_sym->ts));
2003 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2005 gfc_formal_arglist *arg = def_sym->formal;
2006 for ( ; arg; arg = arg->next)
2009 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2010 else if (arg->sym->attr.allocatable
2011 || arg->sym->attr.asynchronous
2012 || arg->sym->attr.optional
2013 || arg->sym->attr.pointer
2014 || arg->sym->attr.target
2015 || arg->sym->attr.value
2016 || arg->sym->attr.volatile_)
2018 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2019 "has an attribute that requires an explicit "
2020 "interface for this procedure", arg->sym->name,
2021 sym->name, &sym->declared_at);
2024 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2025 else if (arg->sym && arg->sym->as
2026 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2028 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2029 "argument '%s' must have an explicit interface",
2030 sym->name, &sym->declared_at, arg->sym->name);
2033 /* F2008, 12.4.2.2 (2c) */
2034 else if (arg->sym->attr.codimension)
2036 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2037 "'%s' must have an explicit interface",
2038 sym->name, &sym->declared_at, arg->sym->name);
2041 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2042 else if (false) /* TODO: is a parametrized derived type */
2044 gfc_error ("Procedure '%s' at %L with parametrized derived "
2045 "type argument '%s' must have an explicit "
2046 "interface", sym->name, &sym->declared_at,
2050 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2051 else if (arg->sym->ts.type == BT_CLASS)
2053 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2054 "argument '%s' must have an explicit interface",
2055 sym->name, &sym->declared_at, arg->sym->name);
2060 if (def_sym->attr.function)
2062 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2063 if (def_sym->as && def_sym->as->rank
2064 && (!sym->as || sym->as->rank != def_sym->as->rank))
2065 gfc_error ("The reference to function '%s' at %L either needs an "
2066 "explicit INTERFACE or the rank is incorrect", sym->name,
2069 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2070 if ((def_sym->result->attr.pointer
2071 || def_sym->result->attr.allocatable)
2072 && (sym->attr.if_source != IFSRC_IFBODY
2073 || def_sym->result->attr.pointer
2074 != sym->result->attr.pointer
2075 || def_sym->result->attr.allocatable
2076 != sym->result->attr.allocatable))
2077 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2078 "result must have an explicit interface", sym->name,
2081 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2082 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2083 && def_sym->ts.u.cl->length != NULL)
2085 gfc_charlen *cl = sym->ts.u.cl;
2087 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2088 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2090 gfc_error ("Nonconstant character-length function '%s' at %L "
2091 "must have an explicit interface", sym->name,
2097 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2098 if (def_sym->attr.elemental && !sym->attr.elemental)
2100 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2101 "interface", sym->name, &sym->declared_at);
2104 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2105 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2107 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2108 "an explicit interface", sym->name, &sym->declared_at);
2111 if (gfc_option.flag_whole_file == 1
2112 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2113 && !(gfc_option.warn_std & GFC_STD_GNU)))
2114 gfc_errors_to_warnings (1);
2116 if (sym->attr.if_source != IFSRC_IFBODY)
2117 gfc_procedure_use (def_sym, actual, where);
2119 gfc_errors_to_warnings (0);
2122 if (gsym->type == GSYM_UNKNOWN)
2125 gsym->where = *where;
2132 /************* Function resolution *************/
2134 /* Resolve a function call known to be generic.
2135 Section 14.1.2.4.1. */
2138 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2142 if (sym->attr.generic)
2144 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2147 expr->value.function.name = s->name;
2148 expr->value.function.esym = s;
2150 if (s->ts.type != BT_UNKNOWN)
2152 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2153 expr->ts = s->result->ts;
2156 expr->rank = s->as->rank;
2157 else if (s->result != NULL && s->result->as != NULL)
2158 expr->rank = s->result->as->rank;
2160 gfc_set_sym_referenced (expr->value.function.esym);
2165 /* TODO: Need to search for elemental references in generic
2169 if (sym->attr.intrinsic)
2170 return gfc_intrinsic_func_interface (expr, 0);
2177 resolve_generic_f (gfc_expr *expr)
2182 sym = expr->symtree->n.sym;
2186 m = resolve_generic_f0 (expr, sym);
2189 else if (m == MATCH_ERROR)
2193 if (sym->ns->parent == NULL)
2195 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2199 if (!generic_sym (sym))
2203 /* Last ditch attempt. See if the reference is to an intrinsic
2204 that possesses a matching interface. 14.1.2.4 */
2205 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2207 gfc_error ("There is no specific function for the generic '%s' at %L",
2208 expr->symtree->n.sym->name, &expr->where);
2212 m = gfc_intrinsic_func_interface (expr, 0);
2216 gfc_error ("Generic function '%s' at %L is not consistent with a "
2217 "specific intrinsic interface", expr->symtree->n.sym->name,
2224 /* Resolve a function call known to be specific. */
2227 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2231 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2233 if (sym->attr.dummy)
2235 sym->attr.proc = PROC_DUMMY;
2239 sym->attr.proc = PROC_EXTERNAL;
2243 if (sym->attr.proc == PROC_MODULE
2244 || sym->attr.proc == PROC_ST_FUNCTION
2245 || sym->attr.proc == PROC_INTERNAL)
2248 if (sym->attr.intrinsic)
2250 m = gfc_intrinsic_func_interface (expr, 1);
2254 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2255 "with an intrinsic", sym->name, &expr->where);
2263 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2266 expr->ts = sym->result->ts;
2269 expr->value.function.name = sym->name;
2270 expr->value.function.esym = sym;
2271 if (sym->as != NULL)
2272 expr->rank = sym->as->rank;
2279 resolve_specific_f (gfc_expr *expr)
2284 sym = expr->symtree->n.sym;
2288 m = resolve_specific_f0 (sym, expr);
2291 if (m == MATCH_ERROR)
2294 if (sym->ns->parent == NULL)
2297 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2303 gfc_error ("Unable to resolve the specific function '%s' at %L",
2304 expr->symtree->n.sym->name, &expr->where);
2310 /* Resolve a procedure call not known to be generic nor specific. */
2313 resolve_unknown_f (gfc_expr *expr)
2318 sym = expr->symtree->n.sym;
2320 if (sym->attr.dummy)
2322 sym->attr.proc = PROC_DUMMY;
2323 expr->value.function.name = sym->name;
2327 /* See if we have an intrinsic function reference. */
2329 if (gfc_is_intrinsic (sym, 0, expr->where))
2331 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2336 /* The reference is to an external name. */
2338 sym->attr.proc = PROC_EXTERNAL;
2339 expr->value.function.name = sym->name;
2340 expr->value.function.esym = expr->symtree->n.sym;
2342 if (sym->as != NULL)
2343 expr->rank = sym->as->rank;
2345 /* Type of the expression is either the type of the symbol or the
2346 default type of the symbol. */
2349 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2351 if (sym->ts.type != BT_UNKNOWN)
2355 ts = gfc_get_default_type (sym->name, sym->ns);
2357 if (ts->type == BT_UNKNOWN)
2359 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2360 sym->name, &expr->where);
2371 /* Return true, if the symbol is an external procedure. */
2373 is_external_proc (gfc_symbol *sym)
2375 if (!sym->attr.dummy && !sym->attr.contained
2376 && !(sym->attr.intrinsic
2377 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2378 && sym->attr.proc != PROC_ST_FUNCTION
2379 && !sym->attr.proc_pointer
2380 && !sym->attr.use_assoc
2388 /* Figure out if a function reference is pure or not. Also set the name
2389 of the function for a potential error message. Return nonzero if the
2390 function is PURE, zero if not. */
2392 pure_stmt_function (gfc_expr *, gfc_symbol *);
2395 pure_function (gfc_expr *e, const char **name)
2401 if (e->symtree != NULL
2402 && e->symtree->n.sym != NULL
2403 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2404 return pure_stmt_function (e, e->symtree->n.sym);
2406 if (e->value.function.esym)
2408 pure = gfc_pure (e->value.function.esym);
2409 *name = e->value.function.esym->name;
2411 else if (e->value.function.isym)
2413 pure = e->value.function.isym->pure
2414 || e->value.function.isym->elemental;
2415 *name = e->value.function.isym->name;
2419 /* Implicit functions are not pure. */
2421 *name = e->value.function.name;
2429 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2430 int *f ATTRIBUTE_UNUSED)
2434 /* Don't bother recursing into other statement functions
2435 since they will be checked individually for purity. */
2436 if (e->expr_type != EXPR_FUNCTION
2438 || e->symtree->n.sym == sym
2439 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2442 return pure_function (e, &name) ? false : true;
2447 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2449 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2454 is_scalar_expr_ptr (gfc_expr *expr)
2456 gfc_try retval = SUCCESS;
2461 /* See if we have a gfc_ref, which means we have a substring, array
2462 reference, or a component. */
2463 if (expr->ref != NULL)
2466 while (ref->next != NULL)
2472 if (ref->u.ss.length != NULL
2473 && ref->u.ss.length->length != NULL
2475 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2477 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2479 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2480 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2481 if (end - start + 1 != 1)
2488 if (ref->u.ar.type == AR_ELEMENT)
2490 else if (ref->u.ar.type == AR_FULL)
2492 /* The user can give a full array if the array is of size 1. */
2493 if (ref->u.ar.as != NULL
2494 && ref->u.ar.as->rank == 1
2495 && ref->u.ar.as->type == AS_EXPLICIT
2496 && ref->u.ar.as->lower[0] != NULL
2497 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2498 && ref->u.ar.as->upper[0] != NULL
2499 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2501 /* If we have a character string, we need to check if
2502 its length is one. */
2503 if (expr->ts.type == BT_CHARACTER)
2505 if (expr->ts.u.cl == NULL
2506 || expr->ts.u.cl->length == NULL
2507 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2513 /* We have constant lower and upper bounds. If the
2514 difference between is 1, it can be considered a
2516 start = (int) mpz_get_si
2517 (ref->u.ar.as->lower[0]->value.integer);
2518 end = (int) mpz_get_si
2519 (ref->u.ar.as->upper[0]->value.integer);
2520 if (end - start + 1 != 1)
2535 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2537 /* Character string. Make sure it's of length 1. */
2538 if (expr->ts.u.cl == NULL
2539 || expr->ts.u.cl->length == NULL
2540 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2543 else if (expr->rank != 0)
2550 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2551 and, in the case of c_associated, set the binding label based on
2555 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2556 gfc_symbol **new_sym)
2558 char name[GFC_MAX_SYMBOL_LEN + 1];
2559 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2560 int optional_arg = 0;
2561 gfc_try retval = SUCCESS;
2562 gfc_symbol *args_sym;
2563 gfc_typespec *arg_ts;
2564 symbol_attribute arg_attr;
2566 if (args->expr->expr_type == EXPR_CONSTANT
2567 || args->expr->expr_type == EXPR_OP
2568 || args->expr->expr_type == EXPR_NULL)
2570 gfc_error ("Argument to '%s' at %L is not a variable",
2571 sym->name, &(args->expr->where));
2575 args_sym = args->expr->symtree->n.sym;
2577 /* The typespec for the actual arg should be that stored in the expr
2578 and not necessarily that of the expr symbol (args_sym), because
2579 the actual expression could be a part-ref of the expr symbol. */
2580 arg_ts = &(args->expr->ts);
2581 arg_attr = gfc_expr_attr (args->expr);
2583 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2585 /* If the user gave two args then they are providing something for
2586 the optional arg (the second cptr). Therefore, set the name and
2587 binding label to the c_associated for two cptrs. Otherwise,
2588 set c_associated to expect one cptr. */
2592 sprintf (name, "%s_2", sym->name);
2593 sprintf (binding_label, "%s_2", sym->binding_label);
2599 sprintf (name, "%s_1", sym->name);
2600 sprintf (binding_label, "%s_1", sym->binding_label);
2604 /* Get a new symbol for the version of c_associated that
2606 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2608 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2609 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2611 sprintf (name, "%s", sym->name);
2612 sprintf (binding_label, "%s", sym->binding_label);
2614 /* Error check the call. */
2615 if (args->next != NULL)
2617 gfc_error_now ("More actual than formal arguments in '%s' "
2618 "call at %L", name, &(args->expr->where));
2621 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2623 /* Make sure we have either the target or pointer attribute. */
2624 if (!arg_attr.target && !arg_attr.pointer)
2626 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2627 "a TARGET or an associated pointer",
2629 sym->name, &(args->expr->where));
2633 /* See if we have interoperable type and type param. */
2634 if (verify_c_interop (arg_ts) == SUCCESS
2635 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2637 if (args_sym->attr.target == 1)
2639 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2640 has the target attribute and is interoperable. */
2641 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2642 allocatable variable that has the TARGET attribute and
2643 is not an array of zero size. */
2644 if (args_sym->attr.allocatable == 1)
2646 if (args_sym->attr.dimension != 0
2647 && (args_sym->as && args_sym->as->rank == 0))
2649 gfc_error_now ("Allocatable variable '%s' used as a "
2650 "parameter to '%s' at %L must not be "
2651 "an array of zero size",
2652 args_sym->name, sym->name,
2653 &(args->expr->where));
2659 /* A non-allocatable target variable with C
2660 interoperable type and type parameters must be
2662 if (args_sym && args_sym->attr.dimension)
2664 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2666 gfc_error ("Assumed-shape array '%s' at %L "
2667 "cannot be an argument to the "
2668 "procedure '%s' because "
2669 "it is not C interoperable",
2671 &(args->expr->where), sym->name);
2674 else if (args_sym->as->type == AS_DEFERRED)
2676 gfc_error ("Deferred-shape array '%s' at %L "
2677 "cannot be an argument to the "
2678 "procedure '%s' because "
2679 "it is not C interoperable",
2681 &(args->expr->where), sym->name);
2686 /* Make sure it's not a character string. Arrays of
2687 any type should be ok if the variable is of a C
2688 interoperable type. */
2689 if (arg_ts->type == BT_CHARACTER)
2690 if (arg_ts->u.cl != NULL
2691 && (arg_ts->u.cl->length == NULL
2692 || arg_ts->u.cl->length->expr_type
2695 (arg_ts->u.cl->length->value.integer, 1)
2697 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2699 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2700 "at %L must have a length of 1",
2701 args_sym->name, sym->name,
2702 &(args->expr->where));
2707 else if (arg_attr.pointer
2708 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2710 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2712 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2713 "associated scalar POINTER", args_sym->name,
2714 sym->name, &(args->expr->where));
2720 /* The parameter is not required to be C interoperable. If it
2721 is not C interoperable, it must be a nonpolymorphic scalar
2722 with no length type parameters. It still must have either
2723 the pointer or target attribute, and it can be
2724 allocatable (but must be allocated when c_loc is called). */
2725 if (args->expr->rank != 0
2726 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2728 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2729 "scalar", args_sym->name, sym->name,
2730 &(args->expr->where));
2733 else if (arg_ts->type == BT_CHARACTER
2734 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2736 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2737 "%L must have a length of 1",
2738 args_sym->name, sym->name,
2739 &(args->expr->where));
2742 else if (arg_ts->type == BT_CLASS)
2744 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2745 "polymorphic", args_sym->name, sym->name,
2746 &(args->expr->where));
2751 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2753 if (args_sym->attr.flavor != FL_PROCEDURE)
2755 /* TODO: Update this error message to allow for procedure
2756 pointers once they are implemented. */
2757 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2759 args_sym->name, sym->name,
2760 &(args->expr->where));
2763 else if (args_sym->attr.is_bind_c != 1)
2765 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2767 args_sym->name, sym->name,
2768 &(args->expr->where));
2773 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2778 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2779 "iso_c_binding function: '%s'!\n", sym->name);
2786 /* Resolve a function call, which means resolving the arguments, then figuring
2787 out which entity the name refers to. */
2788 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2789 to INTENT(OUT) or INTENT(INOUT). */
2792 resolve_function (gfc_expr *expr)
2794 gfc_actual_arglist *arg;
2799 procedure_type p = PROC_INTRINSIC;
2800 bool no_formal_args;
2804 sym = expr->symtree->n.sym;
2806 /* If this is a procedure pointer component, it has already been resolved. */
2807 if (gfc_is_proc_ptr_comp (expr, NULL))
2810 if (sym && sym->attr.intrinsic
2811 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2814 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2816 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2820 /* If this ia a deferred TBP with an abstract interface (which may
2821 of course be referenced), expr->value.function.esym will be set. */
2822 if (sym && sym->attr.abstract && !expr->value.function.esym)
2824 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2825 sym->name, &expr->where);
2829 /* Switch off assumed size checking and do this again for certain kinds
2830 of procedure, once the procedure itself is resolved. */
2831 need_full_assumed_size++;
2833 if (expr->symtree && expr->symtree->n.sym)
2834 p = expr->symtree->n.sym->attr.proc;
2836 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2837 inquiry_argument = true;
2838 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2840 if (resolve_actual_arglist (expr->value.function.actual,
2841 p, no_formal_args) == FAILURE)
2843 inquiry_argument = false;
2847 inquiry_argument = false;
2849 /* Need to setup the call to the correct c_associated, depending on
2850 the number of cptrs to user gives to compare. */
2851 if (sym && sym->attr.is_iso_c == 1)
2853 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2857 /* Get the symtree for the new symbol (resolved func).
2858 the old one will be freed later, when it's no longer used. */
2859 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2862 /* Resume assumed_size checking. */
2863 need_full_assumed_size--;
2865 /* If the procedure is external, check for usage. */
2866 if (sym && is_external_proc (sym))
2867 resolve_global_procedure (sym, &expr->where,
2868 &expr->value.function.actual, 0);
2870 if (sym && sym->ts.type == BT_CHARACTER
2872 && sym->ts.u.cl->length == NULL
2874 && expr->value.function.esym == NULL
2875 && !sym->attr.contained)
2877 /* Internal procedures are taken care of in resolve_contained_fntype. */
2878 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2879 "be used at %L since it is not a dummy argument",
2880 sym->name, &expr->where);
2884 /* See if function is already resolved. */
2886 if (expr->value.function.name != NULL)
2888 if (expr->ts.type == BT_UNKNOWN)
2894 /* Apply the rules of section 14.1.2. */
2896 switch (procedure_kind (sym))
2899 t = resolve_generic_f (expr);
2902 case PTYPE_SPECIFIC:
2903 t = resolve_specific_f (expr);
2907 t = resolve_unknown_f (expr);
2911 gfc_internal_error ("resolve_function(): bad function type");
2915 /* If the expression is still a function (it might have simplified),
2916 then we check to see if we are calling an elemental function. */
2918 if (expr->expr_type != EXPR_FUNCTION)
2921 temp = need_full_assumed_size;
2922 need_full_assumed_size = 0;
2924 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2927 if (omp_workshare_flag
2928 && expr->value.function.esym
2929 && ! gfc_elemental (expr->value.function.esym))
2931 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2932 "in WORKSHARE construct", expr->value.function.esym->name,
2937 #define GENERIC_ID expr->value.function.isym->id
2938 else if (expr->value.function.actual != NULL
2939 && expr->value.function.isym != NULL
2940 && GENERIC_ID != GFC_ISYM_LBOUND
2941 && GENERIC_ID != GFC_ISYM_LEN
2942 && GENERIC_ID != GFC_ISYM_LOC
2943 && GENERIC_ID != GFC_ISYM_PRESENT)
2945 /* Array intrinsics must also have the last upper bound of an
2946 assumed size array argument. UBOUND and SIZE have to be
2947 excluded from the check if the second argument is anything
2950 for (arg = expr->value.function.actual; arg; arg = arg->next)
2952 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2953 && arg->next != NULL && arg->next->expr)
2955 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2958 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2961 if ((int)mpz_get_si (arg->next->expr->value.integer)
2966 if (arg->expr != NULL
2967 && arg->expr->rank > 0
2968 && resolve_assumed_size_actual (arg->expr))
2974 need_full_assumed_size = temp;
2977 if (!pure_function (expr, &name) && name)
2981 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2982 "FORALL %s", name, &expr->where,
2983 forall_flag == 2 ? "mask" : "block");
2986 else if (gfc_pure (NULL))
2988 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2989 "procedure within a PURE procedure", name, &expr->where);
2994 /* Functions without the RECURSIVE attribution are not allowed to
2995 * call themselves. */
2996 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2999 esym = expr->value.function.esym;
3001 if (is_illegal_recursion (esym, gfc_current_ns))
3003 if (esym->attr.entry && esym->ns->entries)
3004 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3005 " function '%s' is not RECURSIVE",
3006 esym->name, &expr->where, esym->ns->entries->sym->name);
3008 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3009 " is not RECURSIVE", esym->name, &expr->where);
3015 /* Character lengths of use associated functions may contains references to
3016 symbols not referenced from the current program unit otherwise. Make sure
3017 those symbols are marked as referenced. */
3019 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3020 && expr->value.function.esym->attr.use_assoc)
3022 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3026 && !((expr->value.function.esym
3027 && expr->value.function.esym->attr.elemental)
3029 (expr->value.function.isym
3030 && expr->value.function.isym->elemental)))
3031 find_noncopying_intrinsics (expr->value.function.esym,
3032 expr->value.function.actual);
3034 /* Make sure that the expression has a typespec that works. */
3035 if (expr->ts.type == BT_UNKNOWN)
3037 if (expr->symtree->n.sym->result
3038 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3039 && !expr->symtree->n.sym->result->attr.proc_pointer)
3040 expr->ts = expr->symtree->n.sym->result->ts;
3047 /************* Subroutine resolution *************/
3050 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3056 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3057 sym->name, &c->loc);
3058 else if (gfc_pure (NULL))
3059 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3065 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3069 if (sym->attr.generic)
3071 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3074 c->resolved_sym = s;
3075 pure_subroutine (c, s);
3079 /* TODO: Need to search for elemental references in generic interface. */
3082 if (sym->attr.intrinsic)
3083 return gfc_intrinsic_sub_interface (c, 0);
3090 resolve_generic_s (gfc_code *c)
3095 sym = c->symtree->n.sym;
3099 m = resolve_generic_s0 (c, sym);
3102 else if (m == MATCH_ERROR)
3106 if (sym->ns->parent == NULL)
3108 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3112 if (!generic_sym (sym))
3116 /* Last ditch attempt. See if the reference is to an intrinsic
3117 that possesses a matching interface. 14.1.2.4 */
3118 sym = c->symtree->n.sym;
3120 if (!gfc_is_intrinsic (sym, 1, c->loc))
3122 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3123 sym->name, &c->loc);
3127 m = gfc_intrinsic_sub_interface (c, 0);
3131 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3132 "intrinsic subroutine interface", sym->name, &c->loc);
3138 /* Set the name and binding label of the subroutine symbol in the call
3139 expression represented by 'c' to include the type and kind of the
3140 second parameter. This function is for resolving the appropriate
3141 version of c_f_pointer() and c_f_procpointer(). For example, a
3142 call to c_f_pointer() for a default integer pointer could have a
3143 name of c_f_pointer_i4. If no second arg exists, which is an error
3144 for these two functions, it defaults to the generic symbol's name
3145 and binding label. */
3148 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3149 char *name, char *binding_label)
3151 gfc_expr *arg = NULL;
3155 /* The second arg of c_f_pointer and c_f_procpointer determines
3156 the type and kind for the procedure name. */
3157 arg = c->ext.actual->next->expr;
3161 /* Set up the name to have the given symbol's name,
3162 plus the type and kind. */
3163 /* a derived type is marked with the type letter 'u' */
3164 if (arg->ts.type == BT_DERIVED)
3167 kind = 0; /* set the kind as 0 for now */
3171 type = gfc_type_letter (arg->ts.type);
3172 kind = arg->ts.kind;
3175 if (arg->ts.type == BT_CHARACTER)
3176 /* Kind info for character strings not needed. */
3179 sprintf (name, "%s_%c%d", sym->name, type, kind);
3180 /* Set up the binding label as the given symbol's label plus
3181 the type and kind. */
3182 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3186 /* If the second arg is missing, set the name and label as
3187 was, cause it should at least be found, and the missing
3188 arg error will be caught by compare_parameters(). */
3189 sprintf (name, "%s", sym->name);
3190 sprintf (binding_label, "%s", sym->binding_label);
3197 /* Resolve a generic version of the iso_c_binding procedure given
3198 (sym) to the specific one based on the type and kind of the
3199 argument(s). Currently, this function resolves c_f_pointer() and
3200 c_f_procpointer based on the type and kind of the second argument
3201 (FPTR). Other iso_c_binding procedures aren't specially handled.
3202 Upon successfully exiting, c->resolved_sym will hold the resolved
3203 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3207 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3209 gfc_symbol *new_sym;
3210 /* this is fine, since we know the names won't use the max */
3211 char name[GFC_MAX_SYMBOL_LEN + 1];
3212 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3213 /* default to success; will override if find error */
3214 match m = MATCH_YES;
3216 /* Make sure the actual arguments are in the necessary order (based on the
3217 formal args) before resolving. */
3218 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3220 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3221 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3223 set_name_and_label (c, sym, name, binding_label);
3225 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3227 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3229 /* Make sure we got a third arg if the second arg has non-zero
3230 rank. We must also check that the type and rank are
3231 correct since we short-circuit this check in
3232 gfc_procedure_use() (called above to sort actual args). */
3233 if (c->ext.actual->next->expr->rank != 0)
3235 if(c->ext.actual->next->next == NULL
3236 || c->ext.actual->next->next->expr == NULL)
3239 gfc_error ("Missing SHAPE parameter for call to %s "
3240 "at %L", sym->name, &(c->loc));
3242 else if (c->ext.actual->next->next->expr->ts.type
3244 || c->ext.actual->next->next->expr->rank != 1)
3247 gfc_error ("SHAPE parameter for call to %s at %L must "
3248 "be a rank 1 INTEGER array", sym->name,
3255 if (m != MATCH_ERROR)
3257 /* the 1 means to add the optional arg to formal list */
3258 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3260 /* for error reporting, say it's declared where the original was */
3261 new_sym->declared_at = sym->declared_at;
3266 /* no differences for c_loc or c_funloc */
3270 /* set the resolved symbol */
3271 if (m != MATCH_ERROR)
3272 c->resolved_sym = new_sym;
3274 c->resolved_sym = sym;
3280 /* Resolve a subroutine call known to be specific. */
3283 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3287 if(sym->attr.is_iso_c)
3289 m = gfc_iso_c_sub_interface (c,sym);
3293 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3295 if (sym->attr.dummy)
3297 sym->attr.proc = PROC_DUMMY;
3301 sym->attr.proc = PROC_EXTERNAL;
3305 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3308 if (sym->attr.intrinsic)
3310 m = gfc_intrinsic_sub_interface (c, 1);
3314 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3315 "with an intrinsic", sym->name, &c->loc);
3323 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3325 c->resolved_sym = sym;
3326 pure_subroutine (c, sym);
3333 resolve_specific_s (gfc_code *c)
3338 sym = c->symtree->n.sym;
3342 m = resolve_specific_s0 (c, sym);
3345 if (m == MATCH_ERROR)
3348 if (sym->ns->parent == NULL)
3351 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3357 sym = c->symtree->n.sym;
3358 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3359 sym->name, &c->loc);
3365 /* Resolve a subroutine call not known to be generic nor specific. */
3368 resolve_unknown_s (gfc_code *c)
3372 sym = c->symtree->n.sym;
3374 if (sym->attr.dummy)
3376 sym->attr.proc = PROC_DUMMY;
3380 /* See if we have an intrinsic function reference. */
3382 if (gfc_is_intrinsic (sym, 1, c->loc))
3384 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3389 /* The reference is to an external name. */
3392 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3394 c->resolved_sym = sym;
3396 pure_subroutine (c, sym);
3402 /* Resolve a subroutine call. Although it was tempting to use the same code
3403 for functions, subroutines and functions are stored differently and this
3404 makes things awkward. */
3407 resolve_call (gfc_code *c)
3410 procedure_type ptype = PROC_INTRINSIC;
3411 gfc_symbol *csym, *sym;
3412 bool no_formal_args;
3414 csym = c->symtree ? c->symtree->n.sym : NULL;
3416 if (csym && csym->ts.type != BT_UNKNOWN)
3418 gfc_error ("'%s' at %L has a type, which is not consistent with "
3419 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3423 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3426 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3427 sym = st ? st->n.sym : NULL;
3428 if (sym && csym != sym
3429 && sym->ns == gfc_current_ns
3430 && sym->attr.flavor == FL_PROCEDURE
3431 && sym->attr.contained)
3434 if (csym->attr.generic)
3435 c->symtree->n.sym = sym;
3438 csym = c->symtree->n.sym;
3442 /* If this ia a deferred TBP with an abstract interface
3443 (which may of course be referenced), c->expr1 will be set. */
3444 if (csym && csym->attr.abstract && !c->expr1)
3446 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3447 csym->name, &c->loc);
3451 /* Subroutines without the RECURSIVE attribution are not allowed to
3452 * call themselves. */
3453 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3455 if (csym->attr.entry && csym->ns->entries)
3456 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3457 " subroutine '%s' is not RECURSIVE",
3458 csym->name, &c->loc, csym->ns->entries->sym->name);
3460 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3461 " is not RECURSIVE", csym->name, &c->loc);
3466 /* Switch off assumed size checking and do this again for certain kinds
3467 of procedure, once the procedure itself is resolved. */
3468 need_full_assumed_size++;
3471 ptype = csym->attr.proc;
3473 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3474 if (resolve_actual_arglist (c->ext.actual, ptype,
3475 no_formal_args) == FAILURE)
3478 /* Resume assumed_size checking. */
3479 need_full_assumed_size--;
3481 /* If external, check for usage. */
3482 if (csym && is_external_proc (csym))
3483 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3486 if (c->resolved_sym == NULL)
3488 c->resolved_isym = NULL;
3489 switch (procedure_kind (csym))
3492 t = resolve_generic_s (c);
3495 case PTYPE_SPECIFIC:
3496 t = resolve_specific_s (c);
3500 t = resolve_unknown_s (c);
3504 gfc_internal_error ("resolve_subroutine(): bad function type");
3508 /* Some checks of elemental subroutine actual arguments. */
3509 if (resolve_elemental_actual (NULL, c) == FAILURE)
3512 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
3513 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3518 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3519 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3520 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3521 if their shapes do not match. If either op1->shape or op2->shape is
3522 NULL, return SUCCESS. */
3525 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3532 if (op1->shape != NULL && op2->shape != NULL)
3534 for (i = 0; i < op1->rank; i++)
3536 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3538 gfc_error ("Shapes for operands at %L and %L are not conformable",
3539 &op1->where, &op2->where);
3550 /* Resolve an operator expression node. This can involve replacing the
3551 operation with a user defined function call. */
3554 resolve_operator (gfc_expr *e)
3556 gfc_expr *op1, *op2;
3558 bool dual_locus_error;
3561 /* Resolve all subnodes-- give them types. */
3563 switch (e->value.op.op)
3566 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3569 /* Fall through... */
3572 case INTRINSIC_UPLUS:
3573 case INTRINSIC_UMINUS:
3574 case INTRINSIC_PARENTHESES:
3575 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3580 /* Typecheck the new node. */
3582 op1 = e->value.op.op1;
3583 op2 = e->value.op.op2;
3584 dual_locus_error = false;
3586 if ((op1 && op1->expr_type == EXPR_NULL)
3587 || (op2 && op2->expr_type == EXPR_NULL))
3589 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3593 switch (e->value.op.op)
3595 case INTRINSIC_UPLUS:
3596 case INTRINSIC_UMINUS:
3597 if (op1->ts.type == BT_INTEGER
3598 || op1->ts.type == BT_REAL
3599 || op1->ts.type == BT_COMPLEX)
3605 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3606 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3609 case INTRINSIC_PLUS:
3610 case INTRINSIC_MINUS:
3611 case INTRINSIC_TIMES:
3612 case INTRINSIC_DIVIDE:
3613 case INTRINSIC_POWER:
3614 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3616 gfc_type_convert_binary (e, 1);
3621 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3622 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3623 gfc_typename (&op2->ts));
3626 case INTRINSIC_CONCAT:
3627 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3628 && op1->ts.kind == op2->ts.kind)
3630 e->ts.type = BT_CHARACTER;
3631 e->ts.kind = op1->ts.kind;
3636 _("Operands of string concatenation operator at %%L are %s/%s"),
3637 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3643 case INTRINSIC_NEQV:
3644 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3646 e->ts.type = BT_LOGICAL;
3647 e->ts.kind = gfc_kind_max (op1, op2);
3648 if (op1->ts.kind < e->ts.kind)
3649 gfc_convert_type (op1, &e->ts, 2);
3650 else if (op2->ts.kind < e->ts.kind)
3651 gfc_convert_type (op2, &e->ts, 2);
3655 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3656 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3657 gfc_typename (&op2->ts));
3662 if (op1->ts.type == BT_LOGICAL)
3664 e->ts.type = BT_LOGICAL;
3665 e->ts.kind = op1->ts.kind;
3669 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3670 gfc_typename (&op1->ts));
3674 case INTRINSIC_GT_OS:
3676 case INTRINSIC_GE_OS:
3678 case INTRINSIC_LT_OS:
3680 case INTRINSIC_LE_OS:
3681 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3683 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3687 /* Fall through... */
3690 case INTRINSIC_EQ_OS:
3692 case INTRINSIC_NE_OS:
3693 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3694 && op1->ts.kind == op2->ts.kind)
3696 e->ts.type = BT_LOGICAL;
3697 e->ts.kind = gfc_default_logical_kind;
3701 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3703 gfc_type_convert_binary (e, 1);
3705 e->ts.type = BT_LOGICAL;
3706 e->ts.kind = gfc_default_logical_kind;
3710 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3712 _("Logicals at %%L must be compared with %s instead of %s"),
3713 (e->value.op.op == INTRINSIC_EQ
3714 || e->value.op.op == INTRINSIC_EQ_OS)
3715 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3718 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3719 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3720 gfc_typename (&op2->ts));
3724 case INTRINSIC_USER:
3725 if (e->value.op.uop->op == NULL)
3726 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3727 else if (op2 == NULL)
3728 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3729 e->value.op.uop->name, gfc_typename (&op1->ts));
3731 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3732 e->value.op.uop->name, gfc_typename (&op1->ts),
3733 gfc_typename (&op2->ts));
3737 case INTRINSIC_PARENTHESES:
3739 if (e->ts.type == BT_CHARACTER)
3740 e->ts.u.cl = op1->ts.u.cl;
3744 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3747 /* Deal with arrayness of an operand through an operator. */
3751 switch (e->value.op.op)
3753 case INTRINSIC_PLUS:
3754 case INTRINSIC_MINUS:
3755 case INTRINSIC_TIMES:
3756 case INTRINSIC_DIVIDE:
3757 case INTRINSIC_POWER:
3758 case INTRINSIC_CONCAT:
3762 case INTRINSIC_NEQV:
3764 case INTRINSIC_EQ_OS:
3766 case INTRINSIC_NE_OS:
3768 case INTRINSIC_GT_OS:
3770 case INTRINSIC_GE_OS:
3772 case INTRINSIC_LT_OS:
3774 case INTRINSIC_LE_OS:
3776 if (op1->rank == 0 && op2->rank == 0)
3779 if (op1->rank == 0 && op2->rank != 0)
3781 e->rank = op2->rank;
3783 if (e->shape == NULL)
3784 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3787 if (op1->rank != 0 && op2->rank == 0)
3789 e->rank = op1->rank;
3791 if (e->shape == NULL)
3792 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3795 if (op1->rank != 0 && op2->rank != 0)
3797 if (op1->rank == op2->rank)
3799 e->rank = op1->rank;
3800 if (e->shape == NULL)
3802 t = compare_shapes (op1, op2);
3806 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3811 /* Allow higher level expressions to work. */
3814 /* Try user-defined operators, and otherwise throw an error. */
3815 dual_locus_error = true;
3817 _("Inconsistent ranks for operator at %%L and %%L"));
3824 case INTRINSIC_PARENTHESES:
3826 case INTRINSIC_UPLUS:
3827 case INTRINSIC_UMINUS:
3828 /* Simply copy arrayness attribute */
3829 e->rank = op1->rank;
3831 if (e->shape == NULL)
3832 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3840 /* Attempt to simplify the expression. */
3843 t = gfc_simplify_expr (e, 0);
3844 /* Some calls do not succeed in simplification and return FAILURE
3845 even though there is no error; e.g. variable references to
3846 PARAMETER arrays. */
3847 if (!gfc_is_constant_expr (e))
3856 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3863 if (dual_locus_error)
3864 gfc_error (msg, &op1->where, &op2->where);
3866 gfc_error (msg, &e->where);
3872 /************** Array resolution subroutines **************/
3875 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3878 /* Compare two integer expressions. */
3881 compare_bound (gfc_expr *a, gfc_expr *b)
3885 if (a == NULL || a->expr_type != EXPR_CONSTANT
3886 || b == NULL || b->expr_type != EXPR_CONSTANT)
3889 /* If either of the types isn't INTEGER, we must have
3890 raised an error earlier. */
3892 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3895 i = mpz_cmp (a->value.integer, b->value.integer);
3905 /* Compare an integer expression with an integer. */
3908 compare_bound_int (gfc_expr *a, int b)
3912 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3915 if (a->ts.type != BT_INTEGER)
3916 gfc_internal_error ("compare_bound_int(): Bad expression");
3918 i = mpz_cmp_si (a->value.integer, b);
3928 /* Compare an integer expression with a mpz_t. */
3931 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3935 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3938 if (a->ts.type != BT_INTEGER)
3939 gfc_internal_error ("compare_bound_int(): Bad expression");
3941 i = mpz_cmp (a->value.integer, b);
3951 /* Compute the last value of a sequence given by a triplet.
3952 Return 0 if it wasn't able to compute the last value, or if the
3953 sequence if empty, and 1 otherwise. */
3956 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3957 gfc_expr *stride, mpz_t last)
3961 if (start == NULL || start->expr_type != EXPR_CONSTANT
3962 || end == NULL || end->expr_type != EXPR_CONSTANT
3963 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3966 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3967 || (stride != NULL && stride->ts.type != BT_INTEGER))
3970 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3972 if (compare_bound (start, end) == CMP_GT)
3974 mpz_set (last, end->value.integer);
3978 if (compare_bound_int (stride, 0) == CMP_GT)
3980 /* Stride is positive */
3981 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3986 /* Stride is negative */
3987 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3992 mpz_sub (rem, end->value.integer, start->value.integer);
3993 mpz_tdiv_r (rem, rem, stride->value.integer);
3994 mpz_sub (last, end->value.integer, rem);
4001 /* Compare a single dimension of an array reference to the array
4005 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4009 if (ar->dimen_type[i] == DIMEN_STAR)
4011 gcc_assert (ar->stride[i] == NULL);
4012 /* This implies [*] as [*:] and [*:3] are not possible. */
4013 if (ar->start[i] == NULL)
4015 gcc_assert (ar->end[i] == NULL);
4020 /* Given start, end and stride values, calculate the minimum and
4021 maximum referenced indexes. */
4023 switch (ar->dimen_type[i])
4030 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4033 gfc_warning ("Array reference at %L is out of bounds "
4034 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4035 mpz_get_si (ar->start[i]->value.integer),
4036 mpz_get_si (as->lower[i]->value.integer), i+1);
4038 gfc_warning ("Array reference at %L is out of bounds "
4039 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4040 mpz_get_si (ar->start[i]->value.integer),
4041 mpz_get_si (as->lower[i]->value.integer),
4045 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4048 gfc_warning ("Array reference at %L is out of bounds "
4049 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4050 mpz_get_si (ar->start[i]->value.integer),
4051 mpz_get_si (as->upper[i]->value.integer), i+1);
4053 gfc_warning ("Array reference at %L is out of bounds "
4054 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4055 mpz_get_si (ar->start[i]->value.integer),
4056 mpz_get_si (as->upper[i]->value.integer),
4065 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4066 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4068 comparison comp_start_end = compare_bound (AR_START, AR_END);
4070 /* Check for zero stride, which is not allowed. */
4071 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4073 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4077 /* if start == len || (stride > 0 && start < len)
4078 || (stride < 0 && start > len),
4079 then the array section contains at least one element. In this
4080 case, there is an out-of-bounds access if
4081 (start < lower || start > upper). */
4082 if (compare_bound (AR_START, AR_END) == CMP_EQ
4083 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4084 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4085 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4086 && comp_start_end == CMP_GT))
4088 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4090 gfc_warning ("Lower array reference at %L is out of bounds "
4091 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4092 mpz_get_si (AR_START->value.integer),
4093 mpz_get_si (as->lower[i]->value.integer), i+1);
4096 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4098 gfc_warning ("Lower array reference at %L is out of bounds "
4099 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4100 mpz_get_si (AR_START->value.integer),
4101 mpz_get_si (as->upper[i]->value.integer), i+1);
4106 /* If we can compute the highest index of the array section,
4107 then it also has to be between lower and upper. */
4108 mpz_init (last_value);
4109 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4112 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4114 gfc_warning ("Upper array reference at %L is out of bounds "
4115 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4116 mpz_get_si (last_value),
4117 mpz_get_si (as->lower[i]->value.integer), i+1);
4118 mpz_clear (last_value);
4121 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4123 gfc_warning ("Upper array reference at %L is out of bounds "
4124 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4125 mpz_get_si (last_value),
4126 mpz_get_si (as->upper[i]->value.integer), i+1);
4127 mpz_clear (last_value);
4131 mpz_clear (last_value);
4139 gfc_internal_error ("check_dimension(): Bad array reference");
4146 /* Compare an array reference with an array specification. */
4149 compare_spec_to_ref (gfc_array_ref *ar)
4156 /* TODO: Full array sections are only allowed as actual parameters. */
4157 if (as->type == AS_ASSUMED_SIZE
4158 && (/*ar->type == AR_FULL
4159 ||*/ (ar->type == AR_SECTION
4160 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4162 gfc_error ("Rightmost upper bound of assumed size array section "
4163 "not specified at %L", &ar->where);
4167 if (ar->type == AR_FULL)
4170 if (as->rank != ar->dimen)
4172 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4173 &ar->where, ar->dimen, as->rank);
4177 /* ar->codimen == 0 is a local array. */
4178 if (as->corank != ar->codimen && ar->codimen != 0)
4180 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4181 &ar->where, ar->codimen, as->corank);
4185 for (i = 0; i < as->rank; i++)
4186 if (check_dimension (i, ar, as) == FAILURE)
4189 /* Local access has no coarray spec. */
4190 if (ar->codimen != 0)
4191 for (i = as->rank; i < as->rank + as->corank; i++)
4193 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
4195 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4196 i + 1 - as->rank, &ar->where);
4199 if (check_dimension (i, ar, as) == FAILURE)
4207 /* Resolve one part of an array index. */
4210 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4211 int force_index_integer_kind)
4218 if (gfc_resolve_expr (index) == FAILURE)
4221 if (check_scalar && index->rank != 0)
4223 gfc_error ("Array index at %L must be scalar", &index->where);
4227 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4229 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4230 &index->where, gfc_basic_typename (index->ts.type));
4234 if (index->ts.type == BT_REAL)
4235 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4236 &index->where) == FAILURE)
4239 if ((index->ts.kind != gfc_index_integer_kind
4240 && force_index_integer_kind)
4241 || index->ts.type != BT_INTEGER)
4244 ts.type = BT_INTEGER;
4245 ts.kind = gfc_index_integer_kind;
4247 gfc_convert_type_warn (index, &ts, 2, 0);
4253 /* Resolve one part of an array index. */
4256 gfc_resolve_index (gfc_expr *index, int check_scalar)
4258 return gfc_resolve_index_1 (index, check_scalar, 1);
4261 /* Resolve a dim argument to an intrinsic function. */
4264 gfc_resolve_dim_arg (gfc_expr *dim)
4269 if (gfc_resolve_expr (dim) == FAILURE)
4274 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4279 if (dim->ts.type != BT_INTEGER)
4281 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4285 if (dim->ts.kind != gfc_index_integer_kind)
4290 ts.type = BT_INTEGER;
4291 ts.kind = gfc_index_integer_kind;
4293 gfc_convert_type_warn (dim, &ts, 2, 0);
4299 /* Given an expression that contains array references, update those array
4300 references to point to the right array specifications. While this is
4301 filled in during matching, this information is difficult to save and load
4302 in a module, so we take care of it here.
4304 The idea here is that the original array reference comes from the
4305 base symbol. We traverse the list of reference structures, setting
4306 the stored reference to references. Component references can
4307 provide an additional array specification. */
4310 find_array_spec (gfc_expr *e)
4314 gfc_symbol *derived;
4317 if (e->symtree->n.sym->ts.type == BT_CLASS)
4318 as = CLASS_DATA (e->symtree->n.sym)->as;
4320 as = e->symtree->n.sym->as;
4323 for (ref = e->ref; ref; ref = ref->next)
4328 gfc_internal_error ("find_array_spec(): Missing spec");
4335 if (derived == NULL)
4336 derived = e->symtree->n.sym->ts.u.derived;
4338 if (derived->attr.is_class)
4339 derived = derived->components->ts.u.derived;
4341 c = derived->components;
4343 for (; c; c = c->next)
4344 if (c == ref->u.c.component)
4346 /* Track the sequence of component references. */
4347 if (c->ts.type == BT_DERIVED)
4348 derived = c->ts.u.derived;
4353 gfc_internal_error ("find_array_spec(): Component not found");
4355 if (c->attr.dimension)
4358 gfc_internal_error ("find_array_spec(): unused as(1)");
4369 gfc_internal_error ("find_array_spec(): unused as(2)");
4373 /* Resolve an array reference. */
4376 resolve_array_ref (gfc_array_ref *ar)
4378 int i, check_scalar;
4381 for (i = 0; i < ar->dimen + ar->codimen; i++)
4383 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4385 /* Do not force gfc_index_integer_kind for the start. We can
4386 do fine with any integer kind. This avoids temporary arrays
4387 created for indexing with a vector. */
4388 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4390 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4392 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4397 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4401 ar->dimen_type[i] = DIMEN_ELEMENT;
4405 ar->dimen_type[i] = DIMEN_VECTOR;
4406 if (e->expr_type == EXPR_VARIABLE
4407 && e->symtree->n.sym->ts.type == BT_DERIVED)
4408 ar->start[i] = gfc_get_parentheses (e);
4412 gfc_error ("Array index at %L is an array of rank %d",
4413 &ar->c_where[i], e->rank);
4417 /* Fill in the upper bound, which may be lower than the
4418 specified one for something like a(2:10:5), which is
4419 identical to a(2:7:5). Only relevant for strides not equal
4421 if (ar->dimen_type[i] == DIMEN_RANGE
4422 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4423 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
4427 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4429 if (ar->end[i] == NULL)
4432 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4434 mpz_set (ar->end[i]->value.integer, end);
4436 else if (ar->end[i]->ts.type == BT_INTEGER
4437 && ar->end[i]->expr_type == EXPR_CONSTANT)
4439 mpz_set (ar->end[i]->value.integer, end);
4450 if (ar->type == AR_FULL && ar->as->rank == 0)
4451 ar->type = AR_ELEMENT;
4453 /* If the reference type is unknown, figure out what kind it is. */
4455 if (ar->type == AR_UNKNOWN)
4457 ar->type = AR_ELEMENT;
4458 for (i = 0; i < ar->dimen; i++)
4459 if (ar->dimen_type[i] == DIMEN_RANGE
4460 || ar->dimen_type[i] == DIMEN_VECTOR)
4462 ar->type = AR_SECTION;
4467 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4475 resolve_substring (gfc_ref *ref)
4477 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4479 if (ref->u.ss.start != NULL)
4481 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4484 if (ref->u.ss.start->ts.type != BT_INTEGER)
4486 gfc_error ("Substring start index at %L must be of type INTEGER",
4487 &ref->u.ss.start->where);
4491 if (ref->u.ss.start->rank != 0)
4493 gfc_error ("Substring start index at %L must be scalar",
4494 &ref->u.ss.start->where);
4498 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4499 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4500 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4502 gfc_error ("Substring start index at %L is less than one",
4503 &ref->u.ss.start->where);
4508 if (ref->u.ss.end != NULL)
4510 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4513 if (ref->u.ss.end->ts.type != BT_INTEGER)
4515 gfc_error ("Substring end index at %L must be of type INTEGER",
4516 &ref->u.ss.end->where);
4520 if (ref->u.ss.end->rank != 0)
4522 gfc_error ("Substring end index at %L must be scalar",
4523 &ref->u.ss.end->where);
4527 if (ref->u.ss.length != NULL
4528 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4529 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4530 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4532 gfc_error ("Substring end index at %L exceeds the string length",
4533 &ref->u.ss.start->where);
4537 if (compare_bound_mpz_t (ref->u.ss.end,
4538 gfc_integer_kinds[k].huge) == CMP_GT
4539 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4540 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4542 gfc_error ("Substring end index at %L is too large",
4543 &ref->u.ss.end->where);
4552 /* This function supplies missing substring charlens. */
4555 gfc_resolve_substring_charlen (gfc_expr *e)
4558 gfc_expr *start, *end;
4560 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4561 if (char_ref->type == REF_SUBSTRING)
4567 gcc_assert (char_ref->next == NULL);
4571 if (e->ts.u.cl->length)
4572 gfc_free_expr (e->ts.u.cl->length);
4573 else if (e->expr_type == EXPR_VARIABLE
4574 && e->symtree->n.sym->attr.dummy)
4578 e->ts.type = BT_CHARACTER;
4579 e->ts.kind = gfc_default_character_kind;
4582 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4584 if (char_ref->u.ss.start)
4585 start = gfc_copy_expr (char_ref->u.ss.start);
4587 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4589 if (char_ref->u.ss.end)
4590 end = gfc_copy_expr (char_ref->u.ss.end);
4591 else if (e->expr_type == EXPR_VARIABLE)
4592 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4599 /* Length = (end - start +1). */
4600 e->ts.u.cl->length = gfc_subtract (end, start);
4601 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4602 gfc_get_int_expr (gfc_default_integer_kind,
4605 e->ts.u.cl->length->ts.type = BT_INTEGER;
4606 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4608 /* Make sure that the length is simplified. */
4609 gfc_simplify_expr (e->ts.u.cl->length, 1);
4610 gfc_resolve_expr (e->ts.u.cl->length);
4614 /* Resolve subtype references. */
4617 resolve_ref (gfc_expr *expr)
4619 int current_part_dimension, n_components, seen_part_dimension;
4622 for (ref = expr->ref; ref; ref = ref->next)
4623 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4625 find_array_spec (expr);
4629 for (ref = expr->ref; ref; ref = ref->next)
4633 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4641 resolve_substring (ref);
4645 /* Check constraints on part references. */
4647 current_part_dimension = 0;
4648 seen_part_dimension = 0;
4651 for (ref = expr->ref; ref; ref = ref->next)
4656 switch (ref->u.ar.type)
4659 /* Coarray scalar. */
4660 if (ref->u.ar.as->rank == 0)
4662 current_part_dimension = 0;
4667 current_part_dimension = 1;
4671 current_part_dimension = 0;
4675 gfc_internal_error ("resolve_ref(): Bad array reference");
4681 if (current_part_dimension || seen_part_dimension)
4684 if (ref->u.c.component->attr.pointer
4685 || ref->u.c.component->attr.proc_pointer)
4687 gfc_error ("Component to the right of a part reference "
4688 "with nonzero rank must not have the POINTER "
4689 "attribute at %L", &expr->where);
4692 else if (ref->u.c.component->attr.allocatable)
4694 gfc_error ("Component to the right of a part reference "
4695 "with nonzero rank must not have the ALLOCATABLE "
4696 "attribute at %L", &expr->where);
4708 if (((ref->type == REF_COMPONENT && n_components > 1)
4709 || ref->next == NULL)
4710 && current_part_dimension
4711 && seen_part_dimension)
4713 gfc_error ("Two or more part references with nonzero rank must "
4714 "not be specified at %L", &expr->where);
4718 if (ref->type == REF_COMPONENT)
4720 if (current_part_dimension)
4721 seen_part_dimension = 1;
4723 /* reset to make sure */
4724 current_part_dimension = 0;
4732 /* Given an expression, determine its shape. This is easier than it sounds.
4733 Leaves the shape array NULL if it is not possible to determine the shape. */
4736 expression_shape (gfc_expr *e)
4738 mpz_t array[GFC_MAX_DIMENSIONS];
4741 if (e->rank == 0 || e->shape != NULL)
4744 for (i = 0; i < e->rank; i++)
4745 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4748 e->shape = gfc_get_shape (e->rank);
4750 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4755 for (i--; i >= 0; i--)
4756 mpz_clear (array[i]);
4760 /* Given a variable expression node, compute the rank of the expression by
4761 examining the base symbol and any reference structures it may have. */
4764 expression_rank (gfc_expr *e)
4769 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4770 could lead to serious confusion... */
4771 gcc_assert (e->expr_type != EXPR_COMPCALL);
4775 if (e->expr_type == EXPR_ARRAY)
4777 /* Constructors can have a rank different from one via RESHAPE(). */
4779 if (e->symtree == NULL)
4785 e->rank = (e->symtree->n.sym->as == NULL)
4786 ? 0 : e->symtree->n.sym->as->rank;
4792 for (ref = e->ref; ref; ref = ref->next)
4794 if (ref->type != REF_ARRAY)
4797 if (ref->u.ar.type == AR_FULL)
4799 rank = ref->u.ar.as->rank;
4803 if (ref->u.ar.type == AR_SECTION)
4805 /* Figure out the rank of the section. */
4807 gfc_internal_error ("expression_rank(): Two array specs");
4809 for (i = 0; i < ref->u.ar.dimen; i++)
4810 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4811 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4821 expression_shape (e);
4825 /* Resolve a variable expression. */
4828 resolve_variable (gfc_expr *e)
4835 if (e->symtree == NULL)
4837 sym = e->symtree->n.sym;
4839 /* If this is an associate-name, it may be parsed with references in error
4840 even though the target is scalar. Fail directly in this case. */
4841 if (sym->assoc && !sym->attr.dimension && e->ref)
4844 /* On the other hand, the parser may not have known this is an array;
4845 in this case, we have to add a FULL reference. */
4846 if (sym->assoc && sym->attr.dimension && !e->ref)
4848 e->ref = gfc_get_ref ();
4849 e->ref->type = REF_ARRAY;
4850 e->ref->u.ar.type = AR_FULL;
4851 e->ref->u.ar.dimen = 0;
4854 if (e->ref && resolve_ref (e) == FAILURE)
4857 if (sym->attr.flavor == FL_PROCEDURE
4858 && (!sym->attr.function
4859 || (sym->attr.function && sym->result
4860 && sym->result->attr.proc_pointer
4861 && !sym->result->attr.function)))
4863 e->ts.type = BT_PROCEDURE;
4864 goto resolve_procedure;
4867 if (sym->ts.type != BT_UNKNOWN)
4868 gfc_variable_attr (e, &e->ts);
4871 /* Must be a simple variable reference. */
4872 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4877 if (check_assumed_size_reference (sym, e))
4880 /* Deal with forward references to entries during resolve_code, to
4881 satisfy, at least partially, 12.5.2.5. */
4882 if (gfc_current_ns->entries
4883 && current_entry_id == sym->entry_id
4886 && cs_base->current->op != EXEC_ENTRY)
4888 gfc_entry_list *entry;
4889 gfc_formal_arglist *formal;
4893 /* If the symbol is a dummy... */
4894 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4896 entry = gfc_current_ns->entries;
4899 /* ...test if the symbol is a parameter of previous entries. */
4900 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4901 for (formal = entry->sym->formal; formal; formal = formal->next)
4903 if (formal->sym && sym->name == formal->sym->name)
4907 /* If it has not been seen as a dummy, this is an error. */
4910 if (specification_expr)
4911 gfc_error ("Variable '%s', used in a specification expression"
4912 ", is referenced at %L before the ENTRY statement "
4913 "in which it is a parameter",
4914 sym->name, &cs_base->current->loc);
4916 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4917 "statement in which it is a parameter",
4918 sym->name, &cs_base->current->loc);
4923 /* Now do the same check on the specification expressions. */
4924 specification_expr = 1;
4925 if (sym->ts.type == BT_CHARACTER
4926 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4930 for (n = 0; n < sym->as->rank; n++)
4932 specification_expr = 1;
4933 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4935 specification_expr = 1;
4936 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4939 specification_expr = 0;
4942 /* Update the symbol's entry level. */
4943 sym->entry_id = current_entry_id + 1;
4946 /* If a symbol has been host_associated mark it. This is used latter,
4947 to identify if aliasing is possible via host association. */
4948 if (sym->attr.flavor == FL_VARIABLE
4949 && gfc_current_ns->parent
4950 && (gfc_current_ns->parent == sym->ns
4951 || (gfc_current_ns->parent->parent
4952 && gfc_current_ns->parent->parent == sym->ns)))
4953 sym->attr.host_assoc = 1;
4956 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
4959 /* F2008, C617 and C1229. */
4960 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
4961 && gfc_is_coindexed (e))
4963 gfc_ref *ref, *ref2 = NULL;
4965 if (e->ts.type == BT_CLASS)
4967 gfc_error ("Polymorphic subobject of coindexed object at %L",
4972 for (ref = e->ref; ref; ref = ref->next)
4974 if (ref->type == REF_COMPONENT)
4976 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
4980 for ( ; ref; ref = ref->next)
4981 if (ref->type == REF_COMPONENT)
4984 /* Expression itself is coindexed object. */
4988 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
4989 for ( ; c; c = c->next)
4990 if (c->attr.allocatable && c->ts.type == BT_CLASS)
4992 gfc_error ("Coindexed object with polymorphic allocatable "
4993 "subcomponent at %L", &e->where);
5004 /* Checks to see that the correct symbol has been host associated.
5005 The only situation where this arises is that in which a twice
5006 contained function is parsed after the host association is made.
5007 Therefore, on detecting this, change the symbol in the expression
5008 and convert the array reference into an actual arglist if the old
5009 symbol is a variable. */
5011 check_host_association (gfc_expr *e)
5013 gfc_symbol *sym, *old_sym;
5017 gfc_actual_arglist *arg, *tail = NULL;
5018 bool retval = e->expr_type == EXPR_FUNCTION;
5020 /* If the expression is the result of substitution in
5021 interface.c(gfc_extend_expr) because there is no way in
5022 which the host association can be wrong. */
5023 if (e->symtree == NULL
5024 || e->symtree->n.sym == NULL
5025 || e->user_operator)
5028 old_sym = e->symtree->n.sym;
5030 if (gfc_current_ns->parent
5031 && old_sym->ns != gfc_current_ns)
5033 /* Use the 'USE' name so that renamed module symbols are
5034 correctly handled. */
5035 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5037 if (sym && old_sym != sym
5038 && sym->ts.type == old_sym->ts.type
5039 && sym->attr.flavor == FL_PROCEDURE
5040 && sym->attr.contained)
5042 /* Clear the shape, since it might not be valid. */
5043 if (e->shape != NULL)
5045 for (n = 0; n < e->rank; n++)
5046 mpz_clear (e->shape[n]);
5048 gfc_free (e->shape);
5051 /* Give the expression the right symtree! */
5052 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5053 gcc_assert (st != NULL);
5055 if (old_sym->attr.flavor == FL_PROCEDURE
5056 || e->expr_type == EXPR_FUNCTION)
5058 /* Original was function so point to the new symbol, since
5059 the actual argument list is already attached to the
5061 e->value.function.esym = NULL;
5066 /* Original was variable so convert array references into
5067 an actual arglist. This does not need any checking now
5068 since gfc_resolve_function will take care of it. */
5069 e->value.function.actual = NULL;
5070 e->expr_type = EXPR_FUNCTION;
5073 /* Ambiguity will not arise if the array reference is not
5074 the last reference. */
5075 for (ref = e->ref; ref; ref = ref->next)
5076 if (ref->type == REF_ARRAY && ref->next == NULL)
5079 gcc_assert (ref->type == REF_ARRAY);
5081 /* Grab the start expressions from the array ref and
5082 copy them into actual arguments. */
5083 for (n = 0; n < ref->u.ar.dimen; n++)
5085 arg = gfc_get_actual_arglist ();
5086 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5087 if (e->value.function.actual == NULL)
5088 tail = e->value.function.actual = arg;
5096 /* Dump the reference list and set the rank. */
5097 gfc_free_ref_list (e->ref);
5099 e->rank = sym->as ? sym->as->rank : 0;
5102 gfc_resolve_expr (e);
5106 /* This might have changed! */
5107 return e->expr_type == EXPR_FUNCTION;
5112 gfc_resolve_character_operator (gfc_expr *e)
5114 gfc_expr *op1 = e->value.op.op1;
5115 gfc_expr *op2 = e->value.op.op2;
5116 gfc_expr *e1 = NULL;
5117 gfc_expr *e2 = NULL;
5119 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5121 if (op1->ts.u.cl && op1->ts.u.cl->length)
5122 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5123 else if (op1->expr_type == EXPR_CONSTANT)
5124 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5125 op1->value.character.length);
5127 if (op2->ts.u.cl && op2->ts.u.cl->length)
5128 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5129 else if (op2->expr_type == EXPR_CONSTANT)
5130 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5131 op2->value.character.length);
5133 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5138 e->ts.u.cl->length = gfc_add (e1, e2);
5139 e->ts.u.cl->length->ts.type = BT_INTEGER;
5140 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5141 gfc_simplify_expr (e->ts.u.cl->length, 0);
5142 gfc_resolve_expr (e->ts.u.cl->length);
5148 /* Ensure that an character expression has a charlen and, if possible, a
5149 length expression. */
5152 fixup_charlen (gfc_expr *e)
5154 /* The cases fall through so that changes in expression type and the need
5155 for multiple fixes are picked up. In all circumstances, a charlen should
5156 be available for the middle end to hang a backend_decl on. */
5157 switch (e->expr_type)
5160 gfc_resolve_character_operator (e);
5163 if (e->expr_type == EXPR_ARRAY)
5164 gfc_resolve_character_array_constructor (e);
5166 case EXPR_SUBSTRING:
5167 if (!e->ts.u.cl && e->ref)
5168 gfc_resolve_substring_charlen (e);
5172 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5179 /* Update an actual argument to include the passed-object for type-bound
5180 procedures at the right position. */
5182 static gfc_actual_arglist*
5183 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5186 gcc_assert (argpos > 0);
5190 gfc_actual_arglist* result;
5192 result = gfc_get_actual_arglist ();
5196 result->name = name;
5202 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5204 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5209 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5212 extract_compcall_passed_object (gfc_expr* e)
5216 gcc_assert (e->expr_type == EXPR_COMPCALL);
5218 if (e->value.compcall.base_object)
5219 po = gfc_copy_expr (e->value.compcall.base_object);
5222 po = gfc_get_expr ();
5223 po->expr_type = EXPR_VARIABLE;
5224 po->symtree = e->symtree;
5225 po->ref = gfc_copy_ref (e->ref);
5226 po->where = e->where;
5229 if (gfc_resolve_expr (po) == FAILURE)
5236 /* Update the arglist of an EXPR_COMPCALL expression to include the
5240 update_compcall_arglist (gfc_expr* e)
5243 gfc_typebound_proc* tbp;
5245 tbp = e->value.compcall.tbp;
5250 po = extract_compcall_passed_object (e);
5254 if (tbp->nopass || e->value.compcall.ignore_pass)
5260 gcc_assert (tbp->pass_arg_num > 0);
5261 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5269 /* Extract the passed object from a PPC call (a copy of it). */
5272 extract_ppc_passed_object (gfc_expr *e)
5277 po = gfc_get_expr ();
5278 po->expr_type = EXPR_VARIABLE;
5279 po->symtree = e->symtree;
5280 po->ref = gfc_copy_ref (e->ref);
5281 po->where = e->where;
5283 /* Remove PPC reference. */
5285 while ((*ref)->next)
5286 ref = &(*ref)->next;
5287 gfc_free_ref_list (*ref);
5290 if (gfc_resolve_expr (po) == FAILURE)
5297 /* Update the actual arglist of a procedure pointer component to include the
5301 update_ppc_arglist (gfc_expr* e)
5305 gfc_typebound_proc* tb;
5307 if (!gfc_is_proc_ptr_comp (e, &ppc))
5314 else if (tb->nopass)
5317 po = extract_ppc_passed_object (e);
5323 gfc_error ("Passed-object at %L must be scalar", &e->where);
5327 gcc_assert (tb->pass_arg_num > 0);
5328 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5336 /* Check that the object a TBP is called on is valid, i.e. it must not be
5337 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5340 check_typebound_baseobject (gfc_expr* e)
5344 base = extract_compcall_passed_object (e);
5348 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5350 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5352 gfc_error ("Base object for type-bound procedure call at %L is of"
5353 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5357 /* If the procedure called is NOPASS, the base object must be scalar. */
5358 if (e->value.compcall.tbp->nopass && base->rank > 0)
5360 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5361 " be scalar", &e->where);
5365 /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
5368 gfc_error ("Non-scalar base object at %L currently not implemented",
5377 /* Resolve a call to a type-bound procedure, either function or subroutine,
5378 statically from the data in an EXPR_COMPCALL expression. The adapted
5379 arglist and the target-procedure symtree are returned. */
5382 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5383 gfc_actual_arglist** actual)
5385 gcc_assert (e->expr_type == EXPR_COMPCALL);
5386 gcc_assert (!e->value.compcall.tbp->is_generic);
5388 /* Update the actual arglist for PASS. */
5389 if (update_compcall_arglist (e) == FAILURE)
5392 *actual = e->value.compcall.actual;
5393 *target = e->value.compcall.tbp->u.specific;
5395 gfc_free_ref_list (e->ref);
5397 e->value.compcall.actual = NULL;
5403 /* Get the ultimate declared type from an expression. In addition,
5404 return the last class/derived type reference and the copy of the
5407 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5410 gfc_symbol *declared;
5417 *new_ref = gfc_copy_ref (e->ref);
5419 for (ref = e->ref; ref; ref = ref->next)
5421 if (ref->type != REF_COMPONENT)
5424 if (ref->u.c.component->ts.type == BT_CLASS
5425 || ref->u.c.component->ts.type == BT_DERIVED)
5427 declared = ref->u.c.component->ts.u.derived;
5433 if (declared == NULL)
5434 declared = e->symtree->n.sym->ts.u.derived;
5440 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5441 which of the specific bindings (if any) matches the arglist and transform
5442 the expression into a call of that binding. */
5445 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5447 gfc_typebound_proc* genproc;
5448 const char* genname;
5450 gfc_symbol *derived;
5452 gcc_assert (e->expr_type == EXPR_COMPCALL);
5453 genname = e->value.compcall.name;
5454 genproc = e->value.compcall.tbp;
5456 if (!genproc->is_generic)
5459 /* Try the bindings on this type and in the inheritance hierarchy. */
5460 for (; genproc; genproc = genproc->overridden)
5464 gcc_assert (genproc->is_generic);
5465 for (g = genproc->u.generic; g; g = g->next)
5468 gfc_actual_arglist* args;
5471 gcc_assert (g->specific);
5473 if (g->specific->error)
5476 target = g->specific->u.specific->n.sym;
5478 /* Get the right arglist by handling PASS/NOPASS. */
5479 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5480 if (!g->specific->nopass)
5483 po = extract_compcall_passed_object (e);
5487 gcc_assert (g->specific->pass_arg_num > 0);
5488 gcc_assert (!g->specific->error);
5489 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5490 g->specific->pass_arg);
5492 resolve_actual_arglist (args, target->attr.proc,
5493 is_external_proc (target) && !target->formal);
5495 /* Check if this arglist matches the formal. */
5496 matches = gfc_arglist_matches_symbol (&args, target);
5498 /* Clean up and break out of the loop if we've found it. */
5499 gfc_free_actual_arglist (args);
5502 e->value.compcall.tbp = g->specific;
5503 genname = g->specific_st->name;
5504 /* Pass along the name for CLASS methods, where the vtab
5505 procedure pointer component has to be referenced. */
5513 /* Nothing matching found! */
5514 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5515 " '%s' at %L", genname, &e->where);
5519 /* Make sure that we have the right specific instance for the name. */
5520 derived = get_declared_from_expr (NULL, NULL, e);
5522 st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5524 e->value.compcall.tbp = st->n.tb;
5530 /* Resolve a call to a type-bound subroutine. */
5533 resolve_typebound_call (gfc_code* c, const char **name)
5535 gfc_actual_arglist* newactual;
5536 gfc_symtree* target;
5538 /* Check that's really a SUBROUTINE. */
5539 if (!c->expr1->value.compcall.tbp->subroutine)
5541 gfc_error ("'%s' at %L should be a SUBROUTINE",
5542 c->expr1->value.compcall.name, &c->loc);
5546 if (check_typebound_baseobject (c->expr1) == FAILURE)
5549 /* Pass along the name for CLASS methods, where the vtab
5550 procedure pointer component has to be referenced. */
5552 *name = c->expr1->value.compcall.name;
5554 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5557 /* Transform into an ordinary EXEC_CALL for now. */
5559 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5562 c->ext.actual = newactual;
5563 c->symtree = target;
5564 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5566 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5568 gfc_free_expr (c->expr1);
5569 c->expr1 = gfc_get_expr ();
5570 c->expr1->expr_type = EXPR_FUNCTION;
5571 c->expr1->symtree = target;
5572 c->expr1->where = c->loc;
5574 return resolve_call (c);
5578 /* Resolve a component-call expression. */
5580 resolve_compcall (gfc_expr* e, const char **name)
5582 gfc_actual_arglist* newactual;
5583 gfc_symtree* target;
5585 /* Check that's really a FUNCTION. */
5586 if (!e->value.compcall.tbp->function)
5588 gfc_error ("'%s' at %L should be a FUNCTION",
5589 e->value.compcall.name, &e->where);
5593 /* These must not be assign-calls! */
5594 gcc_assert (!e->value.compcall.assign);
5596 if (check_typebound_baseobject (e) == FAILURE)
5599 /* Pass along the name for CLASS methods, where the vtab
5600 procedure pointer component has to be referenced. */
5602 *name = e->value.compcall.name;
5604 if (resolve_typebound_generic_call (e, name) == FAILURE)
5606 gcc_assert (!e->value.compcall.tbp->is_generic);
5608 /* Take the rank from the function's symbol. */
5609 if (e->value.compcall.tbp->u.specific->n.sym->as)
5610 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5612 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5613 arglist to the TBP's binding target. */
5615 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5618 e->value.function.actual = newactual;
5619 e->value.function.name = NULL;
5620 e->value.function.esym = target->n.sym;
5621 e->value.function.isym = NULL;
5622 e->symtree = target;
5623 e->ts = target->n.sym->ts;
5624 e->expr_type = EXPR_FUNCTION;
5626 /* Resolution is not necessary if this is a class subroutine; this
5627 function only has to identify the specific proc. Resolution of
5628 the call will be done next in resolve_typebound_call. */
5629 return gfc_resolve_expr (e);
5634 /* Resolve a typebound function, or 'method'. First separate all
5635 the non-CLASS references by calling resolve_compcall directly. */
5638 resolve_typebound_function (gfc_expr* e)
5640 gfc_symbol *declared;
5651 /* Deal with typebound operators for CLASS objects. */
5652 expr = e->value.compcall.base_object;
5653 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5654 && e->value.compcall.name)
5656 /* Since the typebound operators are generic, we have to ensure
5657 that any delays in resolution are corrected and that the vtab
5659 ts = expr->symtree->n.sym->ts;
5660 declared = ts.u.derived;
5661 c = gfc_find_component (declared, "$vptr", true, true);
5662 if (c->ts.u.derived == NULL)
5663 c->ts.u.derived = gfc_find_derived_vtab (declared);
5665 if (resolve_compcall (e, &name) == FAILURE)
5668 /* Use the generic name if it is there. */
5669 name = name ? name : e->value.function.esym->name;
5670 e->symtree = expr->symtree;
5671 expr->symtree->n.sym->ts.u.derived = declared;
5672 gfc_add_component_ref (e, "$vptr");
5673 gfc_add_component_ref (e, name);
5674 e->value.function.esym = NULL;
5679 return resolve_compcall (e, NULL);
5681 if (resolve_ref (e) == FAILURE)
5684 /* Get the CLASS declared type. */
5685 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5687 /* Weed out cases of the ultimate component being a derived type. */
5688 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5689 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5691 gfc_free_ref_list (new_ref);
5692 return resolve_compcall (e, NULL);
5695 c = gfc_find_component (declared, "$data", true, true);
5696 declared = c->ts.u.derived;
5698 /* Treat the call as if it is a typebound procedure, in order to roll
5699 out the correct name for the specific function. */
5700 if (resolve_compcall (e, &name) == FAILURE)
5704 /* Then convert the expression to a procedure pointer component call. */
5705 e->value.function.esym = NULL;
5711 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5712 gfc_add_component_ref (e, "$vptr");
5713 gfc_add_component_ref (e, name);
5715 /* Recover the typespec for the expression. This is really only
5716 necessary for generic procedures, where the additional call
5717 to gfc_add_component_ref seems to throw the collection of the
5718 correct typespec. */
5723 /* Resolve a typebound subroutine, or 'method'. First separate all
5724 the non-CLASS references by calling resolve_typebound_call
5728 resolve_typebound_subroutine (gfc_code *code)
5730 gfc_symbol *declared;
5739 st = code->expr1->symtree;
5741 /* Deal with typebound operators for CLASS objects. */
5742 expr = code->expr1->value.compcall.base_object;
5743 if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
5744 && code->expr1->value.compcall.name)
5746 /* Since the typebound operators are generic, we have to ensure
5747 that any delays in resolution are corrected and that the vtab
5749 ts = expr->symtree->n.sym->ts;
5750 declared = ts.u.derived;
5751 c = gfc_find_component (declared, "$vptr", true, true);
5752 if (c->ts.u.derived == NULL)
5753 c->ts.u.derived = gfc_find_derived_vtab (declared);
5755 if (resolve_typebound_call (code, &name) == FAILURE)
5758 /* Use the generic name if it is there. */
5759 name = name ? name : code->expr1->value.function.esym->name;
5760 code->expr1->symtree = expr->symtree;
5761 expr->symtree->n.sym->ts.u.derived = declared;
5762 gfc_add_component_ref (code->expr1, "$vptr");
5763 gfc_add_component_ref (code->expr1, name);
5764 code->expr1->value.function.esym = NULL;
5769 return resolve_typebound_call (code, NULL);
5771 if (resolve_ref (code->expr1) == FAILURE)
5774 /* Get the CLASS declared type. */
5775 get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5777 /* Weed out cases of the ultimate component being a derived type. */
5778 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5779 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5781 gfc_free_ref_list (new_ref);
5782 return resolve_typebound_call (code, NULL);
5785 if (resolve_typebound_call (code, &name) == FAILURE)
5787 ts = code->expr1->ts;
5789 /* Then convert the expression to a procedure pointer component call. */
5790 code->expr1->value.function.esym = NULL;
5791 code->expr1->symtree = st;
5794 code->expr1->ref = new_ref;
5796 /* '$vptr' points to the vtab, which contains the procedure pointers. */
5797 gfc_add_component_ref (code->expr1, "$vptr");
5798 gfc_add_component_ref (code->expr1, name);
5800 /* Recover the typespec for the expression. This is really only
5801 necessary for generic procedures, where the additional call
5802 to gfc_add_component_ref seems to throw the collection of the
5803 correct typespec. */
5804 code->expr1->ts = ts;
5809 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5812 resolve_ppc_call (gfc_code* c)
5814 gfc_component *comp;
5817 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5820 c->resolved_sym = c->expr1->symtree->n.sym;
5821 c->expr1->expr_type = EXPR_VARIABLE;
5823 if (!comp->attr.subroutine)
5824 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5826 if (resolve_ref (c->expr1) == FAILURE)
5829 if (update_ppc_arglist (c->expr1) == FAILURE)
5832 c->ext.actual = c->expr1->value.compcall.actual;
5834 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5835 comp->formal == NULL) == FAILURE)
5838 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5844 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5847 resolve_expr_ppc (gfc_expr* e)
5849 gfc_component *comp;
5852 b = gfc_is_proc_ptr_comp (e, &comp);
5855 /* Convert to EXPR_FUNCTION. */
5856 e->expr_type = EXPR_FUNCTION;
5857 e->value.function.isym = NULL;
5858 e->value.function.actual = e->value.compcall.actual;
5860 if (comp->as != NULL)
5861 e->rank = comp->as->rank;
5863 if (!comp->attr.function)
5864 gfc_add_function (&comp->attr, comp->name, &e->where);
5866 if (resolve_ref (e) == FAILURE)
5869 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5870 comp->formal == NULL) == FAILURE)
5873 if (update_ppc_arglist (e) == FAILURE)
5876 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5883 gfc_is_expandable_expr (gfc_expr *e)
5885 gfc_constructor *con;
5887 if (e->expr_type == EXPR_ARRAY)
5889 /* Traverse the constructor looking for variables that are flavor
5890 parameter. Parameters must be expanded since they are fully used at
5892 con = gfc_constructor_first (e->value.constructor);
5893 for (; con; con = gfc_constructor_next (con))
5895 if (con->expr->expr_type == EXPR_VARIABLE
5896 && con->expr->symtree
5897 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5898 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
5900 if (con->expr->expr_type == EXPR_ARRAY
5901 && gfc_is_expandable_expr (con->expr))
5909 /* Resolve an expression. That is, make sure that types of operands agree
5910 with their operators, intrinsic operators are converted to function calls
5911 for overloaded types and unresolved function references are resolved. */
5914 gfc_resolve_expr (gfc_expr *e)
5922 /* inquiry_argument only applies to variables. */
5923 inquiry_save = inquiry_argument;
5924 if (e->expr_type != EXPR_VARIABLE)
5925 inquiry_argument = false;
5927 switch (e->expr_type)
5930 t = resolve_operator (e);
5936 if (check_host_association (e))
5937 t = resolve_function (e);
5940 t = resolve_variable (e);
5942 expression_rank (e);
5945 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
5946 && e->ref->type != REF_SUBSTRING)
5947 gfc_resolve_substring_charlen (e);
5952 t = resolve_typebound_function (e);
5955 case EXPR_SUBSTRING:
5956 t = resolve_ref (e);
5965 t = resolve_expr_ppc (e);
5970 if (resolve_ref (e) == FAILURE)
5973 t = gfc_resolve_array_constructor (e);
5974 /* Also try to expand a constructor. */
5977 expression_rank (e);
5978 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
5979 gfc_expand_constructor (e, false);
5982 /* This provides the opportunity for the length of constructors with
5983 character valued function elements to propagate the string length
5984 to the expression. */
5985 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
5987 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
5988 here rather then add a duplicate test for it above. */
5989 gfc_expand_constructor (e, false);
5990 t = gfc_resolve_character_array_constructor (e);
5995 case EXPR_STRUCTURE:
5996 t = resolve_ref (e);
6000 t = resolve_structure_cons (e, 0);
6004 t = gfc_simplify_expr (e, 0);
6008 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6011 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6014 inquiry_argument = inquiry_save;
6020 /* Resolve an expression from an iterator. They must be scalar and have
6021 INTEGER or (optionally) REAL type. */
6024 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6025 const char *name_msgid)
6027 if (gfc_resolve_expr (expr) == FAILURE)
6030 if (expr->rank != 0)
6032 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6036 if (expr->ts.type != BT_INTEGER)
6038 if (expr->ts.type == BT_REAL)
6041 return gfc_notify_std (GFC_STD_F95_DEL,
6042 "Deleted feature: %s at %L must be integer",
6043 _(name_msgid), &expr->where);
6046 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6053 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6061 /* Resolve the expressions in an iterator structure. If REAL_OK is
6062 false allow only INTEGER type iterators, otherwise allow REAL types. */
6065 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6067 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6071 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
6073 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
6078 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6079 "Start expression in DO loop") == FAILURE)
6082 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6083 "End expression in DO loop") == FAILURE)
6086 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6087 "Step expression in DO loop") == FAILURE)
6090 if (iter->step->expr_type == EXPR_CONSTANT)
6092 if ((iter->step->ts.type == BT_INTEGER
6093 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6094 || (iter->step->ts.type == BT_REAL
6095 && mpfr_sgn (iter->step->value.real) == 0))
6097 gfc_error ("Step expression in DO loop at %L cannot be zero",
6098 &iter->step->where);
6103 /* Convert start, end, and step to the same type as var. */
6104 if (iter->start->ts.kind != iter->var->ts.kind
6105 || iter->start->ts.type != iter->var->ts.type)
6106 gfc_convert_type (iter->start, &iter->var->ts, 2);
6108 if (iter->end->ts.kind != iter->var->ts.kind
6109 || iter->end->ts.type != iter->var->ts.type)
6110 gfc_convert_type (iter->end, &iter->var->ts, 2);
6112 if (iter->step->ts.kind != iter->var->ts.kind
6113 || iter->step->ts.type != iter->var->ts.type)
6114 gfc_convert_type (iter->step, &iter->var->ts, 2);
6116 if (iter->start->expr_type == EXPR_CONSTANT
6117 && iter->end->expr_type == EXPR_CONSTANT
6118 && iter->step->expr_type == EXPR_CONSTANT)
6121 if (iter->start->ts.type == BT_INTEGER)
6123 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6124 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6128 sgn = mpfr_sgn (iter->step->value.real);
6129 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6131 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6132 gfc_warning ("DO loop at %L will be executed zero times",
6133 &iter->step->where);
6140 /* Traversal function for find_forall_index. f == 2 signals that
6141 that variable itself is not to be checked - only the references. */
6144 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6146 if (expr->expr_type != EXPR_VARIABLE)
6149 /* A scalar assignment */
6150 if (!expr->ref || *f == 1)
6152 if (expr->symtree->n.sym == sym)
6164 /* Check whether the FORALL index appears in the expression or not.
6165 Returns SUCCESS if SYM is found in EXPR. */
6168 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6170 if (gfc_traverse_expr (expr, sym, forall_index, f))
6177 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6178 to be a scalar INTEGER variable. The subscripts and stride are scalar
6179 INTEGERs, and if stride is a constant it must be nonzero.
6180 Furthermore "A subscript or stride in a forall-triplet-spec shall
6181 not contain a reference to any index-name in the
6182 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6185 resolve_forall_iterators (gfc_forall_iterator *it)
6187 gfc_forall_iterator *iter, *iter2;
6189 for (iter = it; iter; iter = iter->next)
6191 if (gfc_resolve_expr (iter->var) == SUCCESS
6192 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6193 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6196 if (gfc_resolve_expr (iter->start) == SUCCESS
6197 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6198 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6199 &iter->start->where);
6200 if (iter->var->ts.kind != iter->start->ts.kind)
6201 gfc_convert_type (iter->start, &iter->var->ts, 2);
6203 if (gfc_resolve_expr (iter->end) == SUCCESS
6204 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6205 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6207 if (iter->var->ts.kind != iter->end->ts.kind)
6208 gfc_convert_type (iter->end, &iter->var->ts, 2);
6210 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6212 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6213 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6214 &iter->stride->where, "INTEGER");
6216 if (iter->stride->expr_type == EXPR_CONSTANT
6217 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6218 gfc_error ("FORALL stride expression at %L cannot be zero",
6219 &iter->stride->where);
6221 if (iter->var->ts.kind != iter->stride->ts.kind)
6222 gfc_convert_type (iter->stride, &iter->var->ts, 2);
6225 for (iter = it; iter; iter = iter->next)
6226 for (iter2 = iter; iter2; iter2 = iter2->next)
6228 if (find_forall_index (iter2->start,
6229 iter->var->symtree->n.sym, 0) == SUCCESS
6230 || find_forall_index (iter2->end,
6231 iter->var->symtree->n.sym, 0) == SUCCESS
6232 || find_forall_index (iter2->stride,
6233 iter->var->symtree->n.sym, 0) == SUCCESS)
6234 gfc_error ("FORALL index '%s' may not appear in triplet "
6235 "specification at %L", iter->var->symtree->name,
6236 &iter2->start->where);
6241 /* Given a pointer to a symbol that is a derived type, see if it's
6242 inaccessible, i.e. if it's defined in another module and the components are
6243 PRIVATE. The search is recursive if necessary. Returns zero if no
6244 inaccessible components are found, nonzero otherwise. */
6247 derived_inaccessible (gfc_symbol *sym)
6251 if (sym->attr.use_assoc && sym->attr.private_comp)
6254 for (c = sym->components; c; c = c->next)
6256 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6264 /* Resolve the argument of a deallocate expression. The expression must be
6265 a pointer or a full array. */
6268 resolve_deallocate_expr (gfc_expr *e)
6270 symbol_attribute attr;
6271 int allocatable, pointer, check_intent_in;
6276 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6277 check_intent_in = 1;
6279 if (gfc_resolve_expr (e) == FAILURE)
6282 if (e->expr_type != EXPR_VARIABLE)
6285 sym = e->symtree->n.sym;
6287 if (sym->ts.type == BT_CLASS)
6289 allocatable = CLASS_DATA (sym)->attr.allocatable;
6290 pointer = CLASS_DATA (sym)->attr.class_pointer;
6294 allocatable = sym->attr.allocatable;
6295 pointer = sym->attr.pointer;
6297 for (ref = e->ref; ref; ref = ref->next)
6300 check_intent_in = 0;
6305 if (ref->u.ar.type != AR_FULL)
6310 c = ref->u.c.component;
6311 if (c->ts.type == BT_CLASS)
6313 allocatable = CLASS_DATA (c)->attr.allocatable;
6314 pointer = CLASS_DATA (c)->attr.class_pointer;
6318 allocatable = c->attr.allocatable;
6319 pointer = c->attr.pointer;
6329 attr = gfc_expr_attr (e);
6331 if (allocatable == 0 && attr.pointer == 0)
6334 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6339 if (check_intent_in && sym->attr.intent == INTENT_IN)
6341 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
6342 sym->name, &e->where);
6346 if (e->ts.type == BT_CLASS)
6348 /* Only deallocate the DATA component. */
6349 gfc_add_component_ref (e, "$data");
6356 /* Returns true if the expression e contains a reference to the symbol sym. */
6358 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6360 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6367 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6369 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6373 /* Given the expression node e for an allocatable/pointer of derived type to be
6374 allocated, get the expression node to be initialized afterwards (needed for
6375 derived types with default initializers, and derived types with allocatable
6376 components that need nullification.) */
6379 gfc_expr_to_initialize (gfc_expr *e)
6385 result = gfc_copy_expr (e);
6387 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6388 for (ref = result->ref; ref; ref = ref->next)
6389 if (ref->type == REF_ARRAY && ref->next == NULL)
6391 ref->u.ar.type = AR_FULL;
6393 for (i = 0; i < ref->u.ar.dimen; i++)
6394 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6396 result->rank = ref->u.ar.dimen;
6404 /* Used in resolve_allocate_expr to check that a allocation-object and
6405 a source-expr are conformable. This does not catch all possible
6406 cases; in particular a runtime checking is needed. */
6409 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6412 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6414 /* First compare rank. */
6415 if (tail && e1->rank != tail->u.ar.as->rank)
6417 gfc_error ("Source-expr at %L must be scalar or have the "
6418 "same rank as the allocate-object at %L",
6419 &e1->where, &e2->where);
6430 for (i = 0; i < e1->rank; i++)
6432 if (tail->u.ar.end[i])
6434 mpz_set (s, tail->u.ar.end[i]->value.integer);
6435 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6436 mpz_add_ui (s, s, 1);
6440 mpz_set (s, tail->u.ar.start[i]->value.integer);
6443 if (mpz_cmp (e1->shape[i], s) != 0)
6445 gfc_error ("Source-expr at %L and allocate-object at %L must "
6446 "have the same shape", &e1->where, &e2->where);
6459 /* Resolve the expression in an ALLOCATE statement, doing the additional
6460 checks to see whether the expression is OK or not. The expression must
6461 have a trailing array reference that gives the size of the array. */
6464 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6466 int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
6468 symbol_attribute attr;
6469 gfc_ref *ref, *ref2;
6471 gfc_symbol *sym = NULL;
6475 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6476 check_intent_in = 1;
6478 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6479 checking of coarrays. */
6480 for (ref = e->ref; ref; ref = ref->next)
6481 if (ref->next == NULL)
6484 if (ref && ref->type == REF_ARRAY)
6485 ref->u.ar.in_allocate = true;
6487 if (gfc_resolve_expr (e) == FAILURE)
6490 /* Make sure the expression is allocatable or a pointer. If it is
6491 pointer, the next-to-last reference must be a pointer. */
6495 sym = e->symtree->n.sym;
6497 /* Check whether ultimate component is abstract and CLASS. */
6500 if (e->expr_type != EXPR_VARIABLE)
6503 attr = gfc_expr_attr (e);
6504 pointer = attr.pointer;
6505 dimension = attr.dimension;
6506 codimension = attr.codimension;
6510 if (sym->ts.type == BT_CLASS)
6512 allocatable = CLASS_DATA (sym)->attr.allocatable;
6513 pointer = CLASS_DATA (sym)->attr.class_pointer;
6514 dimension = CLASS_DATA (sym)->attr.dimension;
6515 codimension = CLASS_DATA (sym)->attr.codimension;
6516 is_abstract = CLASS_DATA (sym)->attr.abstract;
6520 allocatable = sym->attr.allocatable;
6521 pointer = sym->attr.pointer;
6522 dimension = sym->attr.dimension;
6523 codimension = sym->attr.codimension;
6526 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6529 check_intent_in = 0;
6534 if (ref->next != NULL)
6540 if (gfc_is_coindexed (e))
6542 gfc_error ("Coindexed allocatable object at %L",
6547 c = ref->u.c.component;
6548 if (c->ts.type == BT_CLASS)
6550 allocatable = CLASS_DATA (c)->attr.allocatable;
6551 pointer = CLASS_DATA (c)->attr.class_pointer;
6552 dimension = CLASS_DATA (c)->attr.dimension;
6553 codimension = CLASS_DATA (c)->attr.codimension;
6554 is_abstract = CLASS_DATA (c)->attr.abstract;
6558 allocatable = c->attr.allocatable;
6559 pointer = c->attr.pointer;
6560 dimension = c->attr.dimension;
6561 codimension = c->attr.codimension;
6562 is_abstract = c->attr.abstract;
6574 if (allocatable == 0 && pointer == 0)
6576 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6581 /* Some checks for the SOURCE tag. */
6584 /* Check F03:C631. */
6585 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6587 gfc_error ("Type of entity at %L is type incompatible with "
6588 "source-expr at %L", &e->where, &code->expr3->where);
6592 /* Check F03:C632 and restriction following Note 6.18. */
6593 if (code->expr3->rank > 0
6594 && conformable_arrays (code->expr3, e) == FAILURE)
6597 /* Check F03:C633. */
6598 if (code->expr3->ts.kind != e->ts.kind)
6600 gfc_error ("The allocate-object at %L and the source-expr at %L "
6601 "shall have the same kind type parameter",
6602 &e->where, &code->expr3->where);
6607 /* Check F08:C629. */
6608 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6611 gcc_assert (e->ts.type == BT_CLASS);
6612 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6613 "type-spec or source-expr", sym->name, &e->where);
6617 if (check_intent_in && sym->attr.intent == INTENT_IN)
6619 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
6620 sym->name, &e->where);
6624 if (!code->expr3 || code->expr3->mold)
6626 /* Add default initializer for those derived types that need them. */
6627 gfc_expr *init_e = NULL;
6630 if (code->ext.alloc.ts.type == BT_DERIVED)
6631 ts = code->ext.alloc.ts;
6632 else if (code->expr3)
6633 ts = code->expr3->ts;
6637 if (ts.type == BT_DERIVED)
6638 init_e = gfc_default_initializer (&ts);
6639 /* FIXME: Use default init of dynamic type (cf. PR 44541). */
6640 else if (e->ts.type == BT_CLASS)
6641 init_e = gfc_default_initializer (&ts.u.derived->components->ts);
6645 gfc_code *init_st = gfc_get_code ();
6646 init_st->loc = code->loc;
6647 init_st->op = EXEC_INIT_ASSIGN;
6648 init_st->expr1 = gfc_expr_to_initialize (e);
6649 init_st->expr2 = init_e;
6650 init_st->next = code->next;
6651 code->next = init_st;
6655 if (e->ts.type == BT_CLASS)
6657 /* Make sure the vtab symbol is present when
6658 the module variables are generated. */
6659 gfc_typespec ts = e->ts;
6661 ts = code->expr3->ts;
6662 else if (code->ext.alloc.ts.type == BT_DERIVED)
6663 ts = code->ext.alloc.ts;
6664 gfc_find_derived_vtab (ts.u.derived);
6667 if (pointer || (dimension == 0 && codimension == 0))
6670 /* Make sure the next-to-last reference node is an array specification. */
6672 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6673 || (dimension && ref2->u.ar.dimen == 0))
6675 gfc_error ("Array specification required in ALLOCATE statement "
6676 "at %L", &e->where);
6680 /* Make sure that the array section reference makes sense in the
6681 context of an ALLOCATE specification. */
6685 if (codimension && ar->codimen == 0)
6687 gfc_error ("Coarray specification required in ALLOCATE statement "
6688 "at %L", &e->where);
6692 for (i = 0; i < ar->dimen; i++)
6694 if (ref2->u.ar.type == AR_ELEMENT)
6697 switch (ar->dimen_type[i])
6703 if (ar->start[i] != NULL
6704 && ar->end[i] != NULL
6705 && ar->stride[i] == NULL)
6708 /* Fall Through... */
6713 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6719 for (a = code->ext.alloc.list; a; a = a->next)
6721 sym = a->expr->symtree->n.sym;
6723 /* TODO - check derived type components. */
6724 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6727 if ((ar->start[i] != NULL
6728 && gfc_find_sym_in_expr (sym, ar->start[i]))
6729 || (ar->end[i] != NULL
6730 && gfc_find_sym_in_expr (sym, ar->end[i])))
6732 gfc_error ("'%s' must not appear in the array specification at "
6733 "%L in the same ALLOCATE statement where it is "
6734 "itself allocated", sym->name, &ar->where);
6740 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
6742 if (ar->dimen_type[i] == DIMEN_ELEMENT
6743 || ar->dimen_type[i] == DIMEN_RANGE)
6745 if (i == (ar->dimen + ar->codimen - 1))
6747 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6748 "statement at %L", &e->where);
6754 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
6755 && ar->stride[i] == NULL)
6758 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6763 if (codimension && ar->as->rank == 0)
6765 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6766 "at %L", &e->where);
6778 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6780 gfc_expr *stat, *errmsg, *pe, *qe;
6781 gfc_alloc *a, *p, *q;
6783 stat = code->expr1 ? code->expr1 : NULL;
6785 errmsg = code->expr2 ? code->expr2 : NULL;
6787 /* Check the stat variable. */
6790 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
6791 gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
6792 stat->symtree->n.sym->name, &stat->where);
6794 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
6795 gfc_error ("Illegal stat-variable at %L for a PURE procedure",
6798 if ((stat->ts.type != BT_INTEGER
6799 && !(stat->ref && (stat->ref->type == REF_ARRAY
6800 || stat->ref->type == REF_COMPONENT)))
6802 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6803 "variable", &stat->where);
6805 for (p = code->ext.alloc.list; p; p = p->next)
6806 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6808 gfc_ref *ref1, *ref2;
6811 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
6812 ref1 = ref1->next, ref2 = ref2->next)
6814 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6816 if (ref1->u.c.component->name != ref2->u.c.component->name)
6825 gfc_error ("Stat-variable at %L shall not be %sd within "
6826 "the same %s statement", &stat->where, fcn, fcn);
6832 /* Check the errmsg variable. */
6836 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6839 if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
6840 gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
6841 errmsg->symtree->n.sym->name, &errmsg->where);
6843 if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
6844 gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
6847 if ((errmsg->ts.type != BT_CHARACTER
6849 && (errmsg->ref->type == REF_ARRAY
6850 || errmsg->ref->type == REF_COMPONENT)))
6851 || errmsg->rank > 0 )
6852 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6853 "variable", &errmsg->where);
6855 for (p = code->ext.alloc.list; p; p = p->next)
6856 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6858 gfc_ref *ref1, *ref2;
6861 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
6862 ref1 = ref1->next, ref2 = ref2->next)
6864 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
6866 if (ref1->u.c.component->name != ref2->u.c.component->name)
6875 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6876 "the same %s statement", &errmsg->where, fcn, fcn);
6882 /* Check that an allocate-object appears only once in the statement.
6883 FIXME: Checking derived types is disabled. */
6884 for (p = code->ext.alloc.list; p; p = p->next)
6887 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6888 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6890 for (q = p->next; q; q = q->next)
6893 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6894 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6895 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6896 gfc_error ("Allocate-object at %L also appears at %L",
6897 &pe->where, &qe->where);
6902 if (strcmp (fcn, "ALLOCATE") == 0)
6904 for (a = code->ext.alloc.list; a; a = a->next)
6905 resolve_allocate_expr (a->expr, code);
6909 for (a = code->ext.alloc.list; a; a = a->next)
6910 resolve_deallocate_expr (a->expr);
6915 /************ SELECT CASE resolution subroutines ************/
6917 /* Callback function for our mergesort variant. Determines interval
6918 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
6919 op1 > op2. Assumes we're not dealing with the default case.
6920 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
6921 There are nine situations to check. */
6924 compare_cases (const gfc_case *op1, const gfc_case *op2)
6928 if (op1->low == NULL) /* op1 = (:L) */
6930 /* op2 = (:N), so overlap. */
6932 /* op2 = (M:) or (M:N), L < M */
6933 if (op2->low != NULL
6934 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6937 else if (op1->high == NULL) /* op1 = (K:) */
6939 /* op2 = (M:), so overlap. */
6941 /* op2 = (:N) or (M:N), K > N */
6942 if (op2->high != NULL
6943 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6946 else /* op1 = (K:L) */
6948 if (op2->low == NULL) /* op2 = (:N), K > N */
6949 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6951 else if (op2->high == NULL) /* op2 = (M:), L < M */
6952 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6954 else /* op2 = (M:N) */
6958 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6961 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6970 /* Merge-sort a double linked case list, detecting overlap in the
6971 process. LIST is the head of the double linked case list before it
6972 is sorted. Returns the head of the sorted list if we don't see any
6973 overlap, or NULL otherwise. */
6976 check_case_overlap (gfc_case *list)
6978 gfc_case *p, *q, *e, *tail;
6979 int insize, nmerges, psize, qsize, cmp, overlap_seen;
6981 /* If the passed list was empty, return immediately. */
6988 /* Loop unconditionally. The only exit from this loop is a return
6989 statement, when we've finished sorting the case list. */
6996 /* Count the number of merges we do in this pass. */
6999 /* Loop while there exists a merge to be done. */
7004 /* Count this merge. */
7007 /* Cut the list in two pieces by stepping INSIZE places
7008 forward in the list, starting from P. */
7011 for (i = 0; i < insize; i++)
7020 /* Now we have two lists. Merge them! */
7021 while (psize > 0 || (qsize > 0 && q != NULL))
7023 /* See from which the next case to merge comes from. */
7026 /* P is empty so the next case must come from Q. */
7031 else if (qsize == 0 || q == NULL)
7040 cmp = compare_cases (p, q);
7043 /* The whole case range for P is less than the
7051 /* The whole case range for Q is greater than
7052 the case range for P. */
7059 /* The cases overlap, or they are the same
7060 element in the list. Either way, we must
7061 issue an error and get the next case from P. */
7062 /* FIXME: Sort P and Q by line number. */
7063 gfc_error ("CASE label at %L overlaps with CASE "
7064 "label at %L", &p->where, &q->where);
7072 /* Add the next element to the merged list. */
7081 /* P has now stepped INSIZE places along, and so has Q. So
7082 they're the same. */
7087 /* If we have done only one merge or none at all, we've
7088 finished sorting the cases. */
7097 /* Otherwise repeat, merging lists twice the size. */
7103 /* Check to see if an expression is suitable for use in a CASE statement.
7104 Makes sure that all case expressions are scalar constants of the same
7105 type. Return FAILURE if anything is wrong. */
7108 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7110 if (e == NULL) return SUCCESS;
7112 if (e->ts.type != case_expr->ts.type)
7114 gfc_error ("Expression in CASE statement at %L must be of type %s",
7115 &e->where, gfc_basic_typename (case_expr->ts.type));
7119 /* C805 (R808) For a given case-construct, each case-value shall be of
7120 the same type as case-expr. For character type, length differences
7121 are allowed, but the kind type parameters shall be the same. */
7123 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7125 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7126 &e->where, case_expr->ts.kind);
7130 /* Convert the case value kind to that of case expression kind,
7133 if (e->ts.kind != case_expr->ts.kind)
7134 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7138 gfc_error ("Expression in CASE statement at %L must be scalar",
7147 /* Given a completely parsed select statement, we:
7149 - Validate all expressions and code within the SELECT.
7150 - Make sure that the selection expression is not of the wrong type.
7151 - Make sure that no case ranges overlap.
7152 - Eliminate unreachable cases and unreachable code resulting from
7153 removing case labels.
7155 The standard does allow unreachable cases, e.g. CASE (5:3). But
7156 they are a hassle for code generation, and to prevent that, we just
7157 cut them out here. This is not necessary for overlapping cases
7158 because they are illegal and we never even try to generate code.
7160 We have the additional caveat that a SELECT construct could have
7161 been a computed GOTO in the source code. Fortunately we can fairly
7162 easily work around that here: The case_expr for a "real" SELECT CASE
7163 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7164 we have to do is make sure that the case_expr is a scalar integer
7168 resolve_select (gfc_code *code)
7171 gfc_expr *case_expr;
7172 gfc_case *cp, *default_case, *tail, *head;
7173 int seen_unreachable;
7179 if (code->expr1 == NULL)
7181 /* This was actually a computed GOTO statement. */
7182 case_expr = code->expr2;
7183 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7184 gfc_error ("Selection expression in computed GOTO statement "
7185 "at %L must be a scalar integer expression",
7188 /* Further checking is not necessary because this SELECT was built
7189 by the compiler, so it should always be OK. Just move the
7190 case_expr from expr2 to expr so that we can handle computed
7191 GOTOs as normal SELECTs from here on. */
7192 code->expr1 = code->expr2;
7197 case_expr = code->expr1;
7199 type = case_expr->ts.type;
7200 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7202 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7203 &case_expr->where, gfc_typename (&case_expr->ts));
7205 /* Punt. Going on here just produce more garbage error messages. */
7209 if (case_expr->rank != 0)
7211 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7212 "expression", &case_expr->where);
7219 /* Raise a warning if an INTEGER case value exceeds the range of
7220 the case-expr. Later, all expressions will be promoted to the
7221 largest kind of all case-labels. */
7223 if (type == BT_INTEGER)
7224 for (body = code->block; body; body = body->block)
7225 for (cp = body->ext.case_list; cp; cp = cp->next)
7228 && gfc_check_integer_range (cp->low->value.integer,
7229 case_expr->ts.kind) != ARITH_OK)
7230 gfc_warning ("Expression in CASE statement at %L is "
7231 "not in the range of %s", &cp->low->where,
7232 gfc_typename (&case_expr->ts));
7235 && cp->low != cp->high
7236 && gfc_check_integer_range (cp->high->value.integer,
7237 case_expr->ts.kind) != ARITH_OK)
7238 gfc_warning ("Expression in CASE statement at %L is "
7239 "not in the range of %s", &cp->high->where,
7240 gfc_typename (&case_expr->ts));
7243 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7244 of the SELECT CASE expression and its CASE values. Walk the lists
7245 of case values, and if we find a mismatch, promote case_expr to
7246 the appropriate kind. */
7248 if (type == BT_LOGICAL || type == BT_INTEGER)
7250 for (body = code->block; body; body = body->block)
7252 /* Walk the case label list. */
7253 for (cp = body->ext.case_list; cp; cp = cp->next)
7255 /* Intercept the DEFAULT case. It does not have a kind. */
7256 if (cp->low == NULL && cp->high == NULL)
7259 /* Unreachable case ranges are discarded, so ignore. */
7260 if (cp->low != NULL && cp->high != NULL
7261 && cp->low != cp->high
7262 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7266 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7267 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7269 if (cp->high != NULL
7270 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7271 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7276 /* Assume there is no DEFAULT case. */
7277 default_case = NULL;
7282 for (body = code->block; body; body = body->block)
7284 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7286 seen_unreachable = 0;
7288 /* Walk the case label list, making sure that all case labels
7290 for (cp = body->ext.case_list; cp; cp = cp->next)
7292 /* Count the number of cases in the whole construct. */
7295 /* Intercept the DEFAULT case. */
7296 if (cp->low == NULL && cp->high == NULL)
7298 if (default_case != NULL)
7300 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7301 "by a second DEFAULT CASE at %L",
7302 &default_case->where, &cp->where);
7313 /* Deal with single value cases and case ranges. Errors are
7314 issued from the validation function. */
7315 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7316 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7322 if (type == BT_LOGICAL
7323 && ((cp->low == NULL || cp->high == NULL)
7324 || cp->low != cp->high))
7326 gfc_error ("Logical range in CASE statement at %L is not "
7327 "allowed", &cp->low->where);
7332 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7335 value = cp->low->value.logical == 0 ? 2 : 1;
7336 if (value & seen_logical)
7338 gfc_error ("Constant logical value in CASE statement "
7339 "is repeated at %L",
7344 seen_logical |= value;
7347 if (cp->low != NULL && cp->high != NULL
7348 && cp->low != cp->high
7349 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7351 if (gfc_option.warn_surprising)
7352 gfc_warning ("Range specification at %L can never "
7353 "be matched", &cp->where);
7355 cp->unreachable = 1;
7356 seen_unreachable = 1;
7360 /* If the case range can be matched, it can also overlap with
7361 other cases. To make sure it does not, we put it in a
7362 double linked list here. We sort that with a merge sort
7363 later on to detect any overlapping cases. */
7367 head->right = head->left = NULL;
7372 tail->right->left = tail;
7379 /* It there was a failure in the previous case label, give up
7380 for this case label list. Continue with the next block. */
7384 /* See if any case labels that are unreachable have been seen.
7385 If so, we eliminate them. This is a bit of a kludge because
7386 the case lists for a single case statement (label) is a
7387 single forward linked lists. */
7388 if (seen_unreachable)
7390 /* Advance until the first case in the list is reachable. */
7391 while (body->ext.case_list != NULL
7392 && body->ext.case_list->unreachable)
7394 gfc_case *n = body->ext.case_list;
7395 body->ext.case_list = body->ext.case_list->next;
7397 gfc_free_case_list (n);
7400 /* Strip all other unreachable cases. */
7401 if (body->ext.case_list)
7403 for (cp = body->ext.case_list; cp->next; cp = cp->next)
7405 if (cp->next->unreachable)
7407 gfc_case *n = cp->next;
7408 cp->next = cp->next->next;
7410 gfc_free_case_list (n);
7417 /* See if there were overlapping cases. If the check returns NULL,
7418 there was overlap. In that case we don't do anything. If head
7419 is non-NULL, we prepend the DEFAULT case. The sorted list can
7420 then used during code generation for SELECT CASE constructs with
7421 a case expression of a CHARACTER type. */
7424 head = check_case_overlap (head);
7426 /* Prepend the default_case if it is there. */
7427 if (head != NULL && default_case)
7429 default_case->left = NULL;
7430 default_case->right = head;
7431 head->left = default_case;
7435 /* Eliminate dead blocks that may be the result if we've seen
7436 unreachable case labels for a block. */
7437 for (body = code; body && body->block; body = body->block)
7439 if (body->block->ext.case_list == NULL)
7441 /* Cut the unreachable block from the code chain. */
7442 gfc_code *c = body->block;
7443 body->block = c->block;
7445 /* Kill the dead block, but not the blocks below it. */
7447 gfc_free_statements (c);
7451 /* More than two cases is legal but insane for logical selects.
7452 Issue a warning for it. */
7453 if (gfc_option.warn_surprising && type == BT_LOGICAL
7455 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7460 /* Check if a derived type is extensible. */
7463 gfc_type_is_extensible (gfc_symbol *sym)
7465 return !(sym->attr.is_bind_c || sym->attr.sequence);
7469 /* Resolve a SELECT TYPE statement. */
7472 resolve_select_type (gfc_code *code)
7474 gfc_symbol *selector_type;
7475 gfc_code *body, *new_st, *if_st, *tail;
7476 gfc_code *class_is = NULL, *default_case = NULL;
7479 char name[GFC_MAX_SYMBOL_LEN];
7483 ns = code->ext.block.ns;
7486 /* Check for F03:C813. */
7487 if (code->expr1->ts.type != BT_CLASS
7488 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7490 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7491 "at %L", &code->loc);
7497 if (code->expr1->symtree->n.sym->attr.untyped)
7498 code->expr1->symtree->n.sym->ts = code->expr2->ts;
7499 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7502 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7504 /* Loop over TYPE IS / CLASS IS cases. */
7505 for (body = code->block; body; body = body->block)
7507 c = body->ext.case_list;
7509 /* Check F03:C815. */
7510 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7511 && !gfc_type_is_extensible (c->ts.u.derived))
7513 gfc_error ("Derived type '%s' at %L must be extensible",
7514 c->ts.u.derived->name, &c->where);
7519 /* Check F03:C816. */
7520 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7521 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7523 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7524 c->ts.u.derived->name, &c->where, selector_type->name);
7529 /* Intercept the DEFAULT case. */
7530 if (c->ts.type == BT_UNKNOWN)
7532 /* Check F03:C818. */
7535 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7536 "by a second DEFAULT CASE at %L",
7537 &default_case->ext.case_list->where, &c->where);
7542 default_case = body;
7551 /* Insert assignment for selector variable. */
7552 new_st = gfc_get_code ();
7553 new_st->op = EXEC_ASSIGN;
7554 new_st->expr1 = gfc_copy_expr (code->expr1);
7555 new_st->expr2 = gfc_copy_expr (code->expr2);
7559 /* Put SELECT TYPE statement inside a BLOCK. */
7560 new_st = gfc_get_code ();
7561 new_st->op = code->op;
7562 new_st->expr1 = code->expr1;
7563 new_st->expr2 = code->expr2;
7564 new_st->block = code->block;
7568 ns->code->next = new_st;
7569 code->op = EXEC_BLOCK;
7570 code->ext.block.assoc = NULL;
7571 code->expr1 = code->expr2 = NULL;
7576 /* Transform to EXEC_SELECT. */
7577 code->op = EXEC_SELECT;
7578 gfc_add_component_ref (code->expr1, "$vptr");
7579 gfc_add_component_ref (code->expr1, "$hash");
7581 /* Loop over TYPE IS / CLASS IS cases. */
7582 for (body = code->block; body; body = body->block)
7584 c = body->ext.case_list;
7586 if (c->ts.type == BT_DERIVED)
7587 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7588 c->ts.u.derived->hash_value);
7590 else if (c->ts.type == BT_UNKNOWN)
7593 /* Assign temporary to selector. */
7594 if (c->ts.type == BT_CLASS)
7595 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
7597 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
7598 st = gfc_find_symtree (ns->sym_root, name);
7599 new_st = gfc_get_code ();
7600 new_st->expr1 = gfc_get_variable_expr (st);
7601 new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
7602 if (c->ts.type == BT_DERIVED)
7604 new_st->op = EXEC_POINTER_ASSIGN;
7605 gfc_add_component_ref (new_st->expr2, "$data");
7608 new_st->op = EXEC_POINTER_ASSIGN;
7609 new_st->next = body->next;
7610 body->next = new_st;
7613 /* Take out CLASS IS cases for separate treatment. */
7615 while (body && body->block)
7617 if (body->block->ext.case_list->ts.type == BT_CLASS)
7619 /* Add to class_is list. */
7620 if (class_is == NULL)
7622 class_is = body->block;
7627 for (tail = class_is; tail->block; tail = tail->block) ;
7628 tail->block = body->block;
7631 /* Remove from EXEC_SELECT list. */
7632 body->block = body->block->block;
7645 /* Add a default case to hold the CLASS IS cases. */
7646 for (tail = code; tail->block; tail = tail->block) ;
7647 tail->block = gfc_get_code ();
7649 tail->op = EXEC_SELECT_TYPE;
7650 tail->ext.case_list = gfc_get_case ();
7651 tail->ext.case_list->ts.type = BT_UNKNOWN;
7653 default_case = tail;
7656 /* More than one CLASS IS block? */
7657 if (class_is->block)
7661 /* Sort CLASS IS blocks by extension level. */
7665 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7668 /* F03:C817 (check for doubles). */
7669 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7670 == c2->ext.case_list->ts.u.derived->hash_value)
7672 gfc_error ("Double CLASS IS block in SELECT TYPE "
7673 "statement at %L", &c2->ext.case_list->where);
7676 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7677 < c2->ext.case_list->ts.u.derived->attr.extension)
7680 (*c1)->block = c2->block;
7690 /* Generate IF chain. */
7691 if_st = gfc_get_code ();
7692 if_st->op = EXEC_IF;
7694 for (body = class_is; body; body = body->block)
7696 new_st->block = gfc_get_code ();
7697 new_st = new_st->block;
7698 new_st->op = EXEC_IF;
7699 /* Set up IF condition: Call _gfortran_is_extension_of. */
7700 new_st->expr1 = gfc_get_expr ();
7701 new_st->expr1->expr_type = EXPR_FUNCTION;
7702 new_st->expr1->ts.type = BT_LOGICAL;
7703 new_st->expr1->ts.kind = 4;
7704 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7705 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7706 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7707 /* Set up arguments. */
7708 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7709 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7710 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7711 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7712 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7713 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7714 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7715 new_st->next = body->next;
7717 if (default_case->next)
7719 new_st->block = gfc_get_code ();
7720 new_st = new_st->block;
7721 new_st->op = EXEC_IF;
7722 new_st->next = default_case->next;
7725 /* Replace CLASS DEFAULT code by the IF chain. */
7726 default_case->next = if_st;
7729 resolve_select (code);
7734 /* Resolve a transfer statement. This is making sure that:
7735 -- a derived type being transferred has only non-pointer components
7736 -- a derived type being transferred doesn't have private components, unless
7737 it's being transferred from the module where the type was defined
7738 -- we're not trying to transfer a whole assumed size array. */
7741 resolve_transfer (gfc_code *code)
7750 while (exp != NULL && exp->expr_type == EXPR_OP
7751 && exp->value.op.op == INTRINSIC_PARENTHESES)
7752 exp = exp->value.op.op1;
7754 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
7755 && exp->expr_type != EXPR_FUNCTION))
7758 sym = exp->symtree->n.sym;
7761 /* Go to actual component transferred. */
7762 for (ref = code->expr1->ref; ref; ref = ref->next)
7763 if (ref->type == REF_COMPONENT)
7764 ts = &ref->u.c.component->ts;
7766 if (ts->type == BT_DERIVED)
7768 /* Check that transferred derived type doesn't contain POINTER
7770 if (ts->u.derived->attr.pointer_comp)
7772 gfc_error ("Data transfer element at %L cannot have "
7773 "POINTER components", &code->loc);
7777 if (ts->u.derived->attr.alloc_comp)
7779 gfc_error ("Data transfer element at %L cannot have "
7780 "ALLOCATABLE components", &code->loc);
7784 if (derived_inaccessible (ts->u.derived))
7786 gfc_error ("Data transfer element at %L cannot have "
7787 "PRIVATE components",&code->loc);
7792 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7793 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7795 gfc_error ("Data transfer element at %L cannot be a full reference to "
7796 "an assumed-size array", &code->loc);
7802 /*********** Toplevel code resolution subroutines ***********/
7804 /* Find the set of labels that are reachable from this block. We also
7805 record the last statement in each block. */
7808 find_reachable_labels (gfc_code *block)
7815 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
7817 /* Collect labels in this block. We don't keep those corresponding
7818 to END {IF|SELECT}, these are checked in resolve_branch by going
7819 up through the code_stack. */
7820 for (c = block; c; c = c->next)
7822 if (c->here && c->op != EXEC_END_BLOCK)
7823 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
7826 /* Merge with labels from parent block. */
7829 gcc_assert (cs_base->prev->reachable_labels);
7830 bitmap_ior_into (cs_base->reachable_labels,
7831 cs_base->prev->reachable_labels);
7837 resolve_sync (gfc_code *code)
7839 /* Check imageset. The * case matches expr1 == NULL. */
7842 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
7843 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
7844 "INTEGER expression", &code->expr1->where);
7845 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
7846 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
7847 gfc_error ("Imageset argument at %L must between 1 and num_images()",
7848 &code->expr1->where);
7849 else if (code->expr1->expr_type == EXPR_ARRAY
7850 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
7852 gfc_constructor *cons;
7853 cons = gfc_constructor_first (code->expr1->value.constructor);
7854 for (; cons; cons = gfc_constructor_next (cons))
7855 if (cons->expr->expr_type == EXPR_CONSTANT
7856 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
7857 gfc_error ("Imageset argument at %L must between 1 and "
7858 "num_images()", &cons->expr->where);
7864 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
7865 || code->expr2->expr_type != EXPR_VARIABLE))
7866 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
7867 &code->expr2->where);
7871 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
7872 || code->expr3->expr_type != EXPR_VARIABLE))
7873 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
7874 &code->expr3->where);
7878 /* Given a branch to a label, see if the branch is conforming.
7879 The code node describes where the branch is located. */
7882 resolve_branch (gfc_st_label *label, gfc_code *code)
7889 /* Step one: is this a valid branching target? */
7891 if (label->defined == ST_LABEL_UNKNOWN)
7893 gfc_error ("Label %d referenced at %L is never defined", label->value,
7898 if (label->defined != ST_LABEL_TARGET)
7900 gfc_error ("Statement at %L is not a valid branch target statement "
7901 "for the branch statement at %L", &label->where, &code->loc);
7905 /* Step two: make sure this branch is not a branch to itself ;-) */
7907 if (code->here == label)
7909 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
7913 /* Step three: See if the label is in the same block as the
7914 branching statement. The hard work has been done by setting up
7915 the bitmap reachable_labels. */
7917 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
7919 /* Check now whether there is a CRITICAL construct; if so, check
7920 whether the label is still visible outside of the CRITICAL block,
7921 which is invalid. */
7922 for (stack = cs_base; stack; stack = stack->prev)
7923 if (stack->current->op == EXEC_CRITICAL
7924 && bitmap_bit_p (stack->reachable_labels, label->value))
7925 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
7926 " at %L", &code->loc, &label->where);
7931 /* Step four: If we haven't found the label in the bitmap, it may
7932 still be the label of the END of the enclosing block, in which
7933 case we find it by going up the code_stack. */
7935 for (stack = cs_base; stack; stack = stack->prev)
7937 if (stack->current->next && stack->current->next->here == label)
7939 if (stack->current->op == EXEC_CRITICAL)
7941 /* Note: A label at END CRITICAL does not leave the CRITICAL
7942 construct as END CRITICAL is still part of it. */
7943 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
7944 " at %L", &code->loc, &label->where);
7951 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
7955 /* The label is not in an enclosing block, so illegal. This was
7956 allowed in Fortran 66, so we allow it as extension. No
7957 further checks are necessary in this case. */
7958 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
7959 "as the GOTO statement at %L", &label->where,
7965 /* Check whether EXPR1 has the same shape as EXPR2. */
7968 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
7970 mpz_t shape[GFC_MAX_DIMENSIONS];
7971 mpz_t shape2[GFC_MAX_DIMENSIONS];
7972 gfc_try result = FAILURE;
7975 /* Compare the rank. */
7976 if (expr1->rank != expr2->rank)
7979 /* Compare the size of each dimension. */
7980 for (i=0; i<expr1->rank; i++)
7982 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
7985 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
7988 if (mpz_cmp (shape[i], shape2[i]))
7992 /* When either of the two expression is an assumed size array, we
7993 ignore the comparison of dimension sizes. */
7998 for (i--; i >= 0; i--)
8000 mpz_clear (shape[i]);
8001 mpz_clear (shape2[i]);
8007 /* Check whether a WHERE assignment target or a WHERE mask expression
8008 has the same shape as the outmost WHERE mask expression. */
8011 resolve_where (gfc_code *code, gfc_expr *mask)
8017 cblock = code->block;
8019 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8020 In case of nested WHERE, only the outmost one is stored. */
8021 if (mask == NULL) /* outmost WHERE */
8023 else /* inner WHERE */
8030 /* Check if the mask-expr has a consistent shape with the
8031 outmost WHERE mask-expr. */
8032 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8033 gfc_error ("WHERE mask at %L has inconsistent shape",
8034 &cblock->expr1->where);
8037 /* the assignment statement of a WHERE statement, or the first
8038 statement in where-body-construct of a WHERE construct */
8039 cnext = cblock->next;
8044 /* WHERE assignment statement */
8047 /* Check shape consistent for WHERE assignment target. */
8048 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8049 gfc_error ("WHERE assignment target at %L has "
8050 "inconsistent shape", &cnext->expr1->where);
8054 case EXEC_ASSIGN_CALL:
8055 resolve_call (cnext);
8056 if (!cnext->resolved_sym->attr.elemental)
8057 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8058 &cnext->ext.actual->expr->where);
8061 /* WHERE or WHERE construct is part of a where-body-construct */
8063 resolve_where (cnext, e);
8067 gfc_error ("Unsupported statement inside WHERE at %L",
8070 /* the next statement within the same where-body-construct */
8071 cnext = cnext->next;
8073 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8074 cblock = cblock->block;
8079 /* Resolve assignment in FORALL construct.
8080 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8081 FORALL index variables. */
8084 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8088 for (n = 0; n < nvar; n++)
8090 gfc_symbol *forall_index;
8092 forall_index = var_expr[n]->symtree->n.sym;
8094 /* Check whether the assignment target is one of the FORALL index
8096 if ((code->expr1->expr_type == EXPR_VARIABLE)
8097 && (code->expr1->symtree->n.sym == forall_index))
8098 gfc_error ("Assignment to a FORALL index variable at %L",
8099 &code->expr1->where);
8102 /* If one of the FORALL index variables doesn't appear in the
8103 assignment variable, then there could be a many-to-one
8104 assignment. Emit a warning rather than an error because the
8105 mask could be resolving this problem. */
8106 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8107 gfc_warning ("The FORALL with index '%s' is not used on the "
8108 "left side of the assignment at %L and so might "
8109 "cause multiple assignment to this object",
8110 var_expr[n]->symtree->name, &code->expr1->where);
8116 /* Resolve WHERE statement in FORALL construct. */
8119 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8120 gfc_expr **var_expr)
8125 cblock = code->block;
8128 /* the assignment statement of a WHERE statement, or the first
8129 statement in where-body-construct of a WHERE construct */
8130 cnext = cblock->next;
8135 /* WHERE assignment statement */
8137 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8140 /* WHERE operator assignment statement */
8141 case EXEC_ASSIGN_CALL:
8142 resolve_call (cnext);
8143 if (!cnext->resolved_sym->attr.elemental)
8144 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8145 &cnext->ext.actual->expr->where);
8148 /* WHERE or WHERE construct is part of a where-body-construct */
8150 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8154 gfc_error ("Unsupported statement inside WHERE at %L",
8157 /* the next statement within the same where-body-construct */
8158 cnext = cnext->next;
8160 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8161 cblock = cblock->block;
8166 /* Traverse the FORALL body to check whether the following errors exist:
8167 1. For assignment, check if a many-to-one assignment happens.
8168 2. For WHERE statement, check the WHERE body to see if there is any
8169 many-to-one assignment. */
8172 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8176 c = code->block->next;
8182 case EXEC_POINTER_ASSIGN:
8183 gfc_resolve_assign_in_forall (c, nvar, var_expr);
8186 case EXEC_ASSIGN_CALL:
8190 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8191 there is no need to handle it here. */
8195 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8200 /* The next statement in the FORALL body. */
8206 /* Counts the number of iterators needed inside a forall construct, including
8207 nested forall constructs. This is used to allocate the needed memory
8208 in gfc_resolve_forall. */
8211 gfc_count_forall_iterators (gfc_code *code)
8213 int max_iters, sub_iters, current_iters;
8214 gfc_forall_iterator *fa;
8216 gcc_assert(code->op == EXEC_FORALL);
8220 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8223 code = code->block->next;
8227 if (code->op == EXEC_FORALL)
8229 sub_iters = gfc_count_forall_iterators (code);
8230 if (sub_iters > max_iters)
8231 max_iters = sub_iters;
8236 return current_iters + max_iters;
8240 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8241 gfc_resolve_forall_body to resolve the FORALL body. */
8244 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8246 static gfc_expr **var_expr;
8247 static int total_var = 0;
8248 static int nvar = 0;
8250 gfc_forall_iterator *fa;
8255 /* Start to resolve a FORALL construct */
8256 if (forall_save == 0)
8258 /* Count the total number of FORALL index in the nested FORALL
8259 construct in order to allocate the VAR_EXPR with proper size. */
8260 total_var = gfc_count_forall_iterators (code);
8262 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8263 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
8266 /* The information about FORALL iterator, including FORALL index start, end
8267 and stride. The FORALL index can not appear in start, end or stride. */
8268 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8270 /* Check if any outer FORALL index name is the same as the current
8272 for (i = 0; i < nvar; i++)
8274 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8276 gfc_error ("An outer FORALL construct already has an index "
8277 "with this name %L", &fa->var->where);
8281 /* Record the current FORALL index. */
8282 var_expr[nvar] = gfc_copy_expr (fa->var);
8286 /* No memory leak. */
8287 gcc_assert (nvar <= total_var);
8290 /* Resolve the FORALL body. */
8291 gfc_resolve_forall_body (code, nvar, var_expr);
8293 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8294 gfc_resolve_blocks (code->block, ns);
8298 /* Free only the VAR_EXPRs allocated in this frame. */
8299 for (i = nvar; i < tmp; i++)
8300 gfc_free_expr (var_expr[i]);
8304 /* We are in the outermost FORALL construct. */
8305 gcc_assert (forall_save == 0);
8307 /* VAR_EXPR is not needed any more. */
8308 gfc_free (var_expr);
8314 /* Resolve a BLOCK construct statement. */
8317 resolve_block_construct (gfc_code* code)
8319 /* Resolve the BLOCK's namespace. */
8320 gfc_resolve (code->ext.block.ns);
8322 /* For an ASSOCIATE block, the associations (and their targets) are already
8323 resolved during gfc_resolve_symbol. */
8327 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8330 static void resolve_code (gfc_code *, gfc_namespace *);
8333 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8337 for (; b; b = b->block)
8339 t = gfc_resolve_expr (b->expr1);
8340 if (gfc_resolve_expr (b->expr2) == FAILURE)
8346 if (t == SUCCESS && b->expr1 != NULL
8347 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8348 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8355 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8356 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8361 resolve_branch (b->label1, b);
8365 resolve_block_construct (b);
8369 case EXEC_SELECT_TYPE:
8380 case EXEC_OMP_ATOMIC:
8381 case EXEC_OMP_CRITICAL:
8383 case EXEC_OMP_MASTER:
8384 case EXEC_OMP_ORDERED:
8385 case EXEC_OMP_PARALLEL:
8386 case EXEC_OMP_PARALLEL_DO:
8387 case EXEC_OMP_PARALLEL_SECTIONS:
8388 case EXEC_OMP_PARALLEL_WORKSHARE:
8389 case EXEC_OMP_SECTIONS:
8390 case EXEC_OMP_SINGLE:
8392 case EXEC_OMP_TASKWAIT:
8393 case EXEC_OMP_WORKSHARE:
8397 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8400 resolve_code (b->next, ns);
8405 /* Does everything to resolve an ordinary assignment. Returns true
8406 if this is an interface assignment. */
8408 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8418 if (gfc_extend_assign (code, ns) == SUCCESS)
8422 if (code->op == EXEC_ASSIGN_CALL)
8424 lhs = code->ext.actual->expr;
8425 rhsptr = &code->ext.actual->next->expr;
8429 gfc_actual_arglist* args;
8430 gfc_typebound_proc* tbp;
8432 gcc_assert (code->op == EXEC_COMPCALL);
8434 args = code->expr1->value.compcall.actual;
8436 rhsptr = &args->next->expr;
8438 tbp = code->expr1->value.compcall.tbp;
8439 gcc_assert (!tbp->is_generic);
8442 /* Make a temporary rhs when there is a default initializer
8443 and rhs is the same symbol as the lhs. */
8444 if ((*rhsptr)->expr_type == EXPR_VARIABLE
8445 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8446 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8447 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8448 *rhsptr = gfc_get_parentheses (*rhsptr);
8457 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8458 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8459 &code->loc) == FAILURE)
8462 /* Handle the case of a BOZ literal on the RHS. */
8463 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8466 if (gfc_option.warn_surprising)
8467 gfc_warning ("BOZ literal at %L is bitwise transferred "
8468 "non-integer symbol '%s'", &code->loc,
8469 lhs->symtree->n.sym->name);
8471 if (!gfc_convert_boz (rhs, &lhs->ts))
8473 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8475 if (rc == ARITH_UNDERFLOW)
8476 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8477 ". This check can be disabled with the option "
8478 "-fno-range-check", &rhs->where);
8479 else if (rc == ARITH_OVERFLOW)
8480 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8481 ". This check can be disabled with the option "
8482 "-fno-range-check", &rhs->where);
8483 else if (rc == ARITH_NAN)
8484 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8485 ". This check can be disabled with the option "
8486 "-fno-range-check", &rhs->where);
8492 if (lhs->ts.type == BT_CHARACTER
8493 && gfc_option.warn_character_truncation)
8495 if (lhs->ts.u.cl != NULL
8496 && lhs->ts.u.cl->length != NULL
8497 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8498 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
8500 if (rhs->expr_type == EXPR_CONSTANT)
8501 rlen = rhs->value.character.length;
8503 else if (rhs->ts.u.cl != NULL
8504 && rhs->ts.u.cl->length != NULL
8505 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8506 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
8508 if (rlen && llen && rlen > llen)
8509 gfc_warning_now ("CHARACTER expression will be truncated "
8510 "in assignment (%d/%d) at %L",
8511 llen, rlen, &code->loc);
8514 /* Ensure that a vector index expression for the lvalue is evaluated
8515 to a temporary if the lvalue symbol is referenced in it. */
8518 for (ref = lhs->ref; ref; ref= ref->next)
8519 if (ref->type == REF_ARRAY)
8521 for (n = 0; n < ref->u.ar.dimen; n++)
8522 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
8523 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
8524 ref->u.ar.start[n]))
8526 = gfc_get_parentheses (ref->u.ar.start[n]);
8530 if (gfc_pure (NULL))
8532 if (gfc_impure_variable (lhs->symtree->n.sym))
8534 gfc_error ("Cannot assign to variable '%s' in PURE "
8536 lhs->symtree->n.sym->name,
8541 if (lhs->ts.type == BT_DERIVED
8542 && lhs->expr_type == EXPR_VARIABLE
8543 && lhs->ts.u.derived->attr.pointer_comp
8544 && rhs->expr_type == EXPR_VARIABLE
8545 && (gfc_impure_variable (rhs->symtree->n.sym)
8546 || gfc_is_coindexed (rhs)))
8549 if (gfc_is_coindexed (rhs))
8550 gfc_error ("Coindexed expression at %L is assigned to "
8551 "a derived type variable with a POINTER "
8552 "component in a PURE procedure",
8555 gfc_error ("The impure variable at %L is assigned to "
8556 "a derived type variable with a POINTER "
8557 "component in a PURE procedure (12.6)",
8562 /* Fortran 2008, C1283. */
8563 if (gfc_is_coindexed (lhs))
8565 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8566 "procedure", &rhs->where);
8572 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8573 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8574 if (lhs->ts.type == BT_CLASS)
8576 gfc_error ("Variable must not be polymorphic in assignment at %L",
8581 /* F2008, Section 7.2.1.2. */
8582 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
8584 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8585 "component in assignment at %L", &lhs->where);
8589 gfc_check_assign (lhs, rhs, 1);
8594 /* Given a block of code, recursively resolve everything pointed to by this
8598 resolve_code (gfc_code *code, gfc_namespace *ns)
8600 int omp_workshare_save;
8605 frame.prev = cs_base;
8609 find_reachable_labels (code);
8611 for (; code; code = code->next)
8613 frame.current = code;
8614 forall_save = forall_flag;
8616 if (code->op == EXEC_FORALL)
8619 gfc_resolve_forall (code, ns, forall_save);
8622 else if (code->block)
8624 omp_workshare_save = -1;
8627 case EXEC_OMP_PARALLEL_WORKSHARE:
8628 omp_workshare_save = omp_workshare_flag;
8629 omp_workshare_flag = 1;
8630 gfc_resolve_omp_parallel_blocks (code, ns);
8632 case EXEC_OMP_PARALLEL:
8633 case EXEC_OMP_PARALLEL_DO:
8634 case EXEC_OMP_PARALLEL_SECTIONS:
8636 omp_workshare_save = omp_workshare_flag;
8637 omp_workshare_flag = 0;
8638 gfc_resolve_omp_parallel_blocks (code, ns);
8641 gfc_resolve_omp_do_blocks (code, ns);
8643 case EXEC_SELECT_TYPE:
8644 gfc_current_ns = code->ext.block.ns;
8645 gfc_resolve_blocks (code->block, gfc_current_ns);
8646 gfc_current_ns = ns;
8648 case EXEC_OMP_WORKSHARE:
8649 omp_workshare_save = omp_workshare_flag;
8650 omp_workshare_flag = 1;
8653 gfc_resolve_blocks (code->block, ns);
8657 if (omp_workshare_save != -1)
8658 omp_workshare_flag = omp_workshare_save;
8662 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
8663 t = gfc_resolve_expr (code->expr1);
8664 forall_flag = forall_save;
8666 if (gfc_resolve_expr (code->expr2) == FAILURE)
8669 if (code->op == EXEC_ALLOCATE
8670 && gfc_resolve_expr (code->expr3) == FAILURE)
8676 case EXEC_END_BLOCK:
8680 case EXEC_ERROR_STOP:
8684 case EXEC_ASSIGN_CALL:
8689 case EXEC_SYNC_IMAGES:
8690 case EXEC_SYNC_MEMORY:
8691 resolve_sync (code);
8695 /* Keep track of which entry we are up to. */
8696 current_entry_id = code->ext.entry->id;
8700 resolve_where (code, NULL);
8704 if (code->expr1 != NULL)
8706 if (code->expr1->ts.type != BT_INTEGER)
8707 gfc_error ("ASSIGNED GOTO statement at %L requires an "
8708 "INTEGER variable", &code->expr1->where);
8709 else if (code->expr1->symtree->n.sym->attr.assign != 1)
8710 gfc_error ("Variable '%s' has not been assigned a target "
8711 "label at %L", code->expr1->symtree->n.sym->name,
8712 &code->expr1->where);
8715 resolve_branch (code->label1, code);
8719 if (code->expr1 != NULL
8720 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
8721 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
8722 "INTEGER return specifier", &code->expr1->where);
8725 case EXEC_INIT_ASSIGN:
8726 case EXEC_END_PROCEDURE:
8733 if (resolve_ordinary_assign (code, ns))
8735 if (code->op == EXEC_COMPCALL)
8742 case EXEC_LABEL_ASSIGN:
8743 if (code->label1->defined == ST_LABEL_UNKNOWN)
8744 gfc_error ("Label %d referenced at %L is never defined",
8745 code->label1->value, &code->label1->where);
8747 && (code->expr1->expr_type != EXPR_VARIABLE
8748 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8749 || code->expr1->symtree->n.sym->ts.kind
8750 != gfc_default_integer_kind
8751 || code->expr1->symtree->n.sym->as != NULL))
8752 gfc_error ("ASSIGN statement at %L requires a scalar "
8753 "default INTEGER variable", &code->expr1->where);
8756 case EXEC_POINTER_ASSIGN:
8760 gfc_check_pointer_assign (code->expr1, code->expr2);
8763 case EXEC_ARITHMETIC_IF:
8765 && code->expr1->ts.type != BT_INTEGER
8766 && code->expr1->ts.type != BT_REAL)
8767 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8768 "expression", &code->expr1->where);
8770 resolve_branch (code->label1, code);
8771 resolve_branch (code->label2, code);
8772 resolve_branch (code->label3, code);
8776 if (t == SUCCESS && code->expr1 != NULL
8777 && (code->expr1->ts.type != BT_LOGICAL
8778 || code->expr1->rank != 0))
8779 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8780 &code->expr1->where);
8785 resolve_call (code);
8790 resolve_typebound_subroutine (code);
8794 resolve_ppc_call (code);
8798 /* Select is complicated. Also, a SELECT construct could be
8799 a transformed computed GOTO. */
8800 resolve_select (code);
8803 case EXEC_SELECT_TYPE:
8804 resolve_select_type (code);
8808 resolve_block_construct (code);
8812 if (code->ext.iterator != NULL)
8814 gfc_iterator *iter = code->ext.iterator;
8815 if (gfc_resolve_iterator (iter, true) != FAILURE)
8816 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
8821 if (code->expr1 == NULL)
8822 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
8824 && (code->expr1->rank != 0
8825 || code->expr1->ts.type != BT_LOGICAL))
8826 gfc_error ("Exit condition of DO WHILE loop at %L must be "
8827 "a scalar LOGICAL expression", &code->expr1->where);
8832 resolve_allocate_deallocate (code, "ALLOCATE");
8836 case EXEC_DEALLOCATE:
8838 resolve_allocate_deallocate (code, "DEALLOCATE");
8843 if (gfc_resolve_open (code->ext.open) == FAILURE)
8846 resolve_branch (code->ext.open->err, code);
8850 if (gfc_resolve_close (code->ext.close) == FAILURE)
8853 resolve_branch (code->ext.close->err, code);
8856 case EXEC_BACKSPACE:
8860 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
8863 resolve_branch (code->ext.filepos->err, code);
8867 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8870 resolve_branch (code->ext.inquire->err, code);
8874 gcc_assert (code->ext.inquire != NULL);
8875 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8878 resolve_branch (code->ext.inquire->err, code);
8882 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
8885 resolve_branch (code->ext.wait->err, code);
8886 resolve_branch (code->ext.wait->end, code);
8887 resolve_branch (code->ext.wait->eor, code);
8892 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
8895 resolve_branch (code->ext.dt->err, code);
8896 resolve_branch (code->ext.dt->end, code);
8897 resolve_branch (code->ext.dt->eor, code);
8901 resolve_transfer (code);
8905 resolve_forall_iterators (code->ext.forall_iterator);
8907 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
8908 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
8909 "expression", &code->expr1->where);
8912 case EXEC_OMP_ATOMIC:
8913 case EXEC_OMP_BARRIER:
8914 case EXEC_OMP_CRITICAL:
8915 case EXEC_OMP_FLUSH:
8917 case EXEC_OMP_MASTER:
8918 case EXEC_OMP_ORDERED:
8919 case EXEC_OMP_SECTIONS:
8920 case EXEC_OMP_SINGLE:
8921 case EXEC_OMP_TASKWAIT:
8922 case EXEC_OMP_WORKSHARE:
8923 gfc_resolve_omp_directive (code, ns);
8926 case EXEC_OMP_PARALLEL:
8927 case EXEC_OMP_PARALLEL_DO:
8928 case EXEC_OMP_PARALLEL_SECTIONS:
8929 case EXEC_OMP_PARALLEL_WORKSHARE:
8931 omp_workshare_save = omp_workshare_flag;
8932 omp_workshare_flag = 0;
8933 gfc_resolve_omp_directive (code, ns);
8934 omp_workshare_flag = omp_workshare_save;
8938 gfc_internal_error ("resolve_code(): Bad statement code");
8942 cs_base = frame.prev;
8946 /* Resolve initial values and make sure they are compatible with
8950 resolve_values (gfc_symbol *sym)
8954 if (sym->value == NULL)
8957 if (sym->value->expr_type == EXPR_STRUCTURE)
8958 t= resolve_structure_cons (sym->value, 1);
8960 t = gfc_resolve_expr (sym->value);
8965 gfc_check_assign_symbol (sym, sym->value);
8969 /* Verify the binding labels for common blocks that are BIND(C). The label
8970 for a BIND(C) common block must be identical in all scoping units in which
8971 the common block is declared. Further, the binding label can not collide
8972 with any other global entity in the program. */
8975 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
8977 if (comm_block_tree->n.common->is_bind_c == 1)
8979 gfc_gsymbol *binding_label_gsym;
8980 gfc_gsymbol *comm_name_gsym;
8982 /* See if a global symbol exists by the common block's name. It may
8983 be NULL if the common block is use-associated. */
8984 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
8985 comm_block_tree->n.common->name);
8986 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
8987 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
8988 "with the global entity '%s' at %L",
8989 comm_block_tree->n.common->binding_label,
8990 comm_block_tree->n.common->name,
8991 &(comm_block_tree->n.common->where),
8992 comm_name_gsym->name, &(comm_name_gsym->where));
8993 else if (comm_name_gsym != NULL
8994 && strcmp (comm_name_gsym->name,
8995 comm_block_tree->n.common->name) == 0)
8997 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
8999 if (comm_name_gsym->binding_label == NULL)
9000 /* No binding label for common block stored yet; save this one. */
9001 comm_name_gsym->binding_label =
9002 comm_block_tree->n.common->binding_label;
9004 if (strcmp (comm_name_gsym->binding_label,
9005 comm_block_tree->n.common->binding_label) != 0)
9007 /* Common block names match but binding labels do not. */
9008 gfc_error ("Binding label '%s' for common block '%s' at %L "
9009 "does not match the binding label '%s' for common "
9011 comm_block_tree->n.common->binding_label,
9012 comm_block_tree->n.common->name,
9013 &(comm_block_tree->n.common->where),
9014 comm_name_gsym->binding_label,
9015 comm_name_gsym->name,
9016 &(comm_name_gsym->where));
9021 /* There is no binding label (NAME="") so we have nothing further to
9022 check and nothing to add as a global symbol for the label. */
9023 if (comm_block_tree->n.common->binding_label[0] == '\0' )
9026 binding_label_gsym =
9027 gfc_find_gsymbol (gfc_gsym_root,
9028 comm_block_tree->n.common->binding_label);
9029 if (binding_label_gsym == NULL)
9031 /* Need to make a global symbol for the binding label to prevent
9032 it from colliding with another. */
9033 binding_label_gsym =
9034 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9035 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9036 binding_label_gsym->type = GSYM_COMMON;
9040 /* If comm_name_gsym is NULL, the name common block is use
9041 associated and the name could be colliding. */
9042 if (binding_label_gsym->type != GSYM_COMMON)
9043 gfc_error ("Binding label '%s' for common block '%s' at %L "
9044 "collides with the global entity '%s' at %L",
9045 comm_block_tree->n.common->binding_label,
9046 comm_block_tree->n.common->name,
9047 &(comm_block_tree->n.common->where),
9048 binding_label_gsym->name,
9049 &(binding_label_gsym->where));
9050 else if (comm_name_gsym != NULL
9051 && (strcmp (binding_label_gsym->name,
9052 comm_name_gsym->binding_label) != 0)
9053 && (strcmp (binding_label_gsym->sym_name,
9054 comm_name_gsym->name) != 0))
9055 gfc_error ("Binding label '%s' for common block '%s' at %L "
9056 "collides with global entity '%s' at %L",
9057 binding_label_gsym->name, binding_label_gsym->sym_name,
9058 &(comm_block_tree->n.common->where),
9059 comm_name_gsym->name, &(comm_name_gsym->where));
9067 /* Verify any BIND(C) derived types in the namespace so we can report errors
9068 for them once, rather than for each variable declared of that type. */
9071 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9073 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9074 && derived_sym->attr.is_bind_c == 1)
9075 verify_bind_c_derived_type (derived_sym);
9081 /* Verify that any binding labels used in a given namespace do not collide
9082 with the names or binding labels of any global symbols. */
9085 gfc_verify_binding_labels (gfc_symbol *sym)
9089 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9090 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9092 gfc_gsymbol *bind_c_sym;
9094 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9095 if (bind_c_sym != NULL
9096 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9098 if (sym->attr.if_source == IFSRC_DECL
9099 && (bind_c_sym->type != GSYM_SUBROUTINE
9100 && bind_c_sym->type != GSYM_FUNCTION)
9101 && ((sym->attr.contained == 1
9102 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9103 || (sym->attr.use_assoc == 1
9104 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9106 /* Make sure global procedures don't collide with anything. */
9107 gfc_error ("Binding label '%s' at %L collides with the global "
9108 "entity '%s' at %L", sym->binding_label,
9109 &(sym->declared_at), bind_c_sym->name,
9110 &(bind_c_sym->where));
9113 else if (sym->attr.contained == 0
9114 && (sym->attr.if_source == IFSRC_IFBODY
9115 && sym->attr.flavor == FL_PROCEDURE)
9116 && (bind_c_sym->sym_name != NULL
9117 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9119 /* Make sure procedures in interface bodies don't collide. */
9120 gfc_error ("Binding label '%s' in interface body at %L collides "
9121 "with the global entity '%s' at %L",
9123 &(sym->declared_at), bind_c_sym->name,
9124 &(bind_c_sym->where));
9127 else if (sym->attr.contained == 0
9128 && sym->attr.if_source == IFSRC_UNKNOWN)
9129 if ((sym->attr.use_assoc && bind_c_sym->mod_name
9130 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9131 || sym->attr.use_assoc == 0)
9133 gfc_error ("Binding label '%s' at %L collides with global "
9134 "entity '%s' at %L", sym->binding_label,
9135 &(sym->declared_at), bind_c_sym->name,
9136 &(bind_c_sym->where));
9141 /* Clear the binding label to prevent checking multiple times. */
9142 sym->binding_label[0] = '\0';
9144 else if (bind_c_sym == NULL)
9146 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9147 bind_c_sym->where = sym->declared_at;
9148 bind_c_sym->sym_name = sym->name;
9150 if (sym->attr.use_assoc == 1)
9151 bind_c_sym->mod_name = sym->module;
9153 if (sym->ns->proc_name != NULL)
9154 bind_c_sym->mod_name = sym->ns->proc_name->name;
9156 if (sym->attr.contained == 0)
9158 if (sym->attr.subroutine)
9159 bind_c_sym->type = GSYM_SUBROUTINE;
9160 else if (sym->attr.function)
9161 bind_c_sym->type = GSYM_FUNCTION;
9169 /* Resolve an index expression. */
9172 resolve_index_expr (gfc_expr *e)
9174 if (gfc_resolve_expr (e) == FAILURE)
9177 if (gfc_simplify_expr (e, 0) == FAILURE)
9180 if (gfc_specification_expr (e) == FAILURE)
9186 /* Resolve a charlen structure. */
9189 resolve_charlen (gfc_charlen *cl)
9198 specification_expr = 1;
9200 if (resolve_index_expr (cl->length) == FAILURE)
9202 specification_expr = 0;
9206 /* "If the character length parameter value evaluates to a negative
9207 value, the length of character entities declared is zero." */
9208 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9210 if (gfc_option.warn_surprising)
9211 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9212 " the length has been set to zero",
9213 &cl->length->where, i);
9214 gfc_replace_expr (cl->length,
9215 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9218 /* Check that the character length is not too large. */
9219 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9220 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9221 && cl->length->ts.type == BT_INTEGER
9222 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9224 gfc_error ("String length at %L is too large", &cl->length->where);
9232 /* Test for non-constant shape arrays. */
9235 is_non_constant_shape_array (gfc_symbol *sym)
9241 not_constant = false;
9242 if (sym->as != NULL)
9244 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9245 has not been simplified; parameter array references. Do the
9246 simplification now. */
9247 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9249 e = sym->as->lower[i];
9250 if (e && (resolve_index_expr (e) == FAILURE
9251 || !gfc_is_constant_expr (e)))
9252 not_constant = true;
9253 e = sym->as->upper[i];
9254 if (e && (resolve_index_expr (e) == FAILURE
9255 || !gfc_is_constant_expr (e)))
9256 not_constant = true;
9259 return not_constant;
9262 /* Given a symbol and an initialization expression, add code to initialize
9263 the symbol to the function entry. */
9265 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9269 gfc_namespace *ns = sym->ns;
9271 /* Search for the function namespace if this is a contained
9272 function without an explicit result. */
9273 if (sym->attr.function && sym == sym->result
9274 && sym->name != sym->ns->proc_name->name)
9277 for (;ns; ns = ns->sibling)
9278 if (strcmp (ns->proc_name->name, sym->name) == 0)
9284 gfc_free_expr (init);
9288 /* Build an l-value expression for the result. */
9289 lval = gfc_lval_expr_from_sym (sym);
9291 /* Add the code at scope entry. */
9292 init_st = gfc_get_code ();
9293 init_st->next = ns->code;
9296 /* Assign the default initializer to the l-value. */
9297 init_st->loc = sym->declared_at;
9298 init_st->op = EXEC_INIT_ASSIGN;
9299 init_st->expr1 = lval;
9300 init_st->expr2 = init;
9303 /* Assign the default initializer to a derived type variable or result. */
9306 apply_default_init (gfc_symbol *sym)
9308 gfc_expr *init = NULL;
9310 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9313 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9314 init = gfc_default_initializer (&sym->ts);
9319 build_init_assign (sym, init);
9322 /* Build an initializer for a local integer, real, complex, logical, or
9323 character variable, based on the command line flags finit-local-zero,
9324 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9325 null if the symbol should not have a default initialization. */
9327 build_default_init_expr (gfc_symbol *sym)
9330 gfc_expr *init_expr;
9333 /* These symbols should never have a default initialization. */
9334 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9335 || sym->attr.external
9337 || sym->attr.pointer
9338 || sym->attr.in_equivalence
9339 || sym->attr.in_common
9342 || sym->attr.cray_pointee
9343 || sym->attr.cray_pointer)
9346 /* Now we'll try to build an initializer expression. */
9347 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9350 /* We will only initialize integers, reals, complex, logicals, and
9351 characters, and only if the corresponding command-line flags
9352 were set. Otherwise, we free init_expr and return null. */
9353 switch (sym->ts.type)
9356 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9357 mpz_set_si (init_expr->value.integer,
9358 gfc_option.flag_init_integer_value);
9361 gfc_free_expr (init_expr);
9367 switch (gfc_option.flag_init_real)
9369 case GFC_INIT_REAL_SNAN:
9370 init_expr->is_snan = 1;
9372 case GFC_INIT_REAL_NAN:
9373 mpfr_set_nan (init_expr->value.real);
9376 case GFC_INIT_REAL_INF:
9377 mpfr_set_inf (init_expr->value.real, 1);
9380 case GFC_INIT_REAL_NEG_INF:
9381 mpfr_set_inf (init_expr->value.real, -1);
9384 case GFC_INIT_REAL_ZERO:
9385 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9389 gfc_free_expr (init_expr);
9396 switch (gfc_option.flag_init_real)
9398 case GFC_INIT_REAL_SNAN:
9399 init_expr->is_snan = 1;
9401 case GFC_INIT_REAL_NAN:
9402 mpfr_set_nan (mpc_realref (init_expr->value.complex));
9403 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9406 case GFC_INIT_REAL_INF:
9407 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9408 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9411 case GFC_INIT_REAL_NEG_INF:
9412 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9413 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9416 case GFC_INIT_REAL_ZERO:
9417 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9421 gfc_free_expr (init_expr);
9428 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9429 init_expr->value.logical = 0;
9430 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9431 init_expr->value.logical = 1;
9434 gfc_free_expr (init_expr);
9440 /* For characters, the length must be constant in order to
9441 create a default initializer. */
9442 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9443 && sym->ts.u.cl->length
9444 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9446 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
9447 init_expr->value.character.length = char_len;
9448 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
9449 for (i = 0; i < char_len; i++)
9450 init_expr->value.character.string[i]
9451 = (unsigned char) gfc_option.flag_init_character_value;
9455 gfc_free_expr (init_expr);
9461 gfc_free_expr (init_expr);
9467 /* Add an initialization expression to a local variable. */
9469 apply_default_init_local (gfc_symbol *sym)
9471 gfc_expr *init = NULL;
9473 /* The symbol should be a variable or a function return value. */
9474 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9475 || (sym->attr.function && sym->result != sym))
9478 /* Try to build the initializer expression. If we can't initialize
9479 this symbol, then init will be NULL. */
9480 init = build_default_init_expr (sym);
9484 /* For saved variables, we don't want to add an initializer at
9485 function entry, so we just add a static initializer. */
9486 if (sym->attr.save || sym->ns->save_all
9487 || gfc_option.flag_max_stack_var_size == 0)
9489 /* Don't clobber an existing initializer! */
9490 gcc_assert (sym->value == NULL);
9495 build_init_assign (sym, init);
9498 /* Resolution of common features of flavors variable and procedure. */
9501 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
9503 /* Constraints on deferred shape variable. */
9504 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
9506 if (sym->attr.allocatable)
9508 if (sym->attr.dimension)
9510 gfc_error ("Allocatable array '%s' at %L must have "
9511 "a deferred shape", sym->name, &sym->declared_at);
9514 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
9515 "may not be ALLOCATABLE", sym->name,
9516 &sym->declared_at) == FAILURE)
9520 if (sym->attr.pointer && sym->attr.dimension)
9522 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9523 sym->name, &sym->declared_at);
9529 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
9530 && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
9532 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9533 sym->name, &sym->declared_at);
9538 /* Constraints on polymorphic variables. */
9539 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
9542 if (sym->attr.class_ok
9543 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
9545 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9546 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
9552 /* Assume that use associated symbols were checked in the module ns. */
9553 if (!sym->attr.class_ok && !sym->attr.use_assoc)
9555 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9556 "or pointer", sym->name, &sym->declared_at);
9565 /* Additional checks for symbols with flavor variable and derived
9566 type. To be called from resolve_fl_variable. */
9569 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
9571 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
9573 /* Check to see if a derived type is blocked from being host
9574 associated by the presence of another class I symbol in the same
9575 namespace. 14.6.1.3 of the standard and the discussion on
9576 comp.lang.fortran. */
9577 if (sym->ns != sym->ts.u.derived->ns
9578 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
9581 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
9582 if (s && s->attr.flavor != FL_DERIVED)
9584 gfc_error ("The type '%s' cannot be host associated at %L "
9585 "because it is blocked by an incompatible object "
9586 "of the same name declared at %L",
9587 sym->ts.u.derived->name, &sym->declared_at,
9593 /* 4th constraint in section 11.3: "If an object of a type for which
9594 component-initialization is specified (R429) appears in the
9595 specification-part of a module and does not have the ALLOCATABLE
9596 or POINTER attribute, the object shall have the SAVE attribute."
9598 The check for initializers is performed with
9599 gfc_has_default_initializer because gfc_default_initializer generates
9600 a hidden default for allocatable components. */
9601 if (!(sym->value || no_init_flag) && sym->ns->proc_name
9602 && sym->ns->proc_name->attr.flavor == FL_MODULE
9603 && !sym->ns->save_all && !sym->attr.save
9604 && !sym->attr.pointer && !sym->attr.allocatable
9605 && gfc_has_default_initializer (sym->ts.u.derived)
9606 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
9607 "module variable '%s' at %L, needed due to "
9608 "the default initialization", sym->name,
9609 &sym->declared_at) == FAILURE)
9612 /* Assign default initializer. */
9613 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
9614 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
9616 sym->value = gfc_default_initializer (&sym->ts);
9623 /* Resolve symbols with flavor variable. */
9626 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
9628 int no_init_flag, automatic_flag;
9630 const char *auto_save_msg;
9632 auto_save_msg = "Automatic object '%s' at %L cannot have the "
9635 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9638 /* Set this flag to check that variables are parameters of all entries.
9639 This check is effected by the call to gfc_resolve_expr through
9640 is_non_constant_shape_array. */
9641 specification_expr = 1;
9643 if (sym->ns->proc_name
9644 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9645 || sym->ns->proc_name->attr.is_main_program)
9646 && !sym->attr.use_assoc
9647 && !sym->attr.allocatable
9648 && !sym->attr.pointer
9649 && is_non_constant_shape_array (sym))
9651 /* The shape of a main program or module array needs to be
9653 gfc_error ("The module or main program array '%s' at %L must "
9654 "have constant shape", sym->name, &sym->declared_at);
9655 specification_expr = 0;
9659 if (sym->ts.type == BT_CHARACTER)
9661 /* Make sure that character string variables with assumed length are
9663 e = sym->ts.u.cl->length;
9664 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
9666 gfc_error ("Entity with assumed character length at %L must be a "
9667 "dummy argument or a PARAMETER", &sym->declared_at);
9671 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
9673 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9677 if (!gfc_is_constant_expr (e)
9678 && !(e->expr_type == EXPR_VARIABLE
9679 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
9680 && sym->ns->proc_name
9681 && (sym->ns->proc_name->attr.flavor == FL_MODULE
9682 || sym->ns->proc_name->attr.is_main_program)
9683 && !sym->attr.use_assoc)
9685 gfc_error ("'%s' at %L must have constant character length "
9686 "in this context", sym->name, &sym->declared_at);
9691 if (sym->value == NULL && sym->attr.referenced)
9692 apply_default_init_local (sym); /* Try to apply a default initialization. */
9694 /* Determine if the symbol may not have an initializer. */
9695 no_init_flag = automatic_flag = 0;
9696 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
9697 || sym->attr.intrinsic || sym->attr.result)
9699 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
9700 && is_non_constant_shape_array (sym))
9702 no_init_flag = automatic_flag = 1;
9704 /* Also, they must not have the SAVE attribute.
9705 SAVE_IMPLICIT is checked below. */
9706 if (sym->attr.save == SAVE_EXPLICIT)
9708 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
9713 /* Ensure that any initializer is simplified. */
9715 gfc_simplify_expr (sym->value, 1);
9717 /* Reject illegal initializers. */
9718 if (!sym->mark && sym->value)
9720 if (sym->attr.allocatable)
9721 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
9722 sym->name, &sym->declared_at);
9723 else if (sym->attr.external)
9724 gfc_error ("External '%s' at %L cannot have an initializer",
9725 sym->name, &sym->declared_at);
9726 else if (sym->attr.dummy
9727 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
9728 gfc_error ("Dummy '%s' at %L cannot have an initializer",
9729 sym->name, &sym->declared_at);
9730 else if (sym->attr.intrinsic)
9731 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
9732 sym->name, &sym->declared_at);
9733 else if (sym->attr.result)
9734 gfc_error ("Function result '%s' at %L cannot have an initializer",
9735 sym->name, &sym->declared_at);
9736 else if (automatic_flag)
9737 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
9738 sym->name, &sym->declared_at);
9745 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9746 return resolve_fl_variable_derived (sym, no_init_flag);
9752 /* Resolve a procedure. */
9755 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9757 gfc_formal_arglist *arg;
9759 if (sym->attr.function
9760 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9763 if (sym->ts.type == BT_CHARACTER)
9765 gfc_charlen *cl = sym->ts.u.cl;
9767 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9768 && resolve_charlen (cl) == FAILURE)
9771 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9772 && sym->attr.proc == PROC_ST_FUNCTION)
9774 gfc_error ("Character-valued statement function '%s' at %L must "
9775 "have constant length", sym->name, &sym->declared_at);
9780 /* Ensure that derived type for are not of a private type. Internal
9781 module procedures are excluded by 2.2.3.3 - i.e., they are not
9782 externally accessible and can access all the objects accessible in
9784 if (!(sym->ns->parent
9785 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9786 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9788 gfc_interface *iface;
9790 for (arg = sym->formal; arg; arg = arg->next)
9793 && arg->sym->ts.type == BT_DERIVED
9794 && !arg->sym->ts.u.derived->attr.use_assoc
9795 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9796 arg->sym->ts.u.derived->ns->default_access)
9797 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9798 "PRIVATE type and cannot be a dummy argument"
9799 " of '%s', which is PUBLIC at %L",
9800 arg->sym->name, sym->name, &sym->declared_at)
9803 /* Stop this message from recurring. */
9804 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9809 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9810 PRIVATE to the containing module. */
9811 for (iface = sym->generic; iface; iface = iface->next)
9813 for (arg = iface->sym->formal; arg; arg = arg->next)
9816 && arg->sym->ts.type == BT_DERIVED
9817 && !arg->sym->ts.u.derived->attr.use_assoc
9818 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9819 arg->sym->ts.u.derived->ns->default_access)
9820 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
9821 "'%s' in PUBLIC interface '%s' at %L "
9822 "takes dummy arguments of '%s' which is "
9823 "PRIVATE", iface->sym->name, sym->name,
9824 &iface->sym->declared_at,
9825 gfc_typename (&arg->sym->ts)) == FAILURE)
9827 /* Stop this message from recurring. */
9828 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9834 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9835 PRIVATE to the containing module. */
9836 for (iface = sym->generic; iface; iface = iface->next)
9838 for (arg = iface->sym->formal; arg; arg = arg->next)
9841 && arg->sym->ts.type == BT_DERIVED
9842 && !arg->sym->ts.u.derived->attr.use_assoc
9843 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9844 arg->sym->ts.u.derived->ns->default_access)
9845 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
9846 "'%s' in PUBLIC interface '%s' at %L "
9847 "takes dummy arguments of '%s' which is "
9848 "PRIVATE", iface->sym->name, sym->name,
9849 &iface->sym->declared_at,
9850 gfc_typename (&arg->sym->ts)) == FAILURE)
9852 /* Stop this message from recurring. */
9853 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9860 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
9861 && !sym->attr.proc_pointer)
9863 gfc_error ("Function '%s' at %L cannot have an initializer",
9864 sym->name, &sym->declared_at);
9868 /* An external symbol may not have an initializer because it is taken to be
9869 a procedure. Exception: Procedure Pointers. */
9870 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
9872 gfc_error ("External object '%s' at %L may not have an initializer",
9873 sym->name, &sym->declared_at);
9877 /* An elemental function is required to return a scalar 12.7.1 */
9878 if (sym->attr.elemental && sym->attr.function && sym->as)
9880 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
9881 "result", sym->name, &sym->declared_at);
9882 /* Reset so that the error only occurs once. */
9883 sym->attr.elemental = 0;
9887 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
9888 char-len-param shall not be array-valued, pointer-valued, recursive
9889 or pure. ....snip... A character value of * may only be used in the
9890 following ways: (i) Dummy arg of procedure - dummy associates with
9891 actual length; (ii) To declare a named constant; or (iii) External
9892 function - but length must be declared in calling scoping unit. */
9893 if (sym->attr.function
9894 && sym->ts.type == BT_CHARACTER
9895 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
9897 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
9898 || (sym->attr.recursive) || (sym->attr.pure))
9900 if (sym->as && sym->as->rank)
9901 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9902 "array-valued", sym->name, &sym->declared_at);
9904 if (sym->attr.pointer)
9905 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9906 "pointer-valued", sym->name, &sym->declared_at);
9909 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9910 "pure", sym->name, &sym->declared_at);
9912 if (sym->attr.recursive)
9913 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9914 "recursive", sym->name, &sym->declared_at);
9919 /* Appendix B.2 of the standard. Contained functions give an
9920 error anyway. Fixed-form is likely to be F77/legacy. */
9921 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
9922 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
9923 "CHARACTER(*) function '%s' at %L",
9924 sym->name, &sym->declared_at);
9927 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
9929 gfc_formal_arglist *curr_arg;
9930 int has_non_interop_arg = 0;
9932 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9933 sym->common_block) == FAILURE)
9935 /* Clear these to prevent looking at them again if there was an
9937 sym->attr.is_bind_c = 0;
9938 sym->attr.is_c_interop = 0;
9939 sym->ts.is_c_interop = 0;
9943 /* So far, no errors have been found. */
9944 sym->attr.is_c_interop = 1;
9945 sym->ts.is_c_interop = 1;
9948 curr_arg = sym->formal;
9949 while (curr_arg != NULL)
9951 /* Skip implicitly typed dummy args here. */
9952 if (curr_arg->sym->attr.implicit_type == 0)
9953 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
9954 /* If something is found to fail, record the fact so we
9955 can mark the symbol for the procedure as not being
9956 BIND(C) to try and prevent multiple errors being
9958 has_non_interop_arg = 1;
9960 curr_arg = curr_arg->next;
9963 /* See if any of the arguments were not interoperable and if so, clear
9964 the procedure symbol to prevent duplicate error messages. */
9965 if (has_non_interop_arg != 0)
9967 sym->attr.is_c_interop = 0;
9968 sym->ts.is_c_interop = 0;
9969 sym->attr.is_bind_c = 0;
9973 if (!sym->attr.proc_pointer)
9975 if (sym->attr.save == SAVE_EXPLICIT)
9977 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
9978 "in '%s' at %L", sym->name, &sym->declared_at);
9981 if (sym->attr.intent)
9983 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
9984 "in '%s' at %L", sym->name, &sym->declared_at);
9987 if (sym->attr.subroutine && sym->attr.result)
9989 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
9990 "in '%s' at %L", sym->name, &sym->declared_at);
9993 if (sym->attr.external && sym->attr.function
9994 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
9995 || sym->attr.contained))
9997 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
9998 "in '%s' at %L", sym->name, &sym->declared_at);
10001 if (strcmp ("ppr@", sym->name) == 0)
10003 gfc_error ("Procedure pointer result '%s' at %L "
10004 "is missing the pointer attribute",
10005 sym->ns->proc_name->name, &sym->declared_at);
10014 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10015 been defined and we now know their defined arguments, check that they fulfill
10016 the requirements of the standard for procedures used as finalizers. */
10019 gfc_resolve_finalizers (gfc_symbol* derived)
10021 gfc_finalizer* list;
10022 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
10023 gfc_try result = SUCCESS;
10024 bool seen_scalar = false;
10026 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10029 /* Walk over the list of finalizer-procedures, check them, and if any one
10030 does not fit in with the standard's definition, print an error and remove
10031 it from the list. */
10032 prev_link = &derived->f2k_derived->finalizers;
10033 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10039 /* Skip this finalizer if we already resolved it. */
10040 if (list->proc_tree)
10042 prev_link = &(list->next);
10046 /* Check this exists and is a SUBROUTINE. */
10047 if (!list->proc_sym->attr.subroutine)
10049 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10050 list->proc_sym->name, &list->where);
10054 /* We should have exactly one argument. */
10055 if (!list->proc_sym->formal || list->proc_sym->formal->next)
10057 gfc_error ("FINAL procedure at %L must have exactly one argument",
10061 arg = list->proc_sym->formal->sym;
10063 /* This argument must be of our type. */
10064 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10066 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10067 &arg->declared_at, derived->name);
10071 /* It must neither be a pointer nor allocatable nor optional. */
10072 if (arg->attr.pointer)
10074 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10075 &arg->declared_at);
10078 if (arg->attr.allocatable)
10080 gfc_error ("Argument of FINAL procedure at %L must not be"
10081 " ALLOCATABLE", &arg->declared_at);
10084 if (arg->attr.optional)
10086 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10087 &arg->declared_at);
10091 /* It must not be INTENT(OUT). */
10092 if (arg->attr.intent == INTENT_OUT)
10094 gfc_error ("Argument of FINAL procedure at %L must not be"
10095 " INTENT(OUT)", &arg->declared_at);
10099 /* Warn if the procedure is non-scalar and not assumed shape. */
10100 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10101 && arg->as->type != AS_ASSUMED_SHAPE)
10102 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10103 " shape argument", &arg->declared_at);
10105 /* Check that it does not match in kind and rank with a FINAL procedure
10106 defined earlier. To really loop over the *earlier* declarations,
10107 we need to walk the tail of the list as new ones were pushed at the
10109 /* TODO: Handle kind parameters once they are implemented. */
10110 my_rank = (arg->as ? arg->as->rank : 0);
10111 for (i = list->next; i; i = i->next)
10113 /* Argument list might be empty; that is an error signalled earlier,
10114 but we nevertheless continued resolving. */
10115 if (i->proc_sym->formal)
10117 gfc_symbol* i_arg = i->proc_sym->formal->sym;
10118 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10119 if (i_rank == my_rank)
10121 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10122 " rank (%d) as '%s'",
10123 list->proc_sym->name, &list->where, my_rank,
10124 i->proc_sym->name);
10130 /* Is this the/a scalar finalizer procedure? */
10131 if (!arg->as || arg->as->rank == 0)
10132 seen_scalar = true;
10134 /* Find the symtree for this procedure. */
10135 gcc_assert (!list->proc_tree);
10136 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10138 prev_link = &list->next;
10141 /* Remove wrong nodes immediately from the list so we don't risk any
10142 troubles in the future when they might fail later expectations. */
10146 *prev_link = list->next;
10147 gfc_free_finalizer (i);
10150 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10151 were nodes in the list, must have been for arrays. It is surely a good
10152 idea to have a scalar version there if there's something to finalize. */
10153 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10154 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10155 " defined at %L, suggest also scalar one",
10156 derived->name, &derived->declared_at);
10158 /* TODO: Remove this error when finalization is finished. */
10159 gfc_error ("Finalization at %L is not yet implemented",
10160 &derived->declared_at);
10166 /* Check that it is ok for the typebound procedure proc to override the
10170 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
10173 const gfc_symbol* proc_target;
10174 const gfc_symbol* old_target;
10175 unsigned proc_pass_arg, old_pass_arg, argpos;
10176 gfc_formal_arglist* proc_formal;
10177 gfc_formal_arglist* old_formal;
10179 /* This procedure should only be called for non-GENERIC proc. */
10180 gcc_assert (!proc->n.tb->is_generic);
10182 /* If the overwritten procedure is GENERIC, this is an error. */
10183 if (old->n.tb->is_generic)
10185 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10186 old->name, &proc->n.tb->where);
10190 where = proc->n.tb->where;
10191 proc_target = proc->n.tb->u.specific->n.sym;
10192 old_target = old->n.tb->u.specific->n.sym;
10194 /* Check that overridden binding is not NON_OVERRIDABLE. */
10195 if (old->n.tb->non_overridable)
10197 gfc_error ("'%s' at %L overrides a procedure binding declared"
10198 " NON_OVERRIDABLE", proc->name, &where);
10202 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10203 if (!old->n.tb->deferred && proc->n.tb->deferred)
10205 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10206 " non-DEFERRED binding", proc->name, &where);
10210 /* If the overridden binding is PURE, the overriding must be, too. */
10211 if (old_target->attr.pure && !proc_target->attr.pure)
10213 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10214 proc->name, &where);
10218 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10219 is not, the overriding must not be either. */
10220 if (old_target->attr.elemental && !proc_target->attr.elemental)
10222 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10223 " ELEMENTAL", proc->name, &where);
10226 if (!old_target->attr.elemental && proc_target->attr.elemental)
10228 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10229 " be ELEMENTAL, either", proc->name, &where);
10233 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10235 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
10237 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10238 " SUBROUTINE", proc->name, &where);
10242 /* If the overridden binding is a FUNCTION, the overriding must also be a
10243 FUNCTION and have the same characteristics. */
10244 if (old_target->attr.function)
10246 if (!proc_target->attr.function)
10248 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10249 " FUNCTION", proc->name, &where);
10253 /* FIXME: Do more comprehensive checking (including, for instance, the
10254 rank and array-shape). */
10255 gcc_assert (proc_target->result && old_target->result);
10256 if (!gfc_compare_types (&proc_target->result->ts,
10257 &old_target->result->ts))
10259 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10260 " matching result types", proc->name, &where);
10265 /* If the overridden binding is PUBLIC, the overriding one must not be
10267 if (old->n.tb->access == ACCESS_PUBLIC
10268 && proc->n.tb->access == ACCESS_PRIVATE)
10270 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10271 " PRIVATE", proc->name, &where);
10275 /* Compare the formal argument lists of both procedures. This is also abused
10276 to find the position of the passed-object dummy arguments of both
10277 bindings as at least the overridden one might not yet be resolved and we
10278 need those positions in the check below. */
10279 proc_pass_arg = old_pass_arg = 0;
10280 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
10282 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
10285 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
10286 proc_formal && old_formal;
10287 proc_formal = proc_formal->next, old_formal = old_formal->next)
10289 if (proc->n.tb->pass_arg
10290 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
10291 proc_pass_arg = argpos;
10292 if (old->n.tb->pass_arg
10293 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
10294 old_pass_arg = argpos;
10296 /* Check that the names correspond. */
10297 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
10299 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10300 " to match the corresponding argument of the overridden"
10301 " procedure", proc_formal->sym->name, proc->name, &where,
10302 old_formal->sym->name);
10306 /* Check that the types correspond if neither is the passed-object
10308 /* FIXME: Do more comprehensive testing here. */
10309 if (proc_pass_arg != argpos && old_pass_arg != argpos
10310 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
10312 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10313 "in respect to the overridden procedure",
10314 proc_formal->sym->name, proc->name, &where);
10320 if (proc_formal || old_formal)
10322 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10323 " the overridden procedure", proc->name, &where);
10327 /* If the overridden binding is NOPASS, the overriding one must also be
10329 if (old->n.tb->nopass && !proc->n.tb->nopass)
10331 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10332 " NOPASS", proc->name, &where);
10336 /* If the overridden binding is PASS(x), the overriding one must also be
10337 PASS and the passed-object dummy arguments must correspond. */
10338 if (!old->n.tb->nopass)
10340 if (proc->n.tb->nopass)
10342 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10343 " PASS", proc->name, &where);
10347 if (proc_pass_arg != old_pass_arg)
10349 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10350 " the same position as the passed-object dummy argument of"
10351 " the overridden procedure", proc->name, &where);
10360 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10363 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10364 const char* generic_name, locus where)
10369 gcc_assert (t1->specific && t2->specific);
10370 gcc_assert (!t1->specific->is_generic);
10371 gcc_assert (!t2->specific->is_generic);
10373 sym1 = t1->specific->u.specific->n.sym;
10374 sym2 = t2->specific->u.specific->n.sym;
10379 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10380 if (sym1->attr.subroutine != sym2->attr.subroutine
10381 || sym1->attr.function != sym2->attr.function)
10383 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10384 " GENERIC '%s' at %L",
10385 sym1->name, sym2->name, generic_name, &where);
10389 /* Compare the interfaces. */
10390 if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10392 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10393 sym1->name, sym2->name, generic_name, &where);
10401 /* Worker function for resolving a generic procedure binding; this is used to
10402 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10404 The difference between those cases is finding possible inherited bindings
10405 that are overridden, as one has to look for them in tb_sym_root,
10406 tb_uop_root or tb_op, respectively. Thus the caller must already find
10407 the super-type and set p->overridden correctly. */
10410 resolve_tb_generic_targets (gfc_symbol* super_type,
10411 gfc_typebound_proc* p, const char* name)
10413 gfc_tbp_generic* target;
10414 gfc_symtree* first_target;
10415 gfc_symtree* inherited;
10417 gcc_assert (p && p->is_generic);
10419 /* Try to find the specific bindings for the symtrees in our target-list. */
10420 gcc_assert (p->u.generic);
10421 for (target = p->u.generic; target; target = target->next)
10422 if (!target->specific)
10424 gfc_typebound_proc* overridden_tbp;
10425 gfc_tbp_generic* g;
10426 const char* target_name;
10428 target_name = target->specific_st->name;
10430 /* Defined for this type directly. */
10431 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10433 target->specific = target->specific_st->n.tb;
10434 goto specific_found;
10437 /* Look for an inherited specific binding. */
10440 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10445 gcc_assert (inherited->n.tb);
10446 target->specific = inherited->n.tb;
10447 goto specific_found;
10451 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10452 " at %L", target_name, name, &p->where);
10455 /* Once we've found the specific binding, check it is not ambiguous with
10456 other specifics already found or inherited for the same GENERIC. */
10458 gcc_assert (target->specific);
10460 /* This must really be a specific binding! */
10461 if (target->specific->is_generic)
10463 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10464 " '%s' is GENERIC, too", name, &p->where, target_name);
10468 /* Check those already resolved on this type directly. */
10469 for (g = p->u.generic; g; g = g->next)
10470 if (g != target && g->specific
10471 && check_generic_tbp_ambiguity (target, g, name, p->where)
10475 /* Check for ambiguity with inherited specific targets. */
10476 for (overridden_tbp = p->overridden; overridden_tbp;
10477 overridden_tbp = overridden_tbp->overridden)
10478 if (overridden_tbp->is_generic)
10480 for (g = overridden_tbp->u.generic; g; g = g->next)
10482 gcc_assert (g->specific);
10483 if (check_generic_tbp_ambiguity (target, g,
10484 name, p->where) == FAILURE)
10490 /* If we attempt to "overwrite" a specific binding, this is an error. */
10491 if (p->overridden && !p->overridden->is_generic)
10493 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10494 " the same name", name, &p->where);
10498 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10499 all must have the same attributes here. */
10500 first_target = p->u.generic->specific->u.specific;
10501 gcc_assert (first_target);
10502 p->subroutine = first_target->n.sym->attr.subroutine;
10503 p->function = first_target->n.sym->attr.function;
10509 /* Resolve a GENERIC procedure binding for a derived type. */
10512 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10514 gfc_symbol* super_type;
10516 /* Find the overridden binding if any. */
10517 st->n.tb->overridden = NULL;
10518 super_type = gfc_get_derived_super_type (derived);
10521 gfc_symtree* overridden;
10522 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10525 if (overridden && overridden->n.tb)
10526 st->n.tb->overridden = overridden->n.tb;
10529 /* Resolve using worker function. */
10530 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10534 /* Retrieve the target-procedure of an operator binding and do some checks in
10535 common for intrinsic and user-defined type-bound operators. */
10538 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10540 gfc_symbol* target_proc;
10542 gcc_assert (target->specific && !target->specific->is_generic);
10543 target_proc = target->specific->u.specific->n.sym;
10544 gcc_assert (target_proc);
10546 /* All operator bindings must have a passed-object dummy argument. */
10547 if (target->specific->nopass)
10549 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10553 return target_proc;
10557 /* Resolve a type-bound intrinsic operator. */
10560 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10561 gfc_typebound_proc* p)
10563 gfc_symbol* super_type;
10564 gfc_tbp_generic* target;
10566 /* If there's already an error here, do nothing (but don't fail again). */
10570 /* Operators should always be GENERIC bindings. */
10571 gcc_assert (p->is_generic);
10573 /* Look for an overridden binding. */
10574 super_type = gfc_get_derived_super_type (derived);
10575 if (super_type && super_type->f2k_derived)
10576 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10579 p->overridden = NULL;
10581 /* Resolve general GENERIC properties using worker function. */
10582 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10585 /* Check the targets to be procedures of correct interface. */
10586 for (target = p->u.generic; target; target = target->next)
10588 gfc_symbol* target_proc;
10590 target_proc = get_checked_tb_operator_target (target, p->where);
10594 if (!gfc_check_operator_interface (target_proc, op, p->where))
10606 /* Resolve a type-bound user operator (tree-walker callback). */
10608 static gfc_symbol* resolve_bindings_derived;
10609 static gfc_try resolve_bindings_result;
10611 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
10614 resolve_typebound_user_op (gfc_symtree* stree)
10616 gfc_symbol* super_type;
10617 gfc_tbp_generic* target;
10619 gcc_assert (stree && stree->n.tb);
10621 if (stree->n.tb->error)
10624 /* Operators should always be GENERIC bindings. */
10625 gcc_assert (stree->n.tb->is_generic);
10627 /* Find overridden procedure, if any. */
10628 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10629 if (super_type && super_type->f2k_derived)
10631 gfc_symtree* overridden;
10632 overridden = gfc_find_typebound_user_op (super_type, NULL,
10633 stree->name, true, NULL);
10635 if (overridden && overridden->n.tb)
10636 stree->n.tb->overridden = overridden->n.tb;
10639 stree->n.tb->overridden = NULL;
10641 /* Resolve basically using worker function. */
10642 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
10646 /* Check the targets to be functions of correct interface. */
10647 for (target = stree->n.tb->u.generic; target; target = target->next)
10649 gfc_symbol* target_proc;
10651 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
10655 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
10662 resolve_bindings_result = FAILURE;
10663 stree->n.tb->error = 1;
10667 /* Resolve the type-bound procedures for a derived type. */
10670 resolve_typebound_procedure (gfc_symtree* stree)
10674 gfc_symbol* me_arg;
10675 gfc_symbol* super_type;
10676 gfc_component* comp;
10678 gcc_assert (stree);
10680 /* Undefined specific symbol from GENERIC target definition. */
10684 if (stree->n.tb->error)
10687 /* If this is a GENERIC binding, use that routine. */
10688 if (stree->n.tb->is_generic)
10690 if (resolve_typebound_generic (resolve_bindings_derived, stree)
10696 /* Get the target-procedure to check it. */
10697 gcc_assert (!stree->n.tb->is_generic);
10698 gcc_assert (stree->n.tb->u.specific);
10699 proc = stree->n.tb->u.specific->n.sym;
10700 where = stree->n.tb->where;
10702 /* Default access should already be resolved from the parser. */
10703 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
10705 /* It should be a module procedure or an external procedure with explicit
10706 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
10707 if ((!proc->attr.subroutine && !proc->attr.function)
10708 || (proc->attr.proc != PROC_MODULE
10709 && proc->attr.if_source != IFSRC_IFBODY)
10710 || (proc->attr.abstract && !stree->n.tb->deferred))
10712 gfc_error ("'%s' must be a module procedure or an external procedure with"
10713 " an explicit interface at %L", proc->name, &where);
10716 stree->n.tb->subroutine = proc->attr.subroutine;
10717 stree->n.tb->function = proc->attr.function;
10719 /* Find the super-type of the current derived type. We could do this once and
10720 store in a global if speed is needed, but as long as not I believe this is
10721 more readable and clearer. */
10722 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
10724 /* If PASS, resolve and check arguments if not already resolved / loaded
10725 from a .mod file. */
10726 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
10728 if (stree->n.tb->pass_arg)
10730 gfc_formal_arglist* i;
10732 /* If an explicit passing argument name is given, walk the arg-list
10733 and look for it. */
10736 stree->n.tb->pass_arg_num = 1;
10737 for (i = proc->formal; i; i = i->next)
10739 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10744 ++stree->n.tb->pass_arg_num;
10749 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10751 proc->name, stree->n.tb->pass_arg, &where,
10752 stree->n.tb->pass_arg);
10758 /* Otherwise, take the first one; there should in fact be at least
10760 stree->n.tb->pass_arg_num = 1;
10763 gfc_error ("Procedure '%s' with PASS at %L must have at"
10764 " least one argument", proc->name, &where);
10767 me_arg = proc->formal->sym;
10770 /* Now check that the argument-type matches and the passed-object
10771 dummy argument is generally fine. */
10773 gcc_assert (me_arg);
10775 if (me_arg->ts.type != BT_CLASS)
10777 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10778 " at %L", proc->name, &where);
10782 if (CLASS_DATA (me_arg)->ts.u.derived
10783 != resolve_bindings_derived)
10785 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10786 " the derived-type '%s'", me_arg->name, proc->name,
10787 me_arg->name, &where, resolve_bindings_derived->name);
10791 gcc_assert (me_arg->ts.type == BT_CLASS);
10792 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
10794 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
10795 " scalar", proc->name, &where);
10798 if (CLASS_DATA (me_arg)->attr.allocatable)
10800 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10801 " be ALLOCATABLE", proc->name, &where);
10804 if (CLASS_DATA (me_arg)->attr.class_pointer)
10806 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
10807 " be POINTER", proc->name, &where);
10812 /* If we are extending some type, check that we don't override a procedure
10813 flagged NON_OVERRIDABLE. */
10814 stree->n.tb->overridden = NULL;
10817 gfc_symtree* overridden;
10818 overridden = gfc_find_typebound_proc (super_type, NULL,
10819 stree->name, true, NULL);
10821 if (overridden && overridden->n.tb)
10822 stree->n.tb->overridden = overridden->n.tb;
10824 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
10828 /* See if there's a name collision with a component directly in this type. */
10829 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
10830 if (!strcmp (comp->name, stree->name))
10832 gfc_error ("Procedure '%s' at %L has the same name as a component of"
10834 stree->name, &where, resolve_bindings_derived->name);
10838 /* Try to find a name collision with an inherited component. */
10839 if (super_type && gfc_find_component (super_type, stree->name, true, true))
10841 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
10842 " component of '%s'",
10843 stree->name, &where, resolve_bindings_derived->name);
10847 stree->n.tb->error = 0;
10851 resolve_bindings_result = FAILURE;
10852 stree->n.tb->error = 1;
10856 resolve_typebound_procedures (gfc_symbol* derived)
10860 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
10863 resolve_bindings_derived = derived;
10864 resolve_bindings_result = SUCCESS;
10866 if (derived->f2k_derived->tb_sym_root)
10867 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
10868 &resolve_typebound_procedure);
10870 if (derived->f2k_derived->tb_uop_root)
10871 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
10872 &resolve_typebound_user_op);
10874 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
10876 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
10877 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
10879 resolve_bindings_result = FAILURE;
10882 return resolve_bindings_result;
10886 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
10887 to give all identical derived types the same backend_decl. */
10889 add_dt_to_dt_list (gfc_symbol *derived)
10891 gfc_dt_list *dt_list;
10893 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
10894 if (derived == dt_list->derived)
10897 if (dt_list == NULL)
10899 dt_list = gfc_get_dt_list ();
10900 dt_list->next = gfc_derived_types;
10901 dt_list->derived = derived;
10902 gfc_derived_types = dt_list;
10907 /* Ensure that a derived-type is really not abstract, meaning that every
10908 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
10911 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
10916 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
10918 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
10921 if (st->n.tb && st->n.tb->deferred)
10923 gfc_symtree* overriding;
10924 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
10927 gcc_assert (overriding->n.tb);
10928 if (overriding->n.tb->deferred)
10930 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
10931 " '%s' is DEFERRED and not overridden",
10932 sub->name, &sub->declared_at, st->name);
10941 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
10943 /* The algorithm used here is to recursively travel up the ancestry of sub
10944 and for each ancestor-type, check all bindings. If any of them is
10945 DEFERRED, look it up starting from sub and see if the found (overriding)
10946 binding is not DEFERRED.
10947 This is not the most efficient way to do this, but it should be ok and is
10948 clearer than something sophisticated. */
10950 gcc_assert (ancestor && !sub->attr.abstract);
10952 if (!ancestor->attr.abstract)
10955 /* Walk bindings of this ancestor. */
10956 if (ancestor->f2k_derived)
10959 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
10964 /* Find next ancestor type and recurse on it. */
10965 ancestor = gfc_get_derived_super_type (ancestor);
10967 return ensure_not_abstract (sub, ancestor);
10973 static void resolve_symbol (gfc_symbol *sym);
10976 /* Resolve the components of a derived type. */
10979 resolve_fl_derived (gfc_symbol *sym)
10981 gfc_symbol* super_type;
10984 super_type = gfc_get_derived_super_type (sym);
10986 if (sym->attr.is_class && sym->ts.u.derived == NULL)
10988 /* Fix up incomplete CLASS symbols. */
10989 gfc_component *data = gfc_find_component (sym, "$data", true, true);
10990 gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
10991 if (vptr->ts.u.derived == NULL)
10993 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
10995 vptr->ts.u.derived = vtab->ts.u.derived;
11000 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11002 gfc_error ("As extending type '%s' at %L has a coarray component, "
11003 "parent type '%s' shall also have one", sym->name,
11004 &sym->declared_at, super_type->name);
11008 /* Ensure the extended type gets resolved before we do. */
11009 if (super_type && resolve_fl_derived (super_type) == FAILURE)
11012 /* An ABSTRACT type must be extensible. */
11013 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11015 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11016 sym->name, &sym->declared_at);
11020 for (c = sym->components; c != NULL; c = c->next)
11023 if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
11024 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11026 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11027 "deferred shape", c->name, &c->loc);
11032 if (c->attr.codimension && c->ts.type == BT_DERIVED
11033 && c->ts.u.derived->ts.is_iso_c)
11035 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11036 "shall not be a coarray", c->name, &c->loc);
11041 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11042 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11043 || c->attr.allocatable))
11045 gfc_error ("Component '%s' at %L with coarray component "
11046 "shall be a nonpointer, nonallocatable scalar",
11052 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11054 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11055 "is not an array pointer", c->name, &c->loc);
11059 if (c->attr.proc_pointer && c->ts.interface)
11061 if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11062 gfc_error ("Interface '%s', used by procedure pointer component "
11063 "'%s' at %L, is declared in a later PROCEDURE statement",
11064 c->ts.interface->name, c->name, &c->loc);
11066 /* Get the attributes from the interface (now resolved). */
11067 if (c->ts.interface->attr.if_source
11068 || c->ts.interface->attr.intrinsic)
11070 gfc_symbol *ifc = c->ts.interface;
11072 if (ifc->formal && !ifc->formal_ns)
11073 resolve_symbol (ifc);
11075 if (ifc->attr.intrinsic)
11076 resolve_intrinsic (ifc, &ifc->declared_at);
11080 c->ts = ifc->result->ts;
11081 c->attr.allocatable = ifc->result->attr.allocatable;
11082 c->attr.pointer = ifc->result->attr.pointer;
11083 c->attr.dimension = ifc->result->attr.dimension;
11084 c->as = gfc_copy_array_spec (ifc->result->as);
11089 c->attr.allocatable = ifc->attr.allocatable;
11090 c->attr.pointer = ifc->attr.pointer;
11091 c->attr.dimension = ifc->attr.dimension;
11092 c->as = gfc_copy_array_spec (ifc->as);
11094 c->ts.interface = ifc;
11095 c->attr.function = ifc->attr.function;
11096 c->attr.subroutine = ifc->attr.subroutine;
11097 gfc_copy_formal_args_ppc (c, ifc);
11099 c->attr.pure = ifc->attr.pure;
11100 c->attr.elemental = ifc->attr.elemental;
11101 c->attr.recursive = ifc->attr.recursive;
11102 c->attr.always_explicit = ifc->attr.always_explicit;
11103 c->attr.ext_attr |= ifc->attr.ext_attr;
11104 /* Replace symbols in array spec. */
11108 for (i = 0; i < c->as->rank; i++)
11110 gfc_expr_replace_comp (c->as->lower[i], c);
11111 gfc_expr_replace_comp (c->as->upper[i], c);
11114 /* Copy char length. */
11115 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11117 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11118 gfc_expr_replace_comp (cl->length, c);
11119 if (cl->length && !cl->resolved
11120 && gfc_resolve_expr (cl->length) == FAILURE)
11125 else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11127 gfc_error ("Interface '%s' of procedure pointer component "
11128 "'%s' at %L must be explicit", c->ts.interface->name,
11133 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11135 /* Since PPCs are not implicitly typed, a PPC without an explicit
11136 interface must be a subroutine. */
11137 gfc_add_subroutine (&c->attr, c->name, &c->loc);
11140 /* Procedure pointer components: Check PASS arg. */
11141 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11142 && !sym->attr.vtype)
11144 gfc_symbol* me_arg;
11146 if (c->tb->pass_arg)
11148 gfc_formal_arglist* i;
11150 /* If an explicit passing argument name is given, walk the arg-list
11151 and look for it. */
11154 c->tb->pass_arg_num = 1;
11155 for (i = c->formal; i; i = i->next)
11157 if (!strcmp (i->sym->name, c->tb->pass_arg))
11162 c->tb->pass_arg_num++;
11167 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11168 "at %L has no argument '%s'", c->name,
11169 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11176 /* Otherwise, take the first one; there should in fact be at least
11178 c->tb->pass_arg_num = 1;
11181 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11182 "must have at least one argument",
11187 me_arg = c->formal->sym;
11190 /* Now check that the argument-type matches. */
11191 gcc_assert (me_arg);
11192 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11193 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11194 || (me_arg->ts.type == BT_CLASS
11195 && CLASS_DATA (me_arg)->ts.u.derived != sym))
11197 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11198 " the derived type '%s'", me_arg->name, c->name,
11199 me_arg->name, &c->loc, sym->name);
11204 /* Check for C453. */
11205 if (me_arg->attr.dimension)
11207 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11208 "must be scalar", me_arg->name, c->name, me_arg->name,
11214 if (me_arg->attr.pointer)
11216 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11217 "may not have the POINTER attribute", me_arg->name,
11218 c->name, me_arg->name, &c->loc);
11223 if (me_arg->attr.allocatable)
11225 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11226 "may not be ALLOCATABLE", me_arg->name, c->name,
11227 me_arg->name, &c->loc);
11232 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11233 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11234 " at %L", c->name, &c->loc);
11238 /* Check type-spec if this is not the parent-type component. */
11239 if ((!sym->attr.extension || c != sym->components)
11240 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11243 /* If this type is an extension, set the accessibility of the parent
11245 if (super_type && c == sym->components
11246 && strcmp (super_type->name, c->name) == 0)
11247 c->attr.access = super_type->attr.access;
11249 /* If this type is an extension, see if this component has the same name
11250 as an inherited type-bound procedure. */
11251 if (super_type && !sym->attr.is_class
11252 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11254 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11255 " inherited type-bound procedure",
11256 c->name, sym->name, &c->loc);
11260 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
11262 if (c->ts.u.cl->length == NULL
11263 || (resolve_charlen (c->ts.u.cl) == FAILURE)
11264 || !gfc_is_constant_expr (c->ts.u.cl->length))
11266 gfc_error ("Character length of component '%s' needs to "
11267 "be a constant specification expression at %L",
11269 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11274 if (c->ts.type == BT_DERIVED
11275 && sym->component_access != ACCESS_PRIVATE
11276 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11277 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11278 && !c->ts.u.derived->attr.use_assoc
11279 && !gfc_check_access (c->ts.u.derived->attr.access,
11280 c->ts.u.derived->ns->default_access)
11281 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11282 "is a PRIVATE type and cannot be a component of "
11283 "'%s', which is PUBLIC at %L", c->name,
11284 sym->name, &sym->declared_at) == FAILURE)
11287 if (sym->attr.sequence)
11289 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11291 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11292 "not have the SEQUENCE attribute",
11293 c->ts.u.derived->name, &sym->declared_at);
11298 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
11299 && c->ts.u.derived->components == NULL
11300 && !c->ts.u.derived->attr.zero_comp)
11302 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11303 "that has not been declared", c->name, sym->name,
11308 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
11309 && CLASS_DATA (c)->ts.u.derived->components == NULL
11310 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11312 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11313 "that has not been declared", c->name, sym->name,
11319 if (c->ts.type == BT_CLASS
11320 && !(CLASS_DATA (c)->attr.class_pointer
11321 || CLASS_DATA (c)->attr.allocatable))
11323 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11324 "or pointer", c->name, &c->loc);
11328 /* Ensure that all the derived type components are put on the
11329 derived type list; even in formal namespaces, where derived type
11330 pointer components might not have been declared. */
11331 if (c->ts.type == BT_DERIVED
11333 && c->ts.u.derived->components
11335 && sym != c->ts.u.derived)
11336 add_dt_to_dt_list (c->ts.u.derived);
11338 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11339 || c->attr.proc_pointer
11340 || c->attr.allocatable)) == FAILURE)
11344 /* Resolve the type-bound procedures. */
11345 if (resolve_typebound_procedures (sym) == FAILURE)
11348 /* Resolve the finalizer procedures. */
11349 if (gfc_resolve_finalizers (sym) == FAILURE)
11352 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11353 all DEFERRED bindings are overridden. */
11354 if (super_type && super_type->attr.abstract && !sym->attr.abstract
11355 && !sym->attr.is_class
11356 && ensure_not_abstract (sym, super_type) == FAILURE)
11359 /* Add derived type to the derived type list. */
11360 add_dt_to_dt_list (sym);
11367 resolve_fl_namelist (gfc_symbol *sym)
11372 /* Reject PRIVATE objects in a PUBLIC namelist. */
11373 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
11375 for (nl = sym->namelist; nl; nl = nl->next)
11377 if (!nl->sym->attr.use_assoc
11378 && !is_sym_host_assoc (nl->sym, sym->ns)
11379 && !gfc_check_access(nl->sym->attr.access,
11380 nl->sym->ns->default_access))
11382 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11383 "cannot be member of PUBLIC namelist '%s' at %L",
11384 nl->sym->name, sym->name, &sym->declared_at);
11388 /* Types with private components that came here by USE-association. */
11389 if (nl->sym->ts.type == BT_DERIVED
11390 && derived_inaccessible (nl->sym->ts.u.derived))
11392 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11393 "components and cannot be member of namelist '%s' at %L",
11394 nl->sym->name, sym->name, &sym->declared_at);
11398 /* Types with private components that are defined in the same module. */
11399 if (nl->sym->ts.type == BT_DERIVED
11400 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11401 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
11402 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
11403 nl->sym->ns->default_access))
11405 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11406 "cannot be a member of PUBLIC namelist '%s' at %L",
11407 nl->sym->name, sym->name, &sym->declared_at);
11413 for (nl = sym->namelist; nl; nl = nl->next)
11415 /* Reject namelist arrays of assumed shape. */
11416 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11417 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
11418 "must not have assumed shape in namelist "
11419 "'%s' at %L", nl->sym->name, sym->name,
11420 &sym->declared_at) == FAILURE)
11423 /* Reject namelist arrays that are not constant shape. */
11424 if (is_non_constant_shape_array (nl->sym))
11426 gfc_error ("NAMELIST array object '%s' must have constant "
11427 "shape in namelist '%s' at %L", nl->sym->name,
11428 sym->name, &sym->declared_at);
11432 /* Namelist objects cannot have allocatable or pointer components. */
11433 if (nl->sym->ts.type != BT_DERIVED)
11436 if (nl->sym->ts.u.derived->attr.alloc_comp)
11438 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11439 "have ALLOCATABLE components",
11440 nl->sym->name, sym->name, &sym->declared_at);
11444 if (nl->sym->ts.u.derived->attr.pointer_comp)
11446 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
11447 "have POINTER components",
11448 nl->sym->name, sym->name, &sym->declared_at);
11454 /* 14.1.2 A module or internal procedure represent local entities
11455 of the same type as a namelist member and so are not allowed. */
11456 for (nl = sym->namelist; nl; nl = nl->next)
11458 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11461 if (nl->sym->attr.function && nl->sym == nl->sym->result)
11462 if ((nl->sym == sym->ns->proc_name)
11464 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11468 if (nl->sym && nl->sym->name)
11469 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11470 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11472 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11473 "attribute in '%s' at %L", nlsym->name,
11474 &sym->declared_at);
11484 resolve_fl_parameter (gfc_symbol *sym)
11486 /* A parameter array's shape needs to be constant. */
11487 if (sym->as != NULL
11488 && (sym->as->type == AS_DEFERRED
11489 || is_non_constant_shape_array (sym)))
11491 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11492 "or of deferred shape", sym->name, &sym->declared_at);
11496 /* Make sure a parameter that has been implicitly typed still
11497 matches the implicit type, since PARAMETER statements can precede
11498 IMPLICIT statements. */
11499 if (sym->attr.implicit_type
11500 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11503 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11504 "later IMPLICIT type", sym->name, &sym->declared_at);
11508 /* Make sure the types of derived parameters are consistent. This
11509 type checking is deferred until resolution because the type may
11510 refer to a derived type from the host. */
11511 if (sym->ts.type == BT_DERIVED
11512 && !gfc_compare_types (&sym->ts, &sym->value->ts))
11514 gfc_error ("Incompatible derived type in PARAMETER at %L",
11515 &sym->value->where);
11522 /* Do anything necessary to resolve a symbol. Right now, we just
11523 assume that an otherwise unknown symbol is a variable. This sort
11524 of thing commonly happens for symbols in module. */
11527 resolve_symbol (gfc_symbol *sym)
11529 int check_constant, mp_flag;
11530 gfc_symtree *symtree;
11531 gfc_symtree *this_symtree;
11535 /* Avoid double resolution of function result symbols. */
11536 if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns))
11539 if (sym->attr.flavor == FL_UNKNOWN)
11542 /* If we find that a flavorless symbol is an interface in one of the
11543 parent namespaces, find its symtree in this namespace, free the
11544 symbol and set the symtree to point to the interface symbol. */
11545 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
11547 symtree = gfc_find_symtree (ns->sym_root, sym->name);
11548 if (symtree && symtree->n.sym->generic)
11550 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11552 gfc_release_symbol (sym);
11553 symtree->n.sym->refs++;
11554 this_symtree->n.sym = symtree->n.sym;
11559 /* Otherwise give it a flavor according to such attributes as
11561 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
11562 sym->attr.flavor = FL_VARIABLE;
11565 sym->attr.flavor = FL_PROCEDURE;
11566 if (sym->attr.dimension)
11567 sym->attr.function = 1;
11571 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
11572 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
11574 if (sym->attr.procedure && sym->ts.interface
11575 && sym->attr.if_source != IFSRC_DECL)
11577 if (sym->ts.interface == sym)
11579 gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
11580 "interface", sym->name, &sym->declared_at);
11583 if (sym->ts.interface->attr.procedure)
11585 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
11586 " in a later PROCEDURE statement", sym->ts.interface->name,
11587 sym->name,&sym->declared_at);
11591 /* Get the attributes from the interface (now resolved). */
11592 if (sym->ts.interface->attr.if_source
11593 || sym->ts.interface->attr.intrinsic)
11595 gfc_symbol *ifc = sym->ts.interface;
11596 resolve_symbol (ifc);
11598 if (ifc->attr.intrinsic)
11599 resolve_intrinsic (ifc, &ifc->declared_at);
11602 sym->ts = ifc->result->ts;
11605 sym->ts.interface = ifc;
11606 sym->attr.function = ifc->attr.function;
11607 sym->attr.subroutine = ifc->attr.subroutine;
11608 gfc_copy_formal_args (sym, ifc);
11610 sym->attr.allocatable = ifc->attr.allocatable;
11611 sym->attr.pointer = ifc->attr.pointer;
11612 sym->attr.pure = ifc->attr.pure;
11613 sym->attr.elemental = ifc->attr.elemental;
11614 sym->attr.dimension = ifc->attr.dimension;
11615 sym->attr.contiguous = ifc->attr.contiguous;
11616 sym->attr.recursive = ifc->attr.recursive;
11617 sym->attr.always_explicit = ifc->attr.always_explicit;
11618 sym->attr.ext_attr |= ifc->attr.ext_attr;
11619 /* Copy array spec. */
11620 sym->as = gfc_copy_array_spec (ifc->as);
11624 for (i = 0; i < sym->as->rank; i++)
11626 gfc_expr_replace_symbols (sym->as->lower[i], sym);
11627 gfc_expr_replace_symbols (sym->as->upper[i], sym);
11630 /* Copy char length. */
11631 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11633 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11634 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
11635 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
11636 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
11640 else if (sym->ts.interface->name[0] != '\0')
11642 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
11643 sym->ts.interface->name, sym->name, &sym->declared_at);
11648 if (sym->attr.is_protected && !sym->attr.proc_pointer
11649 && (sym->attr.procedure || sym->attr.external))
11651 if (sym->attr.external)
11652 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11653 "at %L", &sym->declared_at);
11655 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11656 "at %L", &sym->declared_at);
11663 if (sym->attr.contiguous
11664 && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
11665 && !sym->attr.pointer)))
11667 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11668 "array pointer or an assumed-shape array", sym->name,
11669 &sym->declared_at);
11673 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
11676 /* Symbols that are module procedures with results (functions) have
11677 the types and array specification copied for type checking in
11678 procedures that call them, as well as for saving to a module
11679 file. These symbols can't stand the scrutiny that their results
11681 mp_flag = (sym->result != NULL && sym->result != sym);
11683 /* Make sure that the intrinsic is consistent with its internal
11684 representation. This needs to be done before assigning a default
11685 type to avoid spurious warnings. */
11686 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
11687 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
11690 /* For associate names, resolve corresponding expression and make sure
11691 they get their type-spec set this way. */
11697 gcc_assert (sym->attr.flavor == FL_VARIABLE);
11699 target = sym->assoc->target;
11700 if (gfc_resolve_expr (target) != SUCCESS)
11703 /* For variable targets, we get some attributes from the target. */
11704 if (target->expr_type == EXPR_VARIABLE)
11708 gcc_assert (target->symtree);
11709 tsym = target->symtree->n.sym;
11711 sym->attr.asynchronous = tsym->attr.asynchronous;
11712 sym->attr.volatile_ = tsym->attr.volatile_;
11714 sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
11717 sym->ts = target->ts;
11718 gcc_assert (sym->ts.type != BT_UNKNOWN);
11720 /* See if this is a valid association-to-variable. */
11721 to_var = (target->expr_type == EXPR_VARIABLE
11722 && !gfc_has_vector_subscript (target));
11723 if (sym->assoc->variable && !to_var)
11725 if (target->expr_type == EXPR_VARIABLE)
11726 gfc_error ("'%s' at %L associated to vector-indexed target can not"
11727 " be used in a variable definition context",
11728 sym->name, &sym->declared_at);
11730 gfc_error ("'%s' at %L associated to expression can not"
11731 " be used in a variable definition context",
11732 sym->name, &sym->declared_at);
11736 sym->assoc->variable = to_var;
11738 /* Finally resolve if this is an array or not. */
11739 if (sym->attr.dimension && target->rank == 0)
11741 gfc_error ("Associate-name '%s' at %L is used as array",
11742 sym->name, &sym->declared_at);
11743 sym->attr.dimension = 0;
11746 if (target->rank > 0)
11747 sym->attr.dimension = 1;
11749 if (sym->attr.dimension)
11751 sym->as = gfc_get_array_spec ();
11752 sym->as->rank = target->rank;
11753 sym->as->type = AS_DEFERRED;
11755 /* Target must not be coindexed, thus the associate-variable
11757 sym->as->corank = 0;
11761 /* Assign default type to symbols that need one and don't have one. */
11762 if (sym->ts.type == BT_UNKNOWN)
11764 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
11765 gfc_set_default_type (sym, 1, NULL);
11767 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
11768 && !sym->attr.function && !sym->attr.subroutine
11769 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
11770 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
11772 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
11774 /* The specific case of an external procedure should emit an error
11775 in the case that there is no implicit type. */
11777 gfc_set_default_type (sym, sym->attr.external, NULL);
11780 /* Result may be in another namespace. */
11781 resolve_symbol (sym->result);
11783 if (!sym->result->attr.proc_pointer)
11785 sym->ts = sym->result->ts;
11786 sym->as = gfc_copy_array_spec (sym->result->as);
11787 sym->attr.dimension = sym->result->attr.dimension;
11788 sym->attr.pointer = sym->result->attr.pointer;
11789 sym->attr.allocatable = sym->result->attr.allocatable;
11790 sym->attr.contiguous = sym->result->attr.contiguous;
11796 /* Assumed size arrays and assumed shape arrays must be dummy
11797 arguments. Array-spec's of implied-shape should have been resolved to
11798 AS_EXPLICIT already. */
11802 gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
11803 if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
11804 || sym->as->type == AS_ASSUMED_SHAPE)
11805 && sym->attr.dummy == 0)
11807 if (sym->as->type == AS_ASSUMED_SIZE)
11808 gfc_error ("Assumed size array at %L must be a dummy argument",
11809 &sym->declared_at);
11811 gfc_error ("Assumed shape array at %L must be a dummy argument",
11812 &sym->declared_at);
11817 /* Make sure symbols with known intent or optional are really dummy
11818 variable. Because of ENTRY statement, this has to be deferred
11819 until resolution time. */
11821 if (!sym->attr.dummy
11822 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
11824 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
11828 if (sym->attr.value && !sym->attr.dummy)
11830 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
11831 "it is not a dummy argument", sym->name, &sym->declared_at);
11835 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
11837 gfc_charlen *cl = sym->ts.u.cl;
11838 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11840 gfc_error ("Character dummy variable '%s' at %L with VALUE "
11841 "attribute must have constant length",
11842 sym->name, &sym->declared_at);
11846 if (sym->ts.is_c_interop
11847 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
11849 gfc_error ("C interoperable character dummy variable '%s' at %L "
11850 "with VALUE attribute must have length one",
11851 sym->name, &sym->declared_at);
11856 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
11857 do this for something that was implicitly typed because that is handled
11858 in gfc_set_default_type. Handle dummy arguments and procedure
11859 definitions separately. Also, anything that is use associated is not
11860 handled here but instead is handled in the module it is declared in.
11861 Finally, derived type definitions are allowed to be BIND(C) since that
11862 only implies that they're interoperable, and they are checked fully for
11863 interoperability when a variable is declared of that type. */
11864 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
11865 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
11866 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
11868 gfc_try t = SUCCESS;
11870 /* First, make sure the variable is declared at the
11871 module-level scope (J3/04-007, Section 15.3). */
11872 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
11873 sym->attr.in_common == 0)
11875 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
11876 "is neither a COMMON block nor declared at the "
11877 "module level scope", sym->name, &(sym->declared_at));
11880 else if (sym->common_head != NULL)
11882 t = verify_com_block_vars_c_interop (sym->common_head);
11886 /* If type() declaration, we need to verify that the components
11887 of the given type are all C interoperable, etc. */
11888 if (sym->ts.type == BT_DERIVED &&
11889 sym->ts.u.derived->attr.is_c_interop != 1)
11891 /* Make sure the user marked the derived type as BIND(C). If
11892 not, call the verify routine. This could print an error
11893 for the derived type more than once if multiple variables
11894 of that type are declared. */
11895 if (sym->ts.u.derived->attr.is_bind_c != 1)
11896 verify_bind_c_derived_type (sym->ts.u.derived);
11900 /* Verify the variable itself as C interoperable if it
11901 is BIND(C). It is not possible for this to succeed if
11902 the verify_bind_c_derived_type failed, so don't have to handle
11903 any error returned by verify_bind_c_derived_type. */
11904 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11905 sym->common_block);
11910 /* clear the is_bind_c flag to prevent reporting errors more than
11911 once if something failed. */
11912 sym->attr.is_bind_c = 0;
11917 /* If a derived type symbol has reached this point, without its
11918 type being declared, we have an error. Notice that most
11919 conditions that produce undefined derived types have already
11920 been dealt with. However, the likes of:
11921 implicit type(t) (t) ..... call foo (t) will get us here if
11922 the type is not declared in the scope of the implicit
11923 statement. Change the type to BT_UNKNOWN, both because it is so
11924 and to prevent an ICE. */
11925 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
11926 && !sym->ts.u.derived->attr.zero_comp)
11928 gfc_error ("The derived type '%s' at %L is of type '%s', "
11929 "which has not been defined", sym->name,
11930 &sym->declared_at, sym->ts.u.derived->name);
11931 sym->ts.type = BT_UNKNOWN;
11935 /* Make sure that the derived type has been resolved and that the
11936 derived type is visible in the symbol's namespace, if it is a
11937 module function and is not PRIVATE. */
11938 if (sym->ts.type == BT_DERIVED
11939 && sym->ts.u.derived->attr.use_assoc
11940 && sym->ns->proc_name
11941 && sym->ns->proc_name->attr.flavor == FL_MODULE)
11945 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
11948 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
11949 if (!ds && sym->attr.function
11950 && gfc_check_access (sym->attr.access, sym->ns->default_access))
11952 symtree = gfc_new_symtree (&sym->ns->sym_root,
11953 sym->ts.u.derived->name);
11954 symtree->n.sym = sym->ts.u.derived;
11955 sym->ts.u.derived->refs++;
11959 /* Unless the derived-type declaration is use associated, Fortran 95
11960 does not allow public entries of private derived types.
11961 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
11962 161 in 95-006r3. */
11963 if (sym->ts.type == BT_DERIVED
11964 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
11965 && !sym->ts.u.derived->attr.use_assoc
11966 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11967 && !gfc_check_access (sym->ts.u.derived->attr.access,
11968 sym->ts.u.derived->ns->default_access)
11969 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
11970 "of PRIVATE derived type '%s'",
11971 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
11972 : "variable", sym->name, &sym->declared_at,
11973 sym->ts.u.derived->name) == FAILURE)
11976 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
11977 default initialization is defined (5.1.2.4.4). */
11978 if (sym->ts.type == BT_DERIVED
11980 && sym->attr.intent == INTENT_OUT
11982 && sym->as->type == AS_ASSUMED_SIZE)
11984 for (c = sym->ts.u.derived->components; c; c = c->next)
11986 if (c->initializer)
11988 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
11989 "ASSUMED SIZE and so cannot have a default initializer",
11990 sym->name, &sym->declared_at);
11997 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
11998 || sym->attr.codimension)
11999 && sym->attr.result)
12000 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12001 "a coarray component", sym->name, &sym->declared_at);
12004 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12005 && sym->ts.u.derived->ts.is_iso_c)
12006 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12007 "shall not be a coarray", sym->name, &sym->declared_at);
12010 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12011 && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12012 || sym->attr.allocatable))
12013 gfc_error ("Variable '%s' at %L with coarray component "
12014 "shall be a nonpointer, nonallocatable scalar",
12015 sym->name, &sym->declared_at);
12017 /* F2008, C526. The function-result case was handled above. */
12018 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12019 || sym->attr.codimension)
12020 && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12021 || sym->ns->proc_name->attr.flavor == FL_MODULE
12022 || sym->ns->proc_name->attr.is_main_program
12023 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12024 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12025 "component and is not ALLOCATABLE, SAVE nor a "
12026 "dummy argument", sym->name, &sym->declared_at);
12027 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12028 else if (sym->attr.codimension && !sym->attr.allocatable
12029 && sym->as && sym->as->cotype == AS_DEFERRED)
12030 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12031 "deferred shape", sym->name, &sym->declared_at);
12032 else if (sym->attr.codimension && sym->attr.allocatable
12033 && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12034 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12035 "deferred shape", sym->name, &sym->declared_at);
12039 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12040 || (sym->attr.codimension && sym->attr.allocatable))
12041 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12042 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12043 "allocatable coarray or have coarray components",
12044 sym->name, &sym->declared_at);
12046 if (sym->attr.codimension && sym->attr.dummy
12047 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12048 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12049 "procedure '%s'", sym->name, &sym->declared_at,
12050 sym->ns->proc_name->name);
12052 switch (sym->attr.flavor)
12055 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12060 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12065 if (resolve_fl_namelist (sym) == FAILURE)
12070 if (resolve_fl_parameter (sym) == FAILURE)
12078 /* Resolve array specifier. Check as well some constraints
12079 on COMMON blocks. */
12081 check_constant = sym->attr.in_common && !sym->attr.pointer;
12083 /* Set the formal_arg_flag so that check_conflict will not throw
12084 an error for host associated variables in the specification
12085 expression for an array_valued function. */
12086 if (sym->attr.function && sym->as)
12087 formal_arg_flag = 1;
12089 gfc_resolve_array_spec (sym->as, check_constant);
12091 formal_arg_flag = 0;
12093 /* Resolve formal namespaces. */
12094 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12095 && !sym->attr.contained && !sym->attr.intrinsic)
12096 gfc_resolve (sym->formal_ns);
12098 /* Make sure the formal namespace is present. */
12099 if (sym->formal && !sym->formal_ns)
12101 gfc_formal_arglist *formal = sym->formal;
12102 while (formal && !formal->sym)
12103 formal = formal->next;
12107 sym->formal_ns = formal->sym->ns;
12108 sym->formal_ns->refs++;
12112 /* Check threadprivate restrictions. */
12113 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12114 && (!sym->attr.in_common
12115 && sym->module == NULL
12116 && (sym->ns->proc_name == NULL
12117 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12118 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12120 /* If we have come this far we can apply default-initializers, as
12121 described in 14.7.5, to those variables that have not already
12122 been assigned one. */
12123 if (sym->ts.type == BT_DERIVED
12124 && sym->attr.referenced
12125 && sym->ns == gfc_current_ns
12127 && !sym->attr.allocatable
12128 && !sym->attr.alloc_comp)
12130 symbol_attribute *a = &sym->attr;
12132 if ((!a->save && !a->dummy && !a->pointer
12133 && !a->in_common && !a->use_assoc
12134 && !(a->function && sym != sym->result))
12135 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12136 apply_default_init (sym);
12139 /* If this symbol has a type-spec, check it. */
12140 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12141 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12142 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12148 /************* Resolve DATA statements *************/
12152 gfc_data_value *vnode;
12158 /* Advance the values structure to point to the next value in the data list. */
12161 next_data_value (void)
12163 while (mpz_cmp_ui (values.left, 0) == 0)
12166 if (values.vnode->next == NULL)
12169 values.vnode = values.vnode->next;
12170 mpz_set (values.left, values.vnode->repeat);
12178 check_data_variable (gfc_data_variable *var, locus *where)
12184 ar_type mark = AR_UNKNOWN;
12186 mpz_t section_index[GFC_MAX_DIMENSIONS];
12192 if (gfc_resolve_expr (var->expr) == FAILURE)
12196 mpz_init_set_si (offset, 0);
12199 if (e->expr_type != EXPR_VARIABLE)
12200 gfc_internal_error ("check_data_variable(): Bad expression");
12202 sym = e->symtree->n.sym;
12204 if (sym->ns->is_block_data && !sym->attr.in_common)
12206 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12207 sym->name, &sym->declared_at);
12210 if (e->ref == NULL && sym->as)
12212 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12213 " declaration", sym->name, where);
12217 has_pointer = sym->attr.pointer;
12219 for (ref = e->ref; ref; ref = ref->next)
12221 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12224 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
12226 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12232 && ref->type == REF_ARRAY
12233 && ref->u.ar.type != AR_FULL)
12235 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12236 "be a full array", sym->name, where);
12241 if (e->rank == 0 || has_pointer)
12243 mpz_init_set_ui (size, 1);
12250 /* Find the array section reference. */
12251 for (ref = e->ref; ref; ref = ref->next)
12253 if (ref->type != REF_ARRAY)
12255 if (ref->u.ar.type == AR_ELEMENT)
12261 /* Set marks according to the reference pattern. */
12262 switch (ref->u.ar.type)
12270 /* Get the start position of array section. */
12271 gfc_get_section_index (ar, section_index, &offset);
12276 gcc_unreachable ();
12279 if (gfc_array_size (e, &size) == FAILURE)
12281 gfc_error ("Nonconstant array section at %L in DATA statement",
12283 mpz_clear (offset);
12290 while (mpz_cmp_ui (size, 0) > 0)
12292 if (next_data_value () == FAILURE)
12294 gfc_error ("DATA statement at %L has more variables than values",
12300 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12304 /* If we have more than one element left in the repeat count,
12305 and we have more than one element left in the target variable,
12306 then create a range assignment. */
12307 /* FIXME: Only done for full arrays for now, since array sections
12309 if (mark == AR_FULL && ref && ref->next == NULL
12310 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12314 if (mpz_cmp (size, values.left) >= 0)
12316 mpz_init_set (range, values.left);
12317 mpz_sub (size, size, values.left);
12318 mpz_set_ui (values.left, 0);
12322 mpz_init_set (range, size);
12323 mpz_sub (values.left, values.left, size);
12324 mpz_set_ui (size, 0);
12327 t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
12330 mpz_add (offset, offset, range);
12337 /* Assign initial value to symbol. */
12340 mpz_sub_ui (values.left, values.left, 1);
12341 mpz_sub_ui (size, size, 1);
12343 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
12347 if (mark == AR_FULL)
12348 mpz_add_ui (offset, offset, 1);
12350 /* Modify the array section indexes and recalculate the offset
12351 for next element. */
12352 else if (mark == AR_SECTION)
12353 gfc_advance_section (section_index, ar, &offset);
12357 if (mark == AR_SECTION)
12359 for (i = 0; i < ar->dimen; i++)
12360 mpz_clear (section_index[i]);
12364 mpz_clear (offset);
12370 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12372 /* Iterate over a list of elements in a DATA statement. */
12375 traverse_data_list (gfc_data_variable *var, locus *where)
12378 iterator_stack frame;
12379 gfc_expr *e, *start, *end, *step;
12380 gfc_try retval = SUCCESS;
12382 mpz_init (frame.value);
12385 start = gfc_copy_expr (var->iter.start);
12386 end = gfc_copy_expr (var->iter.end);
12387 step = gfc_copy_expr (var->iter.step);
12389 if (gfc_simplify_expr (start, 1) == FAILURE
12390 || start->expr_type != EXPR_CONSTANT)
12392 gfc_error ("start of implied-do loop at %L could not be "
12393 "simplified to a constant value", &start->where);
12397 if (gfc_simplify_expr (end, 1) == FAILURE
12398 || end->expr_type != EXPR_CONSTANT)
12400 gfc_error ("end of implied-do loop at %L could not be "
12401 "simplified to a constant value", &start->where);
12405 if (gfc_simplify_expr (step, 1) == FAILURE
12406 || step->expr_type != EXPR_CONSTANT)
12408 gfc_error ("step of implied-do loop at %L could not be "
12409 "simplified to a constant value", &start->where);
12414 mpz_set (trip, end->value.integer);
12415 mpz_sub (trip, trip, start->value.integer);
12416 mpz_add (trip, trip, step->value.integer);
12418 mpz_div (trip, trip, step->value.integer);
12420 mpz_set (frame.value, start->value.integer);
12422 frame.prev = iter_stack;
12423 frame.variable = var->iter.var->symtree;
12424 iter_stack = &frame;
12426 while (mpz_cmp_ui (trip, 0) > 0)
12428 if (traverse_data_var (var->list, where) == FAILURE)
12434 e = gfc_copy_expr (var->expr);
12435 if (gfc_simplify_expr (e, 1) == FAILURE)
12442 mpz_add (frame.value, frame.value, step->value.integer);
12444 mpz_sub_ui (trip, trip, 1);
12448 mpz_clear (frame.value);
12451 gfc_free_expr (start);
12452 gfc_free_expr (end);
12453 gfc_free_expr (step);
12455 iter_stack = frame.prev;
12460 /* Type resolve variables in the variable list of a DATA statement. */
12463 traverse_data_var (gfc_data_variable *var, locus *where)
12467 for (; var; var = var->next)
12469 if (var->expr == NULL)
12470 t = traverse_data_list (var, where);
12472 t = check_data_variable (var, where);
12482 /* Resolve the expressions and iterators associated with a data statement.
12483 This is separate from the assignment checking because data lists should
12484 only be resolved once. */
12487 resolve_data_variables (gfc_data_variable *d)
12489 for (; d; d = d->next)
12491 if (d->list == NULL)
12493 if (gfc_resolve_expr (d->expr) == FAILURE)
12498 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12501 if (resolve_data_variables (d->list) == FAILURE)
12510 /* Resolve a single DATA statement. We implement this by storing a pointer to
12511 the value list into static variables, and then recursively traversing the
12512 variables list, expanding iterators and such. */
12515 resolve_data (gfc_data *d)
12518 if (resolve_data_variables (d->var) == FAILURE)
12521 values.vnode = d->value;
12522 if (d->value == NULL)
12523 mpz_set_ui (values.left, 0);
12525 mpz_set (values.left, d->value->repeat);
12527 if (traverse_data_var (d->var, &d->where) == FAILURE)
12530 /* At this point, we better not have any values left. */
12532 if (next_data_value () == SUCCESS)
12533 gfc_error ("DATA statement at %L has more values than variables",
12538 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12539 accessed by host or use association, is a dummy argument to a pure function,
12540 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12541 is storage associated with any such variable, shall not be used in the
12542 following contexts: (clients of this function). */
12544 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12545 procedure. Returns zero if assignment is OK, nonzero if there is a
12548 gfc_impure_variable (gfc_symbol *sym)
12553 if (sym->attr.use_assoc || sym->attr.in_common)
12556 /* Check if the symbol's ns is inside the pure procedure. */
12557 for (ns = gfc_current_ns; ns; ns = ns->parent)
12561 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12565 proc = sym->ns->proc_name;
12566 if (sym->attr.dummy && gfc_pure (proc)
12567 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12569 proc->attr.function))
12572 /* TODO: Sort out what can be storage associated, if anything, and include
12573 it here. In principle equivalences should be scanned but it does not
12574 seem to be possible to storage associate an impure variable this way. */
12579 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12580 current namespace is inside a pure procedure. */
12583 gfc_pure (gfc_symbol *sym)
12585 symbol_attribute attr;
12590 /* Check if the current namespace or one of its parents
12591 belongs to a pure procedure. */
12592 for (ns = gfc_current_ns; ns; ns = ns->parent)
12594 sym = ns->proc_name;
12598 if (attr.flavor == FL_PROCEDURE && attr.pure)
12606 return attr.flavor == FL_PROCEDURE && attr.pure;
12610 /* Test whether the current procedure is elemental or not. */
12613 gfc_elemental (gfc_symbol *sym)
12615 symbol_attribute attr;
12618 sym = gfc_current_ns->proc_name;
12623 return attr.flavor == FL_PROCEDURE && attr.elemental;
12627 /* Warn about unused labels. */
12630 warn_unused_fortran_label (gfc_st_label *label)
12635 warn_unused_fortran_label (label->left);
12637 if (label->defined == ST_LABEL_UNKNOWN)
12640 switch (label->referenced)
12642 case ST_LABEL_UNKNOWN:
12643 gfc_warning ("Label %d at %L defined but not used", label->value,
12647 case ST_LABEL_BAD_TARGET:
12648 gfc_warning ("Label %d at %L defined but cannot be used",
12649 label->value, &label->where);
12656 warn_unused_fortran_label (label->right);
12660 /* Returns the sequence type of a symbol or sequence. */
12663 sequence_type (gfc_typespec ts)
12672 if (ts.u.derived->components == NULL)
12673 return SEQ_NONDEFAULT;
12675 result = sequence_type (ts.u.derived->components->ts);
12676 for (c = ts.u.derived->components->next; c; c = c->next)
12677 if (sequence_type (c->ts) != result)
12683 if (ts.kind != gfc_default_character_kind)
12684 return SEQ_NONDEFAULT;
12686 return SEQ_CHARACTER;
12689 if (ts.kind != gfc_default_integer_kind)
12690 return SEQ_NONDEFAULT;
12692 return SEQ_NUMERIC;
12695 if (!(ts.kind == gfc_default_real_kind
12696 || ts.kind == gfc_default_double_kind))
12697 return SEQ_NONDEFAULT;
12699 return SEQ_NUMERIC;
12702 if (ts.kind != gfc_default_complex_kind)
12703 return SEQ_NONDEFAULT;
12705 return SEQ_NUMERIC;
12708 if (ts.kind != gfc_default_logical_kind)
12709 return SEQ_NONDEFAULT;
12711 return SEQ_NUMERIC;
12714 return SEQ_NONDEFAULT;
12719 /* Resolve derived type EQUIVALENCE object. */
12722 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
12724 gfc_component *c = derived->components;
12729 /* Shall not be an object of nonsequence derived type. */
12730 if (!derived->attr.sequence)
12732 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
12733 "attribute to be an EQUIVALENCE object", sym->name,
12738 /* Shall not have allocatable components. */
12739 if (derived->attr.alloc_comp)
12741 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
12742 "components to be an EQUIVALENCE object",sym->name,
12747 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
12749 gfc_error ("Derived type variable '%s' at %L with default "
12750 "initialization cannot be in EQUIVALENCE with a variable "
12751 "in COMMON", sym->name, &e->where);
12755 for (; c ; c = c->next)
12757 if (c->ts.type == BT_DERIVED
12758 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
12761 /* Shall not be an object of sequence derived type containing a pointer
12762 in the structure. */
12763 if (c->attr.pointer)
12765 gfc_error ("Derived type variable '%s' at %L with pointer "
12766 "component(s) cannot be an EQUIVALENCE object",
12767 sym->name, &e->where);
12775 /* Resolve equivalence object.
12776 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
12777 an allocatable array, an object of nonsequence derived type, an object of
12778 sequence derived type containing a pointer at any level of component
12779 selection, an automatic object, a function name, an entry name, a result
12780 name, a named constant, a structure component, or a subobject of any of
12781 the preceding objects. A substring shall not have length zero. A
12782 derived type shall not have components with default initialization nor
12783 shall two objects of an equivalence group be initialized.
12784 Either all or none of the objects shall have an protected attribute.
12785 The simple constraints are done in symbol.c(check_conflict) and the rest
12786 are implemented here. */
12789 resolve_equivalence (gfc_equiv *eq)
12792 gfc_symbol *first_sym;
12795 locus *last_where = NULL;
12796 seq_type eq_type, last_eq_type;
12797 gfc_typespec *last_ts;
12798 int object, cnt_protected;
12801 last_ts = &eq->expr->symtree->n.sym->ts;
12803 first_sym = eq->expr->symtree->n.sym;
12807 for (object = 1; eq; eq = eq->eq, object++)
12811 e->ts = e->symtree->n.sym->ts;
12812 /* match_varspec might not know yet if it is seeing
12813 array reference or substring reference, as it doesn't
12815 if (e->ref && e->ref->type == REF_ARRAY)
12817 gfc_ref *ref = e->ref;
12818 sym = e->symtree->n.sym;
12820 if (sym->attr.dimension)
12822 ref->u.ar.as = sym->as;
12826 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
12827 if (e->ts.type == BT_CHARACTER
12829 && ref->type == REF_ARRAY
12830 && ref->u.ar.dimen == 1
12831 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
12832 && ref->u.ar.stride[0] == NULL)
12834 gfc_expr *start = ref->u.ar.start[0];
12835 gfc_expr *end = ref->u.ar.end[0];
12838 /* Optimize away the (:) reference. */
12839 if (start == NULL && end == NULL)
12842 e->ref = ref->next;
12844 e->ref->next = ref->next;
12849 ref->type = REF_SUBSTRING;
12851 start = gfc_get_int_expr (gfc_default_integer_kind,
12853 ref->u.ss.start = start;
12854 if (end == NULL && e->ts.u.cl)
12855 end = gfc_copy_expr (e->ts.u.cl->length);
12856 ref->u.ss.end = end;
12857 ref->u.ss.length = e->ts.u.cl;
12864 /* Any further ref is an error. */
12867 gcc_assert (ref->type == REF_ARRAY);
12868 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
12874 if (gfc_resolve_expr (e) == FAILURE)
12877 sym = e->symtree->n.sym;
12879 if (sym->attr.is_protected)
12881 if (cnt_protected > 0 && cnt_protected != object)
12883 gfc_error ("Either all or none of the objects in the "
12884 "EQUIVALENCE set at %L shall have the "
12885 "PROTECTED attribute",
12890 /* Shall not equivalence common block variables in a PURE procedure. */
12891 if (sym->ns->proc_name
12892 && sym->ns->proc_name->attr.pure
12893 && sym->attr.in_common)
12895 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
12896 "object in the pure procedure '%s'",
12897 sym->name, &e->where, sym->ns->proc_name->name);
12901 /* Shall not be a named constant. */
12902 if (e->expr_type == EXPR_CONSTANT)
12904 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
12905 "object", sym->name, &e->where);
12909 if (e->ts.type == BT_DERIVED
12910 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
12913 /* Check that the types correspond correctly:
12915 A numeric sequence structure may be equivalenced to another sequence
12916 structure, an object of default integer type, default real type, double
12917 precision real type, default logical type such that components of the
12918 structure ultimately only become associated to objects of the same
12919 kind. A character sequence structure may be equivalenced to an object
12920 of default character kind or another character sequence structure.
12921 Other objects may be equivalenced only to objects of the same type and
12922 kind parameters. */
12924 /* Identical types are unconditionally OK. */
12925 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
12926 goto identical_types;
12928 last_eq_type = sequence_type (*last_ts);
12929 eq_type = sequence_type (sym->ts);
12931 /* Since the pair of objects is not of the same type, mixed or
12932 non-default sequences can be rejected. */
12934 msg = "Sequence %s with mixed components in EQUIVALENCE "
12935 "statement at %L with different type objects";
12937 && last_eq_type == SEQ_MIXED
12938 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
12940 || (eq_type == SEQ_MIXED
12941 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12942 &e->where) == FAILURE))
12945 msg = "Non-default type object or sequence %s in EQUIVALENCE "
12946 "statement at %L with objects of different type";
12948 && last_eq_type == SEQ_NONDEFAULT
12949 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
12950 last_where) == FAILURE)
12951 || (eq_type == SEQ_NONDEFAULT
12952 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12953 &e->where) == FAILURE))
12956 msg ="Non-CHARACTER object '%s' in default CHARACTER "
12957 "EQUIVALENCE statement at %L";
12958 if (last_eq_type == SEQ_CHARACTER
12959 && eq_type != SEQ_CHARACTER
12960 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12961 &e->where) == FAILURE)
12964 msg ="Non-NUMERIC object '%s' in default NUMERIC "
12965 "EQUIVALENCE statement at %L";
12966 if (last_eq_type == SEQ_NUMERIC
12967 && eq_type != SEQ_NUMERIC
12968 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
12969 &e->where) == FAILURE)
12974 last_where = &e->where;
12979 /* Shall not be an automatic array. */
12980 if (e->ref->type == REF_ARRAY
12981 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
12983 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
12984 "an EQUIVALENCE object", sym->name, &e->where);
12991 /* Shall not be a structure component. */
12992 if (r->type == REF_COMPONENT)
12994 gfc_error ("Structure component '%s' at %L cannot be an "
12995 "EQUIVALENCE object",
12996 r->u.c.component->name, &e->where);
13000 /* A substring shall not have length zero. */
13001 if (r->type == REF_SUBSTRING)
13003 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13005 gfc_error ("Substring at %L has length zero",
13006 &r->u.ss.start->where);
13016 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13019 resolve_fntype (gfc_namespace *ns)
13021 gfc_entry_list *el;
13024 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13027 /* If there are any entries, ns->proc_name is the entry master
13028 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13030 sym = ns->entries->sym;
13032 sym = ns->proc_name;
13033 if (sym->result == sym
13034 && sym->ts.type == BT_UNKNOWN
13035 && gfc_set_default_type (sym, 0, NULL) == FAILURE
13036 && !sym->attr.untyped)
13038 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13039 sym->name, &sym->declared_at);
13040 sym->attr.untyped = 1;
13043 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13044 && !sym->attr.contained
13045 && !gfc_check_access (sym->ts.u.derived->attr.access,
13046 sym->ts.u.derived->ns->default_access)
13047 && gfc_check_access (sym->attr.access, sym->ns->default_access))
13049 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13050 "%L of PRIVATE type '%s'", sym->name,
13051 &sym->declared_at, sym->ts.u.derived->name);
13055 for (el = ns->entries->next; el; el = el->next)
13057 if (el->sym->result == el->sym
13058 && el->sym->ts.type == BT_UNKNOWN
13059 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13060 && !el->sym->attr.untyped)
13062 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13063 el->sym->name, &el->sym->declared_at);
13064 el->sym->attr.untyped = 1;
13070 /* 12.3.2.1.1 Defined operators. */
13073 check_uop_procedure (gfc_symbol *sym, locus where)
13075 gfc_formal_arglist *formal;
13077 if (!sym->attr.function)
13079 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13080 sym->name, &where);
13084 if (sym->ts.type == BT_CHARACTER
13085 && !(sym->ts.u.cl && sym->ts.u.cl->length)
13086 && !(sym->result && sym->result->ts.u.cl
13087 && sym->result->ts.u.cl->length))
13089 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13090 "character length", sym->name, &where);
13094 formal = sym->formal;
13095 if (!formal || !formal->sym)
13097 gfc_error ("User operator procedure '%s' at %L must have at least "
13098 "one argument", sym->name, &where);
13102 if (formal->sym->attr.intent != INTENT_IN)
13104 gfc_error ("First argument of operator interface at %L must be "
13105 "INTENT(IN)", &where);
13109 if (formal->sym->attr.optional)
13111 gfc_error ("First argument of operator interface at %L cannot be "
13112 "optional", &where);
13116 formal = formal->next;
13117 if (!formal || !formal->sym)
13120 if (formal->sym->attr.intent != INTENT_IN)
13122 gfc_error ("Second argument of operator interface at %L must be "
13123 "INTENT(IN)", &where);
13127 if (formal->sym->attr.optional)
13129 gfc_error ("Second argument of operator interface at %L cannot be "
13130 "optional", &where);
13136 gfc_error ("Operator interface at %L must have, at most, two "
13137 "arguments", &where);
13145 gfc_resolve_uops (gfc_symtree *symtree)
13147 gfc_interface *itr;
13149 if (symtree == NULL)
13152 gfc_resolve_uops (symtree->left);
13153 gfc_resolve_uops (symtree->right);
13155 for (itr = symtree->n.uop->op; itr; itr = itr->next)
13156 check_uop_procedure (itr->sym, itr->sym->declared_at);
13160 /* Examine all of the expressions associated with a program unit,
13161 assign types to all intermediate expressions, make sure that all
13162 assignments are to compatible types and figure out which names
13163 refer to which functions or subroutines. It doesn't check code
13164 block, which is handled by resolve_code. */
13167 resolve_types (gfc_namespace *ns)
13173 gfc_namespace* old_ns = gfc_current_ns;
13175 /* Check that all IMPLICIT types are ok. */
13176 if (!ns->seen_implicit_none)
13179 for (letter = 0; letter != GFC_LETTERS; ++letter)
13180 if (ns->set_flag[letter]
13181 && resolve_typespec_used (&ns->default_type[letter],
13182 &ns->implicit_loc[letter],
13187 gfc_current_ns = ns;
13189 resolve_entries (ns);
13191 resolve_common_vars (ns->blank_common.head, false);
13192 resolve_common_blocks (ns->common_root);
13194 resolve_contained_functions (ns);
13196 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13198 for (cl = ns->cl_list; cl; cl = cl->next)
13199 resolve_charlen (cl);
13201 gfc_traverse_ns (ns, resolve_symbol);
13203 resolve_fntype (ns);
13205 for (n = ns->contained; n; n = n->sibling)
13207 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13208 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13209 "also be PURE", n->proc_name->name,
13210 &n->proc_name->declared_at);
13216 gfc_check_interfaces (ns);
13218 gfc_traverse_ns (ns, resolve_values);
13224 for (d = ns->data; d; d = d->next)
13228 gfc_traverse_ns (ns, gfc_formalize_init_value);
13230 gfc_traverse_ns (ns, gfc_verify_binding_labels);
13232 if (ns->common_root != NULL)
13233 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13235 for (eq = ns->equiv; eq; eq = eq->next)
13236 resolve_equivalence (eq);
13238 /* Warn about unused labels. */
13239 if (warn_unused_label)
13240 warn_unused_fortran_label (ns->st_labels);
13242 gfc_resolve_uops (ns->uop_root);
13244 gfc_current_ns = old_ns;
13248 /* Call resolve_code recursively. */
13251 resolve_codes (gfc_namespace *ns)
13254 bitmap_obstack old_obstack;
13256 for (n = ns->contained; n; n = n->sibling)
13259 gfc_current_ns = ns;
13261 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13262 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13265 /* Set to an out of range value. */
13266 current_entry_id = -1;
13268 old_obstack = labels_obstack;
13269 bitmap_obstack_initialize (&labels_obstack);
13271 resolve_code (ns->code, ns);
13273 bitmap_obstack_release (&labels_obstack);
13274 labels_obstack = old_obstack;
13278 /* This function is called after a complete program unit has been compiled.
13279 Its purpose is to examine all of the expressions associated with a program
13280 unit, assign types to all intermediate expressions, make sure that all
13281 assignments are to compatible types and figure out which names refer to
13282 which functions or subroutines. */
13285 gfc_resolve (gfc_namespace *ns)
13287 gfc_namespace *old_ns;
13288 code_stack *old_cs_base;
13294 old_ns = gfc_current_ns;
13295 old_cs_base = cs_base;
13297 resolve_types (ns);
13298 resolve_codes (ns);
13300 gfc_current_ns = old_ns;
13301 cs_base = old_cs_base;
13304 gfc_run_passes (ns);