1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
41 /* Stack to keep track of the nesting of blocks as we move through the
42 code. See resolve_branch() and resolve_code(). */
44 typedef struct code_stack
46 struct gfc_code *head, *current;
47 struct code_stack *prev;
49 /* This bitmap keeps track of the targets valid for a branch from
50 inside this block except for END {IF|SELECT}s of enclosing
52 bitmap reachable_labels;
56 static code_stack *cs_base = NULL;
59 /* Nonzero if we're inside a FORALL block. */
61 static int forall_flag;
63 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
65 static int omp_workshare_flag;
67 /* Nonzero if we are processing a formal arglist. The corresponding function
68 resets the flag each time that it is read. */
69 static int formal_arg_flag = 0;
71 /* True if we are resolving a specification expression. */
72 static int specification_expr = 0;
74 /* The id of the last entry seen. */
75 static int current_entry_id;
77 /* We use bitmaps to determine if a branch target is valid. */
78 static bitmap_obstack labels_obstack;
81 gfc_is_formal_arg (void)
83 return formal_arg_flag;
86 /* Is the symbol host associated? */
88 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
90 for (ns = ns->parent; ns; ns = ns->parent)
99 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
100 an ABSTRACT derived-type. If where is not NULL, an error message with that
101 locus is printed, optionally using name. */
104 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
106 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
111 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
112 name, where, ts->u.derived->name);
114 gfc_error ("ABSTRACT type '%s' used at %L",
115 ts->u.derived->name, where);
125 /* Resolve types of formal argument lists. These have to be done early so that
126 the formal argument lists of module procedures can be copied to the
127 containing module before the individual procedures are resolved
128 individually. We also resolve argument lists of procedures in interface
129 blocks because they are self-contained scoping units.
131 Since a dummy argument cannot be a non-dummy procedure, the only
132 resort left for untyped names are the IMPLICIT types. */
135 resolve_formal_arglist (gfc_symbol *proc)
137 gfc_formal_arglist *f;
141 if (proc->result != NULL)
146 if (gfc_elemental (proc)
147 || sym->attr.pointer || sym->attr.allocatable
148 || (sym->as && sym->as->rank > 0))
150 proc->attr.always_explicit = 1;
151 sym->attr.always_explicit = 1;
156 for (f = proc->formal; f; f = f->next)
162 /* Alternate return placeholder. */
163 if (gfc_elemental (proc))
164 gfc_error ("Alternate return specifier in elemental subroutine "
165 "'%s' at %L is not allowed", proc->name,
167 if (proc->attr.function)
168 gfc_error ("Alternate return specifier in function "
169 "'%s' at %L is not allowed", proc->name,
174 if (sym->attr.if_source != IFSRC_UNKNOWN)
175 resolve_formal_arglist (sym);
177 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
179 if (gfc_pure (proc) && !gfc_pure (sym))
181 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
182 "also be PURE", sym->name, &sym->declared_at);
186 if (gfc_elemental (proc))
188 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
189 "procedure", &sym->declared_at);
193 if (sym->attr.function
194 && sym->ts.type == BT_UNKNOWN
195 && sym->attr.intrinsic)
197 gfc_intrinsic_sym *isym;
198 isym = gfc_find_function (sym->name);
199 if (isym == NULL || !isym->specific)
201 gfc_error ("Unable to find a specific INTRINSIC procedure "
202 "for the reference '%s' at %L", sym->name,
211 if (sym->ts.type == BT_UNKNOWN)
213 if (!sym->attr.function || sym->result == sym)
214 gfc_set_default_type (sym, 1, sym->ns);
217 gfc_resolve_array_spec (sym->as, 0);
219 /* We can't tell if an array with dimension (:) is assumed or deferred
220 shape until we know if it has the pointer or allocatable attributes.
222 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
223 && !(sym->attr.pointer || sym->attr.allocatable))
225 sym->as->type = AS_ASSUMED_SHAPE;
226 for (i = 0; i < sym->as->rank; i++)
227 sym->as->lower[i] = gfc_int_expr (1);
230 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
231 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
232 || sym->attr.optional)
234 proc->attr.always_explicit = 1;
236 proc->result->attr.always_explicit = 1;
239 /* If the flavor is unknown at this point, it has to be a variable.
240 A procedure specification would have already set the type. */
242 if (sym->attr.flavor == FL_UNKNOWN)
243 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
245 if (gfc_pure (proc) && !sym->attr.pointer
246 && sym->attr.flavor != FL_PROCEDURE)
248 if (proc->attr.function && sym->attr.intent != INTENT_IN)
249 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
250 "INTENT(IN)", sym->name, proc->name,
253 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
254 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
255 "have its INTENT specified", sym->name, proc->name,
259 if (gfc_elemental (proc))
263 gfc_error ("Argument '%s' of elemental procedure at %L must "
264 "be scalar", sym->name, &sym->declared_at);
268 if (sym->attr.pointer)
270 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
271 "have the POINTER attribute", sym->name,
276 if (sym->attr.flavor == FL_PROCEDURE)
278 gfc_error ("Dummy procedure '%s' not allowed in elemental "
279 "procedure '%s' at %L", sym->name, proc->name,
285 /* Each dummy shall be specified to be scalar. */
286 if (proc->attr.proc == PROC_ST_FUNCTION)
290 gfc_error ("Argument '%s' of statement function at %L must "
291 "be scalar", sym->name, &sym->declared_at);
295 if (sym->ts.type == BT_CHARACTER)
297 gfc_charlen *cl = sym->ts.u.cl;
298 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
300 gfc_error ("Character-valued argument '%s' of statement "
301 "function at %L must have constant length",
302 sym->name, &sym->declared_at);
312 /* Work function called when searching for symbols that have argument lists
313 associated with them. */
316 find_arglists (gfc_symbol *sym)
318 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
321 resolve_formal_arglist (sym);
325 /* Given a namespace, resolve all formal argument lists within the namespace.
329 resolve_formal_arglists (gfc_namespace *ns)
334 gfc_traverse_ns (ns, find_arglists);
339 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
343 /* If this namespace is not a function or an entry master function,
345 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
346 || sym->attr.entry_master)
349 /* Try to find out of what the return type is. */
350 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
352 t = gfc_set_default_type (sym->result, 0, ns);
354 if (t == FAILURE && !sym->result->attr.untyped)
356 if (sym->result == sym)
357 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
358 sym->name, &sym->declared_at);
359 else if (!sym->result->attr.proc_pointer)
360 gfc_error ("Result '%s' of contained function '%s' at %L has "
361 "no IMPLICIT type", sym->result->name, sym->name,
362 &sym->result->declared_at);
363 sym->result->attr.untyped = 1;
367 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
368 type, lists the only ways a character length value of * can be used:
369 dummy arguments of procedures, named constants, and function results
370 in external functions. Internal function results and results of module
371 procedures are not on this list, ergo, not permitted. */
373 if (sym->result->ts.type == BT_CHARACTER)
375 gfc_charlen *cl = sym->result->ts.u.cl;
376 if (!cl || !cl->length)
378 /* See if this is a module-procedure and adapt error message
381 gcc_assert (ns->parent && ns->parent->proc_name);
382 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
384 gfc_error ("Character-valued %s '%s' at %L must not be"
386 module_proc ? _("module procedure")
387 : _("internal function"),
388 sym->name, &sym->declared_at);
394 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
395 introduce duplicates. */
398 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
400 gfc_formal_arglist *f, *new_arglist;
403 for (; new_args != NULL; new_args = new_args->next)
405 new_sym = new_args->sym;
406 /* See if this arg is already in the formal argument list. */
407 for (f = proc->formal; f; f = f->next)
409 if (new_sym == f->sym)
416 /* Add a new argument. Argument order is not important. */
417 new_arglist = gfc_get_formal_arglist ();
418 new_arglist->sym = new_sym;
419 new_arglist->next = proc->formal;
420 proc->formal = new_arglist;
425 /* Flag the arguments that are not present in all entries. */
428 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
430 gfc_formal_arglist *f, *head;
433 for (f = proc->formal; f; f = f->next)
438 for (new_args = head; new_args; new_args = new_args->next)
440 if (new_args->sym == f->sym)
447 f->sym->attr.not_always_present = 1;
452 /* Resolve alternate entry points. If a symbol has multiple entry points we
453 create a new master symbol for the main routine, and turn the existing
454 symbol into an entry point. */
457 resolve_entries (gfc_namespace *ns)
459 gfc_namespace *old_ns;
463 char name[GFC_MAX_SYMBOL_LEN + 1];
464 static int master_count = 0;
466 if (ns->proc_name == NULL)
469 /* No need to do anything if this procedure doesn't have alternate entry
474 /* We may already have resolved alternate entry points. */
475 if (ns->proc_name->attr.entry_master)
478 /* If this isn't a procedure something has gone horribly wrong. */
479 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
481 /* Remember the current namespace. */
482 old_ns = gfc_current_ns;
486 /* Add the main entry point to the list of entry points. */
487 el = gfc_get_entry_list ();
488 el->sym = ns->proc_name;
490 el->next = ns->entries;
492 ns->proc_name->attr.entry = 1;
494 /* If it is a module function, it needs to be in the right namespace
495 so that gfc_get_fake_result_decl can gather up the results. The
496 need for this arose in get_proc_name, where these beasts were
497 left in their own namespace, to keep prior references linked to
498 the entry declaration.*/
499 if (ns->proc_name->attr.function
500 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
503 /* Do the same for entries where the master is not a module
504 procedure. These are retained in the module namespace because
505 of the module procedure declaration. */
506 for (el = el->next; el; el = el->next)
507 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
508 && el->sym->attr.mod_proc)
512 /* Add an entry statement for it. */
519 /* Create a new symbol for the master function. */
520 /* Give the internal function a unique name (within this file).
521 Also include the function name so the user has some hope of figuring
522 out what is going on. */
523 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
524 master_count++, ns->proc_name->name);
525 gfc_get_ha_symbol (name, &proc);
526 gcc_assert (proc != NULL);
528 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
529 if (ns->proc_name->attr.subroutine)
530 gfc_add_subroutine (&proc->attr, proc->name, NULL);
534 gfc_typespec *ts, *fts;
535 gfc_array_spec *as, *fas;
536 gfc_add_function (&proc->attr, proc->name, NULL);
538 fas = ns->entries->sym->as;
539 fas = fas ? fas : ns->entries->sym->result->as;
540 fts = &ns->entries->sym->result->ts;
541 if (fts->type == BT_UNKNOWN)
542 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
543 for (el = ns->entries->next; el; el = el->next)
545 ts = &el->sym->result->ts;
547 as = as ? as : el->sym->result->as;
548 if (ts->type == BT_UNKNOWN)
549 ts = gfc_get_default_type (el->sym->result->name, NULL);
551 if (! gfc_compare_types (ts, fts)
552 || (el->sym->result->attr.dimension
553 != ns->entries->sym->result->attr.dimension)
554 || (el->sym->result->attr.pointer
555 != ns->entries->sym->result->attr.pointer))
557 else if (as && fas && ns->entries->sym->result != el->sym->result
558 && gfc_compare_array_spec (as, fas) == 0)
559 gfc_error ("Function %s at %L has entries with mismatched "
560 "array specifications", ns->entries->sym->name,
561 &ns->entries->sym->declared_at);
562 /* The characteristics need to match and thus both need to have
563 the same string length, i.e. both len=*, or both len=4.
564 Having both len=<variable> is also possible, but difficult to
565 check at compile time. */
566 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
567 && (((ts->u.cl->length && !fts->u.cl->length)
568 ||(!ts->u.cl->length && fts->u.cl->length))
570 && ts->u.cl->length->expr_type
571 != fts->u.cl->length->expr_type)
573 && ts->u.cl->length->expr_type == EXPR_CONSTANT
574 && mpz_cmp (ts->u.cl->length->value.integer,
575 fts->u.cl->length->value.integer) != 0)))
576 gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
577 "entries returning variables of different "
578 "string lengths", ns->entries->sym->name,
579 &ns->entries->sym->declared_at);
584 sym = ns->entries->sym->result;
585 /* All result types the same. */
587 if (sym->attr.dimension)
588 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
589 if (sym->attr.pointer)
590 gfc_add_pointer (&proc->attr, NULL);
594 /* Otherwise the result will be passed through a union by
596 proc->attr.mixed_entry_master = 1;
597 for (el = ns->entries; el; el = el->next)
599 sym = el->sym->result;
600 if (sym->attr.dimension)
602 if (el == ns->entries)
603 gfc_error ("FUNCTION result %s can't be an array in "
604 "FUNCTION %s at %L", sym->name,
605 ns->entries->sym->name, &sym->declared_at);
607 gfc_error ("ENTRY result %s can't be an array in "
608 "FUNCTION %s at %L", sym->name,
609 ns->entries->sym->name, &sym->declared_at);
611 else if (sym->attr.pointer)
613 if (el == ns->entries)
614 gfc_error ("FUNCTION result %s can't be a POINTER in "
615 "FUNCTION %s at %L", sym->name,
616 ns->entries->sym->name, &sym->declared_at);
618 gfc_error ("ENTRY result %s can't be a POINTER in "
619 "FUNCTION %s at %L", sym->name,
620 ns->entries->sym->name, &sym->declared_at);
625 if (ts->type == BT_UNKNOWN)
626 ts = gfc_get_default_type (sym->name, NULL);
630 if (ts->kind == gfc_default_integer_kind)
634 if (ts->kind == gfc_default_real_kind
635 || ts->kind == gfc_default_double_kind)
639 if (ts->kind == gfc_default_complex_kind)
643 if (ts->kind == gfc_default_logical_kind)
647 /* We will issue error elsewhere. */
655 if (el == ns->entries)
656 gfc_error ("FUNCTION result %s can't be of type %s "
657 "in FUNCTION %s at %L", sym->name,
658 gfc_typename (ts), ns->entries->sym->name,
661 gfc_error ("ENTRY result %s can't be of type %s "
662 "in FUNCTION %s at %L", sym->name,
663 gfc_typename (ts), ns->entries->sym->name,
670 proc->attr.access = ACCESS_PRIVATE;
671 proc->attr.entry_master = 1;
673 /* Merge all the entry point arguments. */
674 for (el = ns->entries; el; el = el->next)
675 merge_argument_lists (proc, el->sym->formal);
677 /* Check the master formal arguments for any that are not
678 present in all entry points. */
679 for (el = ns->entries; el; el = el->next)
680 check_argument_lists (proc, el->sym->formal);
682 /* Use the master function for the function body. */
683 ns->proc_name = proc;
685 /* Finalize the new symbols. */
686 gfc_commit_symbols ();
688 /* Restore the original namespace. */
689 gfc_current_ns = old_ns;
694 has_default_initializer (gfc_symbol *der)
698 gcc_assert (der->attr.flavor == FL_DERIVED);
699 for (c = der->components; c; c = c->next)
700 if ((c->ts.type != BT_DERIVED && c->initializer)
701 || (c->ts.type == BT_DERIVED
702 && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
708 /* Resolve common variables. */
710 resolve_common_vars (gfc_symbol *sym, bool named_common)
712 gfc_symbol *csym = sym;
714 for (; csym; csym = csym->common_next)
716 if (csym->value || csym->attr.data)
718 if (!csym->ns->is_block_data)
719 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
720 "but only in BLOCK DATA initialization is "
721 "allowed", csym->name, &csym->declared_at);
722 else if (!named_common)
723 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
724 "in a blank COMMON but initialization is only "
725 "allowed in named common blocks", csym->name,
729 if (csym->ts.type != BT_DERIVED)
732 if (!(csym->ts.u.derived->attr.sequence
733 || csym->ts.u.derived->attr.is_bind_c))
734 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
735 "has neither the SEQUENCE nor the BIND(C) "
736 "attribute", csym->name, &csym->declared_at);
737 if (csym->ts.u.derived->attr.alloc_comp)
738 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
739 "has an ultimate component that is "
740 "allocatable", csym->name, &csym->declared_at);
741 if (has_default_initializer (csym->ts.u.derived))
742 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
743 "may not have default initializer", csym->name,
746 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
747 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
751 /* Resolve common blocks. */
753 resolve_common_blocks (gfc_symtree *common_root)
757 if (common_root == NULL)
760 if (common_root->left)
761 resolve_common_blocks (common_root->left);
762 if (common_root->right)
763 resolve_common_blocks (common_root->right);
765 resolve_common_vars (common_root->n.common->head, true);
767 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
771 if (sym->attr.flavor == FL_PARAMETER)
772 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
773 sym->name, &common_root->n.common->where, &sym->declared_at);
775 if (sym->attr.intrinsic)
776 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
777 sym->name, &common_root->n.common->where);
778 else if (sym->attr.result
779 || gfc_is_function_return_value (sym, gfc_current_ns))
780 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
781 "that is also a function result", sym->name,
782 &common_root->n.common->where);
783 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
784 && sym->attr.proc != PROC_ST_FUNCTION)
785 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
786 "that is also a global procedure", sym->name,
787 &common_root->n.common->where);
791 /* Resolve contained function types. Because contained functions can call one
792 another, they have to be worked out before any of the contained procedures
795 The good news is that if a function doesn't already have a type, the only
796 way it can get one is through an IMPLICIT type or a RESULT variable, because
797 by definition contained functions are contained namespace they're contained
798 in, not in a sibling or parent namespace. */
801 resolve_contained_functions (gfc_namespace *ns)
803 gfc_namespace *child;
806 resolve_formal_arglists (ns);
808 for (child = ns->contained; child; child = child->sibling)
810 /* Resolve alternate entry points first. */
811 resolve_entries (child);
813 /* Then check function return types. */
814 resolve_contained_fntype (child->proc_name, child);
815 for (el = child->entries; el; el = el->next)
816 resolve_contained_fntype (el->sym, child);
821 /* Resolve all of the elements of a structure constructor and make sure that
822 the types are correct. */
825 resolve_structure_cons (gfc_expr *expr)
827 gfc_constructor *cons;
833 cons = expr->value.constructor;
834 /* A constructor may have references if it is the result of substituting a
835 parameter variable. In this case we just pull out the component we
838 comp = expr->ref->u.c.sym->components;
840 comp = expr->ts.u.derived->components;
842 /* See if the user is trying to invoke a structure constructor for one of
843 the iso_c_binding derived types. */
844 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
845 && expr->ts.u.derived->ts.is_iso_c && cons && cons->expr != NULL)
847 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
848 expr->ts.u.derived->name, &(expr->where));
852 for (; comp; comp = comp->next, cons = cons->next)
859 if (gfc_resolve_expr (cons->expr) == FAILURE)
865 rank = comp->as ? comp->as->rank : 0;
866 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
867 && (comp->attr.allocatable || cons->expr->rank))
869 gfc_error ("The rank of the element in the derived type "
870 "constructor at %L does not match that of the "
871 "component (%d/%d)", &cons->expr->where,
872 cons->expr->rank, rank);
876 /* If we don't have the right type, try to convert it. */
878 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
881 if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
882 gfc_error ("The element in the derived type constructor at %L, "
883 "for pointer component '%s', is %s but should be %s",
884 &cons->expr->where, comp->name,
885 gfc_basic_typename (cons->expr->ts.type),
886 gfc_basic_typename (comp->ts.type));
888 t = gfc_convert_type (cons->expr, &comp->ts, 1);
891 if (cons->expr->expr_type == EXPR_NULL
892 && !(comp->attr.pointer || comp->attr.allocatable
893 || comp->attr.proc_pointer
894 || (comp->ts.type == BT_CLASS
895 && (comp->ts.u.derived->components->attr.pointer
896 || comp->ts.u.derived->components->attr.allocatable))))
899 gfc_error ("The NULL in the derived type constructor at %L is "
900 "being applied to component '%s', which is neither "
901 "a POINTER nor ALLOCATABLE", &cons->expr->where,
905 if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
908 a = gfc_expr_attr (cons->expr);
910 if (!a.pointer && !a.target)
913 gfc_error ("The element in the derived type constructor at %L, "
914 "for pointer component '%s' should be a POINTER or "
915 "a TARGET", &cons->expr->where, comp->name);
923 /****************** Expression name resolution ******************/
925 /* Returns 0 if a symbol was not declared with a type or
926 attribute declaration statement, nonzero otherwise. */
929 was_declared (gfc_symbol *sym)
935 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
938 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
939 || a.optional || a.pointer || a.save || a.target || a.volatile_
940 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
947 /* Determine if a symbol is generic or not. */
950 generic_sym (gfc_symbol *sym)
954 if (sym->attr.generic ||
955 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
958 if (was_declared (sym) || sym->ns->parent == NULL)
961 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
968 return generic_sym (s);
975 /* Determine if a symbol is specific or not. */
978 specific_sym (gfc_symbol *sym)
982 if (sym->attr.if_source == IFSRC_IFBODY
983 || sym->attr.proc == PROC_MODULE
984 || sym->attr.proc == PROC_INTERNAL
985 || sym->attr.proc == PROC_ST_FUNCTION
986 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
987 || sym->attr.external)
990 if (was_declared (sym) || sym->ns->parent == NULL)
993 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
995 return (s == NULL) ? 0 : specific_sym (s);
999 /* Figure out if the procedure is specific, generic or unknown. */
1002 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1006 procedure_kind (gfc_symbol *sym)
1008 if (generic_sym (sym))
1009 return PTYPE_GENERIC;
1011 if (specific_sym (sym))
1012 return PTYPE_SPECIFIC;
1014 return PTYPE_UNKNOWN;
1017 /* Check references to assumed size arrays. The flag need_full_assumed_size
1018 is nonzero when matching actual arguments. */
1020 static int need_full_assumed_size = 0;
1023 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1025 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1028 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1029 What should it be? */
1030 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1031 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1032 && (e->ref->u.ar.type == AR_FULL))
1034 gfc_error ("The upper bound in the last dimension must "
1035 "appear in the reference to the assumed size "
1036 "array '%s' at %L", sym->name, &e->where);
1043 /* Look for bad assumed size array references in argument expressions
1044 of elemental and array valued intrinsic procedures. Since this is
1045 called from procedure resolution functions, it only recurses at
1049 resolve_assumed_size_actual (gfc_expr *e)
1054 switch (e->expr_type)
1057 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1062 if (resolve_assumed_size_actual (e->value.op.op1)
1063 || resolve_assumed_size_actual (e->value.op.op2))
1074 /* Check a generic procedure, passed as an actual argument, to see if
1075 there is a matching specific name. If none, it is an error, and if
1076 more than one, the reference is ambiguous. */
1078 count_specific_procs (gfc_expr *e)
1085 sym = e->symtree->n.sym;
1087 for (p = sym->generic; p; p = p->next)
1088 if (strcmp (sym->name, p->sym->name) == 0)
1090 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1096 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1100 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1101 "argument at %L", sym->name, &e->where);
1107 /* See if a call to sym could possibly be a not allowed RECURSION because of
1108 a missing RECURIVE declaration. This means that either sym is the current
1109 context itself, or sym is the parent of a contained procedure calling its
1110 non-RECURSIVE containing procedure.
1111 This also works if sym is an ENTRY. */
1114 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1116 gfc_symbol* proc_sym;
1117 gfc_symbol* context_proc;
1118 gfc_namespace* real_context;
1120 if (sym->attr.flavor == FL_PROGRAM)
1123 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1125 /* If we've got an ENTRY, find real procedure. */
1126 if (sym->attr.entry && sym->ns->entries)
1127 proc_sym = sym->ns->entries->sym;
1131 /* If sym is RECURSIVE, all is well of course. */
1132 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1135 /* Find the context procedure's "real" symbol if it has entries.
1136 We look for a procedure symbol, so recurse on the parents if we don't
1137 find one (like in case of a BLOCK construct). */
1138 for (real_context = context; ; real_context = real_context->parent)
1140 /* We should find something, eventually! */
1141 gcc_assert (real_context);
1143 context_proc = (real_context->entries ? real_context->entries->sym
1144 : real_context->proc_name);
1146 /* In some special cases, there may not be a proc_name, like for this
1148 real(bad_kind()) function foo () ...
1149 when checking the call to bad_kind ().
1150 In these cases, we simply return here and assume that the
1155 if (context_proc->attr.flavor != FL_LABEL)
1159 /* A call from sym's body to itself is recursion, of course. */
1160 if (context_proc == proc_sym)
1163 /* The same is true if context is a contained procedure and sym the
1165 if (context_proc->attr.contained)
1167 gfc_symbol* parent_proc;
1169 gcc_assert (context->parent);
1170 parent_proc = (context->parent->entries ? context->parent->entries->sym
1171 : context->parent->proc_name);
1173 if (parent_proc == proc_sym)
1181 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1182 its typespec and formal argument list. */
1185 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1187 gfc_intrinsic_sym* isym;
1193 /* We already know this one is an intrinsic, so we don't call
1194 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1195 gfc_find_subroutine directly to check whether it is a function or
1198 if ((isym = gfc_find_function (sym->name)))
1200 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1201 && !sym->attr.implicit_type)
1202 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1203 " ignored", sym->name, &sym->declared_at);
1205 if (!sym->attr.function &&
1206 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1211 else if ((isym = gfc_find_subroutine (sym->name)))
1213 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1215 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1216 " specifier", sym->name, &sym->declared_at);
1220 if (!sym->attr.subroutine &&
1221 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1226 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1231 gfc_copy_formal_args_intr (sym, isym);
1233 /* Check it is actually available in the standard settings. */
1234 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1237 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1238 " available in the current standard settings but %s. Use"
1239 " an appropriate -std=* option or enable -fall-intrinsics"
1240 " in order to use it.",
1241 sym->name, &sym->declared_at, symstd);
1249 /* Resolve a procedure expression, like passing it to a called procedure or as
1250 RHS for a procedure pointer assignment. */
1253 resolve_procedure_expression (gfc_expr* expr)
1257 if (expr->expr_type != EXPR_VARIABLE)
1259 gcc_assert (expr->symtree);
1261 sym = expr->symtree->n.sym;
1263 if (sym->attr.intrinsic)
1264 resolve_intrinsic (sym, &expr->where);
1266 if (sym->attr.flavor != FL_PROCEDURE
1267 || (sym->attr.function && sym->result == sym))
1270 /* A non-RECURSIVE procedure that is used as procedure expression within its
1271 own body is in danger of being called recursively. */
1272 if (is_illegal_recursion (sym, gfc_current_ns))
1273 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1274 " itself recursively. Declare it RECURSIVE or use"
1275 " -frecursive", sym->name, &expr->where);
1281 /* Resolve an actual argument list. Most of the time, this is just
1282 resolving the expressions in the list.
1283 The exception is that we sometimes have to decide whether arguments
1284 that look like procedure arguments are really simple variable
1288 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1289 bool no_formal_args)
1292 gfc_symtree *parent_st;
1294 int save_need_full_assumed_size;
1295 gfc_component *comp;
1297 for (; arg; arg = arg->next)
1302 /* Check the label is a valid branching target. */
1305 if (arg->label->defined == ST_LABEL_UNKNOWN)
1307 gfc_error ("Label %d referenced at %L is never defined",
1308 arg->label->value, &arg->label->where);
1315 if (gfc_is_proc_ptr_comp (e, &comp))
1318 if (e->expr_type == EXPR_PPC)
1320 if (comp->as != NULL)
1321 e->rank = comp->as->rank;
1322 e->expr_type = EXPR_FUNCTION;
1324 if (gfc_resolve_expr (e) == FAILURE)
1329 if (e->expr_type == EXPR_VARIABLE
1330 && e->symtree->n.sym->attr.generic
1332 && count_specific_procs (e) != 1)
1335 if (e->ts.type != BT_PROCEDURE)
1337 save_need_full_assumed_size = need_full_assumed_size;
1338 if (e->expr_type != EXPR_VARIABLE)
1339 need_full_assumed_size = 0;
1340 if (gfc_resolve_expr (e) != SUCCESS)
1342 need_full_assumed_size = save_need_full_assumed_size;
1346 /* See if the expression node should really be a variable reference. */
1348 sym = e->symtree->n.sym;
1350 if (sym->attr.flavor == FL_PROCEDURE
1351 || sym->attr.intrinsic
1352 || sym->attr.external)
1356 /* If a procedure is not already determined to be something else
1357 check if it is intrinsic. */
1358 if (!sym->attr.intrinsic
1359 && !(sym->attr.external || sym->attr.use_assoc
1360 || sym->attr.if_source == IFSRC_IFBODY)
1361 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1362 sym->attr.intrinsic = 1;
1364 if (sym->attr.proc == PROC_ST_FUNCTION)
1366 gfc_error ("Statement function '%s' at %L is not allowed as an "
1367 "actual argument", sym->name, &e->where);
1370 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1371 sym->attr.subroutine);
1372 if (sym->attr.intrinsic && actual_ok == 0)
1374 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1375 "actual argument", sym->name, &e->where);
1378 if (sym->attr.contained && !sym->attr.use_assoc
1379 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1381 gfc_error ("Internal procedure '%s' is not allowed as an "
1382 "actual argument at %L", sym->name, &e->where);
1385 if (sym->attr.elemental && !sym->attr.intrinsic)
1387 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1388 "allowed as an actual argument at %L", sym->name,
1392 /* Check if a generic interface has a specific procedure
1393 with the same name before emitting an error. */
1394 if (sym->attr.generic && count_specific_procs (e) != 1)
1397 /* Just in case a specific was found for the expression. */
1398 sym = e->symtree->n.sym;
1400 /* If the symbol is the function that names the current (or
1401 parent) scope, then we really have a variable reference. */
1403 if (gfc_is_function_return_value (sym, sym->ns))
1406 /* If all else fails, see if we have a specific intrinsic. */
1407 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1409 gfc_intrinsic_sym *isym;
1411 isym = gfc_find_function (sym->name);
1412 if (isym == NULL || !isym->specific)
1414 gfc_error ("Unable to find a specific INTRINSIC procedure "
1415 "for the reference '%s' at %L", sym->name,
1420 sym->attr.intrinsic = 1;
1421 sym->attr.function = 1;
1424 if (gfc_resolve_expr (e) == FAILURE)
1429 /* See if the name is a module procedure in a parent unit. */
1431 if (was_declared (sym) || sym->ns->parent == NULL)
1434 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1436 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1440 if (parent_st == NULL)
1443 sym = parent_st->n.sym;
1444 e->symtree = parent_st; /* Point to the right thing. */
1446 if (sym->attr.flavor == FL_PROCEDURE
1447 || sym->attr.intrinsic
1448 || sym->attr.external)
1450 if (gfc_resolve_expr (e) == FAILURE)
1456 e->expr_type = EXPR_VARIABLE;
1458 if (sym->as != NULL)
1460 e->rank = sym->as->rank;
1461 e->ref = gfc_get_ref ();
1462 e->ref->type = REF_ARRAY;
1463 e->ref->u.ar.type = AR_FULL;
1464 e->ref->u.ar.as = sym->as;
1467 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1468 primary.c (match_actual_arg). If above code determines that it
1469 is a variable instead, it needs to be resolved as it was not
1470 done at the beginning of this function. */
1471 save_need_full_assumed_size = need_full_assumed_size;
1472 if (e->expr_type != EXPR_VARIABLE)
1473 need_full_assumed_size = 0;
1474 if (gfc_resolve_expr (e) != SUCCESS)
1476 need_full_assumed_size = save_need_full_assumed_size;
1479 /* Check argument list functions %VAL, %LOC and %REF. There is
1480 nothing to do for %REF. */
1481 if (arg->name && arg->name[0] == '%')
1483 if (strncmp ("%VAL", arg->name, 4) == 0)
1485 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1487 gfc_error ("By-value argument at %L is not of numeric "
1494 gfc_error ("By-value argument at %L cannot be an array or "
1495 "an array section", &e->where);
1499 /* Intrinsics are still PROC_UNKNOWN here. However,
1500 since same file external procedures are not resolvable
1501 in gfortran, it is a good deal easier to leave them to
1503 if (ptype != PROC_UNKNOWN
1504 && ptype != PROC_DUMMY
1505 && ptype != PROC_EXTERNAL
1506 && ptype != PROC_MODULE)
1508 gfc_error ("By-value argument at %L is not allowed "
1509 "in this context", &e->where);
1514 /* Statement functions have already been excluded above. */
1515 else if (strncmp ("%LOC", arg->name, 4) == 0
1516 && e->ts.type == BT_PROCEDURE)
1518 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1520 gfc_error ("Passing internal procedure at %L by location "
1521 "not allowed", &e->where);
1532 /* Do the checks of the actual argument list that are specific to elemental
1533 procedures. If called with c == NULL, we have a function, otherwise if
1534 expr == NULL, we have a subroutine. */
1537 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1539 gfc_actual_arglist *arg0;
1540 gfc_actual_arglist *arg;
1541 gfc_symbol *esym = NULL;
1542 gfc_intrinsic_sym *isym = NULL;
1544 gfc_intrinsic_arg *iformal = NULL;
1545 gfc_formal_arglist *eformal = NULL;
1546 bool formal_optional = false;
1547 bool set_by_optional = false;
1551 /* Is this an elemental procedure? */
1552 if (expr && expr->value.function.actual != NULL)
1554 if (expr->value.function.esym != NULL
1555 && expr->value.function.esym->attr.elemental)
1557 arg0 = expr->value.function.actual;
1558 esym = expr->value.function.esym;
1560 else if (expr->value.function.isym != NULL
1561 && expr->value.function.isym->elemental)
1563 arg0 = expr->value.function.actual;
1564 isym = expr->value.function.isym;
1569 else if (c && c->ext.actual != NULL)
1571 arg0 = c->ext.actual;
1573 if (c->resolved_sym)
1574 esym = c->resolved_sym;
1576 esym = c->symtree->n.sym;
1579 if (!esym->attr.elemental)
1585 /* The rank of an elemental is the rank of its array argument(s). */
1586 for (arg = arg0; arg; arg = arg->next)
1588 if (arg->expr != NULL && arg->expr->rank > 0)
1590 rank = arg->expr->rank;
1591 if (arg->expr->expr_type == EXPR_VARIABLE
1592 && arg->expr->symtree->n.sym->attr.optional)
1593 set_by_optional = true;
1595 /* Function specific; set the result rank and shape. */
1599 if (!expr->shape && arg->expr->shape)
1601 expr->shape = gfc_get_shape (rank);
1602 for (i = 0; i < rank; i++)
1603 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1610 /* If it is an array, it shall not be supplied as an actual argument
1611 to an elemental procedure unless an array of the same rank is supplied
1612 as an actual argument corresponding to a nonoptional dummy argument of
1613 that elemental procedure(12.4.1.5). */
1614 formal_optional = false;
1616 iformal = isym->formal;
1618 eformal = esym->formal;
1620 for (arg = arg0; arg; arg = arg->next)
1624 if (eformal->sym && eformal->sym->attr.optional)
1625 formal_optional = true;
1626 eformal = eformal->next;
1628 else if (isym && iformal)
1630 if (iformal->optional)
1631 formal_optional = true;
1632 iformal = iformal->next;
1635 formal_optional = true;
1637 if (pedantic && arg->expr != NULL
1638 && arg->expr->expr_type == EXPR_VARIABLE
1639 && arg->expr->symtree->n.sym->attr.optional
1642 && (set_by_optional || arg->expr->rank != rank)
1643 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1645 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1646 "MISSING, it cannot be the actual argument of an "
1647 "ELEMENTAL procedure unless there is a non-optional "
1648 "argument with the same rank (12.4.1.5)",
1649 arg->expr->symtree->n.sym->name, &arg->expr->where);
1654 for (arg = arg0; arg; arg = arg->next)
1656 if (arg->expr == NULL || arg->expr->rank == 0)
1659 /* Being elemental, the last upper bound of an assumed size array
1660 argument must be present. */
1661 if (resolve_assumed_size_actual (arg->expr))
1664 /* Elemental procedure's array actual arguments must conform. */
1667 if (gfc_check_conformance (arg->expr, e,
1668 "elemental procedure") == FAILURE)
1675 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1676 is an array, the intent inout/out variable needs to be also an array. */
1677 if (rank > 0 && esym && expr == NULL)
1678 for (eformal = esym->formal, arg = arg0; arg && eformal;
1679 arg = arg->next, eformal = eformal->next)
1680 if ((eformal->sym->attr.intent == INTENT_OUT
1681 || eformal->sym->attr.intent == INTENT_INOUT)
1682 && arg->expr && arg->expr->rank == 0)
1684 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1685 "ELEMENTAL subroutine '%s' is a scalar, but another "
1686 "actual argument is an array", &arg->expr->where,
1687 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1688 : "INOUT", eformal->sym->name, esym->name);
1695 /* Go through each actual argument in ACTUAL and see if it can be
1696 implemented as an inlined, non-copying intrinsic. FNSYM is the
1697 function being called, or NULL if not known. */
1700 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1702 gfc_actual_arglist *ap;
1705 for (ap = actual; ap; ap = ap->next)
1707 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1708 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1710 ap->expr->inline_noncopying_intrinsic = 1;
1714 /* This function does the checking of references to global procedures
1715 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1716 77 and 95 standards. It checks for a gsymbol for the name, making
1717 one if it does not already exist. If it already exists, then the
1718 reference being resolved must correspond to the type of gsymbol.
1719 Otherwise, the new symbol is equipped with the attributes of the
1720 reference. The corresponding code that is called in creating
1721 global entities is parse.c.
1723 In addition, for all but -std=legacy, the gsymbols are used to
1724 check the interfaces of external procedures from the same file.
1725 The namespace of the gsymbol is resolved and then, once this is
1726 done the interface is checked. */
1730 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1732 if (!gsym_ns->proc_name->attr.recursive)
1735 if (sym->ns == gsym_ns)
1738 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1745 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1747 if (gsym_ns->entries)
1749 gfc_entry_list *entry = gsym_ns->entries;
1751 for (; entry; entry = entry->next)
1753 if (strcmp (sym->name, entry->sym->name) == 0)
1755 if (strcmp (gsym_ns->proc_name->name,
1756 sym->ns->proc_name->name) == 0)
1760 && strcmp (gsym_ns->proc_name->name,
1761 sym->ns->parent->proc_name->name) == 0)
1770 resolve_global_procedure (gfc_symbol *sym, locus *where,
1771 gfc_actual_arglist **actual, int sub)
1775 enum gfc_symbol_type type;
1777 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1779 gsym = gfc_get_gsymbol (sym->name);
1781 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1782 gfc_global_used (gsym, where);
1784 if (gfc_option.flag_whole_file
1785 && sym->attr.if_source == IFSRC_UNKNOWN
1786 && gsym->type != GSYM_UNKNOWN
1788 && gsym->ns->resolved != -1
1789 && gsym->ns->proc_name
1790 && not_in_recursive (sym, gsym->ns)
1791 && not_entry_self_reference (sym, gsym->ns))
1793 /* Make sure that translation for the gsymbol occurs before
1794 the procedure currently being resolved. */
1795 ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
1796 for (; ns && ns != gsym->ns; ns = ns->sibling)
1798 if (ns->sibling == gsym->ns)
1800 ns->sibling = gsym->ns->sibling;
1801 gsym->ns->sibling = gfc_global_ns_list;
1802 gfc_global_ns_list = gsym->ns;
1807 if (!gsym->ns->resolved)
1809 gfc_dt_list *old_dt_list;
1811 /* Stash away derived types so that the backend_decls do not
1813 old_dt_list = gfc_derived_types;
1814 gfc_derived_types = NULL;
1816 gfc_resolve (gsym->ns);
1818 /* Store the new derived types with the global namespace. */
1819 if (gfc_derived_types)
1820 gsym->ns->derived_types = gfc_derived_types;
1822 /* Restore the derived types of this namespace. */
1823 gfc_derived_types = old_dt_list;
1826 if (gsym->ns->proc_name->attr.function
1827 && gsym->ns->proc_name->as
1828 && gsym->ns->proc_name->as->rank
1829 && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
1830 gfc_error ("The reference to function '%s' at %L either needs an "
1831 "explicit INTERFACE or the rank is incorrect", sym->name,
1834 if (gfc_option.flag_whole_file == 1
1835 || ((gfc_option.warn_std & GFC_STD_LEGACY)
1837 !(gfc_option.warn_std & GFC_STD_GNU)))
1838 gfc_errors_to_warnings (1);
1840 gfc_procedure_use (gsym->ns->proc_name, actual, where);
1842 gfc_errors_to_warnings (0);
1845 if (gsym->type == GSYM_UNKNOWN)
1848 gsym->where = *where;
1855 /************* Function resolution *************/
1857 /* Resolve a function call known to be generic.
1858 Section 14.1.2.4.1. */
1861 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1865 if (sym->attr.generic)
1867 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1870 expr->value.function.name = s->name;
1871 expr->value.function.esym = s;
1873 if (s->ts.type != BT_UNKNOWN)
1875 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1876 expr->ts = s->result->ts;
1879 expr->rank = s->as->rank;
1880 else if (s->result != NULL && s->result->as != NULL)
1881 expr->rank = s->result->as->rank;
1883 gfc_set_sym_referenced (expr->value.function.esym);
1888 /* TODO: Need to search for elemental references in generic
1892 if (sym->attr.intrinsic)
1893 return gfc_intrinsic_func_interface (expr, 0);
1900 resolve_generic_f (gfc_expr *expr)
1905 sym = expr->symtree->n.sym;
1909 m = resolve_generic_f0 (expr, sym);
1912 else if (m == MATCH_ERROR)
1916 if (sym->ns->parent == NULL)
1918 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1922 if (!generic_sym (sym))
1926 /* Last ditch attempt. See if the reference is to an intrinsic
1927 that possesses a matching interface. 14.1.2.4 */
1928 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1930 gfc_error ("There is no specific function for the generic '%s' at %L",
1931 expr->symtree->n.sym->name, &expr->where);
1935 m = gfc_intrinsic_func_interface (expr, 0);
1939 gfc_error ("Generic function '%s' at %L is not consistent with a "
1940 "specific intrinsic interface", expr->symtree->n.sym->name,
1947 /* Resolve a function call known to be specific. */
1950 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1954 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1956 if (sym->attr.dummy)
1958 sym->attr.proc = PROC_DUMMY;
1962 sym->attr.proc = PROC_EXTERNAL;
1966 if (sym->attr.proc == PROC_MODULE
1967 || sym->attr.proc == PROC_ST_FUNCTION
1968 || sym->attr.proc == PROC_INTERNAL)
1971 if (sym->attr.intrinsic)
1973 m = gfc_intrinsic_func_interface (expr, 1);
1977 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1978 "with an intrinsic", sym->name, &expr->where);
1986 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1989 expr->ts = sym->result->ts;
1992 expr->value.function.name = sym->name;
1993 expr->value.function.esym = sym;
1994 if (sym->as != NULL)
1995 expr->rank = sym->as->rank;
2002 resolve_specific_f (gfc_expr *expr)
2007 sym = expr->symtree->n.sym;
2011 m = resolve_specific_f0 (sym, expr);
2014 if (m == MATCH_ERROR)
2017 if (sym->ns->parent == NULL)
2020 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2026 gfc_error ("Unable to resolve the specific function '%s' at %L",
2027 expr->symtree->n.sym->name, &expr->where);
2033 /* Resolve a procedure call not known to be generic nor specific. */
2036 resolve_unknown_f (gfc_expr *expr)
2041 sym = expr->symtree->n.sym;
2043 if (sym->attr.dummy)
2045 sym->attr.proc = PROC_DUMMY;
2046 expr->value.function.name = sym->name;
2050 /* See if we have an intrinsic function reference. */
2052 if (gfc_is_intrinsic (sym, 0, expr->where))
2054 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2059 /* The reference is to an external name. */
2061 sym->attr.proc = PROC_EXTERNAL;
2062 expr->value.function.name = sym->name;
2063 expr->value.function.esym = expr->symtree->n.sym;
2065 if (sym->as != NULL)
2066 expr->rank = sym->as->rank;
2068 /* Type of the expression is either the type of the symbol or the
2069 default type of the symbol. */
2072 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2074 if (sym->ts.type != BT_UNKNOWN)
2078 ts = gfc_get_default_type (sym->name, sym->ns);
2080 if (ts->type == BT_UNKNOWN)
2082 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2083 sym->name, &expr->where);
2094 /* Return true, if the symbol is an external procedure. */
2096 is_external_proc (gfc_symbol *sym)
2098 if (!sym->attr.dummy && !sym->attr.contained
2099 && !(sym->attr.intrinsic
2100 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2101 && sym->attr.proc != PROC_ST_FUNCTION
2102 && !sym->attr.use_assoc
2110 /* Figure out if a function reference is pure or not. Also set the name
2111 of the function for a potential error message. Return nonzero if the
2112 function is PURE, zero if not. */
2114 pure_stmt_function (gfc_expr *, gfc_symbol *);
2117 pure_function (gfc_expr *e, const char **name)
2123 if (e->symtree != NULL
2124 && e->symtree->n.sym != NULL
2125 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2126 return pure_stmt_function (e, e->symtree->n.sym);
2128 if (e->value.function.esym)
2130 pure = gfc_pure (e->value.function.esym);
2131 *name = e->value.function.esym->name;
2133 else if (e->value.function.isym)
2135 pure = e->value.function.isym->pure
2136 || e->value.function.isym->elemental;
2137 *name = e->value.function.isym->name;
2141 /* Implicit functions are not pure. */
2143 *name = e->value.function.name;
2151 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2152 int *f ATTRIBUTE_UNUSED)
2156 /* Don't bother recursing into other statement functions
2157 since they will be checked individually for purity. */
2158 if (e->expr_type != EXPR_FUNCTION
2160 || e->symtree->n.sym == sym
2161 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2164 return pure_function (e, &name) ? false : true;
2169 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2171 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2176 is_scalar_expr_ptr (gfc_expr *expr)
2178 gfc_try retval = SUCCESS;
2183 /* See if we have a gfc_ref, which means we have a substring, array
2184 reference, or a component. */
2185 if (expr->ref != NULL)
2188 while (ref->next != NULL)
2194 if (ref->u.ss.length != NULL
2195 && ref->u.ss.length->length != NULL
2197 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2199 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2201 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2202 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2203 if (end - start + 1 != 1)
2210 if (ref->u.ar.type == AR_ELEMENT)
2212 else if (ref->u.ar.type == AR_FULL)
2214 /* The user can give a full array if the array is of size 1. */
2215 if (ref->u.ar.as != NULL
2216 && ref->u.ar.as->rank == 1
2217 && ref->u.ar.as->type == AS_EXPLICIT
2218 && ref->u.ar.as->lower[0] != NULL
2219 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2220 && ref->u.ar.as->upper[0] != NULL
2221 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2223 /* If we have a character string, we need to check if
2224 its length is one. */
2225 if (expr->ts.type == BT_CHARACTER)
2227 if (expr->ts.u.cl == NULL
2228 || expr->ts.u.cl->length == NULL
2229 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2235 /* We have constant lower and upper bounds. If the
2236 difference between is 1, it can be considered a
2238 start = (int) mpz_get_si
2239 (ref->u.ar.as->lower[0]->value.integer);
2240 end = (int) mpz_get_si
2241 (ref->u.ar.as->upper[0]->value.integer);
2242 if (end - start + 1 != 1)
2257 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2259 /* Character string. Make sure it's of length 1. */
2260 if (expr->ts.u.cl == NULL
2261 || expr->ts.u.cl->length == NULL
2262 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2265 else if (expr->rank != 0)
2272 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2273 and, in the case of c_associated, set the binding label based on
2277 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2278 gfc_symbol **new_sym)
2280 char name[GFC_MAX_SYMBOL_LEN + 1];
2281 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2282 int optional_arg = 0, is_pointer = 0;
2283 gfc_try retval = SUCCESS;
2284 gfc_symbol *args_sym;
2285 gfc_typespec *arg_ts;
2287 if (args->expr->expr_type == EXPR_CONSTANT
2288 || args->expr->expr_type == EXPR_OP
2289 || args->expr->expr_type == EXPR_NULL)
2291 gfc_error ("Argument to '%s' at %L is not a variable",
2292 sym->name, &(args->expr->where));
2296 args_sym = args->expr->symtree->n.sym;
2298 /* The typespec for the actual arg should be that stored in the expr
2299 and not necessarily that of the expr symbol (args_sym), because
2300 the actual expression could be a part-ref of the expr symbol. */
2301 arg_ts = &(args->expr->ts);
2303 is_pointer = gfc_is_data_pointer (args->expr);
2305 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2307 /* If the user gave two args then they are providing something for
2308 the optional arg (the second cptr). Therefore, set the name and
2309 binding label to the c_associated for two cptrs. Otherwise,
2310 set c_associated to expect one cptr. */
2314 sprintf (name, "%s_2", sym->name);
2315 sprintf (binding_label, "%s_2", sym->binding_label);
2321 sprintf (name, "%s_1", sym->name);
2322 sprintf (binding_label, "%s_1", sym->binding_label);
2326 /* Get a new symbol for the version of c_associated that
2328 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2330 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2331 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2333 sprintf (name, "%s", sym->name);
2334 sprintf (binding_label, "%s", sym->binding_label);
2336 /* Error check the call. */
2337 if (args->next != NULL)
2339 gfc_error_now ("More actual than formal arguments in '%s' "
2340 "call at %L", name, &(args->expr->where));
2343 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2345 /* Make sure we have either the target or pointer attribute. */
2346 if (!args_sym->attr.target && !is_pointer)
2348 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2349 "a TARGET or an associated pointer",
2351 sym->name, &(args->expr->where));
2355 /* See if we have interoperable type and type param. */
2356 if (verify_c_interop (arg_ts) == SUCCESS
2357 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2359 if (args_sym->attr.target == 1)
2361 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2362 has the target attribute and is interoperable. */
2363 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2364 allocatable variable that has the TARGET attribute and
2365 is not an array of zero size. */
2366 if (args_sym->attr.allocatable == 1)
2368 if (args_sym->attr.dimension != 0
2369 && (args_sym->as && args_sym->as->rank == 0))
2371 gfc_error_now ("Allocatable variable '%s' used as a "
2372 "parameter to '%s' at %L must not be "
2373 "an array of zero size",
2374 args_sym->name, sym->name,
2375 &(args->expr->where));
2381 /* A non-allocatable target variable with C
2382 interoperable type and type parameters must be
2384 if (args_sym && args_sym->attr.dimension)
2386 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2388 gfc_error ("Assumed-shape array '%s' at %L "
2389 "cannot be an argument to the "
2390 "procedure '%s' because "
2391 "it is not C interoperable",
2393 &(args->expr->where), sym->name);
2396 else if (args_sym->as->type == AS_DEFERRED)
2398 gfc_error ("Deferred-shape array '%s' at %L "
2399 "cannot be an argument to the "
2400 "procedure '%s' because "
2401 "it is not C interoperable",
2403 &(args->expr->where), sym->name);
2408 /* Make sure it's not a character string. Arrays of
2409 any type should be ok if the variable is of a C
2410 interoperable type. */
2411 if (arg_ts->type == BT_CHARACTER)
2412 if (arg_ts->u.cl != NULL
2413 && (arg_ts->u.cl->length == NULL
2414 || arg_ts->u.cl->length->expr_type
2417 (arg_ts->u.cl->length->value.integer, 1)
2419 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2421 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2422 "at %L must have a length of 1",
2423 args_sym->name, sym->name,
2424 &(args->expr->where));
2430 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2432 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2434 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2435 "associated scalar POINTER", args_sym->name,
2436 sym->name, &(args->expr->where));
2442 /* The parameter is not required to be C interoperable. If it
2443 is not C interoperable, it must be a nonpolymorphic scalar
2444 with no length type parameters. It still must have either
2445 the pointer or target attribute, and it can be
2446 allocatable (but must be allocated when c_loc is called). */
2447 if (args->expr->rank != 0
2448 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2450 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2451 "scalar", args_sym->name, sym->name,
2452 &(args->expr->where));
2455 else if (arg_ts->type == BT_CHARACTER
2456 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2458 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2459 "%L must have a length of 1",
2460 args_sym->name, sym->name,
2461 &(args->expr->where));
2466 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2468 if (args_sym->attr.flavor != FL_PROCEDURE)
2470 /* TODO: Update this error message to allow for procedure
2471 pointers once they are implemented. */
2472 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2474 args_sym->name, sym->name,
2475 &(args->expr->where));
2478 else if (args_sym->attr.is_bind_c != 1)
2480 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2482 args_sym->name, sym->name,
2483 &(args->expr->where));
2488 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2493 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2494 "iso_c_binding function: '%s'!\n", sym->name);
2501 /* Resolve a function call, which means resolving the arguments, then figuring
2502 out which entity the name refers to. */
2503 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2504 to INTENT(OUT) or INTENT(INOUT). */
2507 resolve_function (gfc_expr *expr)
2509 gfc_actual_arglist *arg;
2514 procedure_type p = PROC_INTRINSIC;
2515 bool no_formal_args;
2519 sym = expr->symtree->n.sym;
2521 /* If this is a procedure pointer component, it has already been resolved. */
2522 if (gfc_is_proc_ptr_comp (expr, NULL))
2525 if (sym && sym->attr.intrinsic
2526 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2529 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2531 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2535 /* If this ia a deferred TBP with an abstract interface (which may
2536 of course be referenced), expr->value.function.name will be set. */
2537 if (sym && sym->attr.abstract && !expr->value.function.name)
2539 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2540 sym->name, &expr->where);
2544 /* Switch off assumed size checking and do this again for certain kinds
2545 of procedure, once the procedure itself is resolved. */
2546 need_full_assumed_size++;
2548 if (expr->symtree && expr->symtree->n.sym)
2549 p = expr->symtree->n.sym->attr.proc;
2551 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2552 if (resolve_actual_arglist (expr->value.function.actual,
2553 p, no_formal_args) == FAILURE)
2556 /* Need to setup the call to the correct c_associated, depending on
2557 the number of cptrs to user gives to compare. */
2558 if (sym && sym->attr.is_iso_c == 1)
2560 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2564 /* Get the symtree for the new symbol (resolved func).
2565 the old one will be freed later, when it's no longer used. */
2566 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2569 /* Resume assumed_size checking. */
2570 need_full_assumed_size--;
2572 /* If the procedure is external, check for usage. */
2573 if (sym && is_external_proc (sym))
2574 resolve_global_procedure (sym, &expr->where,
2575 &expr->value.function.actual, 0);
2577 if (sym && sym->ts.type == BT_CHARACTER
2579 && sym->ts.u.cl->length == NULL
2581 && expr->value.function.esym == NULL
2582 && !sym->attr.contained)
2584 /* Internal procedures are taken care of in resolve_contained_fntype. */
2585 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2586 "be used at %L since it is not a dummy argument",
2587 sym->name, &expr->where);
2591 /* See if function is already resolved. */
2593 if (expr->value.function.name != NULL)
2595 if (expr->ts.type == BT_UNKNOWN)
2601 /* Apply the rules of section 14.1.2. */
2603 switch (procedure_kind (sym))
2606 t = resolve_generic_f (expr);
2609 case PTYPE_SPECIFIC:
2610 t = resolve_specific_f (expr);
2614 t = resolve_unknown_f (expr);
2618 gfc_internal_error ("resolve_function(): bad function type");
2622 /* If the expression is still a function (it might have simplified),
2623 then we check to see if we are calling an elemental function. */
2625 if (expr->expr_type != EXPR_FUNCTION)
2628 temp = need_full_assumed_size;
2629 need_full_assumed_size = 0;
2631 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2634 if (omp_workshare_flag
2635 && expr->value.function.esym
2636 && ! gfc_elemental (expr->value.function.esym))
2638 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2639 "in WORKSHARE construct", expr->value.function.esym->name,
2644 #define GENERIC_ID expr->value.function.isym->id
2645 else if (expr->value.function.actual != NULL
2646 && expr->value.function.isym != NULL
2647 && GENERIC_ID != GFC_ISYM_LBOUND
2648 && GENERIC_ID != GFC_ISYM_LEN
2649 && GENERIC_ID != GFC_ISYM_LOC
2650 && GENERIC_ID != GFC_ISYM_PRESENT)
2652 /* Array intrinsics must also have the last upper bound of an
2653 assumed size array argument. UBOUND and SIZE have to be
2654 excluded from the check if the second argument is anything
2657 for (arg = expr->value.function.actual; arg; arg = arg->next)
2659 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2660 && arg->next != NULL && arg->next->expr)
2662 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2665 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2668 if ((int)mpz_get_si (arg->next->expr->value.integer)
2673 if (arg->expr != NULL
2674 && arg->expr->rank > 0
2675 && resolve_assumed_size_actual (arg->expr))
2681 need_full_assumed_size = temp;
2684 if (!pure_function (expr, &name) && name)
2688 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2689 "FORALL %s", name, &expr->where,
2690 forall_flag == 2 ? "mask" : "block");
2693 else if (gfc_pure (NULL))
2695 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2696 "procedure within a PURE procedure", name, &expr->where);
2701 /* Functions without the RECURSIVE attribution are not allowed to
2702 * call themselves. */
2703 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2706 esym = expr->value.function.esym;
2708 if (is_illegal_recursion (esym, gfc_current_ns))
2710 if (esym->attr.entry && esym->ns->entries)
2711 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2712 " function '%s' is not RECURSIVE",
2713 esym->name, &expr->where, esym->ns->entries->sym->name);
2715 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
2716 " is not RECURSIVE", esym->name, &expr->where);
2722 /* Character lengths of use associated functions may contains references to
2723 symbols not referenced from the current program unit otherwise. Make sure
2724 those symbols are marked as referenced. */
2726 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2727 && expr->value.function.esym->attr.use_assoc)
2729 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
2733 && !((expr->value.function.esym
2734 && expr->value.function.esym->attr.elemental)
2736 (expr->value.function.isym
2737 && expr->value.function.isym->elemental)))
2738 find_noncopying_intrinsics (expr->value.function.esym,
2739 expr->value.function.actual);
2741 /* Make sure that the expression has a typespec that works. */
2742 if (expr->ts.type == BT_UNKNOWN)
2744 if (expr->symtree->n.sym->result
2745 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
2746 && !expr->symtree->n.sym->result->attr.proc_pointer)
2747 expr->ts = expr->symtree->n.sym->result->ts;
2754 /************* Subroutine resolution *************/
2757 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2763 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2764 sym->name, &c->loc);
2765 else if (gfc_pure (NULL))
2766 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2772 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2776 if (sym->attr.generic)
2778 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2781 c->resolved_sym = s;
2782 pure_subroutine (c, s);
2786 /* TODO: Need to search for elemental references in generic interface. */
2789 if (sym->attr.intrinsic)
2790 return gfc_intrinsic_sub_interface (c, 0);
2797 resolve_generic_s (gfc_code *c)
2802 sym = c->symtree->n.sym;
2806 m = resolve_generic_s0 (c, sym);
2809 else if (m == MATCH_ERROR)
2813 if (sym->ns->parent == NULL)
2815 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2819 if (!generic_sym (sym))
2823 /* Last ditch attempt. See if the reference is to an intrinsic
2824 that possesses a matching interface. 14.1.2.4 */
2825 sym = c->symtree->n.sym;
2827 if (!gfc_is_intrinsic (sym, 1, c->loc))
2829 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2830 sym->name, &c->loc);
2834 m = gfc_intrinsic_sub_interface (c, 0);
2838 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2839 "intrinsic subroutine interface", sym->name, &c->loc);
2845 /* Set the name and binding label of the subroutine symbol in the call
2846 expression represented by 'c' to include the type and kind of the
2847 second parameter. This function is for resolving the appropriate
2848 version of c_f_pointer() and c_f_procpointer(). For example, a
2849 call to c_f_pointer() for a default integer pointer could have a
2850 name of c_f_pointer_i4. If no second arg exists, which is an error
2851 for these two functions, it defaults to the generic symbol's name
2852 and binding label. */
2855 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2856 char *name, char *binding_label)
2858 gfc_expr *arg = NULL;
2862 /* The second arg of c_f_pointer and c_f_procpointer determines
2863 the type and kind for the procedure name. */
2864 arg = c->ext.actual->next->expr;
2868 /* Set up the name to have the given symbol's name,
2869 plus the type and kind. */
2870 /* a derived type is marked with the type letter 'u' */
2871 if (arg->ts.type == BT_DERIVED)
2874 kind = 0; /* set the kind as 0 for now */
2878 type = gfc_type_letter (arg->ts.type);
2879 kind = arg->ts.kind;
2882 if (arg->ts.type == BT_CHARACTER)
2883 /* Kind info for character strings not needed. */
2886 sprintf (name, "%s_%c%d", sym->name, type, kind);
2887 /* Set up the binding label as the given symbol's label plus
2888 the type and kind. */
2889 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2893 /* If the second arg is missing, set the name and label as
2894 was, cause it should at least be found, and the missing
2895 arg error will be caught by compare_parameters(). */
2896 sprintf (name, "%s", sym->name);
2897 sprintf (binding_label, "%s", sym->binding_label);
2904 /* Resolve a generic version of the iso_c_binding procedure given
2905 (sym) to the specific one based on the type and kind of the
2906 argument(s). Currently, this function resolves c_f_pointer() and
2907 c_f_procpointer based on the type and kind of the second argument
2908 (FPTR). Other iso_c_binding procedures aren't specially handled.
2909 Upon successfully exiting, c->resolved_sym will hold the resolved
2910 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2914 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2916 gfc_symbol *new_sym;
2917 /* this is fine, since we know the names won't use the max */
2918 char name[GFC_MAX_SYMBOL_LEN + 1];
2919 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2920 /* default to success; will override if find error */
2921 match m = MATCH_YES;
2923 /* Make sure the actual arguments are in the necessary order (based on the
2924 formal args) before resolving. */
2925 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2927 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2928 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2930 set_name_and_label (c, sym, name, binding_label);
2932 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2934 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2936 /* Make sure we got a third arg if the second arg has non-zero
2937 rank. We must also check that the type and rank are
2938 correct since we short-circuit this check in
2939 gfc_procedure_use() (called above to sort actual args). */
2940 if (c->ext.actual->next->expr->rank != 0)
2942 if(c->ext.actual->next->next == NULL
2943 || c->ext.actual->next->next->expr == NULL)
2946 gfc_error ("Missing SHAPE parameter for call to %s "
2947 "at %L", sym->name, &(c->loc));
2949 else if (c->ext.actual->next->next->expr->ts.type
2951 || c->ext.actual->next->next->expr->rank != 1)
2954 gfc_error ("SHAPE parameter for call to %s at %L must "
2955 "be a rank 1 INTEGER array", sym->name,
2962 if (m != MATCH_ERROR)
2964 /* the 1 means to add the optional arg to formal list */
2965 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2967 /* for error reporting, say it's declared where the original was */
2968 new_sym->declared_at = sym->declared_at;
2973 /* no differences for c_loc or c_funloc */
2977 /* set the resolved symbol */
2978 if (m != MATCH_ERROR)
2979 c->resolved_sym = new_sym;
2981 c->resolved_sym = sym;
2987 /* Resolve a subroutine call known to be specific. */
2990 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2994 if(sym->attr.is_iso_c)
2996 m = gfc_iso_c_sub_interface (c,sym);
3000 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3002 if (sym->attr.dummy)
3004 sym->attr.proc = PROC_DUMMY;
3008 sym->attr.proc = PROC_EXTERNAL;
3012 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3015 if (sym->attr.intrinsic)
3017 m = gfc_intrinsic_sub_interface (c, 1);
3021 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3022 "with an intrinsic", sym->name, &c->loc);
3030 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3032 c->resolved_sym = sym;
3033 pure_subroutine (c, sym);
3040 resolve_specific_s (gfc_code *c)
3045 sym = c->symtree->n.sym;
3049 m = resolve_specific_s0 (c, sym);
3052 if (m == MATCH_ERROR)
3055 if (sym->ns->parent == NULL)
3058 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3064 sym = c->symtree->n.sym;
3065 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3066 sym->name, &c->loc);
3072 /* Resolve a subroutine call not known to be generic nor specific. */
3075 resolve_unknown_s (gfc_code *c)
3079 sym = c->symtree->n.sym;
3081 if (sym->attr.dummy)
3083 sym->attr.proc = PROC_DUMMY;
3087 /* See if we have an intrinsic function reference. */
3089 if (gfc_is_intrinsic (sym, 1, c->loc))
3091 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3096 /* The reference is to an external name. */
3099 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3101 c->resolved_sym = sym;
3103 pure_subroutine (c, sym);
3109 /* Resolve a subroutine call. Although it was tempting to use the same code
3110 for functions, subroutines and functions are stored differently and this
3111 makes things awkward. */
3114 resolve_call (gfc_code *c)
3117 procedure_type ptype = PROC_INTRINSIC;
3118 gfc_symbol *csym, *sym;
3119 bool no_formal_args;
3121 csym = c->symtree ? c->symtree->n.sym : NULL;
3123 if (csym && csym->ts.type != BT_UNKNOWN)
3125 gfc_error ("'%s' at %L has a type, which is not consistent with "
3126 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3130 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3133 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3134 sym = st ? st->n.sym : NULL;
3135 if (sym && csym != sym
3136 && sym->ns == gfc_current_ns
3137 && sym->attr.flavor == FL_PROCEDURE
3138 && sym->attr.contained)
3141 if (csym->attr.generic)
3142 c->symtree->n.sym = sym;
3145 csym = c->symtree->n.sym;
3149 /* If this ia a deferred TBP with an abstract interface
3150 (which may of course be referenced), c->expr1 will be set. */
3151 if (csym && csym->attr.abstract && !c->expr1)
3153 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3154 csym->name, &c->loc);
3158 /* Subroutines without the RECURSIVE attribution are not allowed to
3159 * call themselves. */
3160 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3162 if (csym->attr.entry && csym->ns->entries)
3163 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3164 " subroutine '%s' is not RECURSIVE",
3165 csym->name, &c->loc, csym->ns->entries->sym->name);
3167 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3168 " is not RECURSIVE", csym->name, &c->loc);
3173 /* Switch off assumed size checking and do this again for certain kinds
3174 of procedure, once the procedure itself is resolved. */
3175 need_full_assumed_size++;
3178 ptype = csym->attr.proc;
3180 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3181 if (resolve_actual_arglist (c->ext.actual, ptype,
3182 no_formal_args) == FAILURE)
3185 /* Resume assumed_size checking. */
3186 need_full_assumed_size--;
3188 /* If external, check for usage. */
3189 if (csym && is_external_proc (csym))
3190 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3193 if (c->resolved_sym == NULL)
3195 c->resolved_isym = NULL;
3196 switch (procedure_kind (csym))
3199 t = resolve_generic_s (c);
3202 case PTYPE_SPECIFIC:
3203 t = resolve_specific_s (c);
3207 t = resolve_unknown_s (c);
3211 gfc_internal_error ("resolve_subroutine(): bad function type");
3215 /* Some checks of elemental subroutine actual arguments. */
3216 if (resolve_elemental_actual (NULL, c) == FAILURE)
3219 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
3220 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3225 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3226 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3227 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3228 if their shapes do not match. If either op1->shape or op2->shape is
3229 NULL, return SUCCESS. */
3232 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3239 if (op1->shape != NULL && op2->shape != NULL)
3241 for (i = 0; i < op1->rank; i++)
3243 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3245 gfc_error ("Shapes for operands at %L and %L are not conformable",
3246 &op1->where, &op2->where);
3257 /* Resolve an operator expression node. This can involve replacing the
3258 operation with a user defined function call. */
3261 resolve_operator (gfc_expr *e)
3263 gfc_expr *op1, *op2;
3265 bool dual_locus_error;
3268 /* Resolve all subnodes-- give them types. */
3270 switch (e->value.op.op)
3273 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3276 /* Fall through... */
3279 case INTRINSIC_UPLUS:
3280 case INTRINSIC_UMINUS:
3281 case INTRINSIC_PARENTHESES:
3282 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3287 /* Typecheck the new node. */
3289 op1 = e->value.op.op1;
3290 op2 = e->value.op.op2;
3291 dual_locus_error = false;
3293 if ((op1 && op1->expr_type == EXPR_NULL)
3294 || (op2 && op2->expr_type == EXPR_NULL))
3296 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3300 switch (e->value.op.op)
3302 case INTRINSIC_UPLUS:
3303 case INTRINSIC_UMINUS:
3304 if (op1->ts.type == BT_INTEGER
3305 || op1->ts.type == BT_REAL
3306 || op1->ts.type == BT_COMPLEX)
3312 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3313 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3316 case INTRINSIC_PLUS:
3317 case INTRINSIC_MINUS:
3318 case INTRINSIC_TIMES:
3319 case INTRINSIC_DIVIDE:
3320 case INTRINSIC_POWER:
3321 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3323 gfc_type_convert_binary (e);
3328 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3329 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3330 gfc_typename (&op2->ts));
3333 case INTRINSIC_CONCAT:
3334 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3335 && op1->ts.kind == op2->ts.kind)
3337 e->ts.type = BT_CHARACTER;
3338 e->ts.kind = op1->ts.kind;
3343 _("Operands of string concatenation operator at %%L are %s/%s"),
3344 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3350 case INTRINSIC_NEQV:
3351 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3353 e->ts.type = BT_LOGICAL;
3354 e->ts.kind = gfc_kind_max (op1, op2);
3355 if (op1->ts.kind < e->ts.kind)
3356 gfc_convert_type (op1, &e->ts, 2);
3357 else if (op2->ts.kind < e->ts.kind)
3358 gfc_convert_type (op2, &e->ts, 2);
3362 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3363 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3364 gfc_typename (&op2->ts));
3369 if (op1->ts.type == BT_LOGICAL)
3371 e->ts.type = BT_LOGICAL;
3372 e->ts.kind = op1->ts.kind;
3376 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3377 gfc_typename (&op1->ts));
3381 case INTRINSIC_GT_OS:
3383 case INTRINSIC_GE_OS:
3385 case INTRINSIC_LT_OS:
3387 case INTRINSIC_LE_OS:
3388 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3390 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3394 /* Fall through... */
3397 case INTRINSIC_EQ_OS:
3399 case INTRINSIC_NE_OS:
3400 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3401 && op1->ts.kind == op2->ts.kind)
3403 e->ts.type = BT_LOGICAL;
3404 e->ts.kind = gfc_default_logical_kind;
3408 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3410 gfc_type_convert_binary (e);
3412 e->ts.type = BT_LOGICAL;
3413 e->ts.kind = gfc_default_logical_kind;
3417 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3419 _("Logicals at %%L must be compared with %s instead of %s"),
3420 (e->value.op.op == INTRINSIC_EQ
3421 || e->value.op.op == INTRINSIC_EQ_OS)
3422 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3425 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3426 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3427 gfc_typename (&op2->ts));
3431 case INTRINSIC_USER:
3432 if (e->value.op.uop->op == NULL)
3433 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3434 else if (op2 == NULL)
3435 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3436 e->value.op.uop->name, gfc_typename (&op1->ts));
3438 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3439 e->value.op.uop->name, gfc_typename (&op1->ts),
3440 gfc_typename (&op2->ts));
3444 case INTRINSIC_PARENTHESES:
3446 if (e->ts.type == BT_CHARACTER)
3447 e->ts.u.cl = op1->ts.u.cl;
3451 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3454 /* Deal with arrayness of an operand through an operator. */
3458 switch (e->value.op.op)
3460 case INTRINSIC_PLUS:
3461 case INTRINSIC_MINUS:
3462 case INTRINSIC_TIMES:
3463 case INTRINSIC_DIVIDE:
3464 case INTRINSIC_POWER:
3465 case INTRINSIC_CONCAT:
3469 case INTRINSIC_NEQV:
3471 case INTRINSIC_EQ_OS:
3473 case INTRINSIC_NE_OS:
3475 case INTRINSIC_GT_OS:
3477 case INTRINSIC_GE_OS:
3479 case INTRINSIC_LT_OS:
3481 case INTRINSIC_LE_OS:
3483 if (op1->rank == 0 && op2->rank == 0)
3486 if (op1->rank == 0 && op2->rank != 0)
3488 e->rank = op2->rank;
3490 if (e->shape == NULL)
3491 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3494 if (op1->rank != 0 && op2->rank == 0)
3496 e->rank = op1->rank;
3498 if (e->shape == NULL)
3499 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3502 if (op1->rank != 0 && op2->rank != 0)
3504 if (op1->rank == op2->rank)
3506 e->rank = op1->rank;
3507 if (e->shape == NULL)
3509 t = compare_shapes(op1, op2);
3513 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3518 /* Allow higher level expressions to work. */
3521 /* Try user-defined operators, and otherwise throw an error. */
3522 dual_locus_error = true;
3524 _("Inconsistent ranks for operator at %%L and %%L"));
3531 case INTRINSIC_PARENTHESES:
3533 case INTRINSIC_UPLUS:
3534 case INTRINSIC_UMINUS:
3535 /* Simply copy arrayness attribute */
3536 e->rank = op1->rank;
3538 if (e->shape == NULL)
3539 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3547 /* Attempt to simplify the expression. */
3550 t = gfc_simplify_expr (e, 0);
3551 /* Some calls do not succeed in simplification and return FAILURE
3552 even though there is no error; e.g. variable references to
3553 PARAMETER arrays. */
3554 if (!gfc_is_constant_expr (e))
3563 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3570 if (dual_locus_error)
3571 gfc_error (msg, &op1->where, &op2->where);
3573 gfc_error (msg, &e->where);
3579 /************** Array resolution subroutines **************/
3582 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3585 /* Compare two integer expressions. */
3588 compare_bound (gfc_expr *a, gfc_expr *b)
3592 if (a == NULL || a->expr_type != EXPR_CONSTANT
3593 || b == NULL || b->expr_type != EXPR_CONSTANT)
3596 /* If either of the types isn't INTEGER, we must have
3597 raised an error earlier. */
3599 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3602 i = mpz_cmp (a->value.integer, b->value.integer);
3612 /* Compare an integer expression with an integer. */
3615 compare_bound_int (gfc_expr *a, int b)
3619 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3622 if (a->ts.type != BT_INTEGER)
3623 gfc_internal_error ("compare_bound_int(): Bad expression");
3625 i = mpz_cmp_si (a->value.integer, b);
3635 /* Compare an integer expression with a mpz_t. */
3638 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3642 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3645 if (a->ts.type != BT_INTEGER)
3646 gfc_internal_error ("compare_bound_int(): Bad expression");
3648 i = mpz_cmp (a->value.integer, b);
3658 /* Compute the last value of a sequence given by a triplet.
3659 Return 0 if it wasn't able to compute the last value, or if the
3660 sequence if empty, and 1 otherwise. */
3663 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3664 gfc_expr *stride, mpz_t last)
3668 if (start == NULL || start->expr_type != EXPR_CONSTANT
3669 || end == NULL || end->expr_type != EXPR_CONSTANT
3670 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3673 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3674 || (stride != NULL && stride->ts.type != BT_INTEGER))
3677 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3679 if (compare_bound (start, end) == CMP_GT)
3681 mpz_set (last, end->value.integer);
3685 if (compare_bound_int (stride, 0) == CMP_GT)
3687 /* Stride is positive */
3688 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3693 /* Stride is negative */
3694 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3699 mpz_sub (rem, end->value.integer, start->value.integer);
3700 mpz_tdiv_r (rem, rem, stride->value.integer);
3701 mpz_sub (last, end->value.integer, rem);
3708 /* Compare a single dimension of an array reference to the array
3712 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3716 /* Given start, end and stride values, calculate the minimum and
3717 maximum referenced indexes. */
3719 switch (ar->dimen_type[i])
3725 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3727 gfc_warning ("Array reference at %L is out of bounds "
3728 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3729 mpz_get_si (ar->start[i]->value.integer),
3730 mpz_get_si (as->lower[i]->value.integer), i+1);
3733 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3735 gfc_warning ("Array reference at %L is out of bounds "
3736 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3737 mpz_get_si (ar->start[i]->value.integer),
3738 mpz_get_si (as->upper[i]->value.integer), i+1);
3746 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3747 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3749 comparison comp_start_end = compare_bound (AR_START, AR_END);
3751 /* Check for zero stride, which is not allowed. */
3752 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3754 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3758 /* if start == len || (stride > 0 && start < len)
3759 || (stride < 0 && start > len),
3760 then the array section contains at least one element. In this
3761 case, there is an out-of-bounds access if
3762 (start < lower || start > upper). */
3763 if (compare_bound (AR_START, AR_END) == CMP_EQ
3764 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3765 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3766 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3767 && comp_start_end == CMP_GT))
3769 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3771 gfc_warning ("Lower array reference at %L is out of bounds "
3772 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3773 mpz_get_si (AR_START->value.integer),
3774 mpz_get_si (as->lower[i]->value.integer), i+1);
3777 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3779 gfc_warning ("Lower array reference at %L is out of bounds "
3780 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3781 mpz_get_si (AR_START->value.integer),
3782 mpz_get_si (as->upper[i]->value.integer), i+1);
3787 /* If we can compute the highest index of the array section,
3788 then it also has to be between lower and upper. */
3789 mpz_init (last_value);
3790 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3793 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3795 gfc_warning ("Upper array reference at %L is out of bounds "
3796 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3797 mpz_get_si (last_value),
3798 mpz_get_si (as->lower[i]->value.integer), i+1);
3799 mpz_clear (last_value);
3802 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3804 gfc_warning ("Upper array reference at %L is out of bounds "
3805 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3806 mpz_get_si (last_value),
3807 mpz_get_si (as->upper[i]->value.integer), i+1);
3808 mpz_clear (last_value);
3812 mpz_clear (last_value);
3820 gfc_internal_error ("check_dimension(): Bad array reference");
3827 /* Compare an array reference with an array specification. */
3830 compare_spec_to_ref (gfc_array_ref *ar)
3837 /* TODO: Full array sections are only allowed as actual parameters. */
3838 if (as->type == AS_ASSUMED_SIZE
3839 && (/*ar->type == AR_FULL
3840 ||*/ (ar->type == AR_SECTION
3841 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3843 gfc_error ("Rightmost upper bound of assumed size array section "
3844 "not specified at %L", &ar->where);
3848 if (ar->type == AR_FULL)
3851 if (as->rank != ar->dimen)
3853 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3854 &ar->where, ar->dimen, as->rank);
3858 for (i = 0; i < as->rank; i++)
3859 if (check_dimension (i, ar, as) == FAILURE)
3866 /* Resolve one part of an array index. */
3869 gfc_resolve_index (gfc_expr *index, int check_scalar)
3876 if (gfc_resolve_expr (index) == FAILURE)
3879 if (check_scalar && index->rank != 0)
3881 gfc_error ("Array index at %L must be scalar", &index->where);
3885 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3887 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3888 &index->where, gfc_basic_typename (index->ts.type));
3892 if (index->ts.type == BT_REAL)
3893 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3894 &index->where) == FAILURE)
3897 if (index->ts.kind != gfc_index_integer_kind
3898 || index->ts.type != BT_INTEGER)
3901 ts.type = BT_INTEGER;
3902 ts.kind = gfc_index_integer_kind;
3904 gfc_convert_type_warn (index, &ts, 2, 0);
3910 /* Resolve a dim argument to an intrinsic function. */
3913 gfc_resolve_dim_arg (gfc_expr *dim)
3918 if (gfc_resolve_expr (dim) == FAILURE)
3923 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3928 if (dim->ts.type != BT_INTEGER)
3930 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3934 if (dim->ts.kind != gfc_index_integer_kind)
3938 ts.type = BT_INTEGER;
3939 ts.kind = gfc_index_integer_kind;
3941 gfc_convert_type_warn (dim, &ts, 2, 0);
3947 /* Given an expression that contains array references, update those array
3948 references to point to the right array specifications. While this is
3949 filled in during matching, this information is difficult to save and load
3950 in a module, so we take care of it here.
3952 The idea here is that the original array reference comes from the
3953 base symbol. We traverse the list of reference structures, setting
3954 the stored reference to references. Component references can
3955 provide an additional array specification. */
3958 find_array_spec (gfc_expr *e)
3962 gfc_symbol *derived;
3965 if (e->symtree->n.sym->ts.type == BT_CLASS)
3966 as = e->symtree->n.sym->ts.u.derived->components->as;
3968 as = e->symtree->n.sym->as;
3971 for (ref = e->ref; ref; ref = ref->next)
3976 gfc_internal_error ("find_array_spec(): Missing spec");
3983 if (derived == NULL)
3984 derived = e->symtree->n.sym->ts.u.derived;
3986 c = derived->components;
3988 for (; c; c = c->next)
3989 if (c == ref->u.c.component)
3991 /* Track the sequence of component references. */
3992 if (c->ts.type == BT_DERIVED)
3993 derived = c->ts.u.derived;
3998 gfc_internal_error ("find_array_spec(): Component not found");
4000 if (c->attr.dimension)
4003 gfc_internal_error ("find_array_spec(): unused as(1)");
4014 gfc_internal_error ("find_array_spec(): unused as(2)");
4018 /* Resolve an array reference. */
4021 resolve_array_ref (gfc_array_ref *ar)
4023 int i, check_scalar;
4026 for (i = 0; i < ar->dimen; i++)
4028 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4030 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
4032 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4034 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4039 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4043 ar->dimen_type[i] = DIMEN_ELEMENT;
4047 ar->dimen_type[i] = DIMEN_VECTOR;
4048 if (e->expr_type == EXPR_VARIABLE
4049 && e->symtree->n.sym->ts.type == BT_DERIVED)
4050 ar->start[i] = gfc_get_parentheses (e);
4054 gfc_error ("Array index at %L is an array of rank %d",
4055 &ar->c_where[i], e->rank);
4060 /* If the reference type is unknown, figure out what kind it is. */
4062 if (ar->type == AR_UNKNOWN)
4064 ar->type = AR_ELEMENT;
4065 for (i = 0; i < ar->dimen; i++)
4066 if (ar->dimen_type[i] == DIMEN_RANGE
4067 || ar->dimen_type[i] == DIMEN_VECTOR)
4069 ar->type = AR_SECTION;
4074 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4082 resolve_substring (gfc_ref *ref)
4084 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4086 if (ref->u.ss.start != NULL)
4088 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4091 if (ref->u.ss.start->ts.type != BT_INTEGER)
4093 gfc_error ("Substring start index at %L must be of type INTEGER",
4094 &ref->u.ss.start->where);
4098 if (ref->u.ss.start->rank != 0)
4100 gfc_error ("Substring start index at %L must be scalar",
4101 &ref->u.ss.start->where);
4105 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4106 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4107 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4109 gfc_error ("Substring start index at %L is less than one",
4110 &ref->u.ss.start->where);
4115 if (ref->u.ss.end != NULL)
4117 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4120 if (ref->u.ss.end->ts.type != BT_INTEGER)
4122 gfc_error ("Substring end index at %L must be of type INTEGER",
4123 &ref->u.ss.end->where);
4127 if (ref->u.ss.end->rank != 0)
4129 gfc_error ("Substring end index at %L must be scalar",
4130 &ref->u.ss.end->where);
4134 if (ref->u.ss.length != NULL
4135 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4136 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4137 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4139 gfc_error ("Substring end index at %L exceeds the string length",
4140 &ref->u.ss.start->where);
4144 if (compare_bound_mpz_t (ref->u.ss.end,
4145 gfc_integer_kinds[k].huge) == CMP_GT
4146 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4147 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4149 gfc_error ("Substring end index at %L is too large",
4150 &ref->u.ss.end->where);
4159 /* This function supplies missing substring charlens. */
4162 gfc_resolve_substring_charlen (gfc_expr *e)
4165 gfc_expr *start, *end;
4167 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4168 if (char_ref->type == REF_SUBSTRING)
4174 gcc_assert (char_ref->next == NULL);
4178 if (e->ts.u.cl->length)
4179 gfc_free_expr (e->ts.u.cl->length);
4180 else if (e->expr_type == EXPR_VARIABLE
4181 && e->symtree->n.sym->attr.dummy)
4185 e->ts.type = BT_CHARACTER;
4186 e->ts.kind = gfc_default_character_kind;
4189 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4191 if (char_ref->u.ss.start)
4192 start = gfc_copy_expr (char_ref->u.ss.start);
4194 start = gfc_int_expr (1);
4196 if (char_ref->u.ss.end)
4197 end = gfc_copy_expr (char_ref->u.ss.end);
4198 else if (e->expr_type == EXPR_VARIABLE)
4199 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4206 /* Length = (end - start +1). */
4207 e->ts.u.cl->length = gfc_subtract (end, start);
4208 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1));
4210 e->ts.u.cl->length->ts.type = BT_INTEGER;
4211 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4213 /* Make sure that the length is simplified. */
4214 gfc_simplify_expr (e->ts.u.cl->length, 1);
4215 gfc_resolve_expr (e->ts.u.cl->length);
4219 /* Resolve subtype references. */
4222 resolve_ref (gfc_expr *expr)
4224 int current_part_dimension, n_components, seen_part_dimension;
4227 for (ref = expr->ref; ref; ref = ref->next)
4228 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4230 find_array_spec (expr);
4234 for (ref = expr->ref; ref; ref = ref->next)
4238 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4246 resolve_substring (ref);
4250 /* Check constraints on part references. */
4252 current_part_dimension = 0;
4253 seen_part_dimension = 0;
4256 for (ref = expr->ref; ref; ref = ref->next)
4261 switch (ref->u.ar.type)
4265 current_part_dimension = 1;
4269 current_part_dimension = 0;
4273 gfc_internal_error ("resolve_ref(): Bad array reference");
4279 if (current_part_dimension || seen_part_dimension)
4282 if (ref->u.c.component->attr.pointer
4283 || ref->u.c.component->attr.proc_pointer)
4285 gfc_error ("Component to the right of a part reference "
4286 "with nonzero rank must not have the POINTER "
4287 "attribute at %L", &expr->where);
4290 else if (ref->u.c.component->attr.allocatable)
4292 gfc_error ("Component to the right of a part reference "
4293 "with nonzero rank must not have the ALLOCATABLE "
4294 "attribute at %L", &expr->where);
4306 if (((ref->type == REF_COMPONENT && n_components > 1)
4307 || ref->next == NULL)
4308 && current_part_dimension
4309 && seen_part_dimension)
4311 gfc_error ("Two or more part references with nonzero rank must "
4312 "not be specified at %L", &expr->where);
4316 if (ref->type == REF_COMPONENT)
4318 if (current_part_dimension)
4319 seen_part_dimension = 1;
4321 /* reset to make sure */
4322 current_part_dimension = 0;
4330 /* Given an expression, determine its shape. This is easier than it sounds.
4331 Leaves the shape array NULL if it is not possible to determine the shape. */
4334 expression_shape (gfc_expr *e)
4336 mpz_t array[GFC_MAX_DIMENSIONS];
4339 if (e->rank == 0 || e->shape != NULL)
4342 for (i = 0; i < e->rank; i++)
4343 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4346 e->shape = gfc_get_shape (e->rank);
4348 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4353 for (i--; i >= 0; i--)
4354 mpz_clear (array[i]);
4358 /* Given a variable expression node, compute the rank of the expression by
4359 examining the base symbol and any reference structures it may have. */
4362 expression_rank (gfc_expr *e)
4367 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4368 could lead to serious confusion... */
4369 gcc_assert (e->expr_type != EXPR_COMPCALL);
4373 if (e->expr_type == EXPR_ARRAY)
4375 /* Constructors can have a rank different from one via RESHAPE(). */
4377 if (e->symtree == NULL)
4383 e->rank = (e->symtree->n.sym->as == NULL)
4384 ? 0 : e->symtree->n.sym->as->rank;
4390 for (ref = e->ref; ref; ref = ref->next)
4392 if (ref->type != REF_ARRAY)
4395 if (ref->u.ar.type == AR_FULL)
4397 rank = ref->u.ar.as->rank;
4401 if (ref->u.ar.type == AR_SECTION)
4403 /* Figure out the rank of the section. */
4405 gfc_internal_error ("expression_rank(): Two array specs");
4407 for (i = 0; i < ref->u.ar.dimen; i++)
4408 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4409 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4419 expression_shape (e);
4423 /* Resolve a variable expression. */
4426 resolve_variable (gfc_expr *e)
4433 if (e->symtree == NULL)
4436 if (e->ref && resolve_ref (e) == FAILURE)
4439 sym = e->symtree->n.sym;
4440 if (sym->attr.flavor == FL_PROCEDURE
4441 && (!sym->attr.function
4442 || (sym->attr.function && sym->result
4443 && sym->result->attr.proc_pointer
4444 && !sym->result->attr.function)))
4446 e->ts.type = BT_PROCEDURE;
4447 goto resolve_procedure;
4450 if (sym->ts.type != BT_UNKNOWN)
4451 gfc_variable_attr (e, &e->ts);
4454 /* Must be a simple variable reference. */
4455 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4460 if (check_assumed_size_reference (sym, e))
4463 /* Deal with forward references to entries during resolve_code, to
4464 satisfy, at least partially, 12.5.2.5. */
4465 if (gfc_current_ns->entries
4466 && current_entry_id == sym->entry_id
4469 && cs_base->current->op != EXEC_ENTRY)
4471 gfc_entry_list *entry;
4472 gfc_formal_arglist *formal;
4476 /* If the symbol is a dummy... */
4477 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4479 entry = gfc_current_ns->entries;
4482 /* ...test if the symbol is a parameter of previous entries. */
4483 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4484 for (formal = entry->sym->formal; formal; formal = formal->next)
4486 if (formal->sym && sym->name == formal->sym->name)
4490 /* If it has not been seen as a dummy, this is an error. */
4493 if (specification_expr)
4494 gfc_error ("Variable '%s', used in a specification expression"
4495 ", is referenced at %L before the ENTRY statement "
4496 "in which it is a parameter",
4497 sym->name, &cs_base->current->loc);
4499 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4500 "statement in which it is a parameter",
4501 sym->name, &cs_base->current->loc);
4506 /* Now do the same check on the specification expressions. */
4507 specification_expr = 1;
4508 if (sym->ts.type == BT_CHARACTER
4509 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4513 for (n = 0; n < sym->as->rank; n++)
4515 specification_expr = 1;
4516 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4518 specification_expr = 1;
4519 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4522 specification_expr = 0;
4525 /* Update the symbol's entry level. */
4526 sym->entry_id = current_entry_id + 1;
4530 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
4537 /* Checks to see that the correct symbol has been host associated.
4538 The only situation where this arises is that in which a twice
4539 contained function is parsed after the host association is made.
4540 Therefore, on detecting this, change the symbol in the expression
4541 and convert the array reference into an actual arglist if the old
4542 symbol is a variable. */
4544 check_host_association (gfc_expr *e)
4546 gfc_symbol *sym, *old_sym;
4550 gfc_actual_arglist *arg, *tail = NULL;
4551 bool retval = e->expr_type == EXPR_FUNCTION;
4553 /* If the expression is the result of substitution in
4554 interface.c(gfc_extend_expr) because there is no way in
4555 which the host association can be wrong. */
4556 if (e->symtree == NULL
4557 || e->symtree->n.sym == NULL
4558 || e->user_operator)
4561 old_sym = e->symtree->n.sym;
4563 if (gfc_current_ns->parent
4564 && old_sym->ns != gfc_current_ns)
4566 /* Use the 'USE' name so that renamed module symbols are
4567 correctly handled. */
4568 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
4570 if (sym && old_sym != sym
4571 && sym->ts.type == old_sym->ts.type
4572 && sym->attr.flavor == FL_PROCEDURE
4573 && sym->attr.contained)
4575 /* Clear the shape, since it might not be valid. */
4576 if (e->shape != NULL)
4578 for (n = 0; n < e->rank; n++)
4579 mpz_clear (e->shape[n]);
4581 gfc_free (e->shape);
4584 /* Give the expression the right symtree! */
4585 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
4586 gcc_assert (st != NULL);
4588 if (old_sym->attr.flavor == FL_PROCEDURE
4589 || e->expr_type == EXPR_FUNCTION)
4591 /* Original was function so point to the new symbol, since
4592 the actual argument list is already attached to the
4594 e->value.function.esym = NULL;
4599 /* Original was variable so convert array references into
4600 an actual arglist. This does not need any checking now
4601 since gfc_resolve_function will take care of it. */
4602 e->value.function.actual = NULL;
4603 e->expr_type = EXPR_FUNCTION;
4606 /* Ambiguity will not arise if the array reference is not
4607 the last reference. */
4608 for (ref = e->ref; ref; ref = ref->next)
4609 if (ref->type == REF_ARRAY && ref->next == NULL)
4612 gcc_assert (ref->type == REF_ARRAY);
4614 /* Grab the start expressions from the array ref and
4615 copy them into actual arguments. */
4616 for (n = 0; n < ref->u.ar.dimen; n++)
4618 arg = gfc_get_actual_arglist ();
4619 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
4620 if (e->value.function.actual == NULL)
4621 tail = e->value.function.actual = arg;
4629 /* Dump the reference list and set the rank. */
4630 gfc_free_ref_list (e->ref);
4632 e->rank = sym->as ? sym->as->rank : 0;
4635 gfc_resolve_expr (e);
4639 /* This might have changed! */
4640 return e->expr_type == EXPR_FUNCTION;
4645 gfc_resolve_character_operator (gfc_expr *e)
4647 gfc_expr *op1 = e->value.op.op1;
4648 gfc_expr *op2 = e->value.op.op2;
4649 gfc_expr *e1 = NULL;
4650 gfc_expr *e2 = NULL;
4652 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
4654 if (op1->ts.u.cl && op1->ts.u.cl->length)
4655 e1 = gfc_copy_expr (op1->ts.u.cl->length);
4656 else if (op1->expr_type == EXPR_CONSTANT)
4657 e1 = gfc_int_expr (op1->value.character.length);
4659 if (op2->ts.u.cl && op2->ts.u.cl->length)
4660 e2 = gfc_copy_expr (op2->ts.u.cl->length);
4661 else if (op2->expr_type == EXPR_CONSTANT)
4662 e2 = gfc_int_expr (op2->value.character.length);
4664 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4669 e->ts.u.cl->length = gfc_add (e1, e2);
4670 e->ts.u.cl->length->ts.type = BT_INTEGER;
4671 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4672 gfc_simplify_expr (e->ts.u.cl->length, 0);
4673 gfc_resolve_expr (e->ts.u.cl->length);
4679 /* Ensure that an character expression has a charlen and, if possible, a
4680 length expression. */
4683 fixup_charlen (gfc_expr *e)
4685 /* The cases fall through so that changes in expression type and the need
4686 for multiple fixes are picked up. In all circumstances, a charlen should
4687 be available for the middle end to hang a backend_decl on. */
4688 switch (e->expr_type)
4691 gfc_resolve_character_operator (e);
4694 if (e->expr_type == EXPR_ARRAY)
4695 gfc_resolve_character_array_constructor (e);
4697 case EXPR_SUBSTRING:
4698 if (!e->ts.u.cl && e->ref)
4699 gfc_resolve_substring_charlen (e);
4703 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4710 /* Update an actual argument to include the passed-object for type-bound
4711 procedures at the right position. */
4713 static gfc_actual_arglist*
4714 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
4717 gcc_assert (argpos > 0);
4721 gfc_actual_arglist* result;
4723 result = gfc_get_actual_arglist ();
4727 result->name = name;
4733 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
4735 lst = update_arglist_pass (NULL, po, argpos - 1, name);
4740 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4743 extract_compcall_passed_object (gfc_expr* e)
4747 gcc_assert (e->expr_type == EXPR_COMPCALL);
4749 if (e->value.compcall.base_object)
4750 po = gfc_copy_expr (e->value.compcall.base_object);
4753 po = gfc_get_expr ();
4754 po->expr_type = EXPR_VARIABLE;
4755 po->symtree = e->symtree;
4756 po->ref = gfc_copy_ref (e->ref);
4759 if (gfc_resolve_expr (po) == FAILURE)
4766 /* Update the arglist of an EXPR_COMPCALL expression to include the
4770 update_compcall_arglist (gfc_expr* e)
4773 gfc_typebound_proc* tbp;
4775 tbp = e->value.compcall.tbp;
4780 po = extract_compcall_passed_object (e);
4786 gfc_error ("Passed-object at %L must be scalar", &e->where);
4790 if (tbp->nopass || e->value.compcall.ignore_pass)
4796 gcc_assert (tbp->pass_arg_num > 0);
4797 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4805 /* Extract the passed object from a PPC call (a copy of it). */
4808 extract_ppc_passed_object (gfc_expr *e)
4813 po = gfc_get_expr ();
4814 po->expr_type = EXPR_VARIABLE;
4815 po->symtree = e->symtree;
4816 po->ref = gfc_copy_ref (e->ref);
4818 /* Remove PPC reference. */
4820 while ((*ref)->next)
4821 (*ref) = (*ref)->next;
4822 gfc_free_ref_list (*ref);
4825 if (gfc_resolve_expr (po) == FAILURE)
4832 /* Update the actual arglist of a procedure pointer component to include the
4836 update_ppc_arglist (gfc_expr* e)
4840 gfc_typebound_proc* tb;
4842 if (!gfc_is_proc_ptr_comp (e, &ppc))
4849 else if (tb->nopass)
4852 po = extract_ppc_passed_object (e);
4858 gfc_error ("Passed-object at %L must be scalar", &e->where);
4862 gcc_assert (tb->pass_arg_num > 0);
4863 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4871 /* Check that the object a TBP is called on is valid, i.e. it must not be
4872 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
4875 check_typebound_baseobject (gfc_expr* e)
4879 base = extract_compcall_passed_object (e);
4883 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
4885 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
4887 gfc_error ("Base object for type-bound procedure call at %L is of"
4888 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
4896 /* Resolve a call to a type-bound procedure, either function or subroutine,
4897 statically from the data in an EXPR_COMPCALL expression. The adapted
4898 arglist and the target-procedure symtree are returned. */
4901 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
4902 gfc_actual_arglist** actual)
4904 gcc_assert (e->expr_type == EXPR_COMPCALL);
4905 gcc_assert (!e->value.compcall.tbp->is_generic);
4907 /* Update the actual arglist for PASS. */
4908 if (update_compcall_arglist (e) == FAILURE)
4911 *actual = e->value.compcall.actual;
4912 *target = e->value.compcall.tbp->u.specific;
4914 gfc_free_ref_list (e->ref);
4916 e->value.compcall.actual = NULL;
4922 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4923 which of the specific bindings (if any) matches the arglist and transform
4924 the expression into a call of that binding. */
4927 resolve_typebound_generic_call (gfc_expr* e)
4929 gfc_typebound_proc* genproc;
4930 const char* genname;
4932 gcc_assert (e->expr_type == EXPR_COMPCALL);
4933 genname = e->value.compcall.name;
4934 genproc = e->value.compcall.tbp;
4936 if (!genproc->is_generic)
4939 /* Try the bindings on this type and in the inheritance hierarchy. */
4940 for (; genproc; genproc = genproc->overridden)
4944 gcc_assert (genproc->is_generic);
4945 for (g = genproc->u.generic; g; g = g->next)
4948 gfc_actual_arglist* args;
4951 gcc_assert (g->specific);
4953 if (g->specific->error)
4956 target = g->specific->u.specific->n.sym;
4958 /* Get the right arglist by handling PASS/NOPASS. */
4959 args = gfc_copy_actual_arglist (e->value.compcall.actual);
4960 if (!g->specific->nopass)
4963 po = extract_compcall_passed_object (e);
4967 gcc_assert (g->specific->pass_arg_num > 0);
4968 gcc_assert (!g->specific->error);
4969 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
4970 g->specific->pass_arg);
4972 resolve_actual_arglist (args, target->attr.proc,
4973 is_external_proc (target) && !target->formal);
4975 /* Check if this arglist matches the formal. */
4976 matches = gfc_arglist_matches_symbol (&args, target);
4978 /* Clean up and break out of the loop if we've found it. */
4979 gfc_free_actual_arglist (args);
4982 e->value.compcall.tbp = g->specific;
4988 /* Nothing matching found! */
4989 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4990 " '%s' at %L", genname, &e->where);
4998 /* Resolve a call to a type-bound subroutine. */
5001 resolve_typebound_call (gfc_code* c)
5003 gfc_actual_arglist* newactual;
5004 gfc_symtree* target;
5006 /* Check that's really a SUBROUTINE. */
5007 if (!c->expr1->value.compcall.tbp->subroutine)
5009 gfc_error ("'%s' at %L should be a SUBROUTINE",
5010 c->expr1->value.compcall.name, &c->loc);
5014 if (check_typebound_baseobject (c->expr1) == FAILURE)
5017 if (resolve_typebound_generic_call (c->expr1) == FAILURE)
5020 /* Transform into an ordinary EXEC_CALL for now. */
5022 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5025 c->ext.actual = newactual;
5026 c->symtree = target;
5027 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5029 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5031 gfc_free_expr (c->expr1);
5032 c->expr1 = gfc_get_expr ();
5033 c->expr1->expr_type = EXPR_FUNCTION;
5034 c->expr1->symtree = target;
5035 c->expr1->where = c->loc;
5037 return resolve_call (c);
5041 /* Resolve a component-call expression. This originally was intended
5042 only to see functions. However, it is convenient to use it in
5043 resolving subroutine class methods, since we do not have to add a
5044 gfc_code each time. */
5046 resolve_compcall (gfc_expr* e, bool fcn)
5048 gfc_actual_arglist* newactual;
5049 gfc_symtree* target;
5051 /* Check that's really a FUNCTION. */
5052 if (fcn && !e->value.compcall.tbp->function)
5054 gfc_error ("'%s' at %L should be a FUNCTION",
5055 e->value.compcall.name, &e->where);
5058 else if (!fcn && !e->value.compcall.tbp->subroutine)
5060 /* To resolve class member calls, we borrow this bit
5061 of code to select the specific procedures. */
5062 gfc_error ("'%s' at %L should be a SUBROUTINE",
5063 e->value.compcall.name, &e->where);
5067 /* These must not be assign-calls! */
5068 gcc_assert (!e->value.compcall.assign);
5070 if (check_typebound_baseobject (e) == FAILURE)
5073 if (resolve_typebound_generic_call (e) == FAILURE)
5075 gcc_assert (!e->value.compcall.tbp->is_generic);
5077 /* Take the rank from the function's symbol. */
5078 if (e->value.compcall.tbp->u.specific->n.sym->as)
5079 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5081 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5082 arglist to the TBP's binding target. */
5084 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5087 e->value.function.actual = newactual;
5088 e->value.function.name = e->value.compcall.name;
5089 e->value.function.esym = target->n.sym;
5090 e->value.function.class_esym = NULL;
5091 e->value.function.isym = NULL;
5092 e->symtree = target;
5093 e->ts = target->n.sym->ts;
5094 e->expr_type = EXPR_FUNCTION;
5096 /* Resolution is not necessary if this is a class subroutine; this
5097 function only has to identify the specific proc. Resolution of
5098 the call will be done next in resolve_typebound_call. */
5099 return fcn ? gfc_resolve_expr (e) : SUCCESS;
5103 /* Resolve a typebound call for the members in a class. This group of
5104 functions implements dynamic dispatch in the provisional version
5105 of f03 OOP. As soon as vtables are in place and contain pointers
5106 to methods, this will no longer be necessary. */
5107 static gfc_expr *list_e;
5108 static void check_class_members (gfc_symbol *);
5109 static gfc_try class_try;
5110 static bool fcn_flag;
5111 static gfc_symbol *class_object;
5115 check_members (gfc_symbol *derived)
5117 if (derived->attr.flavor == FL_DERIVED)
5118 check_class_members (derived);
5123 check_class_members (gfc_symbol *derived)
5127 gfc_class_esym_list *etmp;
5129 e = gfc_copy_expr (list_e);
5131 tbp = gfc_find_typebound_proc (derived, &class_try,
5132 e->value.compcall.name,
5137 gfc_error ("no typebound available procedure named '%s' at %L",
5138 e->value.compcall.name, &e->where);
5142 if (tbp->n.tb->is_generic)
5144 /* If we have to match a passed class member, force the actual
5145 expression to have the correct type. */
5146 if (!tbp->n.tb->nopass)
5148 if (e->value.compcall.base_object == NULL)
5149 e->value.compcall.base_object =
5150 extract_compcall_passed_object (e);
5152 e->value.compcall.base_object->ts.type = BT_DERIVED;
5153 e->value.compcall.base_object->ts.u.derived = derived;
5157 e->value.compcall.tbp = tbp->n.tb;
5158 e->value.compcall.name = tbp->name;
5160 /* Let the original expresssion catch the assertion in
5161 resolve_compcall, since this flag does not appear to be reset or
5162 copied in some systems. */
5163 e->value.compcall.assign = 0;
5165 /* Do the renaming, PASSing, generic => specific and other
5166 good things for each class member. */
5167 class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
5168 ? class_try : FAILURE;
5170 /* Now transfer the found symbol to the esym list. */
5171 if (class_try == SUCCESS)
5173 etmp = list_e->value.function.class_esym;
5174 list_e->value.function.class_esym
5175 = gfc_get_class_esym_list();
5176 list_e->value.function.class_esym->next = etmp;
5177 list_e->value.function.class_esym->derived = derived;
5178 list_e->value.function.class_esym->esym
5179 = e->value.function.esym;
5184 /* Burrow down into grandchildren types. */
5185 if (derived->f2k_derived)
5186 gfc_traverse_ns (derived->f2k_derived, check_members);
5190 /* Eliminate esym_lists where all the members point to the
5191 typebound procedure of the declared type; ie. one where
5192 type selection has no effect.. */
5194 resolve_class_esym (gfc_expr *e)
5196 gfc_class_esym_list *p, *q;
5199 gcc_assert (e && e->expr_type == EXPR_FUNCTION);
5201 p = e->value.function.class_esym;
5205 for (; p; p = p->next)
5206 empty = empty && (e->value.function.esym == p->esym);
5210 p = e->value.function.class_esym;
5216 e->value.function.class_esym = NULL;
5221 /* Generate an expression for the hash value, given the reference to
5222 the class of the final expression (class_ref), the base of the
5223 full reference list (new_ref), the declared type and the class
5226 hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
5228 gfc_expr *hash_value;
5230 /* Build an expression for the correct hash_value; ie. that of the last
5234 class_ref->next = NULL;
5238 gfc_free_ref_list (new_ref);
5241 hash_value = gfc_get_expr ();
5242 hash_value->expr_type = EXPR_VARIABLE;
5243 hash_value->symtree = st;
5244 hash_value->symtree->n.sym->refs++;
5245 hash_value->ref = new_ref;
5246 gfc_add_component_ref (hash_value, "$vptr");
5247 gfc_add_component_ref (hash_value, "$hash");
5253 /* Get the ultimate declared type from an expression. In addition,
5254 return the last class/derived type reference and the copy of the
5257 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5260 gfc_symbol *declared;
5265 *new_ref = gfc_copy_ref (e->ref);
5266 for (ref = *new_ref; ref; ref = ref->next)
5268 if (ref->type != REF_COMPONENT)
5271 if (ref->u.c.component->ts.type == BT_CLASS
5272 || ref->u.c.component->ts.type == BT_DERIVED)
5274 declared = ref->u.c.component->ts.u.derived;
5279 if (declared == NULL)
5280 declared = e->symtree->n.sym->ts.u.derived;
5286 /* Resolve the argument expressions so that any arguments expressions
5287 that include class methods are resolved before the current call.
5288 This is necessary because of the static variables used in CLASS
5289 method resolution. */
5291 resolve_arg_exprs (gfc_actual_arglist *arg)
5293 /* Resolve the actual arglist expressions. */
5294 for (; arg; arg = arg->next)
5297 gfc_resolve_expr (arg->expr);
5302 /* Resolve a CLASS typebound function, or 'method'. */
5304 resolve_class_compcall (gfc_expr* e)
5306 gfc_symbol *derived, *declared;
5312 class_object = st->n.sym;
5314 /* Get the CLASS declared type. */
5315 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5317 /* Weed out cases of the ultimate component being a derived type. */
5318 if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5320 gfc_free_ref_list (new_ref);
5321 return resolve_compcall (e, true);
5324 /* Resolve the argument expressions, */
5325 resolve_arg_exprs (e->value.function.actual);
5327 /* Get the data component, which is of the declared type. */
5328 derived = declared->components->ts.u.derived;
5330 /* Resolve the function call for each member of the class. */
5331 class_try = SUCCESS;
5333 list_e = gfc_copy_expr (e);
5334 check_class_members (derived);
5336 class_try = (resolve_compcall (e, true) == SUCCESS)
5337 ? class_try : FAILURE;
5339 /* Transfer the class list to the original expression. Note that
5340 the class_esym list is cleaned up in trans-expr.c, as the calls
5342 e->value.function.class_esym = list_e->value.function.class_esym;
5343 list_e->value.function.class_esym = NULL;
5344 gfc_free_expr (list_e);
5346 resolve_class_esym (e);
5348 /* More than one typebound procedure so transmit an expression for
5349 the hash_value as the selector. */
5350 if (e->value.function.class_esym != NULL)
5351 e->value.function.class_esym->hash_value
5352 = hash_value_expr (class_ref, new_ref, st);
5357 /* Resolve a CLASS typebound subroutine, or 'method'. */
5359 resolve_class_typebound_call (gfc_code *code)
5361 gfc_symbol *derived, *declared;
5366 st = code->expr1->symtree;
5367 class_object = st->n.sym;
5369 /* Get the CLASS declared type. */
5370 declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5372 /* Weed out cases of the ultimate component being a derived type. */
5373 if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5375 gfc_free_ref_list (new_ref);
5376 return resolve_typebound_call (code);
5379 /* Resolve the argument expressions, */
5380 resolve_arg_exprs (code->expr1->value.compcall.actual);
5382 /* Get the data component, which is of the declared type. */
5383 derived = declared->components->ts.u.derived;
5385 class_try = SUCCESS;
5387 list_e = gfc_copy_expr (code->expr1);
5388 check_class_members (derived);
5390 class_try = (resolve_typebound_call (code) == SUCCESS)
5391 ? class_try : FAILURE;
5393 /* Transfer the class list to the original expression. Note that
5394 the class_esym list is cleaned up in trans-expr.c, as the calls
5396 code->expr1->value.function.class_esym
5397 = list_e->value.function.class_esym;
5398 list_e->value.function.class_esym = NULL;
5399 gfc_free_expr (list_e);
5401 resolve_class_esym (code->expr1);
5403 /* More than one typebound procedure so transmit an expression for
5404 the hash_value as the selector. */
5405 if (code->expr1->value.function.class_esym != NULL)
5406 code->expr1->value.function.class_esym->hash_value
5407 = hash_value_expr (class_ref, new_ref, st);
5413 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5416 resolve_ppc_call (gfc_code* c)
5418 gfc_component *comp;
5421 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5424 c->resolved_sym = c->expr1->symtree->n.sym;
5425 c->expr1->expr_type = EXPR_VARIABLE;
5427 if (!comp->attr.subroutine)
5428 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5430 if (resolve_ref (c->expr1) == FAILURE)
5433 if (update_ppc_arglist (c->expr1) == FAILURE)
5436 c->ext.actual = c->expr1->value.compcall.actual;
5438 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5439 comp->formal == NULL) == FAILURE)
5442 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5448 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5451 resolve_expr_ppc (gfc_expr* e)
5453 gfc_component *comp;
5456 b = gfc_is_proc_ptr_comp (e, &comp);
5459 /* Convert to EXPR_FUNCTION. */
5460 e->expr_type = EXPR_FUNCTION;
5461 e->value.function.isym = NULL;
5462 e->value.function.actual = e->value.compcall.actual;
5464 if (comp->as != NULL)
5465 e->rank = comp->as->rank;
5467 if (!comp->attr.function)
5468 gfc_add_function (&comp->attr, comp->name, &e->where);
5470 if (resolve_ref (e) == FAILURE)
5473 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5474 comp->formal == NULL) == FAILURE)
5477 if (update_ppc_arglist (e) == FAILURE)
5480 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5486 /* Resolve an expression. That is, make sure that types of operands agree
5487 with their operators, intrinsic operators are converted to function calls
5488 for overloaded types and unresolved function references are resolved. */
5491 gfc_resolve_expr (gfc_expr *e)
5498 switch (e->expr_type)
5501 t = resolve_operator (e);
5507 if (check_host_association (e))
5508 t = resolve_function (e);
5511 t = resolve_variable (e);
5513 expression_rank (e);
5516 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
5517 && e->ref->type != REF_SUBSTRING)
5518 gfc_resolve_substring_charlen (e);
5523 if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
5524 t = resolve_class_compcall (e);
5526 t = resolve_compcall (e, true);
5529 case EXPR_SUBSTRING:
5530 t = resolve_ref (e);
5539 t = resolve_expr_ppc (e);
5544 if (resolve_ref (e) == FAILURE)
5547 t = gfc_resolve_array_constructor (e);
5548 /* Also try to expand a constructor. */
5551 expression_rank (e);
5552 gfc_expand_constructor (e);
5555 /* This provides the opportunity for the length of constructors with
5556 character valued function elements to propagate the string length
5557 to the expression. */
5558 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
5559 t = gfc_resolve_character_array_constructor (e);
5563 case EXPR_STRUCTURE:
5564 t = resolve_ref (e);
5568 t = resolve_structure_cons (e);
5572 t = gfc_simplify_expr (e, 0);
5576 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
5579 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
5586 /* Resolve an expression from an iterator. They must be scalar and have
5587 INTEGER or (optionally) REAL type. */
5590 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
5591 const char *name_msgid)
5593 if (gfc_resolve_expr (expr) == FAILURE)
5596 if (expr->rank != 0)
5598 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
5602 if (expr->ts.type != BT_INTEGER)
5604 if (expr->ts.type == BT_REAL)
5607 return gfc_notify_std (GFC_STD_F95_DEL,
5608 "Deleted feature: %s at %L must be integer",
5609 _(name_msgid), &expr->where);
5612 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
5619 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
5627 /* Resolve the expressions in an iterator structure. If REAL_OK is
5628 false allow only INTEGER type iterators, otherwise allow REAL types. */
5631 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
5633 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
5637 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
5639 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
5644 if (gfc_resolve_iterator_expr (iter->start, real_ok,
5645 "Start expression in DO loop") == FAILURE)
5648 if (gfc_resolve_iterator_expr (iter->end, real_ok,
5649 "End expression in DO loop") == FAILURE)
5652 if (gfc_resolve_iterator_expr (iter->step, real_ok,
5653 "Step expression in DO loop") == FAILURE)
5656 if (iter->step->expr_type == EXPR_CONSTANT)
5658 if ((iter->step->ts.type == BT_INTEGER
5659 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
5660 || (iter->step->ts.type == BT_REAL
5661 && mpfr_sgn (iter->step->value.real) == 0))
5663 gfc_error ("Step expression in DO loop at %L cannot be zero",
5664 &iter->step->where);
5669 /* Convert start, end, and step to the same type as var. */
5670 if (iter->start->ts.kind != iter->var->ts.kind
5671 || iter->start->ts.type != iter->var->ts.type)
5672 gfc_convert_type (iter->start, &iter->var->ts, 2);
5674 if (iter->end->ts.kind != iter->var->ts.kind
5675 || iter->end->ts.type != iter->var->ts.type)
5676 gfc_convert_type (iter->end, &iter->var->ts, 2);
5678 if (iter->step->ts.kind != iter->var->ts.kind
5679 || iter->step->ts.type != iter->var->ts.type)
5680 gfc_convert_type (iter->step, &iter->var->ts, 2);
5682 if (iter->start->expr_type == EXPR_CONSTANT
5683 && iter->end->expr_type == EXPR_CONSTANT
5684 && iter->step->expr_type == EXPR_CONSTANT)
5687 if (iter->start->ts.type == BT_INTEGER)
5689 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
5690 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
5694 sgn = mpfr_sgn (iter->step->value.real);
5695 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
5697 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
5698 gfc_warning ("DO loop at %L will be executed zero times",
5699 &iter->step->where);
5706 /* Traversal function for find_forall_index. f == 2 signals that
5707 that variable itself is not to be checked - only the references. */
5710 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
5712 if (expr->expr_type != EXPR_VARIABLE)
5715 /* A scalar assignment */
5716 if (!expr->ref || *f == 1)
5718 if (expr->symtree->n.sym == sym)
5730 /* Check whether the FORALL index appears in the expression or not.
5731 Returns SUCCESS if SYM is found in EXPR. */
5734 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
5736 if (gfc_traverse_expr (expr, sym, forall_index, f))
5743 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
5744 to be a scalar INTEGER variable. The subscripts and stride are scalar
5745 INTEGERs, and if stride is a constant it must be nonzero.
5746 Furthermore "A subscript or stride in a forall-triplet-spec shall
5747 not contain a reference to any index-name in the
5748 forall-triplet-spec-list in which it appears." (7.5.4.1) */
5751 resolve_forall_iterators (gfc_forall_iterator *it)
5753 gfc_forall_iterator *iter, *iter2;
5755 for (iter = it; iter; iter = iter->next)
5757 if (gfc_resolve_expr (iter->var) == SUCCESS
5758 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
5759 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
5762 if (gfc_resolve_expr (iter->start) == SUCCESS
5763 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
5764 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
5765 &iter->start->where);
5766 if (iter->var->ts.kind != iter->start->ts.kind)
5767 gfc_convert_type (iter->start, &iter->var->ts, 2);
5769 if (gfc_resolve_expr (iter->end) == SUCCESS
5770 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
5771 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
5773 if (iter->var->ts.kind != iter->end->ts.kind)
5774 gfc_convert_type (iter->end, &iter->var->ts, 2);
5776 if (gfc_resolve_expr (iter->stride) == SUCCESS)
5778 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
5779 gfc_error ("FORALL stride expression at %L must be a scalar %s",
5780 &iter->stride->where, "INTEGER");
5782 if (iter->stride->expr_type == EXPR_CONSTANT
5783 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
5784 gfc_error ("FORALL stride expression at %L cannot be zero",
5785 &iter->stride->where);
5787 if (iter->var->ts.kind != iter->stride->ts.kind)
5788 gfc_convert_type (iter->stride, &iter->var->ts, 2);
5791 for (iter = it; iter; iter = iter->next)
5792 for (iter2 = iter; iter2; iter2 = iter2->next)
5794 if (find_forall_index (iter2->start,
5795 iter->var->symtree->n.sym, 0) == SUCCESS
5796 || find_forall_index (iter2->end,
5797 iter->var->symtree->n.sym, 0) == SUCCESS
5798 || find_forall_index (iter2->stride,
5799 iter->var->symtree->n.sym, 0) == SUCCESS)
5800 gfc_error ("FORALL index '%s' may not appear in triplet "
5801 "specification at %L", iter->var->symtree->name,
5802 &iter2->start->where);
5807 /* Given a pointer to a symbol that is a derived type, see if it's
5808 inaccessible, i.e. if it's defined in another module and the components are
5809 PRIVATE. The search is recursive if necessary. Returns zero if no
5810 inaccessible components are found, nonzero otherwise. */
5813 derived_inaccessible (gfc_symbol *sym)
5817 if (sym->attr.use_assoc && sym->attr.private_comp)
5820 for (c = sym->components; c; c = c->next)
5822 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
5830 /* Resolve the argument of a deallocate expression. The expression must be
5831 a pointer or a full array. */
5834 resolve_deallocate_expr (gfc_expr *e)
5836 symbol_attribute attr;
5837 int allocatable, pointer, check_intent_in;
5842 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5843 check_intent_in = 1;
5845 if (gfc_resolve_expr (e) == FAILURE)
5848 if (e->expr_type != EXPR_VARIABLE)
5851 sym = e->symtree->n.sym;
5853 if (sym->ts.type == BT_CLASS)
5855 allocatable = sym->ts.u.derived->components->attr.allocatable;
5856 pointer = sym->ts.u.derived->components->attr.pointer;
5860 allocatable = sym->attr.allocatable;
5861 pointer = sym->attr.pointer;
5863 for (ref = e->ref; ref; ref = ref->next)
5866 check_intent_in = 0;
5871 if (ref->u.ar.type != AR_FULL)
5876 c = ref->u.c.component;
5877 if (c->ts.type == BT_CLASS)
5879 allocatable = c->ts.u.derived->components->attr.allocatable;
5880 pointer = c->ts.u.derived->components->attr.pointer;
5884 allocatable = c->attr.allocatable;
5885 pointer = c->attr.pointer;
5895 attr = gfc_expr_attr (e);
5897 if (allocatable == 0 && attr.pointer == 0)
5900 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
5904 if (check_intent_in && sym->attr.intent == INTENT_IN)
5906 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5907 sym->name, &e->where);
5911 if (e->ts.type == BT_CLASS)
5913 /* Only deallocate the DATA component. */
5914 gfc_add_component_ref (e, "$data");
5921 /* Returns true if the expression e contains a reference to the symbol sym. */
5923 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5925 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
5932 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
5934 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
5938 /* Given the expression node e for an allocatable/pointer of derived type to be
5939 allocated, get the expression node to be initialized afterwards (needed for
5940 derived types with default initializers, and derived types with allocatable
5941 components that need nullification.) */
5944 gfc_expr_to_initialize (gfc_expr *e)
5950 result = gfc_copy_expr (e);
5952 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5953 for (ref = result->ref; ref; ref = ref->next)
5954 if (ref->type == REF_ARRAY && ref->next == NULL)
5956 ref->u.ar.type = AR_FULL;
5958 for (i = 0; i < ref->u.ar.dimen; i++)
5959 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
5961 result->rank = ref->u.ar.dimen;
5969 /* Used in resolve_allocate_expr to check that a allocation-object and
5970 a source-expr are conformable. This does not catch all possible
5971 cases; in particular a runtime checking is needed. */
5974 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
5976 /* First compare rank. */
5977 if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
5979 gfc_error ("Source-expr at %L must be scalar or have the "
5980 "same rank as the allocate-object at %L",
5981 &e1->where, &e2->where);
5992 for (i = 0; i < e1->rank; i++)
5994 if (e2->ref->u.ar.end[i])
5996 mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
5997 mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
5998 mpz_add_ui (s, s, 1);
6002 mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
6005 if (mpz_cmp (e1->shape[i], s) != 0)
6007 gfc_error ("Source-expr at %L and allocate-object at %L must "
6008 "have the same shape", &e1->where, &e2->where);
6021 /* Resolve the expression in an ALLOCATE statement, doing the additional
6022 checks to see whether the expression is OK or not. The expression must
6023 have a trailing array reference that gives the size of the array. */
6026 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6028 int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
6029 symbol_attribute attr;
6030 gfc_ref *ref, *ref2;
6036 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6037 check_intent_in = 1;
6039 if (gfc_resolve_expr (e) == FAILURE)
6042 /* Make sure the expression is allocatable or a pointer. If it is
6043 pointer, the next-to-last reference must be a pointer. */
6047 sym = e->symtree->n.sym;
6049 /* Check whether ultimate component is abstract and CLASS. */
6052 if (e->expr_type != EXPR_VARIABLE)
6055 attr = gfc_expr_attr (e);
6056 pointer = attr.pointer;
6057 dimension = attr.dimension;
6061 if (sym->ts.type == BT_CLASS)
6063 allocatable = sym->ts.u.derived->components->attr.allocatable;
6064 pointer = sym->ts.u.derived->components->attr.pointer;
6065 dimension = sym->ts.u.derived->components->attr.dimension;
6066 is_abstract = sym->ts.u.derived->components->attr.abstract;
6070 allocatable = sym->attr.allocatable;
6071 pointer = sym->attr.pointer;
6072 dimension = sym->attr.dimension;
6075 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6078 check_intent_in = 0;
6083 if (ref->next != NULL)
6088 c = ref->u.c.component;
6089 if (c->ts.type == BT_CLASS)
6091 allocatable = c->ts.u.derived->components->attr.allocatable;
6092 pointer = c->ts.u.derived->components->attr.pointer;
6093 dimension = c->ts.u.derived->components->attr.dimension;
6094 is_abstract = c->ts.u.derived->components->attr.abstract;
6098 allocatable = c->attr.allocatable;
6099 pointer = c->attr.pointer;
6100 dimension = c->attr.dimension;
6101 is_abstract = c->attr.abstract;
6113 if (allocatable == 0 && pointer == 0)
6115 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6120 /* Some checks for the SOURCE tag. */
6123 /* Check F03:C631. */
6124 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6126 gfc_error ("Type of entity at %L is type incompatible with "
6127 "source-expr at %L", &e->where, &code->expr3->where);
6131 /* Check F03:C632 and restriction following Note 6.18. */
6132 if (code->expr3->rank > 0
6133 && conformable_arrays (code->expr3, e) == FAILURE)
6136 /* Check F03:C633. */
6137 if (code->expr3->ts.kind != e->ts.kind)
6139 gfc_error ("The allocate-object at %L and the source-expr at %L "
6140 "shall have the same kind type parameter",
6141 &e->where, &code->expr3->where);
6145 else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
6147 gcc_assert (e->ts.type == BT_CLASS);
6148 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6149 "type-spec or SOURCE=", sym->name, &e->where);
6153 if (check_intent_in && sym->attr.intent == INTENT_IN)
6155 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
6156 sym->name, &e->where);
6160 if (pointer || dimension == 0)
6163 /* Make sure the next-to-last reference node is an array specification. */
6165 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
6167 gfc_error ("Array specification required in ALLOCATE statement "
6168 "at %L", &e->where);
6172 /* Make sure that the array section reference makes sense in the
6173 context of an ALLOCATE specification. */
6177 for (i = 0; i < ar->dimen; i++)
6179 if (ref2->u.ar.type == AR_ELEMENT)
6182 switch (ar->dimen_type[i])
6188 if (ar->start[i] != NULL
6189 && ar->end[i] != NULL
6190 && ar->stride[i] == NULL)
6193 /* Fall Through... */
6197 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6204 for (a = code->ext.alloc.list; a; a = a->next)
6206 sym = a->expr->symtree->n.sym;
6208 /* TODO - check derived type components. */
6209 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6212 if ((ar->start[i] != NULL
6213 && gfc_find_sym_in_expr (sym, ar->start[i]))
6214 || (ar->end[i] != NULL
6215 && gfc_find_sym_in_expr (sym, ar->end[i])))
6217 gfc_error ("'%s' must not appear in the array specification at "
6218 "%L in the same ALLOCATE statement where it is "
6219 "itself allocated", sym->name, &ar->where);
6229 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6231 gfc_expr *stat, *errmsg, *pe, *qe;
6232 gfc_alloc *a, *p, *q;
6234 stat = code->expr1 ? code->expr1 : NULL;
6236 errmsg = code->expr2 ? code->expr2 : NULL;
6238 /* Check the stat variable. */
6241 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
6242 gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
6243 stat->symtree->n.sym->name, &stat->where);
6245 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
6246 gfc_error ("Illegal stat-variable at %L for a PURE procedure",
6249 if ((stat->ts.type != BT_INTEGER
6250 && !(stat->ref && (stat->ref->type == REF_ARRAY
6251 || stat->ref->type == REF_COMPONENT)))
6253 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6254 "variable", &stat->where);
6256 for (p = code->ext.alloc.list; p; p = p->next)
6257 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6258 gfc_error ("Stat-variable at %L shall not be %sd within "
6259 "the same %s statement", &stat->where, fcn, fcn);
6262 /* Check the errmsg variable. */
6266 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6269 if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
6270 gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
6271 errmsg->symtree->n.sym->name, &errmsg->where);
6273 if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
6274 gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
6277 if ((errmsg->ts.type != BT_CHARACTER
6279 && (errmsg->ref->type == REF_ARRAY
6280 || errmsg->ref->type == REF_COMPONENT)))
6281 || errmsg->rank > 0 )
6282 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6283 "variable", &errmsg->where);
6285 for (p = code->ext.alloc.list; p; p = p->next)
6286 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6287 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6288 "the same %s statement", &errmsg->where, fcn, fcn);
6291 /* Check that an allocate-object appears only once in the statement.
6292 FIXME: Checking derived types is disabled. */
6293 for (p = code->ext.alloc.list; p; p = p->next)
6296 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6297 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6299 for (q = p->next; q; q = q->next)
6302 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6303 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6304 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6305 gfc_error ("Allocate-object at %L also appears at %L",
6306 &pe->where, &qe->where);
6311 if (strcmp (fcn, "ALLOCATE") == 0)
6313 for (a = code->ext.alloc.list; a; a = a->next)
6314 resolve_allocate_expr (a->expr, code);
6318 for (a = code->ext.alloc.list; a; a = a->next)
6319 resolve_deallocate_expr (a->expr);
6324 /************ SELECT CASE resolution subroutines ************/
6326 /* Callback function for our mergesort variant. Determines interval
6327 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
6328 op1 > op2. Assumes we're not dealing with the default case.
6329 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
6330 There are nine situations to check. */
6333 compare_cases (const gfc_case *op1, const gfc_case *op2)
6337 if (op1->low == NULL) /* op1 = (:L) */
6339 /* op2 = (:N), so overlap. */
6341 /* op2 = (M:) or (M:N), L < M */
6342 if (op2->low != NULL
6343 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6346 else if (op1->high == NULL) /* op1 = (K:) */
6348 /* op2 = (M:), so overlap. */
6350 /* op2 = (:N) or (M:N), K > N */
6351 if (op2->high != NULL
6352 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6355 else /* op1 = (K:L) */
6357 if (op2->low == NULL) /* op2 = (:N), K > N */
6358 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6360 else if (op2->high == NULL) /* op2 = (M:), L < M */
6361 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6363 else /* op2 = (M:N) */
6367 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6370 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6379 /* Merge-sort a double linked case list, detecting overlap in the
6380 process. LIST is the head of the double linked case list before it
6381 is sorted. Returns the head of the sorted list if we don't see any
6382 overlap, or NULL otherwise. */
6385 check_case_overlap (gfc_case *list)
6387 gfc_case *p, *q, *e, *tail;
6388 int insize, nmerges, psize, qsize, cmp, overlap_seen;
6390 /* If the passed list was empty, return immediately. */
6397 /* Loop unconditionally. The only exit from this loop is a return
6398 statement, when we've finished sorting the case list. */
6405 /* Count the number of merges we do in this pass. */
6408 /* Loop while there exists a merge to be done. */
6413 /* Count this merge. */
6416 /* Cut the list in two pieces by stepping INSIZE places
6417 forward in the list, starting from P. */
6420 for (i = 0; i < insize; i++)
6429 /* Now we have two lists. Merge them! */
6430 while (psize > 0 || (qsize > 0 && q != NULL))
6432 /* See from which the next case to merge comes from. */
6435 /* P is empty so the next case must come from Q. */
6440 else if (qsize == 0 || q == NULL)
6449 cmp = compare_cases (p, q);
6452 /* The whole case range for P is less than the
6460 /* The whole case range for Q is greater than
6461 the case range for P. */
6468 /* The cases overlap, or they are the same
6469 element in the list. Either way, we must
6470 issue an error and get the next case from P. */
6471 /* FIXME: Sort P and Q by line number. */
6472 gfc_error ("CASE label at %L overlaps with CASE "
6473 "label at %L", &p->where, &q->where);
6481 /* Add the next element to the merged list. */
6490 /* P has now stepped INSIZE places along, and so has Q. So
6491 they're the same. */
6496 /* If we have done only one merge or none at all, we've
6497 finished sorting the cases. */
6506 /* Otherwise repeat, merging lists twice the size. */
6512 /* Check to see if an expression is suitable for use in a CASE statement.
6513 Makes sure that all case expressions are scalar constants of the same
6514 type. Return FAILURE if anything is wrong. */
6517 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
6519 if (e == NULL) return SUCCESS;
6521 if (e->ts.type != case_expr->ts.type)
6523 gfc_error ("Expression in CASE statement at %L must be of type %s",
6524 &e->where, gfc_basic_typename (case_expr->ts.type));
6528 /* C805 (R808) For a given case-construct, each case-value shall be of
6529 the same type as case-expr. For character type, length differences
6530 are allowed, but the kind type parameters shall be the same. */
6532 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
6534 gfc_error ("Expression in CASE statement at %L must be of kind %d",
6535 &e->where, case_expr->ts.kind);
6539 /* Convert the case value kind to that of case expression kind, if needed.
6540 FIXME: Should a warning be issued? */
6541 if (e->ts.kind != case_expr->ts.kind)
6542 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
6546 gfc_error ("Expression in CASE statement at %L must be scalar",
6555 /* Given a completely parsed select statement, we:
6557 - Validate all expressions and code within the SELECT.
6558 - Make sure that the selection expression is not of the wrong type.
6559 - Make sure that no case ranges overlap.
6560 - Eliminate unreachable cases and unreachable code resulting from
6561 removing case labels.
6563 The standard does allow unreachable cases, e.g. CASE (5:3). But
6564 they are a hassle for code generation, and to prevent that, we just
6565 cut them out here. This is not necessary for overlapping cases
6566 because they are illegal and we never even try to generate code.
6568 We have the additional caveat that a SELECT construct could have
6569 been a computed GOTO in the source code. Fortunately we can fairly
6570 easily work around that here: The case_expr for a "real" SELECT CASE
6571 is in code->expr1, but for a computed GOTO it is in code->expr2. All
6572 we have to do is make sure that the case_expr is a scalar integer
6576 resolve_select (gfc_code *code)
6579 gfc_expr *case_expr;
6580 gfc_case *cp, *default_case, *tail, *head;
6581 int seen_unreachable;
6587 if (code->expr1 == NULL)
6589 /* This was actually a computed GOTO statement. */
6590 case_expr = code->expr2;
6591 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
6592 gfc_error ("Selection expression in computed GOTO statement "
6593 "at %L must be a scalar integer expression",
6596 /* Further checking is not necessary because this SELECT was built
6597 by the compiler, so it should always be OK. Just move the
6598 case_expr from expr2 to expr so that we can handle computed
6599 GOTOs as normal SELECTs from here on. */
6600 code->expr1 = code->expr2;
6605 case_expr = code->expr1;
6607 type = case_expr->ts.type;
6608 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
6610 gfc_error ("Argument of SELECT statement at %L cannot be %s",
6611 &case_expr->where, gfc_typename (&case_expr->ts));
6613 /* Punt. Going on here just produce more garbage error messages. */
6617 if (case_expr->rank != 0)
6619 gfc_error ("Argument of SELECT statement at %L must be a scalar "
6620 "expression", &case_expr->where);
6626 /* PR 19168 has a long discussion concerning a mismatch of the kinds
6627 of the SELECT CASE expression and its CASE values. Walk the lists
6628 of case values, and if we find a mismatch, promote case_expr to
6629 the appropriate kind. */
6631 if (type == BT_LOGICAL || type == BT_INTEGER)
6633 for (body = code->block; body; body = body->block)
6635 /* Walk the case label list. */
6636 for (cp = body->ext.case_list; cp; cp = cp->next)
6638 /* Intercept the DEFAULT case. It does not have a kind. */
6639 if (cp->low == NULL && cp->high == NULL)
6642 /* Unreachable case ranges are discarded, so ignore. */
6643 if (cp->low != NULL && cp->high != NULL
6644 && cp->low != cp->high
6645 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
6648 /* FIXME: Should a warning be issued? */
6650 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
6651 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
6653 if (cp->high != NULL
6654 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
6655 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
6660 /* Assume there is no DEFAULT case. */
6661 default_case = NULL;
6666 for (body = code->block; body; body = body->block)
6668 /* Assume the CASE list is OK, and all CASE labels can be matched. */
6670 seen_unreachable = 0;
6672 /* Walk the case label list, making sure that all case labels
6674 for (cp = body->ext.case_list; cp; cp = cp->next)
6676 /* Count the number of cases in the whole construct. */
6679 /* Intercept the DEFAULT case. */
6680 if (cp->low == NULL && cp->high == NULL)
6682 if (default_case != NULL)
6684 gfc_error ("The DEFAULT CASE at %L cannot be followed "
6685 "by a second DEFAULT CASE at %L",
6686 &default_case->where, &cp->where);
6697 /* Deal with single value cases and case ranges. Errors are
6698 issued from the validation function. */
6699 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
6700 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
6706 if (type == BT_LOGICAL
6707 && ((cp->low == NULL || cp->high == NULL)
6708 || cp->low != cp->high))
6710 gfc_error ("Logical range in CASE statement at %L is not "
6711 "allowed", &cp->low->where);
6716 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
6719 value = cp->low->value.logical == 0 ? 2 : 1;
6720 if (value & seen_logical)
6722 gfc_error ("constant logical value in CASE statement "
6723 "is repeated at %L",
6728 seen_logical |= value;
6731 if (cp->low != NULL && cp->high != NULL
6732 && cp->low != cp->high
6733 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
6735 if (gfc_option.warn_surprising)
6736 gfc_warning ("Range specification at %L can never "
6737 "be matched", &cp->where);
6739 cp->unreachable = 1;
6740 seen_unreachable = 1;
6744 /* If the case range can be matched, it can also overlap with
6745 other cases. To make sure it does not, we put it in a
6746 double linked list here. We sort that with a merge sort
6747 later on to detect any overlapping cases. */
6751 head->right = head->left = NULL;
6756 tail->right->left = tail;
6763 /* It there was a failure in the previous case label, give up
6764 for this case label list. Continue with the next block. */
6768 /* See if any case labels that are unreachable have been seen.
6769 If so, we eliminate them. This is a bit of a kludge because
6770 the case lists for a single case statement (label) is a
6771 single forward linked lists. */
6772 if (seen_unreachable)
6774 /* Advance until the first case in the list is reachable. */
6775 while (body->ext.case_list != NULL
6776 && body->ext.case_list->unreachable)
6778 gfc_case *n = body->ext.case_list;
6779 body->ext.case_list = body->ext.case_list->next;
6781 gfc_free_case_list (n);
6784 /* Strip all other unreachable cases. */
6785 if (body->ext.case_list)
6787 for (cp = body->ext.case_list; cp->next; cp = cp->next)
6789 if (cp->next->unreachable)
6791 gfc_case *n = cp->next;
6792 cp->next = cp->next->next;
6794 gfc_free_case_list (n);
6801 /* See if there were overlapping cases. If the check returns NULL,
6802 there was overlap. In that case we don't do anything. If head
6803 is non-NULL, we prepend the DEFAULT case. The sorted list can
6804 then used during code generation for SELECT CASE constructs with
6805 a case expression of a CHARACTER type. */
6808 head = check_case_overlap (head);
6810 /* Prepend the default_case if it is there. */
6811 if (head != NULL && default_case)
6813 default_case->left = NULL;
6814 default_case->right = head;
6815 head->left = default_case;
6819 /* Eliminate dead blocks that may be the result if we've seen
6820 unreachable case labels for a block. */
6821 for (body = code; body && body->block; body = body->block)
6823 if (body->block->ext.case_list == NULL)
6825 /* Cut the unreachable block from the code chain. */
6826 gfc_code *c = body->block;
6827 body->block = c->block;
6829 /* Kill the dead block, but not the blocks below it. */
6831 gfc_free_statements (c);
6835 /* More than two cases is legal but insane for logical selects.
6836 Issue a warning for it. */
6837 if (gfc_option.warn_surprising && type == BT_LOGICAL
6839 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
6844 /* Check if a derived type is extensible. */
6847 gfc_type_is_extensible (gfc_symbol *sym)
6849 return !(sym->attr.is_bind_c || sym->attr.sequence);
6853 /* Resolve a SELECT TYPE statement. */
6856 resolve_select_type (gfc_code *code)
6858 gfc_symbol *selector_type;
6859 gfc_code *body, *new_st, *if_st, *tail;
6860 gfc_code *class_is = NULL, *default_case = NULL;
6863 char name[GFC_MAX_SYMBOL_LEN];
6871 selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
6873 selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
6875 /* Loop over TYPE IS / CLASS IS cases. */
6876 for (body = code->block; body; body = body->block)
6878 c = body->ext.case_list;
6880 /* Check F03:C815. */
6881 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
6882 && !gfc_type_is_extensible (c->ts.u.derived))
6884 gfc_error ("Derived type '%s' at %L must be extensible",
6885 c->ts.u.derived->name, &c->where);
6890 /* Check F03:C816. */
6891 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
6892 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
6894 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
6895 c->ts.u.derived->name, &c->where, selector_type->name);
6900 /* Intercept the DEFAULT case. */
6901 if (c->ts.type == BT_UNKNOWN)
6903 /* Check F03:C818. */
6906 gfc_error ("The DEFAULT CASE at %L cannot be followed "
6907 "by a second DEFAULT CASE at %L",
6908 &default_case->ext.case_list->where, &c->where);
6913 default_case = body;
6922 /* Insert assignment for selector variable. */
6923 new_st = gfc_get_code ();
6924 new_st->op = EXEC_ASSIGN;
6925 new_st->expr1 = gfc_copy_expr (code->expr1);
6926 new_st->expr2 = gfc_copy_expr (code->expr2);
6930 /* Put SELECT TYPE statement inside a BLOCK. */
6931 new_st = gfc_get_code ();
6932 new_st->op = code->op;
6933 new_st->expr1 = code->expr1;
6934 new_st->expr2 = code->expr2;
6935 new_st->block = code->block;
6939 ns->code->next = new_st;
6940 code->op = EXEC_BLOCK;
6941 code->expr1 = code->expr2 = NULL;
6946 /* Transform to EXEC_SELECT. */
6947 code->op = EXEC_SELECT;
6948 gfc_add_component_ref (code->expr1, "$vptr");
6949 gfc_add_component_ref (code->expr1, "$hash");
6951 /* Loop over TYPE IS / CLASS IS cases. */
6952 for (body = code->block; body; body = body->block)
6954 c = body->ext.case_list;
6956 if (c->ts.type == BT_DERIVED)
6957 c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
6958 else if (c->ts.type == BT_UNKNOWN)
6961 /* Assign temporary to selector. */
6962 if (c->ts.type == BT_CLASS)
6963 sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
6965 sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
6966 st = gfc_find_symtree (ns->sym_root, name);
6967 new_st = gfc_get_code ();
6968 new_st->expr1 = gfc_get_variable_expr (st);
6969 new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
6970 if (c->ts.type == BT_DERIVED)
6972 new_st->op = EXEC_POINTER_ASSIGN;
6973 gfc_add_component_ref (new_st->expr2, "$data");
6976 new_st->op = EXEC_POINTER_ASSIGN;
6977 new_st->next = body->next;
6978 body->next = new_st;
6981 /* Take out CLASS IS cases for separate treatment. */
6983 while (body && body->block)
6985 if (body->block->ext.case_list->ts.type == BT_CLASS)
6987 /* Add to class_is list. */
6988 if (class_is == NULL)
6990 class_is = body->block;
6995 for (tail = class_is; tail->block; tail = tail->block) ;
6996 tail->block = body->block;
6999 /* Remove from EXEC_SELECT list. */
7000 body->block = body->block->block;
7013 /* Add a default case to hold the CLASS IS cases. */
7014 for (tail = code; tail->block; tail = tail->block) ;
7015 tail->block = gfc_get_code ();
7017 tail->op = EXEC_SELECT_TYPE;
7018 tail->ext.case_list = gfc_get_case ();
7019 tail->ext.case_list->ts.type = BT_UNKNOWN;
7021 default_case = tail;
7024 /* More than one CLASS IS block? */
7025 if (class_is->block)
7029 /* Sort CLASS IS blocks by extension level. */
7033 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
7036 /* F03:C817 (check for doubles). */
7037 if ((*c1)->ext.case_list->ts.u.derived->hash_value
7038 == c2->ext.case_list->ts.u.derived->hash_value)
7040 gfc_error ("Double CLASS IS block in SELECT TYPE "
7041 "statement at %L", &c2->ext.case_list->where);
7044 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
7045 < c2->ext.case_list->ts.u.derived->attr.extension)
7048 (*c1)->block = c2->block;
7058 /* Generate IF chain. */
7059 if_st = gfc_get_code ();
7060 if_st->op = EXEC_IF;
7062 for (body = class_is; body; body = body->block)
7064 new_st->block = gfc_get_code ();
7065 new_st = new_st->block;
7066 new_st->op = EXEC_IF;
7067 /* Set up IF condition: Call _gfortran_is_extension_of. */
7068 new_st->expr1 = gfc_get_expr ();
7069 new_st->expr1->expr_type = EXPR_FUNCTION;
7070 new_st->expr1->ts.type = BT_LOGICAL;
7071 new_st->expr1->ts.kind = 4;
7072 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
7073 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
7074 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
7075 /* Set up arguments. */
7076 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7077 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7078 gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7079 vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7080 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7081 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7082 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7083 new_st->next = body->next;
7085 if (default_case->next)
7087 new_st->block = gfc_get_code ();
7088 new_st = new_st->block;
7089 new_st->op = EXEC_IF;
7090 new_st->next = default_case->next;
7093 /* Replace CLASS DEFAULT code by the IF chain. */
7094 default_case->next = if_st;
7097 resolve_select (code);
7102 /* Resolve a transfer statement. This is making sure that:
7103 -- a derived type being transferred has only non-pointer components
7104 -- a derived type being transferred doesn't have private components, unless
7105 it's being transferred from the module where the type was defined
7106 -- we're not trying to transfer a whole assumed size array. */
7109 resolve_transfer (gfc_code *code)
7118 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
7121 sym = exp->symtree->n.sym;
7124 /* Go to actual component transferred. */
7125 for (ref = code->expr1->ref; ref; ref = ref->next)
7126 if (ref->type == REF_COMPONENT)
7127 ts = &ref->u.c.component->ts;
7129 if (ts->type == BT_DERIVED)
7131 /* Check that transferred derived type doesn't contain POINTER
7133 if (ts->u.derived->attr.pointer_comp)
7135 gfc_error ("Data transfer element at %L cannot have "
7136 "POINTER components", &code->loc);
7140 if (ts->u.derived->attr.alloc_comp)
7142 gfc_error ("Data transfer element at %L cannot have "
7143 "ALLOCATABLE components", &code->loc);
7147 if (derived_inaccessible (ts->u.derived))
7149 gfc_error ("Data transfer element at %L cannot have "
7150 "PRIVATE components",&code->loc);
7155 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7156 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7158 gfc_error ("Data transfer element at %L cannot be a full reference to "
7159 "an assumed-size array", &code->loc);
7165 /*********** Toplevel code resolution subroutines ***********/
7167 /* Find the set of labels that are reachable from this block. We also
7168 record the last statement in each block. */
7171 find_reachable_labels (gfc_code *block)
7178 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
7180 /* Collect labels in this block. We don't keep those corresponding
7181 to END {IF|SELECT}, these are checked in resolve_branch by going
7182 up through the code_stack. */
7183 for (c = block; c; c = c->next)
7185 if (c->here && c->op != EXEC_END_BLOCK)
7186 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
7189 /* Merge with labels from parent block. */
7192 gcc_assert (cs_base->prev->reachable_labels);
7193 bitmap_ior_into (cs_base->reachable_labels,
7194 cs_base->prev->reachable_labels);
7198 /* Given a branch to a label, see if the branch is conforming.
7199 The code node describes where the branch is located. */
7202 resolve_branch (gfc_st_label *label, gfc_code *code)
7209 /* Step one: is this a valid branching target? */
7211 if (label->defined == ST_LABEL_UNKNOWN)
7213 gfc_error ("Label %d referenced at %L is never defined", label->value,
7218 if (label->defined != ST_LABEL_TARGET)
7220 gfc_error ("Statement at %L is not a valid branch target statement "
7221 "for the branch statement at %L", &label->where, &code->loc);
7225 /* Step two: make sure this branch is not a branch to itself ;-) */
7227 if (code->here == label)
7229 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
7233 /* Step three: See if the label is in the same block as the
7234 branching statement. The hard work has been done by setting up
7235 the bitmap reachable_labels. */
7237 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
7240 /* Step four: If we haven't found the label in the bitmap, it may
7241 still be the label of the END of the enclosing block, in which
7242 case we find it by going up the code_stack. */
7244 for (stack = cs_base; stack; stack = stack->prev)
7245 if (stack->current->next && stack->current->next->here == label)
7250 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
7254 /* The label is not in an enclosing block, so illegal. This was
7255 allowed in Fortran 66, so we allow it as extension. No
7256 further checks are necessary in this case. */
7257 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
7258 "as the GOTO statement at %L", &label->where,
7264 /* Check whether EXPR1 has the same shape as EXPR2. */
7267 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
7269 mpz_t shape[GFC_MAX_DIMENSIONS];
7270 mpz_t shape2[GFC_MAX_DIMENSIONS];
7271 gfc_try result = FAILURE;
7274 /* Compare the rank. */
7275 if (expr1->rank != expr2->rank)
7278 /* Compare the size of each dimension. */
7279 for (i=0; i<expr1->rank; i++)
7281 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
7284 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
7287 if (mpz_cmp (shape[i], shape2[i]))
7291 /* When either of the two expression is an assumed size array, we
7292 ignore the comparison of dimension sizes. */
7297 for (i--; i >= 0; i--)
7299 mpz_clear (shape[i]);
7300 mpz_clear (shape2[i]);
7306 /* Check whether a WHERE assignment target or a WHERE mask expression
7307 has the same shape as the outmost WHERE mask expression. */
7310 resolve_where (gfc_code *code, gfc_expr *mask)
7316 cblock = code->block;
7318 /* Store the first WHERE mask-expr of the WHERE statement or construct.
7319 In case of nested WHERE, only the outmost one is stored. */
7320 if (mask == NULL) /* outmost WHERE */
7322 else /* inner WHERE */
7329 /* Check if the mask-expr has a consistent shape with the
7330 outmost WHERE mask-expr. */
7331 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
7332 gfc_error ("WHERE mask at %L has inconsistent shape",
7333 &cblock->expr1->where);
7336 /* the assignment statement of a WHERE statement, or the first
7337 statement in where-body-construct of a WHERE construct */
7338 cnext = cblock->next;
7343 /* WHERE assignment statement */
7346 /* Check shape consistent for WHERE assignment target. */
7347 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
7348 gfc_error ("WHERE assignment target at %L has "
7349 "inconsistent shape", &cnext->expr1->where);
7353 case EXEC_ASSIGN_CALL:
7354 resolve_call (cnext);
7355 if (!cnext->resolved_sym->attr.elemental)
7356 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
7357 &cnext->ext.actual->expr->where);
7360 /* WHERE or WHERE construct is part of a where-body-construct */
7362 resolve_where (cnext, e);
7366 gfc_error ("Unsupported statement inside WHERE at %L",
7369 /* the next statement within the same where-body-construct */
7370 cnext = cnext->next;
7372 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
7373 cblock = cblock->block;
7378 /* Resolve assignment in FORALL construct.
7379 NVAR is the number of FORALL index variables, and VAR_EXPR records the
7380 FORALL index variables. */
7383 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
7387 for (n = 0; n < nvar; n++)
7389 gfc_symbol *forall_index;
7391 forall_index = var_expr[n]->symtree->n.sym;
7393 /* Check whether the assignment target is one of the FORALL index
7395 if ((code->expr1->expr_type == EXPR_VARIABLE)
7396 && (code->expr1->symtree->n.sym == forall_index))
7397 gfc_error ("Assignment to a FORALL index variable at %L",
7398 &code->expr1->where);
7401 /* If one of the FORALL index variables doesn't appear in the
7402 assignment variable, then there could be a many-to-one
7403 assignment. Emit a warning rather than an error because the
7404 mask could be resolving this problem. */
7405 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
7406 gfc_warning ("The FORALL with index '%s' is not used on the "
7407 "left side of the assignment at %L and so might "
7408 "cause multiple assignment to this object",
7409 var_expr[n]->symtree->name, &code->expr1->where);
7415 /* Resolve WHERE statement in FORALL construct. */
7418 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
7419 gfc_expr **var_expr)
7424 cblock = code->block;
7427 /* the assignment statement of a WHERE statement, or the first
7428 statement in where-body-construct of a WHERE construct */
7429 cnext = cblock->next;
7434 /* WHERE assignment statement */
7436 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
7439 /* WHERE operator assignment statement */
7440 case EXEC_ASSIGN_CALL:
7441 resolve_call (cnext);
7442 if (!cnext->resolved_sym->attr.elemental)
7443 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
7444 &cnext->ext.actual->expr->where);
7447 /* WHERE or WHERE construct is part of a where-body-construct */
7449 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
7453 gfc_error ("Unsupported statement inside WHERE at %L",
7456 /* the next statement within the same where-body-construct */
7457 cnext = cnext->next;
7459 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
7460 cblock = cblock->block;
7465 /* Traverse the FORALL body to check whether the following errors exist:
7466 1. For assignment, check if a many-to-one assignment happens.
7467 2. For WHERE statement, check the WHERE body to see if there is any
7468 many-to-one assignment. */
7471 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
7475 c = code->block->next;
7481 case EXEC_POINTER_ASSIGN:
7482 gfc_resolve_assign_in_forall (c, nvar, var_expr);
7485 case EXEC_ASSIGN_CALL:
7489 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
7490 there is no need to handle it here. */
7494 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
7499 /* The next statement in the FORALL body. */
7505 /* Counts the number of iterators needed inside a forall construct, including
7506 nested forall constructs. This is used to allocate the needed memory
7507 in gfc_resolve_forall. */
7510 gfc_count_forall_iterators (gfc_code *code)
7512 int max_iters, sub_iters, current_iters;
7513 gfc_forall_iterator *fa;
7515 gcc_assert(code->op == EXEC_FORALL);
7519 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
7522 code = code->block->next;
7526 if (code->op == EXEC_FORALL)
7528 sub_iters = gfc_count_forall_iterators (code);
7529 if (sub_iters > max_iters)
7530 max_iters = sub_iters;
7535 return current_iters + max_iters;
7539 /* Given a FORALL construct, first resolve the FORALL iterator, then call
7540 gfc_resolve_forall_body to resolve the FORALL body. */
7543 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
7545 static gfc_expr **var_expr;
7546 static int total_var = 0;
7547 static int nvar = 0;
7549 gfc_forall_iterator *fa;
7554 /* Start to resolve a FORALL construct */
7555 if (forall_save == 0)
7557 /* Count the total number of FORALL index in the nested FORALL
7558 construct in order to allocate the VAR_EXPR with proper size. */
7559 total_var = gfc_count_forall_iterators (code);
7561 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
7562 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
7565 /* The information about FORALL iterator, including FORALL index start, end
7566 and stride. The FORALL index can not appear in start, end or stride. */
7567 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
7569 /* Check if any outer FORALL index name is the same as the current
7571 for (i = 0; i < nvar; i++)
7573 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
7575 gfc_error ("An outer FORALL construct already has an index "
7576 "with this name %L", &fa->var->where);
7580 /* Record the current FORALL index. */
7581 var_expr[nvar] = gfc_copy_expr (fa->var);
7585 /* No memory leak. */
7586 gcc_assert (nvar <= total_var);
7589 /* Resolve the FORALL body. */
7590 gfc_resolve_forall_body (code, nvar, var_expr);
7592 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
7593 gfc_resolve_blocks (code->block, ns);
7597 /* Free only the VAR_EXPRs allocated in this frame. */
7598 for (i = nvar; i < tmp; i++)
7599 gfc_free_expr (var_expr[i]);
7603 /* We are in the outermost FORALL construct. */
7604 gcc_assert (forall_save == 0);
7606 /* VAR_EXPR is not needed any more. */
7607 gfc_free (var_expr);
7613 /* Resolve a BLOCK construct statement. */
7616 resolve_block_construct (gfc_code* code)
7618 /* Eventually, we may want to do some checks here or handle special stuff.
7619 But so far the only thing we can do is resolving the local namespace. */
7621 gfc_resolve (code->ext.ns);
7625 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
7628 static void resolve_code (gfc_code *, gfc_namespace *);
7631 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
7635 for (; b; b = b->block)
7637 t = gfc_resolve_expr (b->expr1);
7638 if (gfc_resolve_expr (b->expr2) == FAILURE)
7644 if (t == SUCCESS && b->expr1 != NULL
7645 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
7646 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7653 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
7654 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
7659 resolve_branch (b->label1, b);
7663 resolve_block_construct (b);
7667 case EXEC_SELECT_TYPE:
7677 case EXEC_OMP_ATOMIC:
7678 case EXEC_OMP_CRITICAL:
7680 case EXEC_OMP_MASTER:
7681 case EXEC_OMP_ORDERED:
7682 case EXEC_OMP_PARALLEL:
7683 case EXEC_OMP_PARALLEL_DO:
7684 case EXEC_OMP_PARALLEL_SECTIONS:
7685 case EXEC_OMP_PARALLEL_WORKSHARE:
7686 case EXEC_OMP_SECTIONS:
7687 case EXEC_OMP_SINGLE:
7689 case EXEC_OMP_TASKWAIT:
7690 case EXEC_OMP_WORKSHARE:
7694 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
7697 resolve_code (b->next, ns);
7702 /* Does everything to resolve an ordinary assignment. Returns true
7703 if this is an interface assignment. */
7705 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
7715 if (gfc_extend_assign (code, ns) == SUCCESS)
7719 if (code->op == EXEC_ASSIGN_CALL)
7721 lhs = code->ext.actual->expr;
7722 rhsptr = &code->ext.actual->next->expr;
7726 gfc_actual_arglist* args;
7727 gfc_typebound_proc* tbp;
7729 gcc_assert (code->op == EXEC_COMPCALL);
7731 args = code->expr1->value.compcall.actual;
7733 rhsptr = &args->next->expr;
7735 tbp = code->expr1->value.compcall.tbp;
7736 gcc_assert (!tbp->is_generic);
7739 /* Make a temporary rhs when there is a default initializer
7740 and rhs is the same symbol as the lhs. */
7741 if ((*rhsptr)->expr_type == EXPR_VARIABLE
7742 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
7743 && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
7744 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
7745 *rhsptr = gfc_get_parentheses (*rhsptr);
7754 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
7755 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
7756 &code->loc) == FAILURE)
7759 /* Handle the case of a BOZ literal on the RHS. */
7760 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
7763 if (gfc_option.warn_surprising)
7764 gfc_warning ("BOZ literal at %L is bitwise transferred "
7765 "non-integer symbol '%s'", &code->loc,
7766 lhs->symtree->n.sym->name);
7768 if (!gfc_convert_boz (rhs, &lhs->ts))
7770 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
7772 if (rc == ARITH_UNDERFLOW)
7773 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
7774 ". This check can be disabled with the option "
7775 "-fno-range-check", &rhs->where);
7776 else if (rc == ARITH_OVERFLOW)
7777 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
7778 ". This check can be disabled with the option "
7779 "-fno-range-check", &rhs->where);
7780 else if (rc == ARITH_NAN)
7781 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
7782 ". This check can be disabled with the option "
7783 "-fno-range-check", &rhs->where);
7789 if (lhs->ts.type == BT_CHARACTER
7790 && gfc_option.warn_character_truncation)
7792 if (lhs->ts.u.cl != NULL
7793 && lhs->ts.u.cl->length != NULL
7794 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7795 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
7797 if (rhs->expr_type == EXPR_CONSTANT)
7798 rlen = rhs->value.character.length;
7800 else if (rhs->ts.u.cl != NULL
7801 && rhs->ts.u.cl->length != NULL
7802 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7803 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
7805 if (rlen && llen && rlen > llen)
7806 gfc_warning_now ("CHARACTER expression will be truncated "
7807 "in assignment (%d/%d) at %L",
7808 llen, rlen, &code->loc);
7811 /* Ensure that a vector index expression for the lvalue is evaluated
7812 to a temporary if the lvalue symbol is referenced in it. */
7815 for (ref = lhs->ref; ref; ref= ref->next)
7816 if (ref->type == REF_ARRAY)
7818 for (n = 0; n < ref->u.ar.dimen; n++)
7819 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
7820 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
7821 ref->u.ar.start[n]))
7823 = gfc_get_parentheses (ref->u.ar.start[n]);
7827 if (gfc_pure (NULL))
7829 if (gfc_impure_variable (lhs->symtree->n.sym))
7831 gfc_error ("Cannot assign to variable '%s' in PURE "
7833 lhs->symtree->n.sym->name,
7838 if (lhs->ts.type == BT_DERIVED
7839 && lhs->expr_type == EXPR_VARIABLE
7840 && lhs->ts.u.derived->attr.pointer_comp
7841 && gfc_impure_variable (rhs->symtree->n.sym))
7843 gfc_error ("The impure variable at %L is assigned to "
7844 "a derived type variable with a POINTER "
7845 "component in a PURE procedure (12.6)",
7852 if (lhs->ts.type == BT_CLASS)
7854 gfc_error ("Variable must not be polymorphic in assignment at %L",
7859 gfc_check_assign (lhs, rhs, 1);
7864 /* Given a block of code, recursively resolve everything pointed to by this
7868 resolve_code (gfc_code *code, gfc_namespace *ns)
7870 int omp_workshare_save;
7875 frame.prev = cs_base;
7879 find_reachable_labels (code);
7881 for (; code; code = code->next)
7883 frame.current = code;
7884 forall_save = forall_flag;
7886 if (code->op == EXEC_FORALL)
7889 gfc_resolve_forall (code, ns, forall_save);
7892 else if (code->block)
7894 omp_workshare_save = -1;
7897 case EXEC_OMP_PARALLEL_WORKSHARE:
7898 omp_workshare_save = omp_workshare_flag;
7899 omp_workshare_flag = 1;
7900 gfc_resolve_omp_parallel_blocks (code, ns);
7902 case EXEC_OMP_PARALLEL:
7903 case EXEC_OMP_PARALLEL_DO:
7904 case EXEC_OMP_PARALLEL_SECTIONS:
7906 omp_workshare_save = omp_workshare_flag;
7907 omp_workshare_flag = 0;
7908 gfc_resolve_omp_parallel_blocks (code, ns);
7911 gfc_resolve_omp_do_blocks (code, ns);
7913 case EXEC_OMP_WORKSHARE:
7914 omp_workshare_save = omp_workshare_flag;
7915 omp_workshare_flag = 1;
7918 gfc_resolve_blocks (code->block, ns);
7922 if (omp_workshare_save != -1)
7923 omp_workshare_flag = omp_workshare_save;
7927 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
7928 t = gfc_resolve_expr (code->expr1);
7929 forall_flag = forall_save;
7931 if (gfc_resolve_expr (code->expr2) == FAILURE)
7934 if (code->op == EXEC_ALLOCATE
7935 && gfc_resolve_expr (code->expr3) == FAILURE)
7941 case EXEC_END_BLOCK:
7948 case EXEC_ASSIGN_CALL:
7952 /* Keep track of which entry we are up to. */
7953 current_entry_id = code->ext.entry->id;
7957 resolve_where (code, NULL);
7961 if (code->expr1 != NULL)
7963 if (code->expr1->ts.type != BT_INTEGER)
7964 gfc_error ("ASSIGNED GOTO statement at %L requires an "
7965 "INTEGER variable", &code->expr1->where);
7966 else if (code->expr1->symtree->n.sym->attr.assign != 1)
7967 gfc_error ("Variable '%s' has not been assigned a target "
7968 "label at %L", code->expr1->symtree->n.sym->name,
7969 &code->expr1->where);
7972 resolve_branch (code->label1, code);
7976 if (code->expr1 != NULL
7977 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
7978 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
7979 "INTEGER return specifier", &code->expr1->where);
7982 case EXEC_INIT_ASSIGN:
7983 case EXEC_END_PROCEDURE:
7990 if (resolve_ordinary_assign (code, ns))
7992 if (code->op == EXEC_COMPCALL)
7999 case EXEC_LABEL_ASSIGN:
8000 if (code->label1->defined == ST_LABEL_UNKNOWN)
8001 gfc_error ("Label %d referenced at %L is never defined",
8002 code->label1->value, &code->label1->where);
8004 && (code->expr1->expr_type != EXPR_VARIABLE
8005 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
8006 || code->expr1->symtree->n.sym->ts.kind
8007 != gfc_default_integer_kind
8008 || code->expr1->symtree->n.sym->as != NULL))
8009 gfc_error ("ASSIGN statement at %L requires a scalar "
8010 "default INTEGER variable", &code->expr1->where);
8013 case EXEC_POINTER_ASSIGN:
8017 gfc_check_pointer_assign (code->expr1, code->expr2);
8020 case EXEC_ARITHMETIC_IF:
8022 && code->expr1->ts.type != BT_INTEGER
8023 && code->expr1->ts.type != BT_REAL)
8024 gfc_error ("Arithmetic IF statement at %L requires a numeric "
8025 "expression", &code->expr1->where);
8027 resolve_branch (code->label1, code);
8028 resolve_branch (code->label2, code);
8029 resolve_branch (code->label3, code);
8033 if (t == SUCCESS && code->expr1 != NULL
8034 && (code->expr1->ts.type != BT_LOGICAL
8035 || code->expr1->rank != 0))
8036 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8037 &code->expr1->where);
8042 resolve_call (code);
8047 if (code->expr1->symtree
8048 && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
8049 resolve_class_typebound_call (code);
8051 resolve_typebound_call (code);
8055 resolve_ppc_call (code);
8059 /* Select is complicated. Also, a SELECT construct could be
8060 a transformed computed GOTO. */
8061 resolve_select (code);
8064 case EXEC_SELECT_TYPE:
8065 resolve_select_type (code);
8069 gfc_resolve (code->ext.ns);
8073 if (code->ext.iterator != NULL)
8075 gfc_iterator *iter = code->ext.iterator;
8076 if (gfc_resolve_iterator (iter, true) != FAILURE)
8077 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
8082 if (code->expr1 == NULL)
8083 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
8085 && (code->expr1->rank != 0
8086 || code->expr1->ts.type != BT_LOGICAL))
8087 gfc_error ("Exit condition of DO WHILE loop at %L must be "
8088 "a scalar LOGICAL expression", &code->expr1->where);
8093 resolve_allocate_deallocate (code, "ALLOCATE");
8097 case EXEC_DEALLOCATE:
8099 resolve_allocate_deallocate (code, "DEALLOCATE");
8104 if (gfc_resolve_open (code->ext.open) == FAILURE)
8107 resolve_branch (code->ext.open->err, code);
8111 if (gfc_resolve_close (code->ext.close) == FAILURE)
8114 resolve_branch (code->ext.close->err, code);
8117 case EXEC_BACKSPACE:
8121 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
8124 resolve_branch (code->ext.filepos->err, code);
8128 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8131 resolve_branch (code->ext.inquire->err, code);
8135 gcc_assert (code->ext.inquire != NULL);
8136 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8139 resolve_branch (code->ext.inquire->err, code);
8143 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
8146 resolve_branch (code->ext.wait->err, code);
8147 resolve_branch (code->ext.wait->end, code);
8148 resolve_branch (code->ext.wait->eor, code);
8153 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
8156 resolve_branch (code->ext.dt->err, code);
8157 resolve_branch (code->ext.dt->end, code);
8158 resolve_branch (code->ext.dt->eor, code);
8162 resolve_transfer (code);
8166 resolve_forall_iterators (code->ext.forall_iterator);
8168 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
8169 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
8170 "expression", &code->expr1->where);
8173 case EXEC_OMP_ATOMIC:
8174 case EXEC_OMP_BARRIER:
8175 case EXEC_OMP_CRITICAL:
8176 case EXEC_OMP_FLUSH:
8178 case EXEC_OMP_MASTER:
8179 case EXEC_OMP_ORDERED:
8180 case EXEC_OMP_SECTIONS:
8181 case EXEC_OMP_SINGLE:
8182 case EXEC_OMP_TASKWAIT:
8183 case EXEC_OMP_WORKSHARE:
8184 gfc_resolve_omp_directive (code, ns);
8187 case EXEC_OMP_PARALLEL:
8188 case EXEC_OMP_PARALLEL_DO:
8189 case EXEC_OMP_PARALLEL_SECTIONS:
8190 case EXEC_OMP_PARALLEL_WORKSHARE:
8192 omp_workshare_save = omp_workshare_flag;
8193 omp_workshare_flag = 0;
8194 gfc_resolve_omp_directive (code, ns);
8195 omp_workshare_flag = omp_workshare_save;
8199 gfc_internal_error ("resolve_code(): Bad statement code");
8203 cs_base = frame.prev;
8207 /* Resolve initial values and make sure they are compatible with
8211 resolve_values (gfc_symbol *sym)
8213 if (sym->value == NULL)
8216 if (gfc_resolve_expr (sym->value) == FAILURE)
8219 gfc_check_assign_symbol (sym, sym->value);
8223 /* Verify the binding labels for common blocks that are BIND(C). The label
8224 for a BIND(C) common block must be identical in all scoping units in which
8225 the common block is declared. Further, the binding label can not collide
8226 with any other global entity in the program. */
8229 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
8231 if (comm_block_tree->n.common->is_bind_c == 1)
8233 gfc_gsymbol *binding_label_gsym;
8234 gfc_gsymbol *comm_name_gsym;
8236 /* See if a global symbol exists by the common block's name. It may
8237 be NULL if the common block is use-associated. */
8238 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
8239 comm_block_tree->n.common->name);
8240 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
8241 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
8242 "with the global entity '%s' at %L",
8243 comm_block_tree->n.common->binding_label,
8244 comm_block_tree->n.common->name,
8245 &(comm_block_tree->n.common->where),
8246 comm_name_gsym->name, &(comm_name_gsym->where));
8247 else if (comm_name_gsym != NULL
8248 && strcmp (comm_name_gsym->name,
8249 comm_block_tree->n.common->name) == 0)
8251 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
8253 if (comm_name_gsym->binding_label == NULL)
8254 /* No binding label for common block stored yet; save this one. */
8255 comm_name_gsym->binding_label =
8256 comm_block_tree->n.common->binding_label;
8258 if (strcmp (comm_name_gsym->binding_label,
8259 comm_block_tree->n.common->binding_label) != 0)
8261 /* Common block names match but binding labels do not. */
8262 gfc_error ("Binding label '%s' for common block '%s' at %L "
8263 "does not match the binding label '%s' for common "
8265 comm_block_tree->n.common->binding_label,
8266 comm_block_tree->n.common->name,
8267 &(comm_block_tree->n.common->where),
8268 comm_name_gsym->binding_label,
8269 comm_name_gsym->name,
8270 &(comm_name_gsym->where));
8275 /* There is no binding label (NAME="") so we have nothing further to
8276 check and nothing to add as a global symbol for the label. */
8277 if (comm_block_tree->n.common->binding_label[0] == '\0' )
8280 binding_label_gsym =
8281 gfc_find_gsymbol (gfc_gsym_root,
8282 comm_block_tree->n.common->binding_label);
8283 if (binding_label_gsym == NULL)
8285 /* Need to make a global symbol for the binding label to prevent
8286 it from colliding with another. */
8287 binding_label_gsym =
8288 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
8289 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
8290 binding_label_gsym->type = GSYM_COMMON;
8294 /* If comm_name_gsym is NULL, the name common block is use
8295 associated and the name could be colliding. */
8296 if (binding_label_gsym->type != GSYM_COMMON)
8297 gfc_error ("Binding label '%s' for common block '%s' at %L "
8298 "collides with the global entity '%s' at %L",
8299 comm_block_tree->n.common->binding_label,
8300 comm_block_tree->n.common->name,
8301 &(comm_block_tree->n.common->where),
8302 binding_label_gsym->name,
8303 &(binding_label_gsym->where));
8304 else if (comm_name_gsym != NULL
8305 && (strcmp (binding_label_gsym->name,
8306 comm_name_gsym->binding_label) != 0)
8307 && (strcmp (binding_label_gsym->sym_name,
8308 comm_name_gsym->name) != 0))
8309 gfc_error ("Binding label '%s' for common block '%s' at %L "
8310 "collides with global entity '%s' at %L",
8311 binding_label_gsym->name, binding_label_gsym->sym_name,
8312 &(comm_block_tree->n.common->where),
8313 comm_name_gsym->name, &(comm_name_gsym->where));
8321 /* Verify any BIND(C) derived types in the namespace so we can report errors
8322 for them once, rather than for each variable declared of that type. */
8325 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
8327 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
8328 && derived_sym->attr.is_bind_c == 1)
8329 verify_bind_c_derived_type (derived_sym);
8335 /* Verify that any binding labels used in a given namespace do not collide
8336 with the names or binding labels of any global symbols. */
8339 gfc_verify_binding_labels (gfc_symbol *sym)
8343 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
8344 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
8346 gfc_gsymbol *bind_c_sym;
8348 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
8349 if (bind_c_sym != NULL
8350 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
8352 if (sym->attr.if_source == IFSRC_DECL
8353 && (bind_c_sym->type != GSYM_SUBROUTINE
8354 && bind_c_sym->type != GSYM_FUNCTION)
8355 && ((sym->attr.contained == 1
8356 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
8357 || (sym->attr.use_assoc == 1
8358 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
8360 /* Make sure global procedures don't collide with anything. */
8361 gfc_error ("Binding label '%s' at %L collides with the global "
8362 "entity '%s' at %L", sym->binding_label,
8363 &(sym->declared_at), bind_c_sym->name,
8364 &(bind_c_sym->where));
8367 else if (sym->attr.contained == 0
8368 && (sym->attr.if_source == IFSRC_IFBODY
8369 && sym->attr.flavor == FL_PROCEDURE)
8370 && (bind_c_sym->sym_name != NULL
8371 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
8373 /* Make sure procedures in interface bodies don't collide. */
8374 gfc_error ("Binding label '%s' in interface body at %L collides "
8375 "with the global entity '%s' at %L",
8377 &(sym->declared_at), bind_c_sym->name,
8378 &(bind_c_sym->where));
8381 else if (sym->attr.contained == 0
8382 && sym->attr.if_source == IFSRC_UNKNOWN)
8383 if ((sym->attr.use_assoc && bind_c_sym->mod_name
8384 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
8385 || sym->attr.use_assoc == 0)
8387 gfc_error ("Binding label '%s' at %L collides with global "
8388 "entity '%s' at %L", sym->binding_label,
8389 &(sym->declared_at), bind_c_sym->name,
8390 &(bind_c_sym->where));
8395 /* Clear the binding label to prevent checking multiple times. */
8396 sym->binding_label[0] = '\0';
8398 else if (bind_c_sym == NULL)
8400 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
8401 bind_c_sym->where = sym->declared_at;
8402 bind_c_sym->sym_name = sym->name;
8404 if (sym->attr.use_assoc == 1)
8405 bind_c_sym->mod_name = sym->module;
8407 if (sym->ns->proc_name != NULL)
8408 bind_c_sym->mod_name = sym->ns->proc_name->name;
8410 if (sym->attr.contained == 0)
8412 if (sym->attr.subroutine)
8413 bind_c_sym->type = GSYM_SUBROUTINE;
8414 else if (sym->attr.function)
8415 bind_c_sym->type = GSYM_FUNCTION;
8423 /* Resolve an index expression. */
8426 resolve_index_expr (gfc_expr *e)
8428 if (gfc_resolve_expr (e) == FAILURE)
8431 if (gfc_simplify_expr (e, 0) == FAILURE)
8434 if (gfc_specification_expr (e) == FAILURE)
8440 /* Resolve a charlen structure. */
8443 resolve_charlen (gfc_charlen *cl)
8452 specification_expr = 1;
8454 if (resolve_index_expr (cl->length) == FAILURE)
8456 specification_expr = 0;
8460 /* "If the character length parameter value evaluates to a negative
8461 value, the length of character entities declared is zero." */
8462 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
8464 gfc_warning_now ("CHARACTER variable has zero length at %L",
8465 &cl->length->where);
8466 gfc_replace_expr (cl->length, gfc_int_expr (0));
8469 /* Check that the character length is not too large. */
8470 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
8471 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
8472 && cl->length->ts.type == BT_INTEGER
8473 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
8475 gfc_error ("String length at %L is too large", &cl->length->where);
8483 /* Test for non-constant shape arrays. */
8486 is_non_constant_shape_array (gfc_symbol *sym)
8492 not_constant = false;
8493 if (sym->as != NULL)
8495 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
8496 has not been simplified; parameter array references. Do the
8497 simplification now. */
8498 for (i = 0; i < sym->as->rank; i++)
8500 e = sym->as->lower[i];
8501 if (e && (resolve_index_expr (e) == FAILURE
8502 || !gfc_is_constant_expr (e)))
8503 not_constant = true;
8505 e = sym->as->upper[i];
8506 if (e && (resolve_index_expr (e) == FAILURE
8507 || !gfc_is_constant_expr (e)))
8508 not_constant = true;
8511 return not_constant;
8514 /* Given a symbol and an initialization expression, add code to initialize
8515 the symbol to the function entry. */
8517 build_init_assign (gfc_symbol *sym, gfc_expr *init)
8521 gfc_namespace *ns = sym->ns;
8523 /* Search for the function namespace if this is a contained
8524 function without an explicit result. */
8525 if (sym->attr.function && sym == sym->result
8526 && sym->name != sym->ns->proc_name->name)
8529 for (;ns; ns = ns->sibling)
8530 if (strcmp (ns->proc_name->name, sym->name) == 0)
8536 gfc_free_expr (init);
8540 /* Build an l-value expression for the result. */
8541 lval = gfc_lval_expr_from_sym (sym);
8543 /* Add the code at scope entry. */
8544 init_st = gfc_get_code ();
8545 init_st->next = ns->code;
8548 /* Assign the default initializer to the l-value. */
8549 init_st->loc = sym->declared_at;
8550 init_st->op = EXEC_INIT_ASSIGN;
8551 init_st->expr1 = lval;
8552 init_st->expr2 = init;
8555 /* Assign the default initializer to a derived type variable or result. */
8558 apply_default_init (gfc_symbol *sym)
8560 gfc_expr *init = NULL;
8562 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
8565 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
8566 init = gfc_default_initializer (&sym->ts);
8571 build_init_assign (sym, init);
8574 /* Build an initializer for a local integer, real, complex, logical, or
8575 character variable, based on the command line flags finit-local-zero,
8576 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
8577 null if the symbol should not have a default initialization. */
8579 build_default_init_expr (gfc_symbol *sym)
8582 gfc_expr *init_expr;
8585 /* These symbols should never have a default initialization. */
8586 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
8587 || sym->attr.external
8589 || sym->attr.pointer
8590 || sym->attr.in_equivalence
8591 || sym->attr.in_common
8594 || sym->attr.cray_pointee
8595 || sym->attr.cray_pointer)
8598 /* Now we'll try to build an initializer expression. */
8599 init_expr = gfc_get_expr ();
8600 init_expr->expr_type = EXPR_CONSTANT;
8601 init_expr->ts.type = sym->ts.type;
8602 init_expr->ts.kind = sym->ts.kind;
8603 init_expr->where = sym->declared_at;
8605 /* We will only initialize integers, reals, complex, logicals, and
8606 characters, and only if the corresponding command-line flags
8607 were set. Otherwise, we free init_expr and return null. */
8608 switch (sym->ts.type)
8611 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
8612 mpz_init_set_si (init_expr->value.integer,
8613 gfc_option.flag_init_integer_value);
8616 gfc_free_expr (init_expr);
8622 mpfr_init (init_expr->value.real);
8623 switch (gfc_option.flag_init_real)
8625 case GFC_INIT_REAL_SNAN:
8626 init_expr->is_snan = 1;
8628 case GFC_INIT_REAL_NAN:
8629 mpfr_set_nan (init_expr->value.real);
8632 case GFC_INIT_REAL_INF:
8633 mpfr_set_inf (init_expr->value.real, 1);
8636 case GFC_INIT_REAL_NEG_INF:
8637 mpfr_set_inf (init_expr->value.real, -1);
8640 case GFC_INIT_REAL_ZERO:
8641 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
8645 gfc_free_expr (init_expr);
8652 mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
8653 switch (gfc_option.flag_init_real)
8655 case GFC_INIT_REAL_SNAN:
8656 init_expr->is_snan = 1;
8658 case GFC_INIT_REAL_NAN:
8659 mpfr_set_nan (mpc_realref (init_expr->value.complex));
8660 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
8663 case GFC_INIT_REAL_INF:
8664 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
8665 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
8668 case GFC_INIT_REAL_NEG_INF:
8669 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
8670 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
8673 case GFC_INIT_REAL_ZERO:
8674 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
8678 gfc_free_expr (init_expr);
8685 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
8686 init_expr->value.logical = 0;
8687 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
8688 init_expr->value.logical = 1;
8691 gfc_free_expr (init_expr);
8697 /* For characters, the length must be constant in order to
8698 create a default initializer. */
8699 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
8700 && sym->ts.u.cl->length
8701 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8703 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
8704 init_expr->value.character.length = char_len;
8705 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
8706 for (i = 0; i < char_len; i++)
8707 init_expr->value.character.string[i]
8708 = (unsigned char) gfc_option.flag_init_character_value;
8712 gfc_free_expr (init_expr);
8718 gfc_free_expr (init_expr);
8724 /* Add an initialization expression to a local variable. */
8726 apply_default_init_local (gfc_symbol *sym)
8728 gfc_expr *init = NULL;
8730 /* The symbol should be a variable or a function return value. */
8731 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
8732 || (sym->attr.function && sym->result != sym))
8735 /* Try to build the initializer expression. If we can't initialize
8736 this symbol, then init will be NULL. */
8737 init = build_default_init_expr (sym);
8741 /* For saved variables, we don't want to add an initializer at
8742 function entry, so we just add a static initializer. */
8743 if (sym->attr.save || sym->ns->save_all
8744 || gfc_option.flag_max_stack_var_size == 0)
8746 /* Don't clobber an existing initializer! */
8747 gcc_assert (sym->value == NULL);
8752 build_init_assign (sym, init);
8755 /* Resolution of common features of flavors variable and procedure. */
8758 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
8760 /* Constraints on deferred shape variable. */
8761 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
8763 if (sym->attr.allocatable)
8765 if (sym->attr.dimension)
8767 gfc_error ("Allocatable array '%s' at %L must have "
8768 "a deferred shape", sym->name, &sym->declared_at);
8771 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
8772 "may not be ALLOCATABLE", sym->name,
8773 &sym->declared_at) == FAILURE)
8777 if (sym->attr.pointer && sym->attr.dimension)
8779 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
8780 sym->name, &sym->declared_at);
8787 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
8788 && !sym->attr.dummy && sym->ts.type != BT_CLASS)
8790 gfc_error ("Array '%s' at %L cannot have a deferred shape",
8791 sym->name, &sym->declared_at);
8799 /* Additional checks for symbols with flavor variable and derived
8800 type. To be called from resolve_fl_variable. */
8803 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
8805 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
8807 /* Check to see if a derived type is blocked from being host
8808 associated by the presence of another class I symbol in the same
8809 namespace. 14.6.1.3 of the standard and the discussion on
8810 comp.lang.fortran. */
8811 if (sym->ns != sym->ts.u.derived->ns
8812 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
8815 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
8816 if (s && s->attr.flavor != FL_DERIVED)
8818 gfc_error ("The type '%s' cannot be host associated at %L "
8819 "because it is blocked by an incompatible object "
8820 "of the same name declared at %L",
8821 sym->ts.u.derived->name, &sym->declared_at,
8827 /* 4th constraint in section 11.3: "If an object of a type for which
8828 component-initialization is specified (R429) appears in the
8829 specification-part of a module and does not have the ALLOCATABLE
8830 or POINTER attribute, the object shall have the SAVE attribute."
8832 The check for initializers is performed with
8833 has_default_initializer because gfc_default_initializer generates
8834 a hidden default for allocatable components. */
8835 if (!(sym->value || no_init_flag) && sym->ns->proc_name
8836 && sym->ns->proc_name->attr.flavor == FL_MODULE
8837 && !sym->ns->save_all && !sym->attr.save
8838 && !sym->attr.pointer && !sym->attr.allocatable
8839 && has_default_initializer (sym->ts.u.derived))
8841 gfc_error("Object '%s' at %L must have the SAVE attribute for "
8842 "default initialization of a component",
8843 sym->name, &sym->declared_at);
8847 if (sym->ts.type == BT_CLASS)
8850 if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
8852 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
8853 sym->ts.u.derived->components->ts.u.derived->name,
8854 sym->name, &sym->declared_at);
8859 /* Assume that use associated symbols were checked in the module ns. */
8860 if (!sym->attr.class_ok && !sym->attr.use_assoc)
8862 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
8863 "or pointer", sym->name, &sym->declared_at);
8868 /* Assign default initializer. */
8869 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
8870 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
8872 sym->value = gfc_default_initializer (&sym->ts);
8879 /* Resolve symbols with flavor variable. */
8882 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
8884 int no_init_flag, automatic_flag;
8886 const char *auto_save_msg;
8888 auto_save_msg = "Automatic object '%s' at %L cannot have the "
8891 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
8894 /* Set this flag to check that variables are parameters of all entries.
8895 This check is effected by the call to gfc_resolve_expr through
8896 is_non_constant_shape_array. */
8897 specification_expr = 1;
8899 if (sym->ns->proc_name
8900 && (sym->ns->proc_name->attr.flavor == FL_MODULE
8901 || sym->ns->proc_name->attr.is_main_program)
8902 && !sym->attr.use_assoc
8903 && !sym->attr.allocatable
8904 && !sym->attr.pointer
8905 && is_non_constant_shape_array (sym))
8907 /* The shape of a main program or module array needs to be
8909 gfc_error ("The module or main program array '%s' at %L must "
8910 "have constant shape", sym->name, &sym->declared_at);
8911 specification_expr = 0;
8915 if (sym->ts.type == BT_CHARACTER)
8917 /* Make sure that character string variables with assumed length are
8919 e = sym->ts.u.cl->length;
8920 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
8922 gfc_error ("Entity with assumed character length at %L must be a "
8923 "dummy argument or a PARAMETER", &sym->declared_at);
8927 if (e && sym->attr.save && !gfc_is_constant_expr (e))
8929 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
8933 if (!gfc_is_constant_expr (e)
8934 && !(e->expr_type == EXPR_VARIABLE
8935 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
8936 && sym->ns->proc_name
8937 && (sym->ns->proc_name->attr.flavor == FL_MODULE
8938 || sym->ns->proc_name->attr.is_main_program)
8939 && !sym->attr.use_assoc)
8941 gfc_error ("'%s' at %L must have constant character length "
8942 "in this context", sym->name, &sym->declared_at);
8947 if (sym->value == NULL && sym->attr.referenced)
8948 apply_default_init_local (sym); /* Try to apply a default initialization. */
8950 /* Determine if the symbol may not have an initializer. */
8951 no_init_flag = automatic_flag = 0;
8952 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
8953 || sym->attr.intrinsic || sym->attr.result)
8955 else if (sym->attr.dimension && !sym->attr.pointer
8956 && is_non_constant_shape_array (sym))
8958 no_init_flag = automatic_flag = 1;
8960 /* Also, they must not have the SAVE attribute.
8961 SAVE_IMPLICIT is checked below. */
8962 if (sym->attr.save == SAVE_EXPLICIT)
8964 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
8969 /* Ensure that any initializer is simplified. */
8971 gfc_simplify_expr (sym->value, 1);
8973 /* Reject illegal initializers. */
8974 if (!sym->mark && sym->value)
8976 if (sym->attr.allocatable)
8977 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
8978 sym->name, &sym->declared_at);
8979 else if (sym->attr.external)
8980 gfc_error ("External '%s' at %L cannot have an initializer",
8981 sym->name, &sym->declared_at);
8982 else if (sym->attr.dummy
8983 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
8984 gfc_error ("Dummy '%s' at %L cannot have an initializer",
8985 sym->name, &sym->declared_at);
8986 else if (sym->attr.intrinsic)
8987 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
8988 sym->name, &sym->declared_at);
8989 else if (sym->attr.result)
8990 gfc_error ("Function result '%s' at %L cannot have an initializer",
8991 sym->name, &sym->declared_at);
8992 else if (automatic_flag)
8993 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
8994 sym->name, &sym->declared_at);
9001 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
9002 return resolve_fl_variable_derived (sym, no_init_flag);
9008 /* Resolve a procedure. */
9011 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
9013 gfc_formal_arglist *arg;
9015 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
9016 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
9017 "interfaces", sym->name, &sym->declared_at);
9019 if (sym->attr.function
9020 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
9023 if (sym->ts.type == BT_CHARACTER)
9025 gfc_charlen *cl = sym->ts.u.cl;
9027 if (cl && cl->length && gfc_is_constant_expr (cl->length)
9028 && resolve_charlen (cl) == FAILURE)
9031 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
9033 if (sym->attr.proc == PROC_ST_FUNCTION)
9035 gfc_error ("Character-valued statement function '%s' at %L must "
9036 "have constant length", sym->name, &sym->declared_at);
9040 if (sym->attr.external && sym->formal == NULL
9041 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
9043 gfc_error ("Automatic character length function '%s' at %L must "
9044 "have an explicit interface", sym->name,
9051 /* Ensure that derived type for are not of a private type. Internal
9052 module procedures are excluded by 2.2.3.3 - i.e., they are not
9053 externally accessible and can access all the objects accessible in
9055 if (!(sym->ns->parent
9056 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
9057 && gfc_check_access(sym->attr.access, sym->ns->default_access))
9059 gfc_interface *iface;
9061 for (arg = sym->formal; arg; arg = arg->next)
9064 && arg->sym->ts.type == BT_DERIVED
9065 && !arg->sym->ts.u.derived->attr.use_assoc
9066 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9067 arg->sym->ts.u.derived->ns->default_access)
9068 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
9069 "PRIVATE type and cannot be a dummy argument"
9070 " of '%s', which is PUBLIC at %L",
9071 arg->sym->name, sym->name, &sym->declared_at)
9074 /* Stop this message from recurring. */
9075 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9080 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9081 PRIVATE to the containing module. */
9082 for (iface = sym->generic; iface; iface = iface->next)
9084 for (arg = iface->sym->formal; arg; arg = arg->next)
9087 && arg->sym->ts.type == BT_DERIVED
9088 && !arg->sym->ts.u.derived->attr.use_assoc
9089 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9090 arg->sym->ts.u.derived->ns->default_access)
9091 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
9092 "'%s' in PUBLIC interface '%s' at %L "
9093 "takes dummy arguments of '%s' which is "
9094 "PRIVATE", iface->sym->name, sym->name,
9095 &iface->sym->declared_at,
9096 gfc_typename (&arg->sym->ts)) == FAILURE)
9098 /* Stop this message from recurring. */
9099 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9105 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9106 PRIVATE to the containing module. */
9107 for (iface = sym->generic; iface; iface = iface->next)
9109 for (arg = iface->sym->formal; arg; arg = arg->next)
9112 && arg->sym->ts.type == BT_DERIVED
9113 && !arg->sym->ts.u.derived->attr.use_assoc
9114 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9115 arg->sym->ts.u.derived->ns->default_access)
9116 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
9117 "'%s' in PUBLIC interface '%s' at %L "
9118 "takes dummy arguments of '%s' which is "
9119 "PRIVATE", iface->sym->name, sym->name,
9120 &iface->sym->declared_at,
9121 gfc_typename (&arg->sym->ts)) == FAILURE)
9123 /* Stop this message from recurring. */
9124 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9131 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
9132 && !sym->attr.proc_pointer)
9134 gfc_error ("Function '%s' at %L cannot have an initializer",
9135 sym->name, &sym->declared_at);
9139 /* An external symbol may not have an initializer because it is taken to be
9140 a procedure. Exception: Procedure Pointers. */
9141 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
9143 gfc_error ("External object '%s' at %L may not have an initializer",
9144 sym->name, &sym->declared_at);
9148 /* An elemental function is required to return a scalar 12.7.1 */
9149 if (sym->attr.elemental && sym->attr.function && sym->as)
9151 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
9152 "result", sym->name, &sym->declared_at);
9153 /* Reset so that the error only occurs once. */
9154 sym->attr.elemental = 0;
9158 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
9159 char-len-param shall not be array-valued, pointer-valued, recursive
9160 or pure. ....snip... A character value of * may only be used in the
9161 following ways: (i) Dummy arg of procedure - dummy associates with
9162 actual length; (ii) To declare a named constant; or (iii) External
9163 function - but length must be declared in calling scoping unit. */
9164 if (sym->attr.function
9165 && sym->ts.type == BT_CHARACTER
9166 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
9168 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
9169 || (sym->attr.recursive) || (sym->attr.pure))
9171 if (sym->as && sym->as->rank)
9172 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9173 "array-valued", sym->name, &sym->declared_at);
9175 if (sym->attr.pointer)
9176 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9177 "pointer-valued", sym->name, &sym->declared_at);
9180 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9181 "pure", sym->name, &sym->declared_at);
9183 if (sym->attr.recursive)
9184 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9185 "recursive", sym->name, &sym->declared_at);
9190 /* Appendix B.2 of the standard. Contained functions give an
9191 error anyway. Fixed-form is likely to be F77/legacy. */
9192 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
9193 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
9194 "CHARACTER(*) function '%s' at %L",
9195 sym->name, &sym->declared_at);
9198 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
9200 gfc_formal_arglist *curr_arg;
9201 int has_non_interop_arg = 0;
9203 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9204 sym->common_block) == FAILURE)
9206 /* Clear these to prevent looking at them again if there was an
9208 sym->attr.is_bind_c = 0;
9209 sym->attr.is_c_interop = 0;
9210 sym->ts.is_c_interop = 0;
9214 /* So far, no errors have been found. */
9215 sym->attr.is_c_interop = 1;
9216 sym->ts.is_c_interop = 1;
9219 curr_arg = sym->formal;
9220 while (curr_arg != NULL)
9222 /* Skip implicitly typed dummy args here. */
9223 if (curr_arg->sym->attr.implicit_type == 0)
9224 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
9225 /* If something is found to fail, record the fact so we
9226 can mark the symbol for the procedure as not being
9227 BIND(C) to try and prevent multiple errors being
9229 has_non_interop_arg = 1;
9231 curr_arg = curr_arg->next;
9234 /* See if any of the arguments were not interoperable and if so, clear
9235 the procedure symbol to prevent duplicate error messages. */
9236 if (has_non_interop_arg != 0)
9238 sym->attr.is_c_interop = 0;
9239 sym->ts.is_c_interop = 0;
9240 sym->attr.is_bind_c = 0;
9244 if (!sym->attr.proc_pointer)
9246 if (sym->attr.save == SAVE_EXPLICIT)
9248 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
9249 "in '%s' at %L", sym->name, &sym->declared_at);
9252 if (sym->attr.intent)
9254 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
9255 "in '%s' at %L", sym->name, &sym->declared_at);
9258 if (sym->attr.subroutine && sym->attr.result)
9260 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
9261 "in '%s' at %L", sym->name, &sym->declared_at);
9264 if (sym->attr.external && sym->attr.function
9265 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
9266 || sym->attr.contained))
9268 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
9269 "in '%s' at %L", sym->name, &sym->declared_at);
9272 if (strcmp ("ppr@", sym->name) == 0)
9274 gfc_error ("Procedure pointer result '%s' at %L "
9275 "is missing the pointer attribute",
9276 sym->ns->proc_name->name, &sym->declared_at);
9285 /* Resolve a list of finalizer procedures. That is, after they have hopefully
9286 been defined and we now know their defined arguments, check that they fulfill
9287 the requirements of the standard for procedures used as finalizers. */
9290 gfc_resolve_finalizers (gfc_symbol* derived)
9292 gfc_finalizer* list;
9293 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
9294 gfc_try result = SUCCESS;
9295 bool seen_scalar = false;
9297 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
9300 /* Walk over the list of finalizer-procedures, check them, and if any one
9301 does not fit in with the standard's definition, print an error and remove
9302 it from the list. */
9303 prev_link = &derived->f2k_derived->finalizers;
9304 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
9310 /* Skip this finalizer if we already resolved it. */
9311 if (list->proc_tree)
9313 prev_link = &(list->next);
9317 /* Check this exists and is a SUBROUTINE. */
9318 if (!list->proc_sym->attr.subroutine)
9320 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
9321 list->proc_sym->name, &list->where);
9325 /* We should have exactly one argument. */
9326 if (!list->proc_sym->formal || list->proc_sym->formal->next)
9328 gfc_error ("FINAL procedure at %L must have exactly one argument",
9332 arg = list->proc_sym->formal->sym;
9334 /* This argument must be of our type. */
9335 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
9337 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
9338 &arg->declared_at, derived->name);
9342 /* It must neither be a pointer nor allocatable nor optional. */
9343 if (arg->attr.pointer)
9345 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
9349 if (arg->attr.allocatable)
9351 gfc_error ("Argument of FINAL procedure at %L must not be"
9352 " ALLOCATABLE", &arg->declared_at);
9355 if (arg->attr.optional)
9357 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
9362 /* It must not be INTENT(OUT). */
9363 if (arg->attr.intent == INTENT_OUT)
9365 gfc_error ("Argument of FINAL procedure at %L must not be"
9366 " INTENT(OUT)", &arg->declared_at);
9370 /* Warn if the procedure is non-scalar and not assumed shape. */
9371 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
9372 && arg->as->type != AS_ASSUMED_SHAPE)
9373 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
9374 " shape argument", &arg->declared_at);
9376 /* Check that it does not match in kind and rank with a FINAL procedure
9377 defined earlier. To really loop over the *earlier* declarations,
9378 we need to walk the tail of the list as new ones were pushed at the
9380 /* TODO: Handle kind parameters once they are implemented. */
9381 my_rank = (arg->as ? arg->as->rank : 0);
9382 for (i = list->next; i; i = i->next)
9384 /* Argument list might be empty; that is an error signalled earlier,
9385 but we nevertheless continued resolving. */
9386 if (i->proc_sym->formal)
9388 gfc_symbol* i_arg = i->proc_sym->formal->sym;
9389 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
9390 if (i_rank == my_rank)
9392 gfc_error ("FINAL procedure '%s' declared at %L has the same"
9393 " rank (%d) as '%s'",
9394 list->proc_sym->name, &list->where, my_rank,
9401 /* Is this the/a scalar finalizer procedure? */
9402 if (!arg->as || arg->as->rank == 0)
9405 /* Find the symtree for this procedure. */
9406 gcc_assert (!list->proc_tree);
9407 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
9409 prev_link = &list->next;
9412 /* Remove wrong nodes immediately from the list so we don't risk any
9413 troubles in the future when they might fail later expectations. */
9417 *prev_link = list->next;
9418 gfc_free_finalizer (i);
9421 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
9422 were nodes in the list, must have been for arrays. It is surely a good
9423 idea to have a scalar version there if there's something to finalize. */
9424 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
9425 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
9426 " defined at %L, suggest also scalar one",
9427 derived->name, &derived->declared_at);
9429 /* TODO: Remove this error when finalization is finished. */
9430 gfc_error ("Finalization at %L is not yet implemented",
9431 &derived->declared_at);
9437 /* Check that it is ok for the typebound procedure proc to override the
9441 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
9444 const gfc_symbol* proc_target;
9445 const gfc_symbol* old_target;
9446 unsigned proc_pass_arg, old_pass_arg, argpos;
9447 gfc_formal_arglist* proc_formal;
9448 gfc_formal_arglist* old_formal;
9450 /* This procedure should only be called for non-GENERIC proc. */
9451 gcc_assert (!proc->n.tb->is_generic);
9453 /* If the overwritten procedure is GENERIC, this is an error. */
9454 if (old->n.tb->is_generic)
9456 gfc_error ("Can't overwrite GENERIC '%s' at %L",
9457 old->name, &proc->n.tb->where);
9461 where = proc->n.tb->where;
9462 proc_target = proc->n.tb->u.specific->n.sym;
9463 old_target = old->n.tb->u.specific->n.sym;
9465 /* Check that overridden binding is not NON_OVERRIDABLE. */
9466 if (old->n.tb->non_overridable)
9468 gfc_error ("'%s' at %L overrides a procedure binding declared"
9469 " NON_OVERRIDABLE", proc->name, &where);
9473 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
9474 if (!old->n.tb->deferred && proc->n.tb->deferred)
9476 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
9477 " non-DEFERRED binding", proc->name, &where);
9481 /* If the overridden binding is PURE, the overriding must be, too. */
9482 if (old_target->attr.pure && !proc_target->attr.pure)
9484 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
9485 proc->name, &where);
9489 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
9490 is not, the overriding must not be either. */
9491 if (old_target->attr.elemental && !proc_target->attr.elemental)
9493 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
9494 " ELEMENTAL", proc->name, &where);
9497 if (!old_target->attr.elemental && proc_target->attr.elemental)
9499 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
9500 " be ELEMENTAL, either", proc->name, &where);
9504 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
9506 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
9508 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
9509 " SUBROUTINE", proc->name, &where);
9513 /* If the overridden binding is a FUNCTION, the overriding must also be a
9514 FUNCTION and have the same characteristics. */
9515 if (old_target->attr.function)
9517 if (!proc_target->attr.function)
9519 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
9520 " FUNCTION", proc->name, &where);
9524 /* FIXME: Do more comprehensive checking (including, for instance, the
9525 rank and array-shape). */
9526 gcc_assert (proc_target->result && old_target->result);
9527 if (!gfc_compare_types (&proc_target->result->ts,
9528 &old_target->result->ts))
9530 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
9531 " matching result types", proc->name, &where);
9536 /* If the overridden binding is PUBLIC, the overriding one must not be
9538 if (old->n.tb->access == ACCESS_PUBLIC
9539 && proc->n.tb->access == ACCESS_PRIVATE)
9541 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
9542 " PRIVATE", proc->name, &where);
9546 /* Compare the formal argument lists of both procedures. This is also abused
9547 to find the position of the passed-object dummy arguments of both
9548 bindings as at least the overridden one might not yet be resolved and we
9549 need those positions in the check below. */
9550 proc_pass_arg = old_pass_arg = 0;
9551 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
9553 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
9556 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
9557 proc_formal && old_formal;
9558 proc_formal = proc_formal->next, old_formal = old_formal->next)
9560 if (proc->n.tb->pass_arg
9561 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
9562 proc_pass_arg = argpos;
9563 if (old->n.tb->pass_arg
9564 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
9565 old_pass_arg = argpos;
9567 /* Check that the names correspond. */
9568 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
9570 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
9571 " to match the corresponding argument of the overridden"
9572 " procedure", proc_formal->sym->name, proc->name, &where,
9573 old_formal->sym->name);
9577 /* Check that the types correspond if neither is the passed-object
9579 /* FIXME: Do more comprehensive testing here. */
9580 if (proc_pass_arg != argpos && old_pass_arg != argpos
9581 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
9583 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
9584 "in respect to the overridden procedure",
9585 proc_formal->sym->name, proc->name, &where);
9591 if (proc_formal || old_formal)
9593 gfc_error ("'%s' at %L must have the same number of formal arguments as"
9594 " the overridden procedure", proc->name, &where);
9598 /* If the overridden binding is NOPASS, the overriding one must also be
9600 if (old->n.tb->nopass && !proc->n.tb->nopass)
9602 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
9603 " NOPASS", proc->name, &where);
9607 /* If the overridden binding is PASS(x), the overriding one must also be
9608 PASS and the passed-object dummy arguments must correspond. */
9609 if (!old->n.tb->nopass)
9611 if (proc->n.tb->nopass)
9613 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
9614 " PASS", proc->name, &where);
9618 if (proc_pass_arg != old_pass_arg)
9620 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
9621 " the same position as the passed-object dummy argument of"
9622 " the overridden procedure", proc->name, &where);
9631 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
9634 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
9635 const char* generic_name, locus where)
9640 gcc_assert (t1->specific && t2->specific);
9641 gcc_assert (!t1->specific->is_generic);
9642 gcc_assert (!t2->specific->is_generic);
9644 sym1 = t1->specific->u.specific->n.sym;
9645 sym2 = t2->specific->u.specific->n.sym;
9650 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
9651 if (sym1->attr.subroutine != sym2->attr.subroutine
9652 || sym1->attr.function != sym2->attr.function)
9654 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
9655 " GENERIC '%s' at %L",
9656 sym1->name, sym2->name, generic_name, &where);
9660 /* Compare the interfaces. */
9661 if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0))
9663 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
9664 sym1->name, sym2->name, generic_name, &where);
9672 /* Worker function for resolving a generic procedure binding; this is used to
9673 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
9675 The difference between those cases is finding possible inherited bindings
9676 that are overridden, as one has to look for them in tb_sym_root,
9677 tb_uop_root or tb_op, respectively. Thus the caller must already find
9678 the super-type and set p->overridden correctly. */
9681 resolve_tb_generic_targets (gfc_symbol* super_type,
9682 gfc_typebound_proc* p, const char* name)
9684 gfc_tbp_generic* target;
9685 gfc_symtree* first_target;
9686 gfc_symtree* inherited;
9688 gcc_assert (p && p->is_generic);
9690 /* Try to find the specific bindings for the symtrees in our target-list. */
9691 gcc_assert (p->u.generic);
9692 for (target = p->u.generic; target; target = target->next)
9693 if (!target->specific)
9695 gfc_typebound_proc* overridden_tbp;
9697 const char* target_name;
9699 target_name = target->specific_st->name;
9701 /* Defined for this type directly. */
9702 if (target->specific_st->n.tb)
9704 target->specific = target->specific_st->n.tb;
9705 goto specific_found;
9708 /* Look for an inherited specific binding. */
9711 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
9716 gcc_assert (inherited->n.tb);
9717 target->specific = inherited->n.tb;
9718 goto specific_found;
9722 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
9723 " at %L", target_name, name, &p->where);
9726 /* Once we've found the specific binding, check it is not ambiguous with
9727 other specifics already found or inherited for the same GENERIC. */
9729 gcc_assert (target->specific);
9731 /* This must really be a specific binding! */
9732 if (target->specific->is_generic)
9734 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
9735 " '%s' is GENERIC, too", name, &p->where, target_name);
9739 /* Check those already resolved on this type directly. */
9740 for (g = p->u.generic; g; g = g->next)
9741 if (g != target && g->specific
9742 && check_generic_tbp_ambiguity (target, g, name, p->where)
9746 /* Check for ambiguity with inherited specific targets. */
9747 for (overridden_tbp = p->overridden; overridden_tbp;
9748 overridden_tbp = overridden_tbp->overridden)
9749 if (overridden_tbp->is_generic)
9751 for (g = overridden_tbp->u.generic; g; g = g->next)
9753 gcc_assert (g->specific);
9754 if (check_generic_tbp_ambiguity (target, g,
9755 name, p->where) == FAILURE)
9761 /* If we attempt to "overwrite" a specific binding, this is an error. */
9762 if (p->overridden && !p->overridden->is_generic)
9764 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
9765 " the same name", name, &p->where);
9769 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
9770 all must have the same attributes here. */
9771 first_target = p->u.generic->specific->u.specific;
9772 gcc_assert (first_target);
9773 p->subroutine = first_target->n.sym->attr.subroutine;
9774 p->function = first_target->n.sym->attr.function;
9780 /* Resolve a GENERIC procedure binding for a derived type. */
9783 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
9785 gfc_symbol* super_type;
9787 /* Find the overridden binding if any. */
9788 st->n.tb->overridden = NULL;
9789 super_type = gfc_get_derived_super_type (derived);
9792 gfc_symtree* overridden;
9793 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
9796 if (overridden && overridden->n.tb)
9797 st->n.tb->overridden = overridden->n.tb;
9800 /* Resolve using worker function. */
9801 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
9805 /* Retrieve the target-procedure of an operator binding and do some checks in
9806 common for intrinsic and user-defined type-bound operators. */
9809 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
9811 gfc_symbol* target_proc;
9813 gcc_assert (target->specific && !target->specific->is_generic);
9814 target_proc = target->specific->u.specific->n.sym;
9815 gcc_assert (target_proc);
9817 /* All operator bindings must have a passed-object dummy argument. */
9818 if (target->specific->nopass)
9820 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
9828 /* Resolve a type-bound intrinsic operator. */
9831 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
9832 gfc_typebound_proc* p)
9834 gfc_symbol* super_type;
9835 gfc_tbp_generic* target;
9837 /* If there's already an error here, do nothing (but don't fail again). */
9841 /* Operators should always be GENERIC bindings. */
9842 gcc_assert (p->is_generic);
9844 /* Look for an overridden binding. */
9845 super_type = gfc_get_derived_super_type (derived);
9846 if (super_type && super_type->f2k_derived)
9847 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
9850 p->overridden = NULL;
9852 /* Resolve general GENERIC properties using worker function. */
9853 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
9856 /* Check the targets to be procedures of correct interface. */
9857 for (target = p->u.generic; target; target = target->next)
9859 gfc_symbol* target_proc;
9861 target_proc = get_checked_tb_operator_target (target, p->where);
9865 if (!gfc_check_operator_interface (target_proc, op, p->where))
9877 /* Resolve a type-bound user operator (tree-walker callback). */
9879 static gfc_symbol* resolve_bindings_derived;
9880 static gfc_try resolve_bindings_result;
9882 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
9885 resolve_typebound_user_op (gfc_symtree* stree)
9887 gfc_symbol* super_type;
9888 gfc_tbp_generic* target;
9890 gcc_assert (stree && stree->n.tb);
9892 if (stree->n.tb->error)
9895 /* Operators should always be GENERIC bindings. */
9896 gcc_assert (stree->n.tb->is_generic);
9898 /* Find overridden procedure, if any. */
9899 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
9900 if (super_type && super_type->f2k_derived)
9902 gfc_symtree* overridden;
9903 overridden = gfc_find_typebound_user_op (super_type, NULL,
9904 stree->name, true, NULL);
9906 if (overridden && overridden->n.tb)
9907 stree->n.tb->overridden = overridden->n.tb;
9910 stree->n.tb->overridden = NULL;
9912 /* Resolve basically using worker function. */
9913 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
9917 /* Check the targets to be functions of correct interface. */
9918 for (target = stree->n.tb->u.generic; target; target = target->next)
9920 gfc_symbol* target_proc;
9922 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
9926 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
9933 resolve_bindings_result = FAILURE;
9934 stree->n.tb->error = 1;
9938 /* Resolve the type-bound procedures for a derived type. */
9941 resolve_typebound_procedure (gfc_symtree* stree)
9946 gfc_symbol* super_type;
9947 gfc_component* comp;
9951 /* Undefined specific symbol from GENERIC target definition. */
9955 if (stree->n.tb->error)
9958 /* If this is a GENERIC binding, use that routine. */
9959 if (stree->n.tb->is_generic)
9961 if (resolve_typebound_generic (resolve_bindings_derived, stree)
9967 /* Get the target-procedure to check it. */
9968 gcc_assert (!stree->n.tb->is_generic);
9969 gcc_assert (stree->n.tb->u.specific);
9970 proc = stree->n.tb->u.specific->n.sym;
9971 where = stree->n.tb->where;
9973 /* Default access should already be resolved from the parser. */
9974 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
9976 /* It should be a module procedure or an external procedure with explicit
9977 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
9978 if ((!proc->attr.subroutine && !proc->attr.function)
9979 || (proc->attr.proc != PROC_MODULE
9980 && proc->attr.if_source != IFSRC_IFBODY)
9981 || (proc->attr.abstract && !stree->n.tb->deferred))
9983 gfc_error ("'%s' must be a module procedure or an external procedure with"
9984 " an explicit interface at %L", proc->name, &where);
9987 stree->n.tb->subroutine = proc->attr.subroutine;
9988 stree->n.tb->function = proc->attr.function;
9990 /* Find the super-type of the current derived type. We could do this once and
9991 store in a global if speed is needed, but as long as not I believe this is
9992 more readable and clearer. */
9993 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
9995 /* If PASS, resolve and check arguments if not already resolved / loaded
9996 from a .mod file. */
9997 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
9999 if (stree->n.tb->pass_arg)
10001 gfc_formal_arglist* i;
10003 /* If an explicit passing argument name is given, walk the arg-list
10004 and look for it. */
10007 stree->n.tb->pass_arg_num = 1;
10008 for (i = proc->formal; i; i = i->next)
10010 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
10015 ++stree->n.tb->pass_arg_num;
10020 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
10022 proc->name, stree->n.tb->pass_arg, &where,
10023 stree->n.tb->pass_arg);
10029 /* Otherwise, take the first one; there should in fact be at least
10031 stree->n.tb->pass_arg_num = 1;
10034 gfc_error ("Procedure '%s' with PASS at %L must have at"
10035 " least one argument", proc->name, &where);
10038 me_arg = proc->formal->sym;
10041 /* Now check that the argument-type matches. */
10042 gcc_assert (me_arg);
10043 if (me_arg->ts.type != BT_CLASS)
10045 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10046 " at %L", proc->name, &where);
10050 if (me_arg->ts.u.derived->components->ts.u.derived
10051 != resolve_bindings_derived)
10053 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10054 " the derived-type '%s'", me_arg->name, proc->name,
10055 me_arg->name, &where, resolve_bindings_derived->name);
10061 /* If we are extending some type, check that we don't override a procedure
10062 flagged NON_OVERRIDABLE. */
10063 stree->n.tb->overridden = NULL;
10066 gfc_symtree* overridden;
10067 overridden = gfc_find_typebound_proc (super_type, NULL,
10068 stree->name, true, NULL);
10070 if (overridden && overridden->n.tb)
10071 stree->n.tb->overridden = overridden->n.tb;
10073 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
10077 /* See if there's a name collision with a component directly in this type. */
10078 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
10079 if (!strcmp (comp->name, stree->name))
10081 gfc_error ("Procedure '%s' at %L has the same name as a component of"
10083 stree->name, &where, resolve_bindings_derived->name);
10087 /* Try to find a name collision with an inherited component. */
10088 if (super_type && gfc_find_component (super_type, stree->name, true, true))
10090 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
10091 " component of '%s'",
10092 stree->name, &where, resolve_bindings_derived->name);
10096 stree->n.tb->error = 0;
10100 resolve_bindings_result = FAILURE;
10101 stree->n.tb->error = 1;
10105 resolve_typebound_procedures (gfc_symbol* derived)
10109 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
10112 resolve_bindings_derived = derived;
10113 resolve_bindings_result = SUCCESS;
10115 if (derived->f2k_derived->tb_sym_root)
10116 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
10117 &resolve_typebound_procedure);
10119 if (derived->f2k_derived->tb_uop_root)
10120 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
10121 &resolve_typebound_user_op);
10123 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
10125 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
10126 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
10128 resolve_bindings_result = FAILURE;
10131 return resolve_bindings_result;
10135 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
10136 to give all identical derived types the same backend_decl. */
10138 add_dt_to_dt_list (gfc_symbol *derived)
10140 gfc_dt_list *dt_list;
10142 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
10143 if (derived == dt_list->derived)
10146 if (dt_list == NULL)
10148 dt_list = gfc_get_dt_list ();
10149 dt_list->next = gfc_derived_types;
10150 dt_list->derived = derived;
10151 gfc_derived_types = dt_list;
10156 /* Ensure that a derived-type is really not abstract, meaning that every
10157 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
10160 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
10165 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
10167 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
10170 if (st->n.tb && st->n.tb->deferred)
10172 gfc_symtree* overriding;
10173 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
10174 gcc_assert (overriding && overriding->n.tb);
10175 if (overriding->n.tb->deferred)
10177 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
10178 " '%s' is DEFERRED and not overridden",
10179 sub->name, &sub->declared_at, st->name);
10188 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
10190 /* The algorithm used here is to recursively travel up the ancestry of sub
10191 and for each ancestor-type, check all bindings. If any of them is
10192 DEFERRED, look it up starting from sub and see if the found (overriding)
10193 binding is not DEFERRED.
10194 This is not the most efficient way to do this, but it should be ok and is
10195 clearer than something sophisticated. */
10197 gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
10199 /* Walk bindings of this ancestor. */
10200 if (ancestor->f2k_derived)
10203 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
10208 /* Find next ancestor type and recurse on it. */
10209 ancestor = gfc_get_derived_super_type (ancestor);
10211 return ensure_not_abstract (sub, ancestor);
10217 static void resolve_symbol (gfc_symbol *sym);
10220 /* Resolve the components of a derived type. */
10223 resolve_fl_derived (gfc_symbol *sym)
10225 gfc_symbol* super_type;
10229 super_type = gfc_get_derived_super_type (sym);
10231 /* Ensure the extended type gets resolved before we do. */
10232 if (super_type && resolve_fl_derived (super_type) == FAILURE)
10235 /* An ABSTRACT type must be extensible. */
10236 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
10238 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
10239 sym->name, &sym->declared_at);
10243 for (c = sym->components; c != NULL; c = c->next)
10245 if (c->attr.proc_pointer && c->ts.interface)
10247 if (c->ts.interface->attr.procedure)
10248 gfc_error ("Interface '%s', used by procedure pointer component "
10249 "'%s' at %L, is declared in a later PROCEDURE statement",
10250 c->ts.interface->name, c->name, &c->loc);
10252 /* Get the attributes from the interface (now resolved). */
10253 if (c->ts.interface->attr.if_source
10254 || c->ts.interface->attr.intrinsic)
10256 gfc_symbol *ifc = c->ts.interface;
10258 if (ifc->formal && !ifc->formal_ns)
10259 resolve_symbol (ifc);
10261 if (ifc->attr.intrinsic)
10262 resolve_intrinsic (ifc, &ifc->declared_at);
10266 c->ts = ifc->result->ts;
10267 c->attr.allocatable = ifc->result->attr.allocatable;
10268 c->attr.pointer = ifc->result->attr.pointer;
10269 c->attr.dimension = ifc->result->attr.dimension;
10270 c->as = gfc_copy_array_spec (ifc->result->as);
10275 c->attr.allocatable = ifc->attr.allocatable;
10276 c->attr.pointer = ifc->attr.pointer;
10277 c->attr.dimension = ifc->attr.dimension;
10278 c->as = gfc_copy_array_spec (ifc->as);
10280 c->ts.interface = ifc;
10281 c->attr.function = ifc->attr.function;
10282 c->attr.subroutine = ifc->attr.subroutine;
10283 gfc_copy_formal_args_ppc (c, ifc);
10285 c->attr.pure = ifc->attr.pure;
10286 c->attr.elemental = ifc->attr.elemental;
10287 c->attr.recursive = ifc->attr.recursive;
10288 c->attr.always_explicit = ifc->attr.always_explicit;
10289 c->attr.ext_attr |= ifc->attr.ext_attr;
10290 /* Replace symbols in array spec. */
10294 for (i = 0; i < c->as->rank; i++)
10296 gfc_expr_replace_comp (c->as->lower[i], c);
10297 gfc_expr_replace_comp (c->as->upper[i], c);
10300 /* Copy char length. */
10301 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
10303 c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
10304 gfc_expr_replace_comp (c->ts.u.cl->length, c);
10307 else if (c->ts.interface->name[0] != '\0')
10309 gfc_error ("Interface '%s' of procedure pointer component "
10310 "'%s' at %L must be explicit", c->ts.interface->name,
10315 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
10317 /* Since PPCs are not implicitly typed, a PPC without an explicit
10318 interface must be a subroutine. */
10319 gfc_add_subroutine (&c->attr, c->name, &c->loc);
10322 /* Procedure pointer components: Check PASS arg. */
10323 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
10325 gfc_symbol* me_arg;
10327 if (c->tb->pass_arg)
10329 gfc_formal_arglist* i;
10331 /* If an explicit passing argument name is given, walk the arg-list
10332 and look for it. */
10335 c->tb->pass_arg_num = 1;
10336 for (i = c->formal; i; i = i->next)
10338 if (!strcmp (i->sym->name, c->tb->pass_arg))
10343 c->tb->pass_arg_num++;
10348 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
10349 "at %L has no argument '%s'", c->name,
10350 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
10357 /* Otherwise, take the first one; there should in fact be at least
10359 c->tb->pass_arg_num = 1;
10362 gfc_error ("Procedure pointer component '%s' with PASS at %L "
10363 "must have at least one argument",
10368 me_arg = c->formal->sym;
10371 /* Now check that the argument-type matches. */
10372 gcc_assert (me_arg);
10373 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
10374 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
10375 || (me_arg->ts.type == BT_CLASS
10376 && me_arg->ts.u.derived->components->ts.u.derived != sym))
10378 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10379 " the derived type '%s'", me_arg->name, c->name,
10380 me_arg->name, &c->loc, sym->name);
10385 /* Check for C453. */
10386 if (me_arg->attr.dimension)
10388 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10389 "must be scalar", me_arg->name, c->name, me_arg->name,
10395 if (me_arg->attr.pointer)
10397 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10398 "may not have the POINTER attribute", me_arg->name,
10399 c->name, me_arg->name, &c->loc);
10404 if (me_arg->attr.allocatable)
10406 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10407 "may not be ALLOCATABLE", me_arg->name, c->name,
10408 me_arg->name, &c->loc);
10413 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
10414 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10415 " at %L", c->name, &c->loc);
10419 /* Check type-spec if this is not the parent-type component. */
10420 if ((!sym->attr.extension || c != sym->components)
10421 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
10424 /* If this type is an extension, see if this component has the same name
10425 as an inherited type-bound procedure. */
10427 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
10429 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
10430 " inherited type-bound procedure",
10431 c->name, sym->name, &c->loc);
10435 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
10437 if (c->ts.u.cl->length == NULL
10438 || (resolve_charlen (c->ts.u.cl) == FAILURE)
10439 || !gfc_is_constant_expr (c->ts.u.cl->length))
10441 gfc_error ("Character length of component '%s' needs to "
10442 "be a constant specification expression at %L",
10444 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
10449 if (c->ts.type == BT_DERIVED
10450 && sym->component_access != ACCESS_PRIVATE
10451 && gfc_check_access (sym->attr.access, sym->ns->default_access)
10452 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
10453 && !c->ts.u.derived->attr.use_assoc
10454 && !gfc_check_access (c->ts.u.derived->attr.access,
10455 c->ts.u.derived->ns->default_access)
10456 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
10457 "is a PRIVATE type and cannot be a component of "
10458 "'%s', which is PUBLIC at %L", c->name,
10459 sym->name, &sym->declared_at) == FAILURE)
10462 if (sym->attr.sequence)
10464 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
10466 gfc_error ("Component %s of SEQUENCE type declared at %L does "
10467 "not have the SEQUENCE attribute",
10468 c->ts.u.derived->name, &sym->declared_at);
10473 if (c->ts.type == BT_DERIVED && c->attr.pointer
10474 && c->ts.u.derived->components == NULL
10475 && !c->ts.u.derived->attr.zero_comp)
10477 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10478 "that has not been declared", c->name, sym->name,
10484 if (c->ts.type == BT_CLASS
10485 && !(c->ts.u.derived->components->attr.pointer
10486 || c->ts.u.derived->components->attr.allocatable))
10488 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
10489 "or pointer", c->name, &c->loc);
10493 /* Ensure that all the derived type components are put on the
10494 derived type list; even in formal namespaces, where derived type
10495 pointer components might not have been declared. */
10496 if (c->ts.type == BT_DERIVED
10498 && c->ts.u.derived->components
10500 && sym != c->ts.u.derived)
10501 add_dt_to_dt_list (c->ts.u.derived);
10503 if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
10507 for (i = 0; i < c->as->rank; i++)
10509 if (c->as->lower[i] == NULL
10510 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
10511 || !gfc_is_constant_expr (c->as->lower[i])
10512 || c->as->upper[i] == NULL
10513 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
10514 || !gfc_is_constant_expr (c->as->upper[i]))
10516 gfc_error ("Component '%s' of '%s' at %L must have "
10517 "constant array bounds",
10518 c->name, sym->name, &c->loc);
10524 /* Resolve the type-bound procedures. */
10525 if (resolve_typebound_procedures (sym) == FAILURE)
10528 /* Resolve the finalizer procedures. */
10529 if (gfc_resolve_finalizers (sym) == FAILURE)
10532 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
10533 all DEFERRED bindings are overridden. */
10534 if (super_type && super_type->attr.abstract && !sym->attr.abstract
10535 && ensure_not_abstract (sym, super_type) == FAILURE)
10538 /* Add derived type to the derived type list. */
10539 add_dt_to_dt_list (sym);
10546 resolve_fl_namelist (gfc_symbol *sym)
10551 /* Reject PRIVATE objects in a PUBLIC namelist. */
10552 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
10554 for (nl = sym->namelist; nl; nl = nl->next)
10556 if (!nl->sym->attr.use_assoc
10557 && !is_sym_host_assoc (nl->sym, sym->ns)
10558 && !gfc_check_access(nl->sym->attr.access,
10559 nl->sym->ns->default_access))
10561 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
10562 "cannot be member of PUBLIC namelist '%s' at %L",
10563 nl->sym->name, sym->name, &sym->declared_at);
10567 /* Types with private components that came here by USE-association. */
10568 if (nl->sym->ts.type == BT_DERIVED
10569 && derived_inaccessible (nl->sym->ts.u.derived))
10571 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
10572 "components and cannot be member of namelist '%s' at %L",
10573 nl->sym->name, sym->name, &sym->declared_at);
10577 /* Types with private components that are defined in the same module. */
10578 if (nl->sym->ts.type == BT_DERIVED
10579 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
10580 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
10581 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
10582 nl->sym->ns->default_access))
10584 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
10585 "cannot be a member of PUBLIC namelist '%s' at %L",
10586 nl->sym->name, sym->name, &sym->declared_at);
10592 for (nl = sym->namelist; nl; nl = nl->next)
10594 /* Reject namelist arrays of assumed shape. */
10595 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
10596 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
10597 "must not have assumed shape in namelist "
10598 "'%s' at %L", nl->sym->name, sym->name,
10599 &sym->declared_at) == FAILURE)
10602 /* Reject namelist arrays that are not constant shape. */
10603 if (is_non_constant_shape_array (nl->sym))
10605 gfc_error ("NAMELIST array object '%s' must have constant "
10606 "shape in namelist '%s' at %L", nl->sym->name,
10607 sym->name, &sym->declared_at);
10611 /* Namelist objects cannot have allocatable or pointer components. */
10612 if (nl->sym->ts.type != BT_DERIVED)
10615 if (nl->sym->ts.u.derived->attr.alloc_comp)
10617 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
10618 "have ALLOCATABLE components",
10619 nl->sym->name, sym->name, &sym->declared_at);
10623 if (nl->sym->ts.u.derived->attr.pointer_comp)
10625 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
10626 "have POINTER components",
10627 nl->sym->name, sym->name, &sym->declared_at);
10633 /* 14.1.2 A module or internal procedure represent local entities
10634 of the same type as a namelist member and so are not allowed. */
10635 for (nl = sym->namelist; nl; nl = nl->next)
10637 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
10640 if (nl->sym->attr.function && nl->sym == nl->sym->result)
10641 if ((nl->sym == sym->ns->proc_name)
10643 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
10647 if (nl->sym && nl->sym->name)
10648 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
10649 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
10651 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
10652 "attribute in '%s' at %L", nlsym->name,
10653 &sym->declared_at);
10663 resolve_fl_parameter (gfc_symbol *sym)
10665 /* A parameter array's shape needs to be constant. */
10666 if (sym->as != NULL
10667 && (sym->as->type == AS_DEFERRED
10668 || is_non_constant_shape_array (sym)))
10670 gfc_error ("Parameter array '%s' at %L cannot be automatic "
10671 "or of deferred shape", sym->name, &sym->declared_at);
10675 /* Make sure a parameter that has been implicitly typed still
10676 matches the implicit type, since PARAMETER statements can precede
10677 IMPLICIT statements. */
10678 if (sym->attr.implicit_type
10679 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
10682 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
10683 "later IMPLICIT type", sym->name, &sym->declared_at);
10687 /* Make sure the types of derived parameters are consistent. This
10688 type checking is deferred until resolution because the type may
10689 refer to a derived type from the host. */
10690 if (sym->ts.type == BT_DERIVED
10691 && !gfc_compare_types (&sym->ts, &sym->value->ts))
10693 gfc_error ("Incompatible derived type in PARAMETER at %L",
10694 &sym->value->where);
10701 /* Do anything necessary to resolve a symbol. Right now, we just
10702 assume that an otherwise unknown symbol is a variable. This sort
10703 of thing commonly happens for symbols in module. */
10706 resolve_symbol (gfc_symbol *sym)
10708 int check_constant, mp_flag;
10709 gfc_symtree *symtree;
10710 gfc_symtree *this_symtree;
10714 if (sym->attr.flavor == FL_UNKNOWN)
10717 /* If we find that a flavorless symbol is an interface in one of the
10718 parent namespaces, find its symtree in this namespace, free the
10719 symbol and set the symtree to point to the interface symbol. */
10720 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
10722 symtree = gfc_find_symtree (ns->sym_root, sym->name);
10723 if (symtree && symtree->n.sym->generic)
10725 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
10729 gfc_free_symbol (sym);
10730 symtree->n.sym->refs++;
10731 this_symtree->n.sym = symtree->n.sym;
10736 /* Otherwise give it a flavor according to such attributes as
10738 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
10739 sym->attr.flavor = FL_VARIABLE;
10742 sym->attr.flavor = FL_PROCEDURE;
10743 if (sym->attr.dimension)
10744 sym->attr.function = 1;
10748 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
10749 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
10751 if (sym->attr.procedure && sym->ts.interface
10752 && sym->attr.if_source != IFSRC_DECL)
10754 if (sym->ts.interface == sym)
10756 gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
10757 "interface", sym->name, &sym->declared_at);
10760 if (sym->ts.interface->attr.procedure)
10762 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
10763 " in a later PROCEDURE statement", sym->ts.interface->name,
10764 sym->name,&sym->declared_at);
10768 /* Get the attributes from the interface (now resolved). */
10769 if (sym->ts.interface->attr.if_source
10770 || sym->ts.interface->attr.intrinsic)
10772 gfc_symbol *ifc = sym->ts.interface;
10773 resolve_symbol (ifc);
10775 if (ifc->attr.intrinsic)
10776 resolve_intrinsic (ifc, &ifc->declared_at);
10779 sym->ts = ifc->result->ts;
10782 sym->ts.interface = ifc;
10783 sym->attr.function = ifc->attr.function;
10784 sym->attr.subroutine = ifc->attr.subroutine;
10785 gfc_copy_formal_args (sym, ifc);
10787 sym->attr.allocatable = ifc->attr.allocatable;
10788 sym->attr.pointer = ifc->attr.pointer;
10789 sym->attr.pure = ifc->attr.pure;
10790 sym->attr.elemental = ifc->attr.elemental;
10791 sym->attr.dimension = ifc->attr.dimension;
10792 sym->attr.recursive = ifc->attr.recursive;
10793 sym->attr.always_explicit = ifc->attr.always_explicit;
10794 sym->attr.ext_attr |= ifc->attr.ext_attr;
10795 /* Copy array spec. */
10796 sym->as = gfc_copy_array_spec (ifc->as);
10800 for (i = 0; i < sym->as->rank; i++)
10802 gfc_expr_replace_symbols (sym->as->lower[i], sym);
10803 gfc_expr_replace_symbols (sym->as->upper[i], sym);
10806 /* Copy char length. */
10807 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
10809 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
10810 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
10813 else if (sym->ts.interface->name[0] != '\0')
10815 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
10816 sym->ts.interface->name, sym->name, &sym->declared_at);
10821 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
10824 /* Symbols that are module procedures with results (functions) have
10825 the types and array specification copied for type checking in
10826 procedures that call them, as well as for saving to a module
10827 file. These symbols can't stand the scrutiny that their results
10829 mp_flag = (sym->result != NULL && sym->result != sym);
10832 /* Make sure that the intrinsic is consistent with its internal
10833 representation. This needs to be done before assigning a default
10834 type to avoid spurious warnings. */
10835 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
10836 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
10839 /* Assign default type to symbols that need one and don't have one. */
10840 if (sym->ts.type == BT_UNKNOWN)
10842 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
10843 gfc_set_default_type (sym, 1, NULL);
10845 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
10846 && !sym->attr.function && !sym->attr.subroutine
10847 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
10848 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
10850 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
10852 /* The specific case of an external procedure should emit an error
10853 in the case that there is no implicit type. */
10855 gfc_set_default_type (sym, sym->attr.external, NULL);
10858 /* Result may be in another namespace. */
10859 resolve_symbol (sym->result);
10861 if (!sym->result->attr.proc_pointer)
10863 sym->ts = sym->result->ts;
10864 sym->as = gfc_copy_array_spec (sym->result->as);
10865 sym->attr.dimension = sym->result->attr.dimension;
10866 sym->attr.pointer = sym->result->attr.pointer;
10867 sym->attr.allocatable = sym->result->attr.allocatable;
10873 /* Assumed size arrays and assumed shape arrays must be dummy
10876 if (sym->as != NULL
10877 && (sym->as->type == AS_ASSUMED_SIZE
10878 || sym->as->type == AS_ASSUMED_SHAPE)
10879 && sym->attr.dummy == 0)
10881 if (sym->as->type == AS_ASSUMED_SIZE)
10882 gfc_error ("Assumed size array at %L must be a dummy argument",
10883 &sym->declared_at);
10885 gfc_error ("Assumed shape array at %L must be a dummy argument",
10886 &sym->declared_at);
10890 /* Make sure symbols with known intent or optional are really dummy
10891 variable. Because of ENTRY statement, this has to be deferred
10892 until resolution time. */
10894 if (!sym->attr.dummy
10895 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
10897 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
10901 if (sym->attr.value && !sym->attr.dummy)
10903 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
10904 "it is not a dummy argument", sym->name, &sym->declared_at);
10908 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
10910 gfc_charlen *cl = sym->ts.u.cl;
10911 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10913 gfc_error ("Character dummy variable '%s' at %L with VALUE "
10914 "attribute must have constant length",
10915 sym->name, &sym->declared_at);
10919 if (sym->ts.is_c_interop
10920 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
10922 gfc_error ("C interoperable character dummy variable '%s' at %L "
10923 "with VALUE attribute must have length one",
10924 sym->name, &sym->declared_at);
10929 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
10930 do this for something that was implicitly typed because that is handled
10931 in gfc_set_default_type. Handle dummy arguments and procedure
10932 definitions separately. Also, anything that is use associated is not
10933 handled here but instead is handled in the module it is declared in.
10934 Finally, derived type definitions are allowed to be BIND(C) since that
10935 only implies that they're interoperable, and they are checked fully for
10936 interoperability when a variable is declared of that type. */
10937 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
10938 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
10939 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
10941 gfc_try t = SUCCESS;
10943 /* First, make sure the variable is declared at the
10944 module-level scope (J3/04-007, Section 15.3). */
10945 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
10946 sym->attr.in_common == 0)
10948 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
10949 "is neither a COMMON block nor declared at the "
10950 "module level scope", sym->name, &(sym->declared_at));
10953 else if (sym->common_head != NULL)
10955 t = verify_com_block_vars_c_interop (sym->common_head);
10959 /* If type() declaration, we need to verify that the components
10960 of the given type are all C interoperable, etc. */
10961 if (sym->ts.type == BT_DERIVED &&
10962 sym->ts.u.derived->attr.is_c_interop != 1)
10964 /* Make sure the user marked the derived type as BIND(C). If
10965 not, call the verify routine. This could print an error
10966 for the derived type more than once if multiple variables
10967 of that type are declared. */
10968 if (sym->ts.u.derived->attr.is_bind_c != 1)
10969 verify_bind_c_derived_type (sym->ts.u.derived);
10973 /* Verify the variable itself as C interoperable if it
10974 is BIND(C). It is not possible for this to succeed if
10975 the verify_bind_c_derived_type failed, so don't have to handle
10976 any error returned by verify_bind_c_derived_type. */
10977 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10978 sym->common_block);
10983 /* clear the is_bind_c flag to prevent reporting errors more than
10984 once if something failed. */
10985 sym->attr.is_bind_c = 0;
10990 /* If a derived type symbol has reached this point, without its
10991 type being declared, we have an error. Notice that most
10992 conditions that produce undefined derived types have already
10993 been dealt with. However, the likes of:
10994 implicit type(t) (t) ..... call foo (t) will get us here if
10995 the type is not declared in the scope of the implicit
10996 statement. Change the type to BT_UNKNOWN, both because it is so
10997 and to prevent an ICE. */
10998 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
10999 && !sym->ts.u.derived->attr.zero_comp)
11001 gfc_error ("The derived type '%s' at %L is of type '%s', "
11002 "which has not been defined", sym->name,
11003 &sym->declared_at, sym->ts.u.derived->name);
11004 sym->ts.type = BT_UNKNOWN;
11008 /* Make sure that the derived type has been resolved and that the
11009 derived type is visible in the symbol's namespace, if it is a
11010 module function and is not PRIVATE. */
11011 if (sym->ts.type == BT_DERIVED
11012 && sym->ts.u.derived->attr.use_assoc
11013 && sym->ns->proc_name
11014 && sym->ns->proc_name->attr.flavor == FL_MODULE)
11018 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
11021 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
11022 if (!ds && sym->attr.function
11023 && gfc_check_access (sym->attr.access, sym->ns->default_access))
11025 symtree = gfc_new_symtree (&sym->ns->sym_root,
11026 sym->ts.u.derived->name);
11027 symtree->n.sym = sym->ts.u.derived;
11028 sym->ts.u.derived->refs++;
11032 /* Unless the derived-type declaration is use associated, Fortran 95
11033 does not allow public entries of private derived types.
11034 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
11035 161 in 95-006r3. */
11036 if (sym->ts.type == BT_DERIVED
11037 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
11038 && !sym->ts.u.derived->attr.use_assoc
11039 && gfc_check_access (sym->attr.access, sym->ns->default_access)
11040 && !gfc_check_access (sym->ts.u.derived->attr.access,
11041 sym->ts.u.derived->ns->default_access)
11042 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
11043 "of PRIVATE derived type '%s'",
11044 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
11045 : "variable", sym->name, &sym->declared_at,
11046 sym->ts.u.derived->name) == FAILURE)
11049 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
11050 default initialization is defined (5.1.2.4.4). */
11051 if (sym->ts.type == BT_DERIVED
11053 && sym->attr.intent == INTENT_OUT
11055 && sym->as->type == AS_ASSUMED_SIZE)
11057 for (c = sym->ts.u.derived->components; c; c = c->next)
11059 if (c->initializer)
11061 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
11062 "ASSUMED SIZE and so cannot have a default initializer",
11063 sym->name, &sym->declared_at);
11069 switch (sym->attr.flavor)
11072 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
11077 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
11082 if (resolve_fl_namelist (sym) == FAILURE)
11087 if (resolve_fl_parameter (sym) == FAILURE)
11095 /* Resolve array specifier. Check as well some constraints
11096 on COMMON blocks. */
11098 check_constant = sym->attr.in_common && !sym->attr.pointer;
11100 /* Set the formal_arg_flag so that check_conflict will not throw
11101 an error for host associated variables in the specification
11102 expression for an array_valued function. */
11103 if (sym->attr.function && sym->as)
11104 formal_arg_flag = 1;
11106 gfc_resolve_array_spec (sym->as, check_constant);
11108 formal_arg_flag = 0;
11110 /* Resolve formal namespaces. */
11111 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
11112 && !sym->attr.contained && !sym->attr.intrinsic)
11113 gfc_resolve (sym->formal_ns);
11115 /* Make sure the formal namespace is present. */
11116 if (sym->formal && !sym->formal_ns)
11118 gfc_formal_arglist *formal = sym->formal;
11119 while (formal && !formal->sym)
11120 formal = formal->next;
11124 sym->formal_ns = formal->sym->ns;
11125 sym->formal_ns->refs++;
11129 /* Check threadprivate restrictions. */
11130 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
11131 && (!sym->attr.in_common
11132 && sym->module == NULL
11133 && (sym->ns->proc_name == NULL
11134 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
11135 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
11137 /* If we have come this far we can apply default-initializers, as
11138 described in 14.7.5, to those variables that have not already
11139 been assigned one. */
11140 if (sym->ts.type == BT_DERIVED
11141 && sym->attr.referenced
11142 && sym->ns == gfc_current_ns
11144 && !sym->attr.allocatable
11145 && !sym->attr.alloc_comp)
11147 symbol_attribute *a = &sym->attr;
11149 if ((!a->save && !a->dummy && !a->pointer
11150 && !a->in_common && !a->use_assoc
11151 && !(a->function && sym != sym->result))
11152 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
11153 apply_default_init (sym);
11156 /* If this symbol has a type-spec, check it. */
11157 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
11158 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
11159 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
11165 /************* Resolve DATA statements *************/
11169 gfc_data_value *vnode;
11175 /* Advance the values structure to point to the next value in the data list. */
11178 next_data_value (void)
11180 while (mpz_cmp_ui (values.left, 0) == 0)
11183 if (values.vnode->next == NULL)
11186 values.vnode = values.vnode->next;
11187 mpz_set (values.left, values.vnode->repeat);
11195 check_data_variable (gfc_data_variable *var, locus *where)
11201 ar_type mark = AR_UNKNOWN;
11203 mpz_t section_index[GFC_MAX_DIMENSIONS];
11209 if (gfc_resolve_expr (var->expr) == FAILURE)
11213 mpz_init_set_si (offset, 0);
11216 if (e->expr_type != EXPR_VARIABLE)
11217 gfc_internal_error ("check_data_variable(): Bad expression");
11219 sym = e->symtree->n.sym;
11221 if (sym->ns->is_block_data && !sym->attr.in_common)
11223 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
11224 sym->name, &sym->declared_at);
11227 if (e->ref == NULL && sym->as)
11229 gfc_error ("DATA array '%s' at %L must be specified in a previous"
11230 " declaration", sym->name, where);
11234 has_pointer = sym->attr.pointer;
11236 for (ref = e->ref; ref; ref = ref->next)
11238 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
11242 && ref->type == REF_ARRAY
11243 && ref->u.ar.type != AR_FULL)
11245 gfc_error ("DATA element '%s' at %L is a pointer and so must "
11246 "be a full array", sym->name, where);
11251 if (e->rank == 0 || has_pointer)
11253 mpz_init_set_ui (size, 1);
11260 /* Find the array section reference. */
11261 for (ref = e->ref; ref; ref = ref->next)
11263 if (ref->type != REF_ARRAY)
11265 if (ref->u.ar.type == AR_ELEMENT)
11271 /* Set marks according to the reference pattern. */
11272 switch (ref->u.ar.type)
11280 /* Get the start position of array section. */
11281 gfc_get_section_index (ar, section_index, &offset);
11286 gcc_unreachable ();
11289 if (gfc_array_size (e, &size) == FAILURE)
11291 gfc_error ("Nonconstant array section at %L in DATA statement",
11293 mpz_clear (offset);
11300 while (mpz_cmp_ui (size, 0) > 0)
11302 if (next_data_value () == FAILURE)
11304 gfc_error ("DATA statement at %L has more variables than values",
11310 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
11314 /* If we have more than one element left in the repeat count,
11315 and we have more than one element left in the target variable,
11316 then create a range assignment. */
11317 /* FIXME: Only done for full arrays for now, since array sections
11319 if (mark == AR_FULL && ref && ref->next == NULL
11320 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
11324 if (mpz_cmp (size, values.left) >= 0)
11326 mpz_init_set (range, values.left);
11327 mpz_sub (size, size, values.left);
11328 mpz_set_ui (values.left, 0);
11332 mpz_init_set (range, size);
11333 mpz_sub (values.left, values.left, size);
11334 mpz_set_ui (size, 0);
11337 gfc_assign_data_value_range (var->expr, values.vnode->expr,
11340 mpz_add (offset, offset, range);
11344 /* Assign initial value to symbol. */
11347 mpz_sub_ui (values.left, values.left, 1);
11348 mpz_sub_ui (size, size, 1);
11350 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
11354 if (mark == AR_FULL)
11355 mpz_add_ui (offset, offset, 1);
11357 /* Modify the array section indexes and recalculate the offset
11358 for next element. */
11359 else if (mark == AR_SECTION)
11360 gfc_advance_section (section_index, ar, &offset);
11364 if (mark == AR_SECTION)
11366 for (i = 0; i < ar->dimen; i++)
11367 mpz_clear (section_index[i]);
11371 mpz_clear (offset);
11377 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
11379 /* Iterate over a list of elements in a DATA statement. */
11382 traverse_data_list (gfc_data_variable *var, locus *where)
11385 iterator_stack frame;
11386 gfc_expr *e, *start, *end, *step;
11387 gfc_try retval = SUCCESS;
11389 mpz_init (frame.value);
11391 start = gfc_copy_expr (var->iter.start);
11392 end = gfc_copy_expr (var->iter.end);
11393 step = gfc_copy_expr (var->iter.step);
11395 if (gfc_simplify_expr (start, 1) == FAILURE
11396 || start->expr_type != EXPR_CONSTANT)
11398 gfc_error ("iterator start at %L does not simplify", &start->where);
11402 if (gfc_simplify_expr (end, 1) == FAILURE
11403 || end->expr_type != EXPR_CONSTANT)
11405 gfc_error ("iterator end at %L does not simplify", &end->where);
11409 if (gfc_simplify_expr (step, 1) == FAILURE
11410 || step->expr_type != EXPR_CONSTANT)
11412 gfc_error ("iterator step at %L does not simplify", &step->where);
11417 mpz_init_set (trip, end->value.integer);
11418 mpz_sub (trip, trip, start->value.integer);
11419 mpz_add (trip, trip, step->value.integer);
11421 mpz_div (trip, trip, step->value.integer);
11423 mpz_set (frame.value, start->value.integer);
11425 frame.prev = iter_stack;
11426 frame.variable = var->iter.var->symtree;
11427 iter_stack = &frame;
11429 while (mpz_cmp_ui (trip, 0) > 0)
11431 if (traverse_data_var (var->list, where) == FAILURE)
11438 e = gfc_copy_expr (var->expr);
11439 if (gfc_simplify_expr (e, 1) == FAILURE)
11447 mpz_add (frame.value, frame.value, step->value.integer);
11449 mpz_sub_ui (trip, trip, 1);
11454 mpz_clear (frame.value);
11456 gfc_free_expr (start);
11457 gfc_free_expr (end);
11458 gfc_free_expr (step);
11460 iter_stack = frame.prev;
11465 /* Type resolve variables in the variable list of a DATA statement. */
11468 traverse_data_var (gfc_data_variable *var, locus *where)
11472 for (; var; var = var->next)
11474 if (var->expr == NULL)
11475 t = traverse_data_list (var, where);
11477 t = check_data_variable (var, where);
11487 /* Resolve the expressions and iterators associated with a data statement.
11488 This is separate from the assignment checking because data lists should
11489 only be resolved once. */
11492 resolve_data_variables (gfc_data_variable *d)
11494 for (; d; d = d->next)
11496 if (d->list == NULL)
11498 if (gfc_resolve_expr (d->expr) == FAILURE)
11503 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
11506 if (resolve_data_variables (d->list) == FAILURE)
11515 /* Resolve a single DATA statement. We implement this by storing a pointer to
11516 the value list into static variables, and then recursively traversing the
11517 variables list, expanding iterators and such. */
11520 resolve_data (gfc_data *d)
11523 if (resolve_data_variables (d->var) == FAILURE)
11526 values.vnode = d->value;
11527 if (d->value == NULL)
11528 mpz_set_ui (values.left, 0);
11530 mpz_set (values.left, d->value->repeat);
11532 if (traverse_data_var (d->var, &d->where) == FAILURE)
11535 /* At this point, we better not have any values left. */
11537 if (next_data_value () == SUCCESS)
11538 gfc_error ("DATA statement at %L has more values than variables",
11543 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
11544 accessed by host or use association, is a dummy argument to a pure function,
11545 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
11546 is storage associated with any such variable, shall not be used in the
11547 following contexts: (clients of this function). */
11549 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
11550 procedure. Returns zero if assignment is OK, nonzero if there is a
11553 gfc_impure_variable (gfc_symbol *sym)
11557 if (sym->attr.use_assoc || sym->attr.in_common)
11560 if (sym->ns != gfc_current_ns)
11561 return !sym->attr.function;
11563 proc = sym->ns->proc_name;
11564 if (sym->attr.dummy && gfc_pure (proc)
11565 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
11567 proc->attr.function))
11570 /* TODO: Sort out what can be storage associated, if anything, and include
11571 it here. In principle equivalences should be scanned but it does not
11572 seem to be possible to storage associate an impure variable this way. */
11577 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
11578 symbol of the current procedure. */
11581 gfc_pure (gfc_symbol *sym)
11583 symbol_attribute attr;
11586 sym = gfc_current_ns->proc_name;
11592 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
11596 /* Test whether the current procedure is elemental or not. */
11599 gfc_elemental (gfc_symbol *sym)
11601 symbol_attribute attr;
11604 sym = gfc_current_ns->proc_name;
11609 return attr.flavor == FL_PROCEDURE && attr.elemental;
11613 /* Warn about unused labels. */
11616 warn_unused_fortran_label (gfc_st_label *label)
11621 warn_unused_fortran_label (label->left);
11623 if (label->defined == ST_LABEL_UNKNOWN)
11626 switch (label->referenced)
11628 case ST_LABEL_UNKNOWN:
11629 gfc_warning ("Label %d at %L defined but not used", label->value,
11633 case ST_LABEL_BAD_TARGET:
11634 gfc_warning ("Label %d at %L defined but cannot be used",
11635 label->value, &label->where);
11642 warn_unused_fortran_label (label->right);
11646 /* Returns the sequence type of a symbol or sequence. */
11649 sequence_type (gfc_typespec ts)
11658 if (ts.u.derived->components == NULL)
11659 return SEQ_NONDEFAULT;
11661 result = sequence_type (ts.u.derived->components->ts);
11662 for (c = ts.u.derived->components->next; c; c = c->next)
11663 if (sequence_type (c->ts) != result)
11669 if (ts.kind != gfc_default_character_kind)
11670 return SEQ_NONDEFAULT;
11672 return SEQ_CHARACTER;
11675 if (ts.kind != gfc_default_integer_kind)
11676 return SEQ_NONDEFAULT;
11678 return SEQ_NUMERIC;
11681 if (!(ts.kind == gfc_default_real_kind
11682 || ts.kind == gfc_default_double_kind))
11683 return SEQ_NONDEFAULT;
11685 return SEQ_NUMERIC;
11688 if (ts.kind != gfc_default_complex_kind)
11689 return SEQ_NONDEFAULT;
11691 return SEQ_NUMERIC;
11694 if (ts.kind != gfc_default_logical_kind)
11695 return SEQ_NONDEFAULT;
11697 return SEQ_NUMERIC;
11700 return SEQ_NONDEFAULT;
11705 /* Resolve derived type EQUIVALENCE object. */
11708 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
11710 gfc_component *c = derived->components;
11715 /* Shall not be an object of nonsequence derived type. */
11716 if (!derived->attr.sequence)
11718 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
11719 "attribute to be an EQUIVALENCE object", sym->name,
11724 /* Shall not have allocatable components. */
11725 if (derived->attr.alloc_comp)
11727 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
11728 "components to be an EQUIVALENCE object",sym->name,
11733 if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived))
11735 gfc_error ("Derived type variable '%s' at %L with default "
11736 "initialization cannot be in EQUIVALENCE with a variable "
11737 "in COMMON", sym->name, &e->where);
11741 for (; c ; c = c->next)
11743 if (c->ts.type == BT_DERIVED
11744 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
11747 /* Shall not be an object of sequence derived type containing a pointer
11748 in the structure. */
11749 if (c->attr.pointer)
11751 gfc_error ("Derived type variable '%s' at %L with pointer "
11752 "component(s) cannot be an EQUIVALENCE object",
11753 sym->name, &e->where);
11761 /* Resolve equivalence object.
11762 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
11763 an allocatable array, an object of nonsequence derived type, an object of
11764 sequence derived type containing a pointer at any level of component
11765 selection, an automatic object, a function name, an entry name, a result
11766 name, a named constant, a structure component, or a subobject of any of
11767 the preceding objects. A substring shall not have length zero. A
11768 derived type shall not have components with default initialization nor
11769 shall two objects of an equivalence group be initialized.
11770 Either all or none of the objects shall have an protected attribute.
11771 The simple constraints are done in symbol.c(check_conflict) and the rest
11772 are implemented here. */
11775 resolve_equivalence (gfc_equiv *eq)
11778 gfc_symbol *first_sym;
11781 locus *last_where = NULL;
11782 seq_type eq_type, last_eq_type;
11783 gfc_typespec *last_ts;
11784 int object, cnt_protected;
11787 last_ts = &eq->expr->symtree->n.sym->ts;
11789 first_sym = eq->expr->symtree->n.sym;
11793 for (object = 1; eq; eq = eq->eq, object++)
11797 e->ts = e->symtree->n.sym->ts;
11798 /* match_varspec might not know yet if it is seeing
11799 array reference or substring reference, as it doesn't
11801 if (e->ref && e->ref->type == REF_ARRAY)
11803 gfc_ref *ref = e->ref;
11804 sym = e->symtree->n.sym;
11806 if (sym->attr.dimension)
11808 ref->u.ar.as = sym->as;
11812 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
11813 if (e->ts.type == BT_CHARACTER
11815 && ref->type == REF_ARRAY
11816 && ref->u.ar.dimen == 1
11817 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
11818 && ref->u.ar.stride[0] == NULL)
11820 gfc_expr *start = ref->u.ar.start[0];
11821 gfc_expr *end = ref->u.ar.end[0];
11824 /* Optimize away the (:) reference. */
11825 if (start == NULL && end == NULL)
11828 e->ref = ref->next;
11830 e->ref->next = ref->next;
11835 ref->type = REF_SUBSTRING;
11837 start = gfc_int_expr (1);
11838 ref->u.ss.start = start;
11839 if (end == NULL && e->ts.u.cl)
11840 end = gfc_copy_expr (e->ts.u.cl->length);
11841 ref->u.ss.end = end;
11842 ref->u.ss.length = e->ts.u.cl;
11849 /* Any further ref is an error. */
11852 gcc_assert (ref->type == REF_ARRAY);
11853 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
11859 if (gfc_resolve_expr (e) == FAILURE)
11862 sym = e->symtree->n.sym;
11864 if (sym->attr.is_protected)
11866 if (cnt_protected > 0 && cnt_protected != object)
11868 gfc_error ("Either all or none of the objects in the "
11869 "EQUIVALENCE set at %L shall have the "
11870 "PROTECTED attribute",
11875 /* Shall not equivalence common block variables in a PURE procedure. */
11876 if (sym->ns->proc_name
11877 && sym->ns->proc_name->attr.pure
11878 && sym->attr.in_common)
11880 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
11881 "object in the pure procedure '%s'",
11882 sym->name, &e->where, sym->ns->proc_name->name);
11886 /* Shall not be a named constant. */
11887 if (e->expr_type == EXPR_CONSTANT)
11889 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
11890 "object", sym->name, &e->where);
11894 if (e->ts.type == BT_DERIVED
11895 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
11898 /* Check that the types correspond correctly:
11900 A numeric sequence structure may be equivalenced to another sequence
11901 structure, an object of default integer type, default real type, double
11902 precision real type, default logical type such that components of the
11903 structure ultimately only become associated to objects of the same
11904 kind. A character sequence structure may be equivalenced to an object
11905 of default character kind or another character sequence structure.
11906 Other objects may be equivalenced only to objects of the same type and
11907 kind parameters. */
11909 /* Identical types are unconditionally OK. */
11910 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
11911 goto identical_types;
11913 last_eq_type = sequence_type (*last_ts);
11914 eq_type = sequence_type (sym->ts);
11916 /* Since the pair of objects is not of the same type, mixed or
11917 non-default sequences can be rejected. */
11919 msg = "Sequence %s with mixed components in EQUIVALENCE "
11920 "statement at %L with different type objects";
11922 && last_eq_type == SEQ_MIXED
11923 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
11925 || (eq_type == SEQ_MIXED
11926 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11927 &e->where) == FAILURE))
11930 msg = "Non-default type object or sequence %s in EQUIVALENCE "
11931 "statement at %L with objects of different type";
11933 && last_eq_type == SEQ_NONDEFAULT
11934 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
11935 last_where) == FAILURE)
11936 || (eq_type == SEQ_NONDEFAULT
11937 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11938 &e->where) == FAILURE))
11941 msg ="Non-CHARACTER object '%s' in default CHARACTER "
11942 "EQUIVALENCE statement at %L";
11943 if (last_eq_type == SEQ_CHARACTER
11944 && eq_type != SEQ_CHARACTER
11945 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11946 &e->where) == FAILURE)
11949 msg ="Non-NUMERIC object '%s' in default NUMERIC "
11950 "EQUIVALENCE statement at %L";
11951 if (last_eq_type == SEQ_NUMERIC
11952 && eq_type != SEQ_NUMERIC
11953 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11954 &e->where) == FAILURE)
11959 last_where = &e->where;
11964 /* Shall not be an automatic array. */
11965 if (e->ref->type == REF_ARRAY
11966 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
11968 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
11969 "an EQUIVALENCE object", sym->name, &e->where);
11976 /* Shall not be a structure component. */
11977 if (r->type == REF_COMPONENT)
11979 gfc_error ("Structure component '%s' at %L cannot be an "
11980 "EQUIVALENCE object",
11981 r->u.c.component->name, &e->where);
11985 /* A substring shall not have length zero. */
11986 if (r->type == REF_SUBSTRING)
11988 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
11990 gfc_error ("Substring at %L has length zero",
11991 &r->u.ss.start->where);
12001 /* Resolve function and ENTRY types, issue diagnostics if needed. */
12004 resolve_fntype (gfc_namespace *ns)
12006 gfc_entry_list *el;
12009 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
12012 /* If there are any entries, ns->proc_name is the entry master
12013 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
12015 sym = ns->entries->sym;
12017 sym = ns->proc_name;
12018 if (sym->result == sym
12019 && sym->ts.type == BT_UNKNOWN
12020 && gfc_set_default_type (sym, 0, NULL) == FAILURE
12021 && !sym->attr.untyped)
12023 gfc_error ("Function '%s' at %L has no IMPLICIT type",
12024 sym->name, &sym->declared_at);
12025 sym->attr.untyped = 1;
12028 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
12029 && !sym->attr.contained
12030 && !gfc_check_access (sym->ts.u.derived->attr.access,
12031 sym->ts.u.derived->ns->default_access)
12032 && gfc_check_access (sym->attr.access, sym->ns->default_access))
12034 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
12035 "%L of PRIVATE type '%s'", sym->name,
12036 &sym->declared_at, sym->ts.u.derived->name);
12040 for (el = ns->entries->next; el; el = el->next)
12042 if (el->sym->result == el->sym
12043 && el->sym->ts.type == BT_UNKNOWN
12044 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
12045 && !el->sym->attr.untyped)
12047 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
12048 el->sym->name, &el->sym->declared_at);
12049 el->sym->attr.untyped = 1;
12055 /* 12.3.2.1.1 Defined operators. */
12058 check_uop_procedure (gfc_symbol *sym, locus where)
12060 gfc_formal_arglist *formal;
12062 if (!sym->attr.function)
12064 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
12065 sym->name, &where);
12069 if (sym->ts.type == BT_CHARACTER
12070 && !(sym->ts.u.cl && sym->ts.u.cl->length)
12071 && !(sym->result && sym->result->ts.u.cl
12072 && sym->result->ts.u.cl->length))
12074 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
12075 "character length", sym->name, &where);
12079 formal = sym->formal;
12080 if (!formal || !formal->sym)
12082 gfc_error ("User operator procedure '%s' at %L must have at least "
12083 "one argument", sym->name, &where);
12087 if (formal->sym->attr.intent != INTENT_IN)
12089 gfc_error ("First argument of operator interface at %L must be "
12090 "INTENT(IN)", &where);
12094 if (formal->sym->attr.optional)
12096 gfc_error ("First argument of operator interface at %L cannot be "
12097 "optional", &where);
12101 formal = formal->next;
12102 if (!formal || !formal->sym)
12105 if (formal->sym->attr.intent != INTENT_IN)
12107 gfc_error ("Second argument of operator interface at %L must be "
12108 "INTENT(IN)", &where);
12112 if (formal->sym->attr.optional)
12114 gfc_error ("Second argument of operator interface at %L cannot be "
12115 "optional", &where);
12121 gfc_error ("Operator interface at %L must have, at most, two "
12122 "arguments", &where);
12130 gfc_resolve_uops (gfc_symtree *symtree)
12132 gfc_interface *itr;
12134 if (symtree == NULL)
12137 gfc_resolve_uops (symtree->left);
12138 gfc_resolve_uops (symtree->right);
12140 for (itr = symtree->n.uop->op; itr; itr = itr->next)
12141 check_uop_procedure (itr->sym, itr->sym->declared_at);
12145 /* Examine all of the expressions associated with a program unit,
12146 assign types to all intermediate expressions, make sure that all
12147 assignments are to compatible types and figure out which names
12148 refer to which functions or subroutines. It doesn't check code
12149 block, which is handled by resolve_code. */
12152 resolve_types (gfc_namespace *ns)
12158 gfc_namespace* old_ns = gfc_current_ns;
12160 /* Check that all IMPLICIT types are ok. */
12161 if (!ns->seen_implicit_none)
12164 for (letter = 0; letter != GFC_LETTERS; ++letter)
12165 if (ns->set_flag[letter]
12166 && resolve_typespec_used (&ns->default_type[letter],
12167 &ns->implicit_loc[letter],
12172 gfc_current_ns = ns;
12174 resolve_entries (ns);
12176 resolve_common_vars (ns->blank_common.head, false);
12177 resolve_common_blocks (ns->common_root);
12179 resolve_contained_functions (ns);
12181 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
12183 for (cl = ns->cl_list; cl; cl = cl->next)
12184 resolve_charlen (cl);
12186 gfc_traverse_ns (ns, resolve_symbol);
12188 resolve_fntype (ns);
12190 for (n = ns->contained; n; n = n->sibling)
12192 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
12193 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
12194 "also be PURE", n->proc_name->name,
12195 &n->proc_name->declared_at);
12201 gfc_check_interfaces (ns);
12203 gfc_traverse_ns (ns, resolve_values);
12209 for (d = ns->data; d; d = d->next)
12213 gfc_traverse_ns (ns, gfc_formalize_init_value);
12215 gfc_traverse_ns (ns, gfc_verify_binding_labels);
12217 if (ns->common_root != NULL)
12218 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
12220 for (eq = ns->equiv; eq; eq = eq->next)
12221 resolve_equivalence (eq);
12223 /* Warn about unused labels. */
12224 if (warn_unused_label)
12225 warn_unused_fortran_label (ns->st_labels);
12227 gfc_resolve_uops (ns->uop_root);
12229 gfc_current_ns = old_ns;
12233 /* Call resolve_code recursively. */
12236 resolve_codes (gfc_namespace *ns)
12239 bitmap_obstack old_obstack;
12241 for (n = ns->contained; n; n = n->sibling)
12244 gfc_current_ns = ns;
12246 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
12247 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
12250 /* Set to an out of range value. */
12251 current_entry_id = -1;
12253 old_obstack = labels_obstack;
12254 bitmap_obstack_initialize (&labels_obstack);
12256 resolve_code (ns->code, ns);
12258 bitmap_obstack_release (&labels_obstack);
12259 labels_obstack = old_obstack;
12263 /* This function is called after a complete program unit has been compiled.
12264 Its purpose is to examine all of the expressions associated with a program
12265 unit, assign types to all intermediate expressions, make sure that all
12266 assignments are to compatible types and figure out which names refer to
12267 which functions or subroutines. */
12270 gfc_resolve (gfc_namespace *ns)
12272 gfc_namespace *old_ns;
12273 code_stack *old_cs_base;
12279 old_ns = gfc_current_ns;
12280 old_cs_base = cs_base;
12282 resolve_types (ns);
12283 resolve_codes (ns);
12285 gfc_current_ns = old_ns;
12286 cs_base = old_cs_base;