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 vindex, 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 vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref,
5227 gfc_symbol *declared, gfc_symtree *st)
5232 /* Build an expression for the correct vindex; ie. that of the last
5234 ref = gfc_get_ref();
5235 ref->type = REF_COMPONENT;
5236 ref->u.c.component = declared->components->next;
5237 ref->u.c.sym = declared;
5241 class_ref->next = ref;
5245 gfc_free_ref_list (new_ref);
5248 vindex = gfc_get_expr ();
5249 vindex->expr_type = EXPR_VARIABLE;
5250 vindex->symtree = st;
5251 vindex->symtree->n.sym->refs++;
5252 vindex->ts = ref->u.c.component->ts;
5253 vindex->ref = new_ref;
5259 /* Get the ultimate declared type from an expression. In addition,
5260 return the last class/derived type reference and the copy of the
5263 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5266 gfc_symbol *declared;
5271 *new_ref = gfc_copy_ref (e->ref);
5272 for (ref = *new_ref; ref; ref = ref->next)
5274 if (ref->type != REF_COMPONENT)
5277 if (ref->u.c.component->ts.type == BT_CLASS
5278 || ref->u.c.component->ts.type == BT_DERIVED)
5280 declared = ref->u.c.component->ts.u.derived;
5285 if (declared == NULL)
5286 declared = e->symtree->n.sym->ts.u.derived;
5292 /* Resolve the argument expressions so that any arguments expressions
5293 that include class methods are resolved before the current call.
5294 This is necessary because of the static variables used in CLASS
5295 method resolution. */
5297 resolve_arg_exprs (gfc_actual_arglist *arg)
5299 /* Resolve the actual arglist expressions. */
5300 for (; arg; arg = arg->next)
5303 gfc_resolve_expr (arg->expr);
5308 /* Resolve a CLASS typebound function, or 'method'. */
5310 resolve_class_compcall (gfc_expr* e)
5312 gfc_symbol *derived, *declared;
5318 class_object = st->n.sym;
5320 /* Get the CLASS declared type. */
5321 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5323 /* Weed out cases of the ultimate component being a derived type. */
5324 if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5326 gfc_free_ref_list (new_ref);
5327 return resolve_compcall (e, true);
5330 /* Resolve the argument expressions, */
5331 resolve_arg_exprs (e->value.function.actual);
5333 /* Get the data component, which is of the declared type. */
5334 derived = declared->components->ts.u.derived;
5336 /* Resolve the function call for each member of the class. */
5337 class_try = SUCCESS;
5339 list_e = gfc_copy_expr (e);
5340 check_class_members (derived);
5342 class_try = (resolve_compcall (e, true) == SUCCESS)
5343 ? class_try : FAILURE;
5345 /* Transfer the class list to the original expression. Note that
5346 the class_esym list is cleaned up in trans-expr.c, as the calls
5348 e->value.function.class_esym = list_e->value.function.class_esym;
5349 list_e->value.function.class_esym = NULL;
5350 gfc_free_expr (list_e);
5352 resolve_class_esym (e);
5354 /* More than one typebound procedure so transmit an expression for
5355 the vindex as the selector. */
5356 if (e->value.function.class_esym != NULL)
5357 e->value.function.class_esym->vindex
5358 = vindex_expr (class_ref, new_ref, declared, st);
5363 /* Resolve a CLASS typebound subroutine, or 'method'. */
5365 resolve_class_typebound_call (gfc_code *code)
5367 gfc_symbol *derived, *declared;
5372 st = code->expr1->symtree;
5373 class_object = st->n.sym;
5375 /* Get the CLASS declared type. */
5376 declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5378 /* Weed out cases of the ultimate component being a derived type. */
5379 if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5381 gfc_free_ref_list (new_ref);
5382 return resolve_typebound_call (code);
5385 /* Resolve the argument expressions, */
5386 resolve_arg_exprs (code->expr1->value.compcall.actual);
5388 /* Get the data component, which is of the declared type. */
5389 derived = declared->components->ts.u.derived;
5391 class_try = SUCCESS;
5393 list_e = gfc_copy_expr (code->expr1);
5394 check_class_members (derived);
5396 class_try = (resolve_typebound_call (code) == SUCCESS)
5397 ? class_try : FAILURE;
5399 /* Transfer the class list to the original expression. Note that
5400 the class_esym list is cleaned up in trans-expr.c, as the calls
5402 code->expr1->value.function.class_esym
5403 = list_e->value.function.class_esym;
5404 list_e->value.function.class_esym = NULL;
5405 gfc_free_expr (list_e);
5407 resolve_class_esym (code->expr1);
5409 /* More than one typebound procedure so transmit an expression for
5410 the vindex as the selector. */
5411 if (code->expr1->value.function.class_esym != NULL)
5412 code->expr1->value.function.class_esym->vindex
5413 = vindex_expr (class_ref, new_ref, declared, st);
5419 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5422 resolve_ppc_call (gfc_code* c)
5424 gfc_component *comp;
5427 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5430 c->resolved_sym = c->expr1->symtree->n.sym;
5431 c->expr1->expr_type = EXPR_VARIABLE;
5433 if (!comp->attr.subroutine)
5434 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5436 if (resolve_ref (c->expr1) == FAILURE)
5439 if (update_ppc_arglist (c->expr1) == FAILURE)
5442 c->ext.actual = c->expr1->value.compcall.actual;
5444 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5445 comp->formal == NULL) == FAILURE)
5448 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5454 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5457 resolve_expr_ppc (gfc_expr* e)
5459 gfc_component *comp;
5462 b = gfc_is_proc_ptr_comp (e, &comp);
5465 /* Convert to EXPR_FUNCTION. */
5466 e->expr_type = EXPR_FUNCTION;
5467 e->value.function.isym = NULL;
5468 e->value.function.actual = e->value.compcall.actual;
5470 if (comp->as != NULL)
5471 e->rank = comp->as->rank;
5473 if (!comp->attr.function)
5474 gfc_add_function (&comp->attr, comp->name, &e->where);
5476 if (resolve_ref (e) == FAILURE)
5479 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5480 comp->formal == NULL) == FAILURE)
5483 if (update_ppc_arglist (e) == FAILURE)
5486 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5492 /* Resolve an expression. That is, make sure that types of operands agree
5493 with their operators, intrinsic operators are converted to function calls
5494 for overloaded types and unresolved function references are resolved. */
5497 gfc_resolve_expr (gfc_expr *e)
5504 switch (e->expr_type)
5507 t = resolve_operator (e);
5513 if (check_host_association (e))
5514 t = resolve_function (e);
5517 t = resolve_variable (e);
5519 expression_rank (e);
5522 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
5523 && e->ref->type != REF_SUBSTRING)
5524 gfc_resolve_substring_charlen (e);
5529 if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
5530 t = resolve_class_compcall (e);
5532 t = resolve_compcall (e, true);
5535 case EXPR_SUBSTRING:
5536 t = resolve_ref (e);
5545 t = resolve_expr_ppc (e);
5550 if (resolve_ref (e) == FAILURE)
5553 t = gfc_resolve_array_constructor (e);
5554 /* Also try to expand a constructor. */
5557 expression_rank (e);
5558 gfc_expand_constructor (e);
5561 /* This provides the opportunity for the length of constructors with
5562 character valued function elements to propagate the string length
5563 to the expression. */
5564 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
5565 t = gfc_resolve_character_array_constructor (e);
5569 case EXPR_STRUCTURE:
5570 t = resolve_ref (e);
5574 t = resolve_structure_cons (e);
5578 t = gfc_simplify_expr (e, 0);
5582 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
5585 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
5592 /* Resolve an expression from an iterator. They must be scalar and have
5593 INTEGER or (optionally) REAL type. */
5596 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
5597 const char *name_msgid)
5599 if (gfc_resolve_expr (expr) == FAILURE)
5602 if (expr->rank != 0)
5604 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
5608 if (expr->ts.type != BT_INTEGER)
5610 if (expr->ts.type == BT_REAL)
5613 return gfc_notify_std (GFC_STD_F95_DEL,
5614 "Deleted feature: %s at %L must be integer",
5615 _(name_msgid), &expr->where);
5618 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
5625 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
5633 /* Resolve the expressions in an iterator structure. If REAL_OK is
5634 false allow only INTEGER type iterators, otherwise allow REAL types. */
5637 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
5639 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
5643 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
5645 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
5650 if (gfc_resolve_iterator_expr (iter->start, real_ok,
5651 "Start expression in DO loop") == FAILURE)
5654 if (gfc_resolve_iterator_expr (iter->end, real_ok,
5655 "End expression in DO loop") == FAILURE)
5658 if (gfc_resolve_iterator_expr (iter->step, real_ok,
5659 "Step expression in DO loop") == FAILURE)
5662 if (iter->step->expr_type == EXPR_CONSTANT)
5664 if ((iter->step->ts.type == BT_INTEGER
5665 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
5666 || (iter->step->ts.type == BT_REAL
5667 && mpfr_sgn (iter->step->value.real) == 0))
5669 gfc_error ("Step expression in DO loop at %L cannot be zero",
5670 &iter->step->where);
5675 /* Convert start, end, and step to the same type as var. */
5676 if (iter->start->ts.kind != iter->var->ts.kind
5677 || iter->start->ts.type != iter->var->ts.type)
5678 gfc_convert_type (iter->start, &iter->var->ts, 2);
5680 if (iter->end->ts.kind != iter->var->ts.kind
5681 || iter->end->ts.type != iter->var->ts.type)
5682 gfc_convert_type (iter->end, &iter->var->ts, 2);
5684 if (iter->step->ts.kind != iter->var->ts.kind
5685 || iter->step->ts.type != iter->var->ts.type)
5686 gfc_convert_type (iter->step, &iter->var->ts, 2);
5688 if (iter->start->expr_type == EXPR_CONSTANT
5689 && iter->end->expr_type == EXPR_CONSTANT
5690 && iter->step->expr_type == EXPR_CONSTANT)
5693 if (iter->start->ts.type == BT_INTEGER)
5695 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
5696 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
5700 sgn = mpfr_sgn (iter->step->value.real);
5701 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
5703 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
5704 gfc_warning ("DO loop at %L will be executed zero times",
5705 &iter->step->where);
5712 /* Traversal function for find_forall_index. f == 2 signals that
5713 that variable itself is not to be checked - only the references. */
5716 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
5718 if (expr->expr_type != EXPR_VARIABLE)
5721 /* A scalar assignment */
5722 if (!expr->ref || *f == 1)
5724 if (expr->symtree->n.sym == sym)
5736 /* Check whether the FORALL index appears in the expression or not.
5737 Returns SUCCESS if SYM is found in EXPR. */
5740 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
5742 if (gfc_traverse_expr (expr, sym, forall_index, f))
5749 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
5750 to be a scalar INTEGER variable. The subscripts and stride are scalar
5751 INTEGERs, and if stride is a constant it must be nonzero.
5752 Furthermore "A subscript or stride in a forall-triplet-spec shall
5753 not contain a reference to any index-name in the
5754 forall-triplet-spec-list in which it appears." (7.5.4.1) */
5757 resolve_forall_iterators (gfc_forall_iterator *it)
5759 gfc_forall_iterator *iter, *iter2;
5761 for (iter = it; iter; iter = iter->next)
5763 if (gfc_resolve_expr (iter->var) == SUCCESS
5764 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
5765 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
5768 if (gfc_resolve_expr (iter->start) == SUCCESS
5769 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
5770 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
5771 &iter->start->where);
5772 if (iter->var->ts.kind != iter->start->ts.kind)
5773 gfc_convert_type (iter->start, &iter->var->ts, 2);
5775 if (gfc_resolve_expr (iter->end) == SUCCESS
5776 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
5777 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
5779 if (iter->var->ts.kind != iter->end->ts.kind)
5780 gfc_convert_type (iter->end, &iter->var->ts, 2);
5782 if (gfc_resolve_expr (iter->stride) == SUCCESS)
5784 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
5785 gfc_error ("FORALL stride expression at %L must be a scalar %s",
5786 &iter->stride->where, "INTEGER");
5788 if (iter->stride->expr_type == EXPR_CONSTANT
5789 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
5790 gfc_error ("FORALL stride expression at %L cannot be zero",
5791 &iter->stride->where);
5793 if (iter->var->ts.kind != iter->stride->ts.kind)
5794 gfc_convert_type (iter->stride, &iter->var->ts, 2);
5797 for (iter = it; iter; iter = iter->next)
5798 for (iter2 = iter; iter2; iter2 = iter2->next)
5800 if (find_forall_index (iter2->start,
5801 iter->var->symtree->n.sym, 0) == SUCCESS
5802 || find_forall_index (iter2->end,
5803 iter->var->symtree->n.sym, 0) == SUCCESS
5804 || find_forall_index (iter2->stride,
5805 iter->var->symtree->n.sym, 0) == SUCCESS)
5806 gfc_error ("FORALL index '%s' may not appear in triplet "
5807 "specification at %L", iter->var->symtree->name,
5808 &iter2->start->where);
5813 /* Given a pointer to a symbol that is a derived type, see if it's
5814 inaccessible, i.e. if it's defined in another module and the components are
5815 PRIVATE. The search is recursive if necessary. Returns zero if no
5816 inaccessible components are found, nonzero otherwise. */
5819 derived_inaccessible (gfc_symbol *sym)
5823 if (sym->attr.use_assoc && sym->attr.private_comp)
5826 for (c = sym->components; c; c = c->next)
5828 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
5836 /* Resolve the argument of a deallocate expression. The expression must be
5837 a pointer or a full array. */
5840 resolve_deallocate_expr (gfc_expr *e)
5842 symbol_attribute attr;
5843 int allocatable, pointer, check_intent_in;
5848 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5849 check_intent_in = 1;
5851 if (gfc_resolve_expr (e) == FAILURE)
5854 if (e->expr_type != EXPR_VARIABLE)
5857 sym = e->symtree->n.sym;
5859 if (sym->ts.type == BT_CLASS)
5861 allocatable = sym->ts.u.derived->components->attr.allocatable;
5862 pointer = sym->ts.u.derived->components->attr.pointer;
5866 allocatable = sym->attr.allocatable;
5867 pointer = sym->attr.pointer;
5869 for (ref = e->ref; ref; ref = ref->next)
5872 check_intent_in = 0;
5877 if (ref->u.ar.type != AR_FULL)
5882 c = ref->u.c.component;
5883 if (c->ts.type == BT_CLASS)
5885 allocatable = c->ts.u.derived->components->attr.allocatable;
5886 pointer = c->ts.u.derived->components->attr.pointer;
5890 allocatable = c->attr.allocatable;
5891 pointer = c->attr.pointer;
5901 attr = gfc_expr_attr (e);
5903 if (allocatable == 0 && attr.pointer == 0)
5906 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
5910 if (check_intent_in && sym->attr.intent == INTENT_IN)
5912 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5913 sym->name, &e->where);
5917 if (e->ts.type == BT_CLASS)
5919 /* Only deallocate the DATA component. */
5920 gfc_add_component_ref (e, "$data");
5927 /* Returns true if the expression e contains a reference to the symbol sym. */
5929 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5931 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
5938 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
5940 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
5944 /* Given the expression node e for an allocatable/pointer of derived type to be
5945 allocated, get the expression node to be initialized afterwards (needed for
5946 derived types with default initializers, and derived types with allocatable
5947 components that need nullification.) */
5950 gfc_expr_to_initialize (gfc_expr *e)
5956 result = gfc_copy_expr (e);
5958 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5959 for (ref = result->ref; ref; ref = ref->next)
5960 if (ref->type == REF_ARRAY && ref->next == NULL)
5962 ref->u.ar.type = AR_FULL;
5964 for (i = 0; i < ref->u.ar.dimen; i++)
5965 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
5967 result->rank = ref->u.ar.dimen;
5975 /* Used in resolve_allocate_expr to check that a allocation-object and
5976 a source-expr are conformable. This does not catch all possible
5977 cases; in particular a runtime checking is needed. */
5980 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
5982 /* First compare rank. */
5983 if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
5985 gfc_error ("Source-expr at %L must be scalar or have the "
5986 "same rank as the allocate-object at %L",
5987 &e1->where, &e2->where);
5998 for (i = 0; i < e1->rank; i++)
6000 if (e2->ref->u.ar.end[i])
6002 mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
6003 mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
6004 mpz_add_ui (s, s, 1);
6008 mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
6011 if (mpz_cmp (e1->shape[i], s) != 0)
6013 gfc_error ("Source-expr at %L and allocate-object at %L must "
6014 "have the same shape", &e1->where, &e2->where);
6027 /* Resolve the expression in an ALLOCATE statement, doing the additional
6028 checks to see whether the expression is OK or not. The expression must
6029 have a trailing array reference that gives the size of the array. */
6032 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6034 int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
6035 symbol_attribute attr;
6036 gfc_ref *ref, *ref2;
6042 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6043 check_intent_in = 1;
6045 if (gfc_resolve_expr (e) == FAILURE)
6048 /* Make sure the expression is allocatable or a pointer. If it is
6049 pointer, the next-to-last reference must be a pointer. */
6053 sym = e->symtree->n.sym;
6055 /* Check whether ultimate component is abstract and CLASS. */
6058 if (e->expr_type != EXPR_VARIABLE)
6061 attr = gfc_expr_attr (e);
6062 pointer = attr.pointer;
6063 dimension = attr.dimension;
6067 if (sym->ts.type == BT_CLASS)
6069 allocatable = sym->ts.u.derived->components->attr.allocatable;
6070 pointer = sym->ts.u.derived->components->attr.pointer;
6071 dimension = sym->ts.u.derived->components->attr.dimension;
6072 is_abstract = sym->ts.u.derived->components->attr.abstract;
6076 allocatable = sym->attr.allocatable;
6077 pointer = sym->attr.pointer;
6078 dimension = sym->attr.dimension;
6081 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6084 check_intent_in = 0;
6089 if (ref->next != NULL)
6094 c = ref->u.c.component;
6095 if (c->ts.type == BT_CLASS)
6097 allocatable = c->ts.u.derived->components->attr.allocatable;
6098 pointer = c->ts.u.derived->components->attr.pointer;
6099 dimension = c->ts.u.derived->components->attr.dimension;
6100 is_abstract = c->ts.u.derived->components->attr.abstract;
6104 allocatable = c->attr.allocatable;
6105 pointer = c->attr.pointer;
6106 dimension = c->attr.dimension;
6107 is_abstract = c->attr.abstract;
6119 if (allocatable == 0 && pointer == 0)
6121 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6126 /* Some checks for the SOURCE tag. */
6129 /* Check F03:C631. */
6130 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6132 gfc_error ("Type of entity at %L is type incompatible with "
6133 "source-expr at %L", &e->where, &code->expr3->where);
6137 /* Check F03:C632 and restriction following Note 6.18. */
6138 if (code->expr3->rank > 0
6139 && conformable_arrays (code->expr3, e) == FAILURE)
6142 /* Check F03:C633. */
6143 if (code->expr3->ts.kind != e->ts.kind)
6145 gfc_error ("The allocate-object at %L and the source-expr at %L "
6146 "shall have the same kind type parameter",
6147 &e->where, &code->expr3->where);
6151 else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
6153 gcc_assert (e->ts.type == BT_CLASS);
6154 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6155 "type-spec or SOURCE=", sym->name, &e->where);
6159 if (check_intent_in && sym->attr.intent == INTENT_IN)
6161 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
6162 sym->name, &e->where);
6166 if (pointer || dimension == 0)
6169 /* Make sure the next-to-last reference node is an array specification. */
6171 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
6173 gfc_error ("Array specification required in ALLOCATE statement "
6174 "at %L", &e->where);
6178 /* Make sure that the array section reference makes sense in the
6179 context of an ALLOCATE specification. */
6183 for (i = 0; i < ar->dimen; i++)
6185 if (ref2->u.ar.type == AR_ELEMENT)
6188 switch (ar->dimen_type[i])
6194 if (ar->start[i] != NULL
6195 && ar->end[i] != NULL
6196 && ar->stride[i] == NULL)
6199 /* Fall Through... */
6203 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6210 for (a = code->ext.alloc.list; a; a = a->next)
6212 sym = a->expr->symtree->n.sym;
6214 /* TODO - check derived type components. */
6215 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6218 if ((ar->start[i] != NULL
6219 && gfc_find_sym_in_expr (sym, ar->start[i]))
6220 || (ar->end[i] != NULL
6221 && gfc_find_sym_in_expr (sym, ar->end[i])))
6223 gfc_error ("'%s' must not appear in the array specification at "
6224 "%L in the same ALLOCATE statement where it is "
6225 "itself allocated", sym->name, &ar->where);
6235 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6237 gfc_expr *stat, *errmsg, *pe, *qe;
6238 gfc_alloc *a, *p, *q;
6240 stat = code->expr1 ? code->expr1 : NULL;
6242 errmsg = code->expr2 ? code->expr2 : NULL;
6244 /* Check the stat variable. */
6247 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
6248 gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
6249 stat->symtree->n.sym->name, &stat->where);
6251 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
6252 gfc_error ("Illegal stat-variable at %L for a PURE procedure",
6255 if ((stat->ts.type != BT_INTEGER
6256 && !(stat->ref && (stat->ref->type == REF_ARRAY
6257 || stat->ref->type == REF_COMPONENT)))
6259 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6260 "variable", &stat->where);
6262 for (p = code->ext.alloc.list; p; p = p->next)
6263 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6264 gfc_error ("Stat-variable at %L shall not be %sd within "
6265 "the same %s statement", &stat->where, fcn, fcn);
6268 /* Check the errmsg variable. */
6272 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6275 if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
6276 gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
6277 errmsg->symtree->n.sym->name, &errmsg->where);
6279 if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
6280 gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
6283 if ((errmsg->ts.type != BT_CHARACTER
6285 && (errmsg->ref->type == REF_ARRAY
6286 || errmsg->ref->type == REF_COMPONENT)))
6287 || errmsg->rank > 0 )
6288 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6289 "variable", &errmsg->where);
6291 for (p = code->ext.alloc.list; p; p = p->next)
6292 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6293 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6294 "the same %s statement", &errmsg->where, fcn, fcn);
6297 /* Check that an allocate-object appears only once in the statement.
6298 FIXME: Checking derived types is disabled. */
6299 for (p = code->ext.alloc.list; p; p = p->next)
6302 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6303 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6305 for (q = p->next; q; q = q->next)
6308 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6309 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6310 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6311 gfc_error ("Allocate-object at %L also appears at %L",
6312 &pe->where, &qe->where);
6317 if (strcmp (fcn, "ALLOCATE") == 0)
6319 for (a = code->ext.alloc.list; a; a = a->next)
6320 resolve_allocate_expr (a->expr, code);
6324 for (a = code->ext.alloc.list; a; a = a->next)
6325 resolve_deallocate_expr (a->expr);
6330 /************ SELECT CASE resolution subroutines ************/
6332 /* Callback function for our mergesort variant. Determines interval
6333 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
6334 op1 > op2. Assumes we're not dealing with the default case.
6335 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
6336 There are nine situations to check. */
6339 compare_cases (const gfc_case *op1, const gfc_case *op2)
6343 if (op1->low == NULL) /* op1 = (:L) */
6345 /* op2 = (:N), so overlap. */
6347 /* op2 = (M:) or (M:N), L < M */
6348 if (op2->low != NULL
6349 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6352 else if (op1->high == NULL) /* op1 = (K:) */
6354 /* op2 = (M:), so overlap. */
6356 /* op2 = (:N) or (M:N), K > N */
6357 if (op2->high != NULL
6358 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6361 else /* op1 = (K:L) */
6363 if (op2->low == NULL) /* op2 = (:N), K > N */
6364 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6366 else if (op2->high == NULL) /* op2 = (M:), L < M */
6367 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6369 else /* op2 = (M:N) */
6373 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6376 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6385 /* Merge-sort a double linked case list, detecting overlap in the
6386 process. LIST is the head of the double linked case list before it
6387 is sorted. Returns the head of the sorted list if we don't see any
6388 overlap, or NULL otherwise. */
6391 check_case_overlap (gfc_case *list)
6393 gfc_case *p, *q, *e, *tail;
6394 int insize, nmerges, psize, qsize, cmp, overlap_seen;
6396 /* If the passed list was empty, return immediately. */
6403 /* Loop unconditionally. The only exit from this loop is a return
6404 statement, when we've finished sorting the case list. */
6411 /* Count the number of merges we do in this pass. */
6414 /* Loop while there exists a merge to be done. */
6419 /* Count this merge. */
6422 /* Cut the list in two pieces by stepping INSIZE places
6423 forward in the list, starting from P. */
6426 for (i = 0; i < insize; i++)
6435 /* Now we have two lists. Merge them! */
6436 while (psize > 0 || (qsize > 0 && q != NULL))
6438 /* See from which the next case to merge comes from. */
6441 /* P is empty so the next case must come from Q. */
6446 else if (qsize == 0 || q == NULL)
6455 cmp = compare_cases (p, q);
6458 /* The whole case range for P is less than the
6466 /* The whole case range for Q is greater than
6467 the case range for P. */
6474 /* The cases overlap, or they are the same
6475 element in the list. Either way, we must
6476 issue an error and get the next case from P. */
6477 /* FIXME: Sort P and Q by line number. */
6478 gfc_error ("CASE label at %L overlaps with CASE "
6479 "label at %L", &p->where, &q->where);
6487 /* Add the next element to the merged list. */
6496 /* P has now stepped INSIZE places along, and so has Q. So
6497 they're the same. */
6502 /* If we have done only one merge or none at all, we've
6503 finished sorting the cases. */
6512 /* Otherwise repeat, merging lists twice the size. */
6518 /* Check to see if an expression is suitable for use in a CASE statement.
6519 Makes sure that all case expressions are scalar constants of the same
6520 type. Return FAILURE if anything is wrong. */
6523 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
6525 if (e == NULL) return SUCCESS;
6527 if (e->ts.type != case_expr->ts.type)
6529 gfc_error ("Expression in CASE statement at %L must be of type %s",
6530 &e->where, gfc_basic_typename (case_expr->ts.type));
6534 /* C805 (R808) For a given case-construct, each case-value shall be of
6535 the same type as case-expr. For character type, length differences
6536 are allowed, but the kind type parameters shall be the same. */
6538 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
6540 gfc_error ("Expression in CASE statement at %L must be of kind %d",
6541 &e->where, case_expr->ts.kind);
6545 /* Convert the case value kind to that of case expression kind, if needed.
6546 FIXME: Should a warning be issued? */
6547 if (e->ts.kind != case_expr->ts.kind)
6548 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
6552 gfc_error ("Expression in CASE statement at %L must be scalar",
6561 /* Given a completely parsed select statement, we:
6563 - Validate all expressions and code within the SELECT.
6564 - Make sure that the selection expression is not of the wrong type.
6565 - Make sure that no case ranges overlap.
6566 - Eliminate unreachable cases and unreachable code resulting from
6567 removing case labels.
6569 The standard does allow unreachable cases, e.g. CASE (5:3). But
6570 they are a hassle for code generation, and to prevent that, we just
6571 cut them out here. This is not necessary for overlapping cases
6572 because they are illegal and we never even try to generate code.
6574 We have the additional caveat that a SELECT construct could have
6575 been a computed GOTO in the source code. Fortunately we can fairly
6576 easily work around that here: The case_expr for a "real" SELECT CASE
6577 is in code->expr1, but for a computed GOTO it is in code->expr2. All
6578 we have to do is make sure that the case_expr is a scalar integer
6582 resolve_select (gfc_code *code)
6585 gfc_expr *case_expr;
6586 gfc_case *cp, *default_case, *tail, *head;
6587 int seen_unreachable;
6593 if (code->expr1 == NULL)
6595 /* This was actually a computed GOTO statement. */
6596 case_expr = code->expr2;
6597 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
6598 gfc_error ("Selection expression in computed GOTO statement "
6599 "at %L must be a scalar integer expression",
6602 /* Further checking is not necessary because this SELECT was built
6603 by the compiler, so it should always be OK. Just move the
6604 case_expr from expr2 to expr so that we can handle computed
6605 GOTOs as normal SELECTs from here on. */
6606 code->expr1 = code->expr2;
6611 case_expr = code->expr1;
6613 type = case_expr->ts.type;
6614 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
6616 gfc_error ("Argument of SELECT statement at %L cannot be %s",
6617 &case_expr->where, gfc_typename (&case_expr->ts));
6619 /* Punt. Going on here just produce more garbage error messages. */
6623 if (case_expr->rank != 0)
6625 gfc_error ("Argument of SELECT statement at %L must be a scalar "
6626 "expression", &case_expr->where);
6632 /* PR 19168 has a long discussion concerning a mismatch of the kinds
6633 of the SELECT CASE expression and its CASE values. Walk the lists
6634 of case values, and if we find a mismatch, promote case_expr to
6635 the appropriate kind. */
6637 if (type == BT_LOGICAL || type == BT_INTEGER)
6639 for (body = code->block; body; body = body->block)
6641 /* Walk the case label list. */
6642 for (cp = body->ext.case_list; cp; cp = cp->next)
6644 /* Intercept the DEFAULT case. It does not have a kind. */
6645 if (cp->low == NULL && cp->high == NULL)
6648 /* Unreachable case ranges are discarded, so ignore. */
6649 if (cp->low != NULL && cp->high != NULL
6650 && cp->low != cp->high
6651 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
6654 /* FIXME: Should a warning be issued? */
6656 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
6657 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
6659 if (cp->high != NULL
6660 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
6661 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
6666 /* Assume there is no DEFAULT case. */
6667 default_case = NULL;
6672 for (body = code->block; body; body = body->block)
6674 /* Assume the CASE list is OK, and all CASE labels can be matched. */
6676 seen_unreachable = 0;
6678 /* Walk the case label list, making sure that all case labels
6680 for (cp = body->ext.case_list; cp; cp = cp->next)
6682 /* Count the number of cases in the whole construct. */
6685 /* Intercept the DEFAULT case. */
6686 if (cp->low == NULL && cp->high == NULL)
6688 if (default_case != NULL)
6690 gfc_error ("The DEFAULT CASE at %L cannot be followed "
6691 "by a second DEFAULT CASE at %L",
6692 &default_case->where, &cp->where);
6703 /* Deal with single value cases and case ranges. Errors are
6704 issued from the validation function. */
6705 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
6706 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
6712 if (type == BT_LOGICAL
6713 && ((cp->low == NULL || cp->high == NULL)
6714 || cp->low != cp->high))
6716 gfc_error ("Logical range in CASE statement at %L is not "
6717 "allowed", &cp->low->where);
6722 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
6725 value = cp->low->value.logical == 0 ? 2 : 1;
6726 if (value & seen_logical)
6728 gfc_error ("constant logical value in CASE statement "
6729 "is repeated at %L",
6734 seen_logical |= value;
6737 if (cp->low != NULL && cp->high != NULL
6738 && cp->low != cp->high
6739 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
6741 if (gfc_option.warn_surprising)
6742 gfc_warning ("Range specification at %L can never "
6743 "be matched", &cp->where);
6745 cp->unreachable = 1;
6746 seen_unreachable = 1;
6750 /* If the case range can be matched, it can also overlap with
6751 other cases. To make sure it does not, we put it in a
6752 double linked list here. We sort that with a merge sort
6753 later on to detect any overlapping cases. */
6757 head->right = head->left = NULL;
6762 tail->right->left = tail;
6769 /* It there was a failure in the previous case label, give up
6770 for this case label list. Continue with the next block. */
6774 /* See if any case labels that are unreachable have been seen.
6775 If so, we eliminate them. This is a bit of a kludge because
6776 the case lists for a single case statement (label) is a
6777 single forward linked lists. */
6778 if (seen_unreachable)
6780 /* Advance until the first case in the list is reachable. */
6781 while (body->ext.case_list != NULL
6782 && body->ext.case_list->unreachable)
6784 gfc_case *n = body->ext.case_list;
6785 body->ext.case_list = body->ext.case_list->next;
6787 gfc_free_case_list (n);
6790 /* Strip all other unreachable cases. */
6791 if (body->ext.case_list)
6793 for (cp = body->ext.case_list; cp->next; cp = cp->next)
6795 if (cp->next->unreachable)
6797 gfc_case *n = cp->next;
6798 cp->next = cp->next->next;
6800 gfc_free_case_list (n);
6807 /* See if there were overlapping cases. If the check returns NULL,
6808 there was overlap. In that case we don't do anything. If head
6809 is non-NULL, we prepend the DEFAULT case. The sorted list can
6810 then used during code generation for SELECT CASE constructs with
6811 a case expression of a CHARACTER type. */
6814 head = check_case_overlap (head);
6816 /* Prepend the default_case if it is there. */
6817 if (head != NULL && default_case)
6819 default_case->left = NULL;
6820 default_case->right = head;
6821 head->left = default_case;
6825 /* Eliminate dead blocks that may be the result if we've seen
6826 unreachable case labels for a block. */
6827 for (body = code; body && body->block; body = body->block)
6829 if (body->block->ext.case_list == NULL)
6831 /* Cut the unreachable block from the code chain. */
6832 gfc_code *c = body->block;
6833 body->block = c->block;
6835 /* Kill the dead block, but not the blocks below it. */
6837 gfc_free_statements (c);
6841 /* More than two cases is legal but insane for logical selects.
6842 Issue a warning for it. */
6843 if (gfc_option.warn_surprising && type == BT_LOGICAL
6845 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
6850 /* Check if a derived type is extensible. */
6853 gfc_type_is_extensible (gfc_symbol *sym)
6855 return !(sym->attr.is_bind_c || sym->attr.sequence);
6859 /* Resolve a SELECT TYPE statement. */
6862 resolve_select_type (gfc_code *code)
6864 gfc_symbol *selector_type;
6865 gfc_code *body, *new_st;
6866 gfc_case *c, *default_case;
6868 char name[GFC_MAX_SYMBOL_LEN];
6875 selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
6877 selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
6879 /* Assume there is no DEFAULT case. */
6880 default_case = NULL;
6882 /* Loop over TYPE IS / CLASS IS cases. */
6883 for (body = code->block; body; body = body->block)
6885 c = body->ext.case_list;
6887 /* Check F03:C815. */
6888 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
6889 && !gfc_type_is_extensible (c->ts.u.derived))
6891 gfc_error ("Derived type '%s' at %L must be extensible",
6892 c->ts.u.derived->name, &c->where);
6896 /* Check F03:C816. */
6897 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
6898 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
6900 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
6901 c->ts.u.derived->name, &c->where, selector_type->name);
6905 /* Intercept the DEFAULT case. */
6906 if (c->ts.type == BT_UNKNOWN)
6908 /* Check F03:C818. */
6909 if (default_case != NULL)
6910 gfc_error ("The DEFAULT CASE at %L cannot be followed "
6911 "by a second DEFAULT CASE at %L",
6912 &default_case->where, &c->where);
6921 /* Insert assignment for selector variable. */
6922 new_st = gfc_get_code ();
6923 new_st->op = EXEC_ASSIGN;
6924 new_st->expr1 = gfc_copy_expr (code->expr1);
6925 new_st->expr2 = gfc_copy_expr (code->expr2);
6929 /* Put SELECT TYPE statement inside a BLOCK. */
6930 new_st = gfc_get_code ();
6931 new_st->op = code->op;
6932 new_st->expr1 = code->expr1;
6933 new_st->expr2 = code->expr2;
6934 new_st->block = code->block;
6938 ns->code->next = new_st;
6939 code->op = EXEC_BLOCK;
6940 code->expr1 = code->expr2 = NULL;
6945 /* Transform to EXEC_SELECT. */
6946 code->op = EXEC_SELECT;
6947 gfc_add_component_ref (code->expr1, "$vindex");
6949 /* Loop over TYPE IS / CLASS IS cases. */
6950 for (body = code->block; body; body = body->block)
6952 c = body->ext.case_list;
6953 if (c->ts.type == BT_DERIVED)
6954 c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex);
6955 else if (c->ts.type == BT_CLASS)
6956 /* Currently IS CLASS blocks are simply ignored.
6957 TODO: Implement IS CLASS. */
6960 if (c->ts.type != BT_DERIVED)
6962 /* Assign temporary to selector. */
6963 sprintf (name, "tmp$%s", c->ts.u.derived->name);
6964 st = gfc_find_symtree (ns->sym_root, name);
6965 new_st = gfc_get_code ();
6966 new_st->op = EXEC_POINTER_ASSIGN;
6967 new_st->expr1 = gfc_get_variable_expr (st);
6968 new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
6969 gfc_add_component_ref (new_st->expr2, "$data");
6970 new_st->next = body->next;
6971 body->next = new_st;
6974 /* Eliminate dead blocks. */
6975 for (body = code; body && body->block; body = body->block)
6977 if (body->block->ext.case_list->unreachable)
6979 /* Cut the unreachable block from the code chain. */
6980 gfc_code *cd = body->block;
6981 body->block = cd->block;
6982 /* Kill the dead block, but not the blocks below it. */
6984 gfc_free_statements (cd);
6988 resolve_select (code);
6993 /* Resolve a transfer statement. This is making sure that:
6994 -- a derived type being transferred has only non-pointer components
6995 -- a derived type being transferred doesn't have private components, unless
6996 it's being transferred from the module where the type was defined
6997 -- we're not trying to transfer a whole assumed size array. */
7000 resolve_transfer (gfc_code *code)
7009 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
7012 sym = exp->symtree->n.sym;
7015 /* Go to actual component transferred. */
7016 for (ref = code->expr1->ref; ref; ref = ref->next)
7017 if (ref->type == REF_COMPONENT)
7018 ts = &ref->u.c.component->ts;
7020 if (ts->type == BT_DERIVED)
7022 /* Check that transferred derived type doesn't contain POINTER
7024 if (ts->u.derived->attr.pointer_comp)
7026 gfc_error ("Data transfer element at %L cannot have "
7027 "POINTER components", &code->loc);
7031 if (ts->u.derived->attr.alloc_comp)
7033 gfc_error ("Data transfer element at %L cannot have "
7034 "ALLOCATABLE components", &code->loc);
7038 if (derived_inaccessible (ts->u.derived))
7040 gfc_error ("Data transfer element at %L cannot have "
7041 "PRIVATE components",&code->loc);
7046 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7047 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7049 gfc_error ("Data transfer element at %L cannot be a full reference to "
7050 "an assumed-size array", &code->loc);
7056 /*********** Toplevel code resolution subroutines ***********/
7058 /* Find the set of labels that are reachable from this block. We also
7059 record the last statement in each block. */
7062 find_reachable_labels (gfc_code *block)
7069 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
7071 /* Collect labels in this block. We don't keep those corresponding
7072 to END {IF|SELECT}, these are checked in resolve_branch by going
7073 up through the code_stack. */
7074 for (c = block; c; c = c->next)
7076 if (c->here && c->op != EXEC_END_BLOCK)
7077 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
7080 /* Merge with labels from parent block. */
7083 gcc_assert (cs_base->prev->reachable_labels);
7084 bitmap_ior_into (cs_base->reachable_labels,
7085 cs_base->prev->reachable_labels);
7089 /* Given a branch to a label, see if the branch is conforming.
7090 The code node describes where the branch is located. */
7093 resolve_branch (gfc_st_label *label, gfc_code *code)
7100 /* Step one: is this a valid branching target? */
7102 if (label->defined == ST_LABEL_UNKNOWN)
7104 gfc_error ("Label %d referenced at %L is never defined", label->value,
7109 if (label->defined != ST_LABEL_TARGET)
7111 gfc_error ("Statement at %L is not a valid branch target statement "
7112 "for the branch statement at %L", &label->where, &code->loc);
7116 /* Step two: make sure this branch is not a branch to itself ;-) */
7118 if (code->here == label)
7120 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
7124 /* Step three: See if the label is in the same block as the
7125 branching statement. The hard work has been done by setting up
7126 the bitmap reachable_labels. */
7128 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
7131 /* Step four: If we haven't found the label in the bitmap, it may
7132 still be the label of the END of the enclosing block, in which
7133 case we find it by going up the code_stack. */
7135 for (stack = cs_base; stack; stack = stack->prev)
7136 if (stack->current->next && stack->current->next->here == label)
7141 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
7145 /* The label is not in an enclosing block, so illegal. This was
7146 allowed in Fortran 66, so we allow it as extension. No
7147 further checks are necessary in this case. */
7148 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
7149 "as the GOTO statement at %L", &label->where,
7155 /* Check whether EXPR1 has the same shape as EXPR2. */
7158 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
7160 mpz_t shape[GFC_MAX_DIMENSIONS];
7161 mpz_t shape2[GFC_MAX_DIMENSIONS];
7162 gfc_try result = FAILURE;
7165 /* Compare the rank. */
7166 if (expr1->rank != expr2->rank)
7169 /* Compare the size of each dimension. */
7170 for (i=0; i<expr1->rank; i++)
7172 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
7175 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
7178 if (mpz_cmp (shape[i], shape2[i]))
7182 /* When either of the two expression is an assumed size array, we
7183 ignore the comparison of dimension sizes. */
7188 for (i--; i >= 0; i--)
7190 mpz_clear (shape[i]);
7191 mpz_clear (shape2[i]);
7197 /* Check whether a WHERE assignment target or a WHERE mask expression
7198 has the same shape as the outmost WHERE mask expression. */
7201 resolve_where (gfc_code *code, gfc_expr *mask)
7207 cblock = code->block;
7209 /* Store the first WHERE mask-expr of the WHERE statement or construct.
7210 In case of nested WHERE, only the outmost one is stored. */
7211 if (mask == NULL) /* outmost WHERE */
7213 else /* inner WHERE */
7220 /* Check if the mask-expr has a consistent shape with the
7221 outmost WHERE mask-expr. */
7222 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
7223 gfc_error ("WHERE mask at %L has inconsistent shape",
7224 &cblock->expr1->where);
7227 /* the assignment statement of a WHERE statement, or the first
7228 statement in where-body-construct of a WHERE construct */
7229 cnext = cblock->next;
7234 /* WHERE assignment statement */
7237 /* Check shape consistent for WHERE assignment target. */
7238 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
7239 gfc_error ("WHERE assignment target at %L has "
7240 "inconsistent shape", &cnext->expr1->where);
7244 case EXEC_ASSIGN_CALL:
7245 resolve_call (cnext);
7246 if (!cnext->resolved_sym->attr.elemental)
7247 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
7248 &cnext->ext.actual->expr->where);
7251 /* WHERE or WHERE construct is part of a where-body-construct */
7253 resolve_where (cnext, e);
7257 gfc_error ("Unsupported statement inside WHERE at %L",
7260 /* the next statement within the same where-body-construct */
7261 cnext = cnext->next;
7263 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
7264 cblock = cblock->block;
7269 /* Resolve assignment in FORALL construct.
7270 NVAR is the number of FORALL index variables, and VAR_EXPR records the
7271 FORALL index variables. */
7274 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
7278 for (n = 0; n < nvar; n++)
7280 gfc_symbol *forall_index;
7282 forall_index = var_expr[n]->symtree->n.sym;
7284 /* Check whether the assignment target is one of the FORALL index
7286 if ((code->expr1->expr_type == EXPR_VARIABLE)
7287 && (code->expr1->symtree->n.sym == forall_index))
7288 gfc_error ("Assignment to a FORALL index variable at %L",
7289 &code->expr1->where);
7292 /* If one of the FORALL index variables doesn't appear in the
7293 assignment variable, then there could be a many-to-one
7294 assignment. Emit a warning rather than an error because the
7295 mask could be resolving this problem. */
7296 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
7297 gfc_warning ("The FORALL with index '%s' is not used on the "
7298 "left side of the assignment at %L and so might "
7299 "cause multiple assignment to this object",
7300 var_expr[n]->symtree->name, &code->expr1->where);
7306 /* Resolve WHERE statement in FORALL construct. */
7309 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
7310 gfc_expr **var_expr)
7315 cblock = code->block;
7318 /* the assignment statement of a WHERE statement, or the first
7319 statement in where-body-construct of a WHERE construct */
7320 cnext = cblock->next;
7325 /* WHERE assignment statement */
7327 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
7330 /* WHERE operator assignment statement */
7331 case EXEC_ASSIGN_CALL:
7332 resolve_call (cnext);
7333 if (!cnext->resolved_sym->attr.elemental)
7334 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
7335 &cnext->ext.actual->expr->where);
7338 /* WHERE or WHERE construct is part of a where-body-construct */
7340 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
7344 gfc_error ("Unsupported statement inside WHERE at %L",
7347 /* the next statement within the same where-body-construct */
7348 cnext = cnext->next;
7350 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
7351 cblock = cblock->block;
7356 /* Traverse the FORALL body to check whether the following errors exist:
7357 1. For assignment, check if a many-to-one assignment happens.
7358 2. For WHERE statement, check the WHERE body to see if there is any
7359 many-to-one assignment. */
7362 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
7366 c = code->block->next;
7372 case EXEC_POINTER_ASSIGN:
7373 gfc_resolve_assign_in_forall (c, nvar, var_expr);
7376 case EXEC_ASSIGN_CALL:
7380 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
7381 there is no need to handle it here. */
7385 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
7390 /* The next statement in the FORALL body. */
7396 /* Counts the number of iterators needed inside a forall construct, including
7397 nested forall constructs. This is used to allocate the needed memory
7398 in gfc_resolve_forall. */
7401 gfc_count_forall_iterators (gfc_code *code)
7403 int max_iters, sub_iters, current_iters;
7404 gfc_forall_iterator *fa;
7406 gcc_assert(code->op == EXEC_FORALL);
7410 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
7413 code = code->block->next;
7417 if (code->op == EXEC_FORALL)
7419 sub_iters = gfc_count_forall_iterators (code);
7420 if (sub_iters > max_iters)
7421 max_iters = sub_iters;
7426 return current_iters + max_iters;
7430 /* Given a FORALL construct, first resolve the FORALL iterator, then call
7431 gfc_resolve_forall_body to resolve the FORALL body. */
7434 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
7436 static gfc_expr **var_expr;
7437 static int total_var = 0;
7438 static int nvar = 0;
7440 gfc_forall_iterator *fa;
7445 /* Start to resolve a FORALL construct */
7446 if (forall_save == 0)
7448 /* Count the total number of FORALL index in the nested FORALL
7449 construct in order to allocate the VAR_EXPR with proper size. */
7450 total_var = gfc_count_forall_iterators (code);
7452 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
7453 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
7456 /* The information about FORALL iterator, including FORALL index start, end
7457 and stride. The FORALL index can not appear in start, end or stride. */
7458 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
7460 /* Check if any outer FORALL index name is the same as the current
7462 for (i = 0; i < nvar; i++)
7464 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
7466 gfc_error ("An outer FORALL construct already has an index "
7467 "with this name %L", &fa->var->where);
7471 /* Record the current FORALL index. */
7472 var_expr[nvar] = gfc_copy_expr (fa->var);
7476 /* No memory leak. */
7477 gcc_assert (nvar <= total_var);
7480 /* Resolve the FORALL body. */
7481 gfc_resolve_forall_body (code, nvar, var_expr);
7483 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
7484 gfc_resolve_blocks (code->block, ns);
7488 /* Free only the VAR_EXPRs allocated in this frame. */
7489 for (i = nvar; i < tmp; i++)
7490 gfc_free_expr (var_expr[i]);
7494 /* We are in the outermost FORALL construct. */
7495 gcc_assert (forall_save == 0);
7497 /* VAR_EXPR is not needed any more. */
7498 gfc_free (var_expr);
7504 /* Resolve a BLOCK construct statement. */
7507 resolve_block_construct (gfc_code* code)
7509 /* Eventually, we may want to do some checks here or handle special stuff.
7510 But so far the only thing we can do is resolving the local namespace. */
7512 gfc_resolve (code->ext.ns);
7516 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
7519 static void resolve_code (gfc_code *, gfc_namespace *);
7522 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
7526 for (; b; b = b->block)
7528 t = gfc_resolve_expr (b->expr1);
7529 if (gfc_resolve_expr (b->expr2) == FAILURE)
7535 if (t == SUCCESS && b->expr1 != NULL
7536 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
7537 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7544 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
7545 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
7550 resolve_branch (b->label1, b);
7554 resolve_block_construct (b);
7558 case EXEC_SELECT_TYPE:
7568 case EXEC_OMP_ATOMIC:
7569 case EXEC_OMP_CRITICAL:
7571 case EXEC_OMP_MASTER:
7572 case EXEC_OMP_ORDERED:
7573 case EXEC_OMP_PARALLEL:
7574 case EXEC_OMP_PARALLEL_DO:
7575 case EXEC_OMP_PARALLEL_SECTIONS:
7576 case EXEC_OMP_PARALLEL_WORKSHARE:
7577 case EXEC_OMP_SECTIONS:
7578 case EXEC_OMP_SINGLE:
7580 case EXEC_OMP_TASKWAIT:
7581 case EXEC_OMP_WORKSHARE:
7585 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
7588 resolve_code (b->next, ns);
7593 /* Does everything to resolve an ordinary assignment. Returns true
7594 if this is an interface assignment. */
7596 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
7606 if (gfc_extend_assign (code, ns) == SUCCESS)
7610 if (code->op == EXEC_ASSIGN_CALL)
7612 lhs = code->ext.actual->expr;
7613 rhsptr = &code->ext.actual->next->expr;
7617 gfc_actual_arglist* args;
7618 gfc_typebound_proc* tbp;
7620 gcc_assert (code->op == EXEC_COMPCALL);
7622 args = code->expr1->value.compcall.actual;
7624 rhsptr = &args->next->expr;
7626 tbp = code->expr1->value.compcall.tbp;
7627 gcc_assert (!tbp->is_generic);
7630 /* Make a temporary rhs when there is a default initializer
7631 and rhs is the same symbol as the lhs. */
7632 if ((*rhsptr)->expr_type == EXPR_VARIABLE
7633 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
7634 && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
7635 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
7636 *rhsptr = gfc_get_parentheses (*rhsptr);
7645 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
7646 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
7647 &code->loc) == FAILURE)
7650 /* Handle the case of a BOZ literal on the RHS. */
7651 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
7654 if (gfc_option.warn_surprising)
7655 gfc_warning ("BOZ literal at %L is bitwise transferred "
7656 "non-integer symbol '%s'", &code->loc,
7657 lhs->symtree->n.sym->name);
7659 if (!gfc_convert_boz (rhs, &lhs->ts))
7661 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
7663 if (rc == ARITH_UNDERFLOW)
7664 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
7665 ". This check can be disabled with the option "
7666 "-fno-range-check", &rhs->where);
7667 else if (rc == ARITH_OVERFLOW)
7668 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
7669 ". This check can be disabled with the option "
7670 "-fno-range-check", &rhs->where);
7671 else if (rc == ARITH_NAN)
7672 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
7673 ". This check can be disabled with the option "
7674 "-fno-range-check", &rhs->where);
7680 if (lhs->ts.type == BT_CHARACTER
7681 && gfc_option.warn_character_truncation)
7683 if (lhs->ts.u.cl != NULL
7684 && lhs->ts.u.cl->length != NULL
7685 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7686 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
7688 if (rhs->expr_type == EXPR_CONSTANT)
7689 rlen = rhs->value.character.length;
7691 else if (rhs->ts.u.cl != NULL
7692 && rhs->ts.u.cl->length != NULL
7693 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7694 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
7696 if (rlen && llen && rlen > llen)
7697 gfc_warning_now ("CHARACTER expression will be truncated "
7698 "in assignment (%d/%d) at %L",
7699 llen, rlen, &code->loc);
7702 /* Ensure that a vector index expression for the lvalue is evaluated
7703 to a temporary if the lvalue symbol is referenced in it. */
7706 for (ref = lhs->ref; ref; ref= ref->next)
7707 if (ref->type == REF_ARRAY)
7709 for (n = 0; n < ref->u.ar.dimen; n++)
7710 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
7711 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
7712 ref->u.ar.start[n]))
7714 = gfc_get_parentheses (ref->u.ar.start[n]);
7718 if (gfc_pure (NULL))
7720 if (gfc_impure_variable (lhs->symtree->n.sym))
7722 gfc_error ("Cannot assign to variable '%s' in PURE "
7724 lhs->symtree->n.sym->name,
7729 if (lhs->ts.type == BT_DERIVED
7730 && lhs->expr_type == EXPR_VARIABLE
7731 && lhs->ts.u.derived->attr.pointer_comp
7732 && gfc_impure_variable (rhs->symtree->n.sym))
7734 gfc_error ("The impure variable at %L is assigned to "
7735 "a derived type variable with a POINTER "
7736 "component in a PURE procedure (12.6)",
7743 if (lhs->ts.type == BT_CLASS)
7745 gfc_error ("Variable must not be polymorphic in assignment at %L",
7750 gfc_check_assign (lhs, rhs, 1);
7755 /* Given a block of code, recursively resolve everything pointed to by this
7759 resolve_code (gfc_code *code, gfc_namespace *ns)
7761 int omp_workshare_save;
7766 frame.prev = cs_base;
7770 find_reachable_labels (code);
7772 for (; code; code = code->next)
7774 frame.current = code;
7775 forall_save = forall_flag;
7777 if (code->op == EXEC_FORALL)
7780 gfc_resolve_forall (code, ns, forall_save);
7783 else if (code->block)
7785 omp_workshare_save = -1;
7788 case EXEC_OMP_PARALLEL_WORKSHARE:
7789 omp_workshare_save = omp_workshare_flag;
7790 omp_workshare_flag = 1;
7791 gfc_resolve_omp_parallel_blocks (code, ns);
7793 case EXEC_OMP_PARALLEL:
7794 case EXEC_OMP_PARALLEL_DO:
7795 case EXEC_OMP_PARALLEL_SECTIONS:
7797 omp_workshare_save = omp_workshare_flag;
7798 omp_workshare_flag = 0;
7799 gfc_resolve_omp_parallel_blocks (code, ns);
7802 gfc_resolve_omp_do_blocks (code, ns);
7804 case EXEC_OMP_WORKSHARE:
7805 omp_workshare_save = omp_workshare_flag;
7806 omp_workshare_flag = 1;
7809 gfc_resolve_blocks (code->block, ns);
7813 if (omp_workshare_save != -1)
7814 omp_workshare_flag = omp_workshare_save;
7818 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
7819 t = gfc_resolve_expr (code->expr1);
7820 forall_flag = forall_save;
7822 if (gfc_resolve_expr (code->expr2) == FAILURE)
7825 if (code->op == EXEC_ALLOCATE
7826 && gfc_resolve_expr (code->expr3) == FAILURE)
7832 case EXEC_END_BLOCK:
7839 case EXEC_ASSIGN_CALL:
7843 /* Keep track of which entry we are up to. */
7844 current_entry_id = code->ext.entry->id;
7848 resolve_where (code, NULL);
7852 if (code->expr1 != NULL)
7854 if (code->expr1->ts.type != BT_INTEGER)
7855 gfc_error ("ASSIGNED GOTO statement at %L requires an "
7856 "INTEGER variable", &code->expr1->where);
7857 else if (code->expr1->symtree->n.sym->attr.assign != 1)
7858 gfc_error ("Variable '%s' has not been assigned a target "
7859 "label at %L", code->expr1->symtree->n.sym->name,
7860 &code->expr1->where);
7863 resolve_branch (code->label1, code);
7867 if (code->expr1 != NULL
7868 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
7869 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
7870 "INTEGER return specifier", &code->expr1->where);
7873 case EXEC_INIT_ASSIGN:
7874 case EXEC_END_PROCEDURE:
7881 if (resolve_ordinary_assign (code, ns))
7883 if (code->op == EXEC_COMPCALL)
7890 case EXEC_LABEL_ASSIGN:
7891 if (code->label1->defined == ST_LABEL_UNKNOWN)
7892 gfc_error ("Label %d referenced at %L is never defined",
7893 code->label1->value, &code->label1->where);
7895 && (code->expr1->expr_type != EXPR_VARIABLE
7896 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
7897 || code->expr1->symtree->n.sym->ts.kind
7898 != gfc_default_integer_kind
7899 || code->expr1->symtree->n.sym->as != NULL))
7900 gfc_error ("ASSIGN statement at %L requires a scalar "
7901 "default INTEGER variable", &code->expr1->where);
7904 case EXEC_POINTER_ASSIGN:
7908 gfc_check_pointer_assign (code->expr1, code->expr2);
7911 case EXEC_ARITHMETIC_IF:
7913 && code->expr1->ts.type != BT_INTEGER
7914 && code->expr1->ts.type != BT_REAL)
7915 gfc_error ("Arithmetic IF statement at %L requires a numeric "
7916 "expression", &code->expr1->where);
7918 resolve_branch (code->label1, code);
7919 resolve_branch (code->label2, code);
7920 resolve_branch (code->label3, code);
7924 if (t == SUCCESS && code->expr1 != NULL
7925 && (code->expr1->ts.type != BT_LOGICAL
7926 || code->expr1->rank != 0))
7927 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7928 &code->expr1->where);
7933 resolve_call (code);
7938 if (code->expr1->symtree
7939 && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
7940 resolve_class_typebound_call (code);
7942 resolve_typebound_call (code);
7946 resolve_ppc_call (code);
7950 /* Select is complicated. Also, a SELECT construct could be
7951 a transformed computed GOTO. */
7952 resolve_select (code);
7955 case EXEC_SELECT_TYPE:
7956 resolve_select_type (code);
7960 gfc_resolve (code->ext.ns);
7964 if (code->ext.iterator != NULL)
7966 gfc_iterator *iter = code->ext.iterator;
7967 if (gfc_resolve_iterator (iter, true) != FAILURE)
7968 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
7973 if (code->expr1 == NULL)
7974 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
7976 && (code->expr1->rank != 0
7977 || code->expr1->ts.type != BT_LOGICAL))
7978 gfc_error ("Exit condition of DO WHILE loop at %L must be "
7979 "a scalar LOGICAL expression", &code->expr1->where);
7984 resolve_allocate_deallocate (code, "ALLOCATE");
7988 case EXEC_DEALLOCATE:
7990 resolve_allocate_deallocate (code, "DEALLOCATE");
7995 if (gfc_resolve_open (code->ext.open) == FAILURE)
7998 resolve_branch (code->ext.open->err, code);
8002 if (gfc_resolve_close (code->ext.close) == FAILURE)
8005 resolve_branch (code->ext.close->err, code);
8008 case EXEC_BACKSPACE:
8012 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
8015 resolve_branch (code->ext.filepos->err, code);
8019 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8022 resolve_branch (code->ext.inquire->err, code);
8026 gcc_assert (code->ext.inquire != NULL);
8027 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8030 resolve_branch (code->ext.inquire->err, code);
8034 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
8037 resolve_branch (code->ext.wait->err, code);
8038 resolve_branch (code->ext.wait->end, code);
8039 resolve_branch (code->ext.wait->eor, code);
8044 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
8047 resolve_branch (code->ext.dt->err, code);
8048 resolve_branch (code->ext.dt->end, code);
8049 resolve_branch (code->ext.dt->eor, code);
8053 resolve_transfer (code);
8057 resolve_forall_iterators (code->ext.forall_iterator);
8059 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
8060 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
8061 "expression", &code->expr1->where);
8064 case EXEC_OMP_ATOMIC:
8065 case EXEC_OMP_BARRIER:
8066 case EXEC_OMP_CRITICAL:
8067 case EXEC_OMP_FLUSH:
8069 case EXEC_OMP_MASTER:
8070 case EXEC_OMP_ORDERED:
8071 case EXEC_OMP_SECTIONS:
8072 case EXEC_OMP_SINGLE:
8073 case EXEC_OMP_TASKWAIT:
8074 case EXEC_OMP_WORKSHARE:
8075 gfc_resolve_omp_directive (code, ns);
8078 case EXEC_OMP_PARALLEL:
8079 case EXEC_OMP_PARALLEL_DO:
8080 case EXEC_OMP_PARALLEL_SECTIONS:
8081 case EXEC_OMP_PARALLEL_WORKSHARE:
8083 omp_workshare_save = omp_workshare_flag;
8084 omp_workshare_flag = 0;
8085 gfc_resolve_omp_directive (code, ns);
8086 omp_workshare_flag = omp_workshare_save;
8090 gfc_internal_error ("resolve_code(): Bad statement code");
8094 cs_base = frame.prev;
8098 /* Resolve initial values and make sure they are compatible with
8102 resolve_values (gfc_symbol *sym)
8104 if (sym->value == NULL)
8107 if (gfc_resolve_expr (sym->value) == FAILURE)
8110 gfc_check_assign_symbol (sym, sym->value);
8114 /* Verify the binding labels for common blocks that are BIND(C). The label
8115 for a BIND(C) common block must be identical in all scoping units in which
8116 the common block is declared. Further, the binding label can not collide
8117 with any other global entity in the program. */
8120 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
8122 if (comm_block_tree->n.common->is_bind_c == 1)
8124 gfc_gsymbol *binding_label_gsym;
8125 gfc_gsymbol *comm_name_gsym;
8127 /* See if a global symbol exists by the common block's name. It may
8128 be NULL if the common block is use-associated. */
8129 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
8130 comm_block_tree->n.common->name);
8131 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
8132 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
8133 "with the global entity '%s' at %L",
8134 comm_block_tree->n.common->binding_label,
8135 comm_block_tree->n.common->name,
8136 &(comm_block_tree->n.common->where),
8137 comm_name_gsym->name, &(comm_name_gsym->where));
8138 else if (comm_name_gsym != NULL
8139 && strcmp (comm_name_gsym->name,
8140 comm_block_tree->n.common->name) == 0)
8142 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
8144 if (comm_name_gsym->binding_label == NULL)
8145 /* No binding label for common block stored yet; save this one. */
8146 comm_name_gsym->binding_label =
8147 comm_block_tree->n.common->binding_label;
8149 if (strcmp (comm_name_gsym->binding_label,
8150 comm_block_tree->n.common->binding_label) != 0)
8152 /* Common block names match but binding labels do not. */
8153 gfc_error ("Binding label '%s' for common block '%s' at %L "
8154 "does not match the binding label '%s' for common "
8156 comm_block_tree->n.common->binding_label,
8157 comm_block_tree->n.common->name,
8158 &(comm_block_tree->n.common->where),
8159 comm_name_gsym->binding_label,
8160 comm_name_gsym->name,
8161 &(comm_name_gsym->where));
8166 /* There is no binding label (NAME="") so we have nothing further to
8167 check and nothing to add as a global symbol for the label. */
8168 if (comm_block_tree->n.common->binding_label[0] == '\0' )
8171 binding_label_gsym =
8172 gfc_find_gsymbol (gfc_gsym_root,
8173 comm_block_tree->n.common->binding_label);
8174 if (binding_label_gsym == NULL)
8176 /* Need to make a global symbol for the binding label to prevent
8177 it from colliding with another. */
8178 binding_label_gsym =
8179 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
8180 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
8181 binding_label_gsym->type = GSYM_COMMON;
8185 /* If comm_name_gsym is NULL, the name common block is use
8186 associated and the name could be colliding. */
8187 if (binding_label_gsym->type != GSYM_COMMON)
8188 gfc_error ("Binding label '%s' for common block '%s' at %L "
8189 "collides with the global entity '%s' at %L",
8190 comm_block_tree->n.common->binding_label,
8191 comm_block_tree->n.common->name,
8192 &(comm_block_tree->n.common->where),
8193 binding_label_gsym->name,
8194 &(binding_label_gsym->where));
8195 else if (comm_name_gsym != NULL
8196 && (strcmp (binding_label_gsym->name,
8197 comm_name_gsym->binding_label) != 0)
8198 && (strcmp (binding_label_gsym->sym_name,
8199 comm_name_gsym->name) != 0))
8200 gfc_error ("Binding label '%s' for common block '%s' at %L "
8201 "collides with global entity '%s' at %L",
8202 binding_label_gsym->name, binding_label_gsym->sym_name,
8203 &(comm_block_tree->n.common->where),
8204 comm_name_gsym->name, &(comm_name_gsym->where));
8212 /* Verify any BIND(C) derived types in the namespace so we can report errors
8213 for them once, rather than for each variable declared of that type. */
8216 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
8218 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
8219 && derived_sym->attr.is_bind_c == 1)
8220 verify_bind_c_derived_type (derived_sym);
8226 /* Verify that any binding labels used in a given namespace do not collide
8227 with the names or binding labels of any global symbols. */
8230 gfc_verify_binding_labels (gfc_symbol *sym)
8234 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
8235 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
8237 gfc_gsymbol *bind_c_sym;
8239 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
8240 if (bind_c_sym != NULL
8241 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
8243 if (sym->attr.if_source == IFSRC_DECL
8244 && (bind_c_sym->type != GSYM_SUBROUTINE
8245 && bind_c_sym->type != GSYM_FUNCTION)
8246 && ((sym->attr.contained == 1
8247 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
8248 || (sym->attr.use_assoc == 1
8249 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
8251 /* Make sure global procedures don't collide with anything. */
8252 gfc_error ("Binding label '%s' at %L collides with the global "
8253 "entity '%s' at %L", sym->binding_label,
8254 &(sym->declared_at), bind_c_sym->name,
8255 &(bind_c_sym->where));
8258 else if (sym->attr.contained == 0
8259 && (sym->attr.if_source == IFSRC_IFBODY
8260 && sym->attr.flavor == FL_PROCEDURE)
8261 && (bind_c_sym->sym_name != NULL
8262 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
8264 /* Make sure procedures in interface bodies don't collide. */
8265 gfc_error ("Binding label '%s' in interface body at %L collides "
8266 "with the global entity '%s' at %L",
8268 &(sym->declared_at), bind_c_sym->name,
8269 &(bind_c_sym->where));
8272 else if (sym->attr.contained == 0
8273 && sym->attr.if_source == IFSRC_UNKNOWN)
8274 if ((sym->attr.use_assoc && bind_c_sym->mod_name
8275 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
8276 || sym->attr.use_assoc == 0)
8278 gfc_error ("Binding label '%s' at %L collides with global "
8279 "entity '%s' at %L", sym->binding_label,
8280 &(sym->declared_at), bind_c_sym->name,
8281 &(bind_c_sym->where));
8286 /* Clear the binding label to prevent checking multiple times. */
8287 sym->binding_label[0] = '\0';
8289 else if (bind_c_sym == NULL)
8291 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
8292 bind_c_sym->where = sym->declared_at;
8293 bind_c_sym->sym_name = sym->name;
8295 if (sym->attr.use_assoc == 1)
8296 bind_c_sym->mod_name = sym->module;
8298 if (sym->ns->proc_name != NULL)
8299 bind_c_sym->mod_name = sym->ns->proc_name->name;
8301 if (sym->attr.contained == 0)
8303 if (sym->attr.subroutine)
8304 bind_c_sym->type = GSYM_SUBROUTINE;
8305 else if (sym->attr.function)
8306 bind_c_sym->type = GSYM_FUNCTION;
8314 /* Resolve an index expression. */
8317 resolve_index_expr (gfc_expr *e)
8319 if (gfc_resolve_expr (e) == FAILURE)
8322 if (gfc_simplify_expr (e, 0) == FAILURE)
8325 if (gfc_specification_expr (e) == FAILURE)
8331 /* Resolve a charlen structure. */
8334 resolve_charlen (gfc_charlen *cl)
8343 specification_expr = 1;
8345 if (resolve_index_expr (cl->length) == FAILURE)
8347 specification_expr = 0;
8351 /* "If the character length parameter value evaluates to a negative
8352 value, the length of character entities declared is zero." */
8353 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
8355 gfc_warning_now ("CHARACTER variable has zero length at %L",
8356 &cl->length->where);
8357 gfc_replace_expr (cl->length, gfc_int_expr (0));
8360 /* Check that the character length is not too large. */
8361 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
8362 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
8363 && cl->length->ts.type == BT_INTEGER
8364 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
8366 gfc_error ("String length at %L is too large", &cl->length->where);
8374 /* Test for non-constant shape arrays. */
8377 is_non_constant_shape_array (gfc_symbol *sym)
8383 not_constant = false;
8384 if (sym->as != NULL)
8386 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
8387 has not been simplified; parameter array references. Do the
8388 simplification now. */
8389 for (i = 0; i < sym->as->rank; i++)
8391 e = sym->as->lower[i];
8392 if (e && (resolve_index_expr (e) == FAILURE
8393 || !gfc_is_constant_expr (e)))
8394 not_constant = true;
8396 e = sym->as->upper[i];
8397 if (e && (resolve_index_expr (e) == FAILURE
8398 || !gfc_is_constant_expr (e)))
8399 not_constant = true;
8402 return not_constant;
8405 /* Given a symbol and an initialization expression, add code to initialize
8406 the symbol to the function entry. */
8408 build_init_assign (gfc_symbol *sym, gfc_expr *init)
8412 gfc_namespace *ns = sym->ns;
8414 /* Search for the function namespace if this is a contained
8415 function without an explicit result. */
8416 if (sym->attr.function && sym == sym->result
8417 && sym->name != sym->ns->proc_name->name)
8420 for (;ns; ns = ns->sibling)
8421 if (strcmp (ns->proc_name->name, sym->name) == 0)
8427 gfc_free_expr (init);
8431 /* Build an l-value expression for the result. */
8432 lval = gfc_lval_expr_from_sym (sym);
8434 /* Add the code at scope entry. */
8435 init_st = gfc_get_code ();
8436 init_st->next = ns->code;
8439 /* Assign the default initializer to the l-value. */
8440 init_st->loc = sym->declared_at;
8441 init_st->op = EXEC_INIT_ASSIGN;
8442 init_st->expr1 = lval;
8443 init_st->expr2 = init;
8446 /* Assign the default initializer to a derived type variable or result. */
8449 apply_default_init (gfc_symbol *sym)
8451 gfc_expr *init = NULL;
8453 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
8456 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
8457 init = gfc_default_initializer (&sym->ts);
8462 build_init_assign (sym, init);
8465 /* Build an initializer for a local integer, real, complex, logical, or
8466 character variable, based on the command line flags finit-local-zero,
8467 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
8468 null if the symbol should not have a default initialization. */
8470 build_default_init_expr (gfc_symbol *sym)
8473 gfc_expr *init_expr;
8476 /* These symbols should never have a default initialization. */
8477 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
8478 || sym->attr.external
8480 || sym->attr.pointer
8481 || sym->attr.in_equivalence
8482 || sym->attr.in_common
8485 || sym->attr.cray_pointee
8486 || sym->attr.cray_pointer)
8489 /* Now we'll try to build an initializer expression. */
8490 init_expr = gfc_get_expr ();
8491 init_expr->expr_type = EXPR_CONSTANT;
8492 init_expr->ts.type = sym->ts.type;
8493 init_expr->ts.kind = sym->ts.kind;
8494 init_expr->where = sym->declared_at;
8496 /* We will only initialize integers, reals, complex, logicals, and
8497 characters, and only if the corresponding command-line flags
8498 were set. Otherwise, we free init_expr and return null. */
8499 switch (sym->ts.type)
8502 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
8503 mpz_init_set_si (init_expr->value.integer,
8504 gfc_option.flag_init_integer_value);
8507 gfc_free_expr (init_expr);
8513 mpfr_init (init_expr->value.real);
8514 switch (gfc_option.flag_init_real)
8516 case GFC_INIT_REAL_SNAN:
8517 init_expr->is_snan = 1;
8519 case GFC_INIT_REAL_NAN:
8520 mpfr_set_nan (init_expr->value.real);
8523 case GFC_INIT_REAL_INF:
8524 mpfr_set_inf (init_expr->value.real, 1);
8527 case GFC_INIT_REAL_NEG_INF:
8528 mpfr_set_inf (init_expr->value.real, -1);
8531 case GFC_INIT_REAL_ZERO:
8532 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
8536 gfc_free_expr (init_expr);
8544 mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
8546 mpfr_init (init_expr->value.complex.r);
8547 mpfr_init (init_expr->value.complex.i);
8549 switch (gfc_option.flag_init_real)
8551 case GFC_INIT_REAL_SNAN:
8552 init_expr->is_snan = 1;
8554 case GFC_INIT_REAL_NAN:
8555 mpfr_set_nan (mpc_realref (init_expr->value.complex));
8556 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
8559 case GFC_INIT_REAL_INF:
8560 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
8561 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
8564 case GFC_INIT_REAL_NEG_INF:
8565 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
8566 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
8569 case GFC_INIT_REAL_ZERO:
8571 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
8573 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
8574 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
8579 gfc_free_expr (init_expr);
8586 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
8587 init_expr->value.logical = 0;
8588 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
8589 init_expr->value.logical = 1;
8592 gfc_free_expr (init_expr);
8598 /* For characters, the length must be constant in order to
8599 create a default initializer. */
8600 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
8601 && sym->ts.u.cl->length
8602 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8604 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
8605 init_expr->value.character.length = char_len;
8606 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
8607 for (i = 0; i < char_len; i++)
8608 init_expr->value.character.string[i]
8609 = (unsigned char) gfc_option.flag_init_character_value;
8613 gfc_free_expr (init_expr);
8619 gfc_free_expr (init_expr);
8625 /* Add an initialization expression to a local variable. */
8627 apply_default_init_local (gfc_symbol *sym)
8629 gfc_expr *init = NULL;
8631 /* The symbol should be a variable or a function return value. */
8632 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
8633 || (sym->attr.function && sym->result != sym))
8636 /* Try to build the initializer expression. If we can't initialize
8637 this symbol, then init will be NULL. */
8638 init = build_default_init_expr (sym);
8642 /* For saved variables, we don't want to add an initializer at
8643 function entry, so we just add a static initializer. */
8644 if (sym->attr.save || sym->ns->save_all
8645 || gfc_option.flag_max_stack_var_size == 0)
8647 /* Don't clobber an existing initializer! */
8648 gcc_assert (sym->value == NULL);
8653 build_init_assign (sym, init);
8656 /* Resolution of common features of flavors variable and procedure. */
8659 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
8661 /* Constraints on deferred shape variable. */
8662 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
8664 if (sym->attr.allocatable)
8666 if (sym->attr.dimension)
8668 gfc_error ("Allocatable array '%s' at %L must have "
8669 "a deferred shape", sym->name, &sym->declared_at);
8672 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
8673 "may not be ALLOCATABLE", sym->name,
8674 &sym->declared_at) == FAILURE)
8678 if (sym->attr.pointer && sym->attr.dimension)
8680 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
8681 sym->name, &sym->declared_at);
8688 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
8689 && !sym->attr.dummy && sym->ts.type != BT_CLASS)
8691 gfc_error ("Array '%s' at %L cannot have a deferred shape",
8692 sym->name, &sym->declared_at);
8700 /* Additional checks for symbols with flavor variable and derived
8701 type. To be called from resolve_fl_variable. */
8704 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
8706 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
8708 /* Check to see if a derived type is blocked from being host
8709 associated by the presence of another class I symbol in the same
8710 namespace. 14.6.1.3 of the standard and the discussion on
8711 comp.lang.fortran. */
8712 if (sym->ns != sym->ts.u.derived->ns
8713 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
8716 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
8717 if (s && s->attr.flavor != FL_DERIVED)
8719 gfc_error ("The type '%s' cannot be host associated at %L "
8720 "because it is blocked by an incompatible object "
8721 "of the same name declared at %L",
8722 sym->ts.u.derived->name, &sym->declared_at,
8728 /* 4th constraint in section 11.3: "If an object of a type for which
8729 component-initialization is specified (R429) appears in the
8730 specification-part of a module and does not have the ALLOCATABLE
8731 or POINTER attribute, the object shall have the SAVE attribute."
8733 The check for initializers is performed with
8734 has_default_initializer because gfc_default_initializer generates
8735 a hidden default for allocatable components. */
8736 if (!(sym->value || no_init_flag) && sym->ns->proc_name
8737 && sym->ns->proc_name->attr.flavor == FL_MODULE
8738 && !sym->ns->save_all && !sym->attr.save
8739 && !sym->attr.pointer && !sym->attr.allocatable
8740 && has_default_initializer (sym->ts.u.derived))
8742 gfc_error("Object '%s' at %L must have the SAVE attribute for "
8743 "default initialization of a component",
8744 sym->name, &sym->declared_at);
8748 if (sym->ts.type == BT_CLASS)
8751 if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
8753 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
8754 sym->ts.u.derived->name, sym->name, &sym->declared_at);
8759 /* Assume that use associated symbols were checked in the module ns. */
8760 if (!sym->attr.class_ok && !sym->attr.use_assoc)
8762 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
8763 "or pointer", sym->name, &sym->declared_at);
8768 /* Assign default initializer. */
8769 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
8770 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
8772 sym->value = gfc_default_initializer (&sym->ts);
8779 /* Resolve symbols with flavor variable. */
8782 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
8784 int no_init_flag, automatic_flag;
8786 const char *auto_save_msg;
8788 auto_save_msg = "Automatic object '%s' at %L cannot have the "
8791 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
8794 /* Set this flag to check that variables are parameters of all entries.
8795 This check is effected by the call to gfc_resolve_expr through
8796 is_non_constant_shape_array. */
8797 specification_expr = 1;
8799 if (sym->ns->proc_name
8800 && (sym->ns->proc_name->attr.flavor == FL_MODULE
8801 || sym->ns->proc_name->attr.is_main_program)
8802 && !sym->attr.use_assoc
8803 && !sym->attr.allocatable
8804 && !sym->attr.pointer
8805 && is_non_constant_shape_array (sym))
8807 /* The shape of a main program or module array needs to be
8809 gfc_error ("The module or main program array '%s' at %L must "
8810 "have constant shape", sym->name, &sym->declared_at);
8811 specification_expr = 0;
8815 if (sym->ts.type == BT_CHARACTER)
8817 /* Make sure that character string variables with assumed length are
8819 e = sym->ts.u.cl->length;
8820 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
8822 gfc_error ("Entity with assumed character length at %L must be a "
8823 "dummy argument or a PARAMETER", &sym->declared_at);
8827 if (e && sym->attr.save && !gfc_is_constant_expr (e))
8829 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
8833 if (!gfc_is_constant_expr (e)
8834 && !(e->expr_type == EXPR_VARIABLE
8835 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
8836 && sym->ns->proc_name
8837 && (sym->ns->proc_name->attr.flavor == FL_MODULE
8838 || sym->ns->proc_name->attr.is_main_program)
8839 && !sym->attr.use_assoc)
8841 gfc_error ("'%s' at %L must have constant character length "
8842 "in this context", sym->name, &sym->declared_at);
8847 if (sym->value == NULL && sym->attr.referenced)
8848 apply_default_init_local (sym); /* Try to apply a default initialization. */
8850 /* Determine if the symbol may not have an initializer. */
8851 no_init_flag = automatic_flag = 0;
8852 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
8853 || sym->attr.intrinsic || sym->attr.result)
8855 else if (sym->attr.dimension && !sym->attr.pointer
8856 && is_non_constant_shape_array (sym))
8858 no_init_flag = automatic_flag = 1;
8860 /* Also, they must not have the SAVE attribute.
8861 SAVE_IMPLICIT is checked below. */
8862 if (sym->attr.save == SAVE_EXPLICIT)
8864 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
8869 /* Ensure that any initializer is simplified. */
8871 gfc_simplify_expr (sym->value, 1);
8873 /* Reject illegal initializers. */
8874 if (!sym->mark && sym->value)
8876 if (sym->attr.allocatable)
8877 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
8878 sym->name, &sym->declared_at);
8879 else if (sym->attr.external)
8880 gfc_error ("External '%s' at %L cannot have an initializer",
8881 sym->name, &sym->declared_at);
8882 else if (sym->attr.dummy
8883 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
8884 gfc_error ("Dummy '%s' at %L cannot have an initializer",
8885 sym->name, &sym->declared_at);
8886 else if (sym->attr.intrinsic)
8887 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
8888 sym->name, &sym->declared_at);
8889 else if (sym->attr.result)
8890 gfc_error ("Function result '%s' at %L cannot have an initializer",
8891 sym->name, &sym->declared_at);
8892 else if (automatic_flag)
8893 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
8894 sym->name, &sym->declared_at);
8901 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
8902 return resolve_fl_variable_derived (sym, no_init_flag);
8908 /* Resolve a procedure. */
8911 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
8913 gfc_formal_arglist *arg;
8915 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
8916 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
8917 "interfaces", sym->name, &sym->declared_at);
8919 if (sym->attr.function
8920 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
8923 if (sym->ts.type == BT_CHARACTER)
8925 gfc_charlen *cl = sym->ts.u.cl;
8927 if (cl && cl->length && gfc_is_constant_expr (cl->length)
8928 && resolve_charlen (cl) == FAILURE)
8931 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
8933 if (sym->attr.proc == PROC_ST_FUNCTION)
8935 gfc_error ("Character-valued statement function '%s' at %L must "
8936 "have constant length", sym->name, &sym->declared_at);
8940 if (sym->attr.external && sym->formal == NULL
8941 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
8943 gfc_error ("Automatic character length function '%s' at %L must "
8944 "have an explicit interface", sym->name,
8951 /* Ensure that derived type for are not of a private type. Internal
8952 module procedures are excluded by 2.2.3.3 - i.e., they are not
8953 externally accessible and can access all the objects accessible in
8955 if (!(sym->ns->parent
8956 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
8957 && gfc_check_access(sym->attr.access, sym->ns->default_access))
8959 gfc_interface *iface;
8961 for (arg = sym->formal; arg; arg = arg->next)
8964 && arg->sym->ts.type == BT_DERIVED
8965 && !arg->sym->ts.u.derived->attr.use_assoc
8966 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
8967 arg->sym->ts.u.derived->ns->default_access)
8968 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
8969 "PRIVATE type and cannot be a dummy argument"
8970 " of '%s', which is PUBLIC at %L",
8971 arg->sym->name, sym->name, &sym->declared_at)
8974 /* Stop this message from recurring. */
8975 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
8980 /* PUBLIC interfaces may expose PRIVATE procedures that take types
8981 PRIVATE to the containing module. */
8982 for (iface = sym->generic; iface; iface = iface->next)
8984 for (arg = iface->sym->formal; arg; arg = arg->next)
8987 && arg->sym->ts.type == BT_DERIVED
8988 && !arg->sym->ts.u.derived->attr.use_assoc
8989 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
8990 arg->sym->ts.u.derived->ns->default_access)
8991 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
8992 "'%s' in PUBLIC interface '%s' at %L "
8993 "takes dummy arguments of '%s' which is "
8994 "PRIVATE", iface->sym->name, sym->name,
8995 &iface->sym->declared_at,
8996 gfc_typename (&arg->sym->ts)) == FAILURE)
8998 /* Stop this message from recurring. */
8999 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9005 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9006 PRIVATE to the containing module. */
9007 for (iface = sym->generic; iface; iface = iface->next)
9009 for (arg = iface->sym->formal; arg; arg = arg->next)
9012 && arg->sym->ts.type == BT_DERIVED
9013 && !arg->sym->ts.u.derived->attr.use_assoc
9014 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9015 arg->sym->ts.u.derived->ns->default_access)
9016 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
9017 "'%s' in PUBLIC interface '%s' at %L "
9018 "takes dummy arguments of '%s' which is "
9019 "PRIVATE", iface->sym->name, sym->name,
9020 &iface->sym->declared_at,
9021 gfc_typename (&arg->sym->ts)) == FAILURE)
9023 /* Stop this message from recurring. */
9024 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9031 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
9032 && !sym->attr.proc_pointer)
9034 gfc_error ("Function '%s' at %L cannot have an initializer",
9035 sym->name, &sym->declared_at);
9039 /* An external symbol may not have an initializer because it is taken to be
9040 a procedure. Exception: Procedure Pointers. */
9041 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
9043 gfc_error ("External object '%s' at %L may not have an initializer",
9044 sym->name, &sym->declared_at);
9048 /* An elemental function is required to return a scalar 12.7.1 */
9049 if (sym->attr.elemental && sym->attr.function && sym->as)
9051 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
9052 "result", sym->name, &sym->declared_at);
9053 /* Reset so that the error only occurs once. */
9054 sym->attr.elemental = 0;
9058 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
9059 char-len-param shall not be array-valued, pointer-valued, recursive
9060 or pure. ....snip... A character value of * may only be used in the
9061 following ways: (i) Dummy arg of procedure - dummy associates with
9062 actual length; (ii) To declare a named constant; or (iii) External
9063 function - but length must be declared in calling scoping unit. */
9064 if (sym->attr.function
9065 && sym->ts.type == BT_CHARACTER
9066 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
9068 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
9069 || (sym->attr.recursive) || (sym->attr.pure))
9071 if (sym->as && sym->as->rank)
9072 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9073 "array-valued", sym->name, &sym->declared_at);
9075 if (sym->attr.pointer)
9076 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9077 "pointer-valued", sym->name, &sym->declared_at);
9080 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9081 "pure", sym->name, &sym->declared_at);
9083 if (sym->attr.recursive)
9084 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9085 "recursive", sym->name, &sym->declared_at);
9090 /* Appendix B.2 of the standard. Contained functions give an
9091 error anyway. Fixed-form is likely to be F77/legacy. */
9092 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
9093 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
9094 "CHARACTER(*) function '%s' at %L",
9095 sym->name, &sym->declared_at);
9098 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
9100 gfc_formal_arglist *curr_arg;
9101 int has_non_interop_arg = 0;
9103 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9104 sym->common_block) == FAILURE)
9106 /* Clear these to prevent looking at them again if there was an
9108 sym->attr.is_bind_c = 0;
9109 sym->attr.is_c_interop = 0;
9110 sym->ts.is_c_interop = 0;
9114 /* So far, no errors have been found. */
9115 sym->attr.is_c_interop = 1;
9116 sym->ts.is_c_interop = 1;
9119 curr_arg = sym->formal;
9120 while (curr_arg != NULL)
9122 /* Skip implicitly typed dummy args here. */
9123 if (curr_arg->sym->attr.implicit_type == 0)
9124 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
9125 /* If something is found to fail, record the fact so we
9126 can mark the symbol for the procedure as not being
9127 BIND(C) to try and prevent multiple errors being
9129 has_non_interop_arg = 1;
9131 curr_arg = curr_arg->next;
9134 /* See if any of the arguments were not interoperable and if so, clear
9135 the procedure symbol to prevent duplicate error messages. */
9136 if (has_non_interop_arg != 0)
9138 sym->attr.is_c_interop = 0;
9139 sym->ts.is_c_interop = 0;
9140 sym->attr.is_bind_c = 0;
9144 if (!sym->attr.proc_pointer)
9146 if (sym->attr.save == SAVE_EXPLICIT)
9148 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
9149 "in '%s' at %L", sym->name, &sym->declared_at);
9152 if (sym->attr.intent)
9154 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
9155 "in '%s' at %L", sym->name, &sym->declared_at);
9158 if (sym->attr.subroutine && sym->attr.result)
9160 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
9161 "in '%s' at %L", sym->name, &sym->declared_at);
9164 if (sym->attr.external && sym->attr.function
9165 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
9166 || sym->attr.contained))
9168 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
9169 "in '%s' at %L", sym->name, &sym->declared_at);
9172 if (strcmp ("ppr@", sym->name) == 0)
9174 gfc_error ("Procedure pointer result '%s' at %L "
9175 "is missing the pointer attribute",
9176 sym->ns->proc_name->name, &sym->declared_at);
9185 /* Resolve a list of finalizer procedures. That is, after they have hopefully
9186 been defined and we now know their defined arguments, check that they fulfill
9187 the requirements of the standard for procedures used as finalizers. */
9190 gfc_resolve_finalizers (gfc_symbol* derived)
9192 gfc_finalizer* list;
9193 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
9194 gfc_try result = SUCCESS;
9195 bool seen_scalar = false;
9197 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
9200 /* Walk over the list of finalizer-procedures, check them, and if any one
9201 does not fit in with the standard's definition, print an error and remove
9202 it from the list. */
9203 prev_link = &derived->f2k_derived->finalizers;
9204 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
9210 /* Skip this finalizer if we already resolved it. */
9211 if (list->proc_tree)
9213 prev_link = &(list->next);
9217 /* Check this exists and is a SUBROUTINE. */
9218 if (!list->proc_sym->attr.subroutine)
9220 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
9221 list->proc_sym->name, &list->where);
9225 /* We should have exactly one argument. */
9226 if (!list->proc_sym->formal || list->proc_sym->formal->next)
9228 gfc_error ("FINAL procedure at %L must have exactly one argument",
9232 arg = list->proc_sym->formal->sym;
9234 /* This argument must be of our type. */
9235 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
9237 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
9238 &arg->declared_at, derived->name);
9242 /* It must neither be a pointer nor allocatable nor optional. */
9243 if (arg->attr.pointer)
9245 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
9249 if (arg->attr.allocatable)
9251 gfc_error ("Argument of FINAL procedure at %L must not be"
9252 " ALLOCATABLE", &arg->declared_at);
9255 if (arg->attr.optional)
9257 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
9262 /* It must not be INTENT(OUT). */
9263 if (arg->attr.intent == INTENT_OUT)
9265 gfc_error ("Argument of FINAL procedure at %L must not be"
9266 " INTENT(OUT)", &arg->declared_at);
9270 /* Warn if the procedure is non-scalar and not assumed shape. */
9271 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
9272 && arg->as->type != AS_ASSUMED_SHAPE)
9273 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
9274 " shape argument", &arg->declared_at);
9276 /* Check that it does not match in kind and rank with a FINAL procedure
9277 defined earlier. To really loop over the *earlier* declarations,
9278 we need to walk the tail of the list as new ones were pushed at the
9280 /* TODO: Handle kind parameters once they are implemented. */
9281 my_rank = (arg->as ? arg->as->rank : 0);
9282 for (i = list->next; i; i = i->next)
9284 /* Argument list might be empty; that is an error signalled earlier,
9285 but we nevertheless continued resolving. */
9286 if (i->proc_sym->formal)
9288 gfc_symbol* i_arg = i->proc_sym->formal->sym;
9289 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
9290 if (i_rank == my_rank)
9292 gfc_error ("FINAL procedure '%s' declared at %L has the same"
9293 " rank (%d) as '%s'",
9294 list->proc_sym->name, &list->where, my_rank,
9301 /* Is this the/a scalar finalizer procedure? */
9302 if (!arg->as || arg->as->rank == 0)
9305 /* Find the symtree for this procedure. */
9306 gcc_assert (!list->proc_tree);
9307 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
9309 prev_link = &list->next;
9312 /* Remove wrong nodes immediately from the list so we don't risk any
9313 troubles in the future when they might fail later expectations. */
9317 *prev_link = list->next;
9318 gfc_free_finalizer (i);
9321 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
9322 were nodes in the list, must have been for arrays. It is surely a good
9323 idea to have a scalar version there if there's something to finalize. */
9324 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
9325 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
9326 " defined at %L, suggest also scalar one",
9327 derived->name, &derived->declared_at);
9329 /* TODO: Remove this error when finalization is finished. */
9330 gfc_error ("Finalization at %L is not yet implemented",
9331 &derived->declared_at);
9337 /* Check that it is ok for the typebound procedure proc to override the
9341 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
9344 const gfc_symbol* proc_target;
9345 const gfc_symbol* old_target;
9346 unsigned proc_pass_arg, old_pass_arg, argpos;
9347 gfc_formal_arglist* proc_formal;
9348 gfc_formal_arglist* old_formal;
9350 /* This procedure should only be called for non-GENERIC proc. */
9351 gcc_assert (!proc->n.tb->is_generic);
9353 /* If the overwritten procedure is GENERIC, this is an error. */
9354 if (old->n.tb->is_generic)
9356 gfc_error ("Can't overwrite GENERIC '%s' at %L",
9357 old->name, &proc->n.tb->where);
9361 where = proc->n.tb->where;
9362 proc_target = proc->n.tb->u.specific->n.sym;
9363 old_target = old->n.tb->u.specific->n.sym;
9365 /* Check that overridden binding is not NON_OVERRIDABLE. */
9366 if (old->n.tb->non_overridable)
9368 gfc_error ("'%s' at %L overrides a procedure binding declared"
9369 " NON_OVERRIDABLE", proc->name, &where);
9373 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
9374 if (!old->n.tb->deferred && proc->n.tb->deferred)
9376 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
9377 " non-DEFERRED binding", proc->name, &where);
9381 /* If the overridden binding is PURE, the overriding must be, too. */
9382 if (old_target->attr.pure && !proc_target->attr.pure)
9384 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
9385 proc->name, &where);
9389 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
9390 is not, the overriding must not be either. */
9391 if (old_target->attr.elemental && !proc_target->attr.elemental)
9393 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
9394 " ELEMENTAL", proc->name, &where);
9397 if (!old_target->attr.elemental && proc_target->attr.elemental)
9399 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
9400 " be ELEMENTAL, either", proc->name, &where);
9404 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
9406 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
9408 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
9409 " SUBROUTINE", proc->name, &where);
9413 /* If the overridden binding is a FUNCTION, the overriding must also be a
9414 FUNCTION and have the same characteristics. */
9415 if (old_target->attr.function)
9417 if (!proc_target->attr.function)
9419 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
9420 " FUNCTION", proc->name, &where);
9424 /* FIXME: Do more comprehensive checking (including, for instance, the
9425 rank and array-shape). */
9426 gcc_assert (proc_target->result && old_target->result);
9427 if (!gfc_compare_types (&proc_target->result->ts,
9428 &old_target->result->ts))
9430 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
9431 " matching result types", proc->name, &where);
9436 /* If the overridden binding is PUBLIC, the overriding one must not be
9438 if (old->n.tb->access == ACCESS_PUBLIC
9439 && proc->n.tb->access == ACCESS_PRIVATE)
9441 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
9442 " PRIVATE", proc->name, &where);
9446 /* Compare the formal argument lists of both procedures. This is also abused
9447 to find the position of the passed-object dummy arguments of both
9448 bindings as at least the overridden one might not yet be resolved and we
9449 need those positions in the check below. */
9450 proc_pass_arg = old_pass_arg = 0;
9451 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
9453 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
9456 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
9457 proc_formal && old_formal;
9458 proc_formal = proc_formal->next, old_formal = old_formal->next)
9460 if (proc->n.tb->pass_arg
9461 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
9462 proc_pass_arg = argpos;
9463 if (old->n.tb->pass_arg
9464 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
9465 old_pass_arg = argpos;
9467 /* Check that the names correspond. */
9468 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
9470 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
9471 " to match the corresponding argument of the overridden"
9472 " procedure", proc_formal->sym->name, proc->name, &where,
9473 old_formal->sym->name);
9477 /* Check that the types correspond if neither is the passed-object
9479 /* FIXME: Do more comprehensive testing here. */
9480 if (proc_pass_arg != argpos && old_pass_arg != argpos
9481 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
9483 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
9484 "in respect to the overridden procedure",
9485 proc_formal->sym->name, proc->name, &where);
9491 if (proc_formal || old_formal)
9493 gfc_error ("'%s' at %L must have the same number of formal arguments as"
9494 " the overridden procedure", proc->name, &where);
9498 /* If the overridden binding is NOPASS, the overriding one must also be
9500 if (old->n.tb->nopass && !proc->n.tb->nopass)
9502 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
9503 " NOPASS", proc->name, &where);
9507 /* If the overridden binding is PASS(x), the overriding one must also be
9508 PASS and the passed-object dummy arguments must correspond. */
9509 if (!old->n.tb->nopass)
9511 if (proc->n.tb->nopass)
9513 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
9514 " PASS", proc->name, &where);
9518 if (proc_pass_arg != old_pass_arg)
9520 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
9521 " the same position as the passed-object dummy argument of"
9522 " the overridden procedure", proc->name, &where);
9531 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
9534 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
9535 const char* generic_name, locus where)
9540 gcc_assert (t1->specific && t2->specific);
9541 gcc_assert (!t1->specific->is_generic);
9542 gcc_assert (!t2->specific->is_generic);
9544 sym1 = t1->specific->u.specific->n.sym;
9545 sym2 = t2->specific->u.specific->n.sym;
9550 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
9551 if (sym1->attr.subroutine != sym2->attr.subroutine
9552 || sym1->attr.function != sym2->attr.function)
9554 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
9555 " GENERIC '%s' at %L",
9556 sym1->name, sym2->name, generic_name, &where);
9560 /* Compare the interfaces. */
9561 if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0))
9563 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
9564 sym1->name, sym2->name, generic_name, &where);
9572 /* Worker function for resolving a generic procedure binding; this is used to
9573 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
9575 The difference between those cases is finding possible inherited bindings
9576 that are overridden, as one has to look for them in tb_sym_root,
9577 tb_uop_root or tb_op, respectively. Thus the caller must already find
9578 the super-type and set p->overridden correctly. */
9581 resolve_tb_generic_targets (gfc_symbol* super_type,
9582 gfc_typebound_proc* p, const char* name)
9584 gfc_tbp_generic* target;
9585 gfc_symtree* first_target;
9586 gfc_symtree* inherited;
9588 gcc_assert (p && p->is_generic);
9590 /* Try to find the specific bindings for the symtrees in our target-list. */
9591 gcc_assert (p->u.generic);
9592 for (target = p->u.generic; target; target = target->next)
9593 if (!target->specific)
9595 gfc_typebound_proc* overridden_tbp;
9597 const char* target_name;
9599 target_name = target->specific_st->name;
9601 /* Defined for this type directly. */
9602 if (target->specific_st->n.tb)
9604 target->specific = target->specific_st->n.tb;
9605 goto specific_found;
9608 /* Look for an inherited specific binding. */
9611 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
9616 gcc_assert (inherited->n.tb);
9617 target->specific = inherited->n.tb;
9618 goto specific_found;
9622 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
9623 " at %L", target_name, name, &p->where);
9626 /* Once we've found the specific binding, check it is not ambiguous with
9627 other specifics already found or inherited for the same GENERIC. */
9629 gcc_assert (target->specific);
9631 /* This must really be a specific binding! */
9632 if (target->specific->is_generic)
9634 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
9635 " '%s' is GENERIC, too", name, &p->where, target_name);
9639 /* Check those already resolved on this type directly. */
9640 for (g = p->u.generic; g; g = g->next)
9641 if (g != target && g->specific
9642 && check_generic_tbp_ambiguity (target, g, name, p->where)
9646 /* Check for ambiguity with inherited specific targets. */
9647 for (overridden_tbp = p->overridden; overridden_tbp;
9648 overridden_tbp = overridden_tbp->overridden)
9649 if (overridden_tbp->is_generic)
9651 for (g = overridden_tbp->u.generic; g; g = g->next)
9653 gcc_assert (g->specific);
9654 if (check_generic_tbp_ambiguity (target, g,
9655 name, p->where) == FAILURE)
9661 /* If we attempt to "overwrite" a specific binding, this is an error. */
9662 if (p->overridden && !p->overridden->is_generic)
9664 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
9665 " the same name", name, &p->where);
9669 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
9670 all must have the same attributes here. */
9671 first_target = p->u.generic->specific->u.specific;
9672 gcc_assert (first_target);
9673 p->subroutine = first_target->n.sym->attr.subroutine;
9674 p->function = first_target->n.sym->attr.function;
9680 /* Resolve a GENERIC procedure binding for a derived type. */
9683 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
9685 gfc_symbol* super_type;
9687 /* Find the overridden binding if any. */
9688 st->n.tb->overridden = NULL;
9689 super_type = gfc_get_derived_super_type (derived);
9692 gfc_symtree* overridden;
9693 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
9696 if (overridden && overridden->n.tb)
9697 st->n.tb->overridden = overridden->n.tb;
9700 /* Resolve using worker function. */
9701 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
9705 /* Retrieve the target-procedure of an operator binding and do some checks in
9706 common for intrinsic and user-defined type-bound operators. */
9709 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
9711 gfc_symbol* target_proc;
9713 gcc_assert (target->specific && !target->specific->is_generic);
9714 target_proc = target->specific->u.specific->n.sym;
9715 gcc_assert (target_proc);
9717 /* All operator bindings must have a passed-object dummy argument. */
9718 if (target->specific->nopass)
9720 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
9728 /* Resolve a type-bound intrinsic operator. */
9731 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
9732 gfc_typebound_proc* p)
9734 gfc_symbol* super_type;
9735 gfc_tbp_generic* target;
9737 /* If there's already an error here, do nothing (but don't fail again). */
9741 /* Operators should always be GENERIC bindings. */
9742 gcc_assert (p->is_generic);
9744 /* Look for an overridden binding. */
9745 super_type = gfc_get_derived_super_type (derived);
9746 if (super_type && super_type->f2k_derived)
9747 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
9750 p->overridden = NULL;
9752 /* Resolve general GENERIC properties using worker function. */
9753 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
9756 /* Check the targets to be procedures of correct interface. */
9757 for (target = p->u.generic; target; target = target->next)
9759 gfc_symbol* target_proc;
9761 target_proc = get_checked_tb_operator_target (target, p->where);
9765 if (!gfc_check_operator_interface (target_proc, op, p->where))
9777 /* Resolve a type-bound user operator (tree-walker callback). */
9779 static gfc_symbol* resolve_bindings_derived;
9780 static gfc_try resolve_bindings_result;
9782 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
9785 resolve_typebound_user_op (gfc_symtree* stree)
9787 gfc_symbol* super_type;
9788 gfc_tbp_generic* target;
9790 gcc_assert (stree && stree->n.tb);
9792 if (stree->n.tb->error)
9795 /* Operators should always be GENERIC bindings. */
9796 gcc_assert (stree->n.tb->is_generic);
9798 /* Find overridden procedure, if any. */
9799 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
9800 if (super_type && super_type->f2k_derived)
9802 gfc_symtree* overridden;
9803 overridden = gfc_find_typebound_user_op (super_type, NULL,
9804 stree->name, true, NULL);
9806 if (overridden && overridden->n.tb)
9807 stree->n.tb->overridden = overridden->n.tb;
9810 stree->n.tb->overridden = NULL;
9812 /* Resolve basically using worker function. */
9813 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
9817 /* Check the targets to be functions of correct interface. */
9818 for (target = stree->n.tb->u.generic; target; target = target->next)
9820 gfc_symbol* target_proc;
9822 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
9826 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
9833 resolve_bindings_result = FAILURE;
9834 stree->n.tb->error = 1;
9838 /* Resolve the type-bound procedures for a derived type. */
9841 resolve_typebound_procedure (gfc_symtree* stree)
9846 gfc_symbol* super_type;
9847 gfc_component* comp;
9851 /* Undefined specific symbol from GENERIC target definition. */
9855 if (stree->n.tb->error)
9858 /* If this is a GENERIC binding, use that routine. */
9859 if (stree->n.tb->is_generic)
9861 if (resolve_typebound_generic (resolve_bindings_derived, stree)
9867 /* Get the target-procedure to check it. */
9868 gcc_assert (!stree->n.tb->is_generic);
9869 gcc_assert (stree->n.tb->u.specific);
9870 proc = stree->n.tb->u.specific->n.sym;
9871 where = stree->n.tb->where;
9873 /* Default access should already be resolved from the parser. */
9874 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
9876 /* It should be a module procedure or an external procedure with explicit
9877 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
9878 if ((!proc->attr.subroutine && !proc->attr.function)
9879 || (proc->attr.proc != PROC_MODULE
9880 && proc->attr.if_source != IFSRC_IFBODY)
9881 || (proc->attr.abstract && !stree->n.tb->deferred))
9883 gfc_error ("'%s' must be a module procedure or an external procedure with"
9884 " an explicit interface at %L", proc->name, &where);
9887 stree->n.tb->subroutine = proc->attr.subroutine;
9888 stree->n.tb->function = proc->attr.function;
9890 /* Find the super-type of the current derived type. We could do this once and
9891 store in a global if speed is needed, but as long as not I believe this is
9892 more readable and clearer. */
9893 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
9895 /* If PASS, resolve and check arguments if not already resolved / loaded
9896 from a .mod file. */
9897 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
9899 if (stree->n.tb->pass_arg)
9901 gfc_formal_arglist* i;
9903 /* If an explicit passing argument name is given, walk the arg-list
9907 stree->n.tb->pass_arg_num = 1;
9908 for (i = proc->formal; i; i = i->next)
9910 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
9915 ++stree->n.tb->pass_arg_num;
9920 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
9922 proc->name, stree->n.tb->pass_arg, &where,
9923 stree->n.tb->pass_arg);
9929 /* Otherwise, take the first one; there should in fact be at least
9931 stree->n.tb->pass_arg_num = 1;
9934 gfc_error ("Procedure '%s' with PASS at %L must have at"
9935 " least one argument", proc->name, &where);
9938 me_arg = proc->formal->sym;
9941 /* Now check that the argument-type matches. */
9942 gcc_assert (me_arg);
9943 if (me_arg->ts.type != BT_CLASS)
9945 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
9946 " at %L", proc->name, &where);
9950 if (me_arg->ts.u.derived->components->ts.u.derived
9951 != resolve_bindings_derived)
9953 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
9954 " the derived-type '%s'", me_arg->name, proc->name,
9955 me_arg->name, &where, resolve_bindings_derived->name);
9961 /* If we are extending some type, check that we don't override a procedure
9962 flagged NON_OVERRIDABLE. */
9963 stree->n.tb->overridden = NULL;
9966 gfc_symtree* overridden;
9967 overridden = gfc_find_typebound_proc (super_type, NULL,
9968 stree->name, true, NULL);
9970 if (overridden && overridden->n.tb)
9971 stree->n.tb->overridden = overridden->n.tb;
9973 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
9977 /* See if there's a name collision with a component directly in this type. */
9978 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
9979 if (!strcmp (comp->name, stree->name))
9981 gfc_error ("Procedure '%s' at %L has the same name as a component of"
9983 stree->name, &where, resolve_bindings_derived->name);
9987 /* Try to find a name collision with an inherited component. */
9988 if (super_type && gfc_find_component (super_type, stree->name, true, true))
9990 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
9991 " component of '%s'",
9992 stree->name, &where, resolve_bindings_derived->name);
9996 stree->n.tb->error = 0;
10000 resolve_bindings_result = FAILURE;
10001 stree->n.tb->error = 1;
10005 resolve_typebound_procedures (gfc_symbol* derived)
10009 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
10012 resolve_bindings_derived = derived;
10013 resolve_bindings_result = SUCCESS;
10015 if (derived->f2k_derived->tb_sym_root)
10016 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
10017 &resolve_typebound_procedure);
10019 if (derived->f2k_derived->tb_uop_root)
10020 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
10021 &resolve_typebound_user_op);
10023 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
10025 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
10026 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
10028 resolve_bindings_result = FAILURE;
10031 return resolve_bindings_result;
10035 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
10036 to give all identical derived types the same backend_decl. */
10038 add_dt_to_dt_list (gfc_symbol *derived)
10040 gfc_dt_list *dt_list;
10042 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
10043 if (derived == dt_list->derived)
10046 if (dt_list == NULL)
10048 dt_list = gfc_get_dt_list ();
10049 dt_list->next = gfc_derived_types;
10050 dt_list->derived = derived;
10051 gfc_derived_types = dt_list;
10056 /* Ensure that a derived-type is really not abstract, meaning that every
10057 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
10060 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
10065 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
10067 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
10070 if (st->n.tb && st->n.tb->deferred)
10072 gfc_symtree* overriding;
10073 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
10074 gcc_assert (overriding && overriding->n.tb);
10075 if (overriding->n.tb->deferred)
10077 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
10078 " '%s' is DEFERRED and not overridden",
10079 sub->name, &sub->declared_at, st->name);
10088 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
10090 /* The algorithm used here is to recursively travel up the ancestry of sub
10091 and for each ancestor-type, check all bindings. If any of them is
10092 DEFERRED, look it up starting from sub and see if the found (overriding)
10093 binding is not DEFERRED.
10094 This is not the most efficient way to do this, but it should be ok and is
10095 clearer than something sophisticated. */
10097 gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
10099 /* Walk bindings of this ancestor. */
10100 if (ancestor->f2k_derived)
10103 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
10108 /* Find next ancestor type and recurse on it. */
10109 ancestor = gfc_get_derived_super_type (ancestor);
10111 return ensure_not_abstract (sub, ancestor);
10117 static void resolve_symbol (gfc_symbol *sym);
10120 /* Resolve the components of a derived type. */
10123 resolve_fl_derived (gfc_symbol *sym)
10125 gfc_symbol* super_type;
10129 super_type = gfc_get_derived_super_type (sym);
10131 /* Ensure the extended type gets resolved before we do. */
10132 if (super_type && resolve_fl_derived (super_type) == FAILURE)
10135 /* An ABSTRACT type must be extensible. */
10136 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
10138 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
10139 sym->name, &sym->declared_at);
10143 for (c = sym->components; c != NULL; c = c->next)
10145 if (c->attr.proc_pointer && c->ts.interface)
10147 if (c->ts.interface->attr.procedure)
10148 gfc_error ("Interface '%s', used by procedure pointer component "
10149 "'%s' at %L, is declared in a later PROCEDURE statement",
10150 c->ts.interface->name, c->name, &c->loc);
10152 /* Get the attributes from the interface (now resolved). */
10153 if (c->ts.interface->attr.if_source
10154 || c->ts.interface->attr.intrinsic)
10156 gfc_symbol *ifc = c->ts.interface;
10158 if (ifc->formal && !ifc->formal_ns)
10159 resolve_symbol (ifc);
10161 if (ifc->attr.intrinsic)
10162 resolve_intrinsic (ifc, &ifc->declared_at);
10166 c->ts = ifc->result->ts;
10167 c->attr.allocatable = ifc->result->attr.allocatable;
10168 c->attr.pointer = ifc->result->attr.pointer;
10169 c->attr.dimension = ifc->result->attr.dimension;
10170 c->as = gfc_copy_array_spec (ifc->result->as);
10175 c->attr.allocatable = ifc->attr.allocatable;
10176 c->attr.pointer = ifc->attr.pointer;
10177 c->attr.dimension = ifc->attr.dimension;
10178 c->as = gfc_copy_array_spec (ifc->as);
10180 c->ts.interface = ifc;
10181 c->attr.function = ifc->attr.function;
10182 c->attr.subroutine = ifc->attr.subroutine;
10183 gfc_copy_formal_args_ppc (c, ifc);
10185 c->attr.pure = ifc->attr.pure;
10186 c->attr.elemental = ifc->attr.elemental;
10187 c->attr.recursive = ifc->attr.recursive;
10188 c->attr.always_explicit = ifc->attr.always_explicit;
10189 c->attr.ext_attr |= ifc->attr.ext_attr;
10190 /* Replace symbols in array spec. */
10194 for (i = 0; i < c->as->rank; i++)
10196 gfc_expr_replace_comp (c->as->lower[i], c);
10197 gfc_expr_replace_comp (c->as->upper[i], c);
10200 /* Copy char length. */
10201 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
10203 c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
10204 gfc_expr_replace_comp (c->ts.u.cl->length, c);
10207 else if (c->ts.interface->name[0] != '\0')
10209 gfc_error ("Interface '%s' of procedure pointer component "
10210 "'%s' at %L must be explicit", c->ts.interface->name,
10215 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
10217 /* Since PPCs are not implicitly typed, a PPC without an explicit
10218 interface must be a subroutine. */
10219 gfc_add_subroutine (&c->attr, c->name, &c->loc);
10222 /* Procedure pointer components: Check PASS arg. */
10223 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
10225 gfc_symbol* me_arg;
10227 if (c->tb->pass_arg)
10229 gfc_formal_arglist* i;
10231 /* If an explicit passing argument name is given, walk the arg-list
10232 and look for it. */
10235 c->tb->pass_arg_num = 1;
10236 for (i = c->formal; i; i = i->next)
10238 if (!strcmp (i->sym->name, c->tb->pass_arg))
10243 c->tb->pass_arg_num++;
10248 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
10249 "at %L has no argument '%s'", c->name,
10250 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
10257 /* Otherwise, take the first one; there should in fact be at least
10259 c->tb->pass_arg_num = 1;
10262 gfc_error ("Procedure pointer component '%s' with PASS at %L "
10263 "must have at least one argument",
10268 me_arg = c->formal->sym;
10271 /* Now check that the argument-type matches. */
10272 gcc_assert (me_arg);
10273 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
10274 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
10275 || (me_arg->ts.type == BT_CLASS
10276 && me_arg->ts.u.derived->components->ts.u.derived != sym))
10278 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10279 " the derived type '%s'", me_arg->name, c->name,
10280 me_arg->name, &c->loc, sym->name);
10285 /* Check for C453. */
10286 if (me_arg->attr.dimension)
10288 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10289 "must be scalar", me_arg->name, c->name, me_arg->name,
10295 if (me_arg->attr.pointer)
10297 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10298 "may not have the POINTER attribute", me_arg->name,
10299 c->name, me_arg->name, &c->loc);
10304 if (me_arg->attr.allocatable)
10306 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10307 "may not be ALLOCATABLE", me_arg->name, c->name,
10308 me_arg->name, &c->loc);
10313 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
10314 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10315 " at %L", c->name, &c->loc);
10319 /* Check type-spec if this is not the parent-type component. */
10320 if ((!sym->attr.extension || c != sym->components)
10321 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
10324 /* If this type is an extension, see if this component has the same name
10325 as an inherited type-bound procedure. */
10327 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
10329 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
10330 " inherited type-bound procedure",
10331 c->name, sym->name, &c->loc);
10335 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
10337 if (c->ts.u.cl->length == NULL
10338 || (resolve_charlen (c->ts.u.cl) == FAILURE)
10339 || !gfc_is_constant_expr (c->ts.u.cl->length))
10341 gfc_error ("Character length of component '%s' needs to "
10342 "be a constant specification expression at %L",
10344 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
10349 if (c->ts.type == BT_DERIVED
10350 && sym->component_access != ACCESS_PRIVATE
10351 && gfc_check_access (sym->attr.access, sym->ns->default_access)
10352 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
10353 && !c->ts.u.derived->attr.use_assoc
10354 && !gfc_check_access (c->ts.u.derived->attr.access,
10355 c->ts.u.derived->ns->default_access)
10356 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
10357 "is a PRIVATE type and cannot be a component of "
10358 "'%s', which is PUBLIC at %L", c->name,
10359 sym->name, &sym->declared_at) == FAILURE)
10362 if (sym->attr.sequence)
10364 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
10366 gfc_error ("Component %s of SEQUENCE type declared at %L does "
10367 "not have the SEQUENCE attribute",
10368 c->ts.u.derived->name, &sym->declared_at);
10373 if (c->ts.type == BT_DERIVED && c->attr.pointer
10374 && c->ts.u.derived->components == NULL
10375 && !c->ts.u.derived->attr.zero_comp)
10377 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10378 "that has not been declared", c->name, sym->name,
10384 if (c->ts.type == BT_CLASS
10385 && !(c->ts.u.derived->components->attr.pointer
10386 || c->ts.u.derived->components->attr.allocatable))
10388 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
10389 "or pointer", c->name, &c->loc);
10393 /* Ensure that all the derived type components are put on the
10394 derived type list; even in formal namespaces, where derived type
10395 pointer components might not have been declared. */
10396 if (c->ts.type == BT_DERIVED
10398 && c->ts.u.derived->components
10400 && sym != c->ts.u.derived)
10401 add_dt_to_dt_list (c->ts.u.derived);
10403 if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
10407 for (i = 0; i < c->as->rank; i++)
10409 if (c->as->lower[i] == NULL
10410 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
10411 || !gfc_is_constant_expr (c->as->lower[i])
10412 || c->as->upper[i] == NULL
10413 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
10414 || !gfc_is_constant_expr (c->as->upper[i]))
10416 gfc_error ("Component '%s' of '%s' at %L must have "
10417 "constant array bounds",
10418 c->name, sym->name, &c->loc);
10424 /* Resolve the type-bound procedures. */
10425 if (resolve_typebound_procedures (sym) == FAILURE)
10428 /* Resolve the finalizer procedures. */
10429 if (gfc_resolve_finalizers (sym) == FAILURE)
10432 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
10433 all DEFERRED bindings are overridden. */
10434 if (super_type && super_type->attr.abstract && !sym->attr.abstract
10435 && ensure_not_abstract (sym, super_type) == FAILURE)
10438 /* Add derived type to the derived type list. */
10439 add_dt_to_dt_list (sym);
10446 resolve_fl_namelist (gfc_symbol *sym)
10451 /* Reject PRIVATE objects in a PUBLIC namelist. */
10452 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
10454 for (nl = sym->namelist; nl; nl = nl->next)
10456 if (!nl->sym->attr.use_assoc
10457 && !is_sym_host_assoc (nl->sym, sym->ns)
10458 && !gfc_check_access(nl->sym->attr.access,
10459 nl->sym->ns->default_access))
10461 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
10462 "cannot be member of PUBLIC namelist '%s' at %L",
10463 nl->sym->name, sym->name, &sym->declared_at);
10467 /* Types with private components that came here by USE-association. */
10468 if (nl->sym->ts.type == BT_DERIVED
10469 && derived_inaccessible (nl->sym->ts.u.derived))
10471 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
10472 "components and cannot be member of namelist '%s' at %L",
10473 nl->sym->name, sym->name, &sym->declared_at);
10477 /* Types with private components that are defined in the same module. */
10478 if (nl->sym->ts.type == BT_DERIVED
10479 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
10480 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
10481 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
10482 nl->sym->ns->default_access))
10484 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
10485 "cannot be a member of PUBLIC namelist '%s' at %L",
10486 nl->sym->name, sym->name, &sym->declared_at);
10492 for (nl = sym->namelist; nl; nl = nl->next)
10494 /* Reject namelist arrays of assumed shape. */
10495 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
10496 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
10497 "must not have assumed shape in namelist "
10498 "'%s' at %L", nl->sym->name, sym->name,
10499 &sym->declared_at) == FAILURE)
10502 /* Reject namelist arrays that are not constant shape. */
10503 if (is_non_constant_shape_array (nl->sym))
10505 gfc_error ("NAMELIST array object '%s' must have constant "
10506 "shape in namelist '%s' at %L", nl->sym->name,
10507 sym->name, &sym->declared_at);
10511 /* Namelist objects cannot have allocatable or pointer components. */
10512 if (nl->sym->ts.type != BT_DERIVED)
10515 if (nl->sym->ts.u.derived->attr.alloc_comp)
10517 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
10518 "have ALLOCATABLE components",
10519 nl->sym->name, sym->name, &sym->declared_at);
10523 if (nl->sym->ts.u.derived->attr.pointer_comp)
10525 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
10526 "have POINTER components",
10527 nl->sym->name, sym->name, &sym->declared_at);
10533 /* 14.1.2 A module or internal procedure represent local entities
10534 of the same type as a namelist member and so are not allowed. */
10535 for (nl = sym->namelist; nl; nl = nl->next)
10537 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
10540 if (nl->sym->attr.function && nl->sym == nl->sym->result)
10541 if ((nl->sym == sym->ns->proc_name)
10543 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
10547 if (nl->sym && nl->sym->name)
10548 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
10549 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
10551 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
10552 "attribute in '%s' at %L", nlsym->name,
10553 &sym->declared_at);
10563 resolve_fl_parameter (gfc_symbol *sym)
10565 /* A parameter array's shape needs to be constant. */
10566 if (sym->as != NULL
10567 && (sym->as->type == AS_DEFERRED
10568 || is_non_constant_shape_array (sym)))
10570 gfc_error ("Parameter array '%s' at %L cannot be automatic "
10571 "or of deferred shape", sym->name, &sym->declared_at);
10575 /* Make sure a parameter that has been implicitly typed still
10576 matches the implicit type, since PARAMETER statements can precede
10577 IMPLICIT statements. */
10578 if (sym->attr.implicit_type
10579 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
10582 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
10583 "later IMPLICIT type", sym->name, &sym->declared_at);
10587 /* Make sure the types of derived parameters are consistent. This
10588 type checking is deferred until resolution because the type may
10589 refer to a derived type from the host. */
10590 if (sym->ts.type == BT_DERIVED
10591 && !gfc_compare_types (&sym->ts, &sym->value->ts))
10593 gfc_error ("Incompatible derived type in PARAMETER at %L",
10594 &sym->value->where);
10601 /* Do anything necessary to resolve a symbol. Right now, we just
10602 assume that an otherwise unknown symbol is a variable. This sort
10603 of thing commonly happens for symbols in module. */
10606 resolve_symbol (gfc_symbol *sym)
10608 int check_constant, mp_flag;
10609 gfc_symtree *symtree;
10610 gfc_symtree *this_symtree;
10614 if (sym->attr.flavor == FL_UNKNOWN)
10617 /* If we find that a flavorless symbol is an interface in one of the
10618 parent namespaces, find its symtree in this namespace, free the
10619 symbol and set the symtree to point to the interface symbol. */
10620 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
10622 symtree = gfc_find_symtree (ns->sym_root, sym->name);
10623 if (symtree && symtree->n.sym->generic)
10625 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
10629 gfc_free_symbol (sym);
10630 symtree->n.sym->refs++;
10631 this_symtree->n.sym = symtree->n.sym;
10636 /* Otherwise give it a flavor according to such attributes as
10638 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
10639 sym->attr.flavor = FL_VARIABLE;
10642 sym->attr.flavor = FL_PROCEDURE;
10643 if (sym->attr.dimension)
10644 sym->attr.function = 1;
10648 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
10649 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
10651 if (sym->attr.procedure && sym->ts.interface
10652 && sym->attr.if_source != IFSRC_DECL)
10654 if (sym->ts.interface == sym)
10656 gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
10657 "interface", sym->name, &sym->declared_at);
10660 if (sym->ts.interface->attr.procedure)
10662 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
10663 " in a later PROCEDURE statement", sym->ts.interface->name,
10664 sym->name,&sym->declared_at);
10668 /* Get the attributes from the interface (now resolved). */
10669 if (sym->ts.interface->attr.if_source
10670 || sym->ts.interface->attr.intrinsic)
10672 gfc_symbol *ifc = sym->ts.interface;
10673 resolve_symbol (ifc);
10675 if (ifc->attr.intrinsic)
10676 resolve_intrinsic (ifc, &ifc->declared_at);
10679 sym->ts = ifc->result->ts;
10682 sym->ts.interface = ifc;
10683 sym->attr.function = ifc->attr.function;
10684 sym->attr.subroutine = ifc->attr.subroutine;
10685 gfc_copy_formal_args (sym, ifc);
10687 sym->attr.allocatable = ifc->attr.allocatable;
10688 sym->attr.pointer = ifc->attr.pointer;
10689 sym->attr.pure = ifc->attr.pure;
10690 sym->attr.elemental = ifc->attr.elemental;
10691 sym->attr.dimension = ifc->attr.dimension;
10692 sym->attr.recursive = ifc->attr.recursive;
10693 sym->attr.always_explicit = ifc->attr.always_explicit;
10694 sym->attr.ext_attr |= ifc->attr.ext_attr;
10695 /* Copy array spec. */
10696 sym->as = gfc_copy_array_spec (ifc->as);
10700 for (i = 0; i < sym->as->rank; i++)
10702 gfc_expr_replace_symbols (sym->as->lower[i], sym);
10703 gfc_expr_replace_symbols (sym->as->upper[i], sym);
10706 /* Copy char length. */
10707 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
10709 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
10710 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
10713 else if (sym->ts.interface->name[0] != '\0')
10715 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
10716 sym->ts.interface->name, sym->name, &sym->declared_at);
10721 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
10724 /* Symbols that are module procedures with results (functions) have
10725 the types and array specification copied for type checking in
10726 procedures that call them, as well as for saving to a module
10727 file. These symbols can't stand the scrutiny that their results
10729 mp_flag = (sym->result != NULL && sym->result != sym);
10732 /* Make sure that the intrinsic is consistent with its internal
10733 representation. This needs to be done before assigning a default
10734 type to avoid spurious warnings. */
10735 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
10736 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
10739 /* Assign default type to symbols that need one and don't have one. */
10740 if (sym->ts.type == BT_UNKNOWN)
10742 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
10743 gfc_set_default_type (sym, 1, NULL);
10745 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
10746 && !sym->attr.function && !sym->attr.subroutine
10747 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
10748 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
10750 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
10752 /* The specific case of an external procedure should emit an error
10753 in the case that there is no implicit type. */
10755 gfc_set_default_type (sym, sym->attr.external, NULL);
10758 /* Result may be in another namespace. */
10759 resolve_symbol (sym->result);
10761 if (!sym->result->attr.proc_pointer)
10763 sym->ts = sym->result->ts;
10764 sym->as = gfc_copy_array_spec (sym->result->as);
10765 sym->attr.dimension = sym->result->attr.dimension;
10766 sym->attr.pointer = sym->result->attr.pointer;
10767 sym->attr.allocatable = sym->result->attr.allocatable;
10773 /* Assumed size arrays and assumed shape arrays must be dummy
10776 if (sym->as != NULL
10777 && (sym->as->type == AS_ASSUMED_SIZE
10778 || sym->as->type == AS_ASSUMED_SHAPE)
10779 && sym->attr.dummy == 0)
10781 if (sym->as->type == AS_ASSUMED_SIZE)
10782 gfc_error ("Assumed size array at %L must be a dummy argument",
10783 &sym->declared_at);
10785 gfc_error ("Assumed shape array at %L must be a dummy argument",
10786 &sym->declared_at);
10790 /* Make sure symbols with known intent or optional are really dummy
10791 variable. Because of ENTRY statement, this has to be deferred
10792 until resolution time. */
10794 if (!sym->attr.dummy
10795 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
10797 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
10801 if (sym->attr.value && !sym->attr.dummy)
10803 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
10804 "it is not a dummy argument", sym->name, &sym->declared_at);
10808 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
10810 gfc_charlen *cl = sym->ts.u.cl;
10811 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10813 gfc_error ("Character dummy variable '%s' at %L with VALUE "
10814 "attribute must have constant length",
10815 sym->name, &sym->declared_at);
10819 if (sym->ts.is_c_interop
10820 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
10822 gfc_error ("C interoperable character dummy variable '%s' at %L "
10823 "with VALUE attribute must have length one",
10824 sym->name, &sym->declared_at);
10829 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
10830 do this for something that was implicitly typed because that is handled
10831 in gfc_set_default_type. Handle dummy arguments and procedure
10832 definitions separately. Also, anything that is use associated is not
10833 handled here but instead is handled in the module it is declared in.
10834 Finally, derived type definitions are allowed to be BIND(C) since that
10835 only implies that they're interoperable, and they are checked fully for
10836 interoperability when a variable is declared of that type. */
10837 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
10838 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
10839 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
10841 gfc_try t = SUCCESS;
10843 /* First, make sure the variable is declared at the
10844 module-level scope (J3/04-007, Section 15.3). */
10845 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
10846 sym->attr.in_common == 0)
10848 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
10849 "is neither a COMMON block nor declared at the "
10850 "module level scope", sym->name, &(sym->declared_at));
10853 else if (sym->common_head != NULL)
10855 t = verify_com_block_vars_c_interop (sym->common_head);
10859 /* If type() declaration, we need to verify that the components
10860 of the given type are all C interoperable, etc. */
10861 if (sym->ts.type == BT_DERIVED &&
10862 sym->ts.u.derived->attr.is_c_interop != 1)
10864 /* Make sure the user marked the derived type as BIND(C). If
10865 not, call the verify routine. This could print an error
10866 for the derived type more than once if multiple variables
10867 of that type are declared. */
10868 if (sym->ts.u.derived->attr.is_bind_c != 1)
10869 verify_bind_c_derived_type (sym->ts.u.derived);
10873 /* Verify the variable itself as C interoperable if it
10874 is BIND(C). It is not possible for this to succeed if
10875 the verify_bind_c_derived_type failed, so don't have to handle
10876 any error returned by verify_bind_c_derived_type. */
10877 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10878 sym->common_block);
10883 /* clear the is_bind_c flag to prevent reporting errors more than
10884 once if something failed. */
10885 sym->attr.is_bind_c = 0;
10890 /* If a derived type symbol has reached this point, without its
10891 type being declared, we have an error. Notice that most
10892 conditions that produce undefined derived types have already
10893 been dealt with. However, the likes of:
10894 implicit type(t) (t) ..... call foo (t) will get us here if
10895 the type is not declared in the scope of the implicit
10896 statement. Change the type to BT_UNKNOWN, both because it is so
10897 and to prevent an ICE. */
10898 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
10899 && !sym->ts.u.derived->attr.zero_comp)
10901 gfc_error ("The derived type '%s' at %L is of type '%s', "
10902 "which has not been defined", sym->name,
10903 &sym->declared_at, sym->ts.u.derived->name);
10904 sym->ts.type = BT_UNKNOWN;
10908 /* Make sure that the derived type has been resolved and that the
10909 derived type is visible in the symbol's namespace, if it is a
10910 module function and is not PRIVATE. */
10911 if (sym->ts.type == BT_DERIVED
10912 && sym->ts.u.derived->attr.use_assoc
10913 && sym->ns->proc_name
10914 && sym->ns->proc_name->attr.flavor == FL_MODULE)
10918 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
10921 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
10922 if (!ds && sym->attr.function
10923 && gfc_check_access (sym->attr.access, sym->ns->default_access))
10925 symtree = gfc_new_symtree (&sym->ns->sym_root,
10926 sym->ts.u.derived->name);
10927 symtree->n.sym = sym->ts.u.derived;
10928 sym->ts.u.derived->refs++;
10932 /* Unless the derived-type declaration is use associated, Fortran 95
10933 does not allow public entries of private derived types.
10934 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
10935 161 in 95-006r3. */
10936 if (sym->ts.type == BT_DERIVED
10937 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
10938 && !sym->ts.u.derived->attr.use_assoc
10939 && gfc_check_access (sym->attr.access, sym->ns->default_access)
10940 && !gfc_check_access (sym->ts.u.derived->attr.access,
10941 sym->ts.u.derived->ns->default_access)
10942 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
10943 "of PRIVATE derived type '%s'",
10944 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
10945 : "variable", sym->name, &sym->declared_at,
10946 sym->ts.u.derived->name) == FAILURE)
10949 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
10950 default initialization is defined (5.1.2.4.4). */
10951 if (sym->ts.type == BT_DERIVED
10953 && sym->attr.intent == INTENT_OUT
10955 && sym->as->type == AS_ASSUMED_SIZE)
10957 for (c = sym->ts.u.derived->components; c; c = c->next)
10959 if (c->initializer)
10961 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
10962 "ASSUMED SIZE and so cannot have a default initializer",
10963 sym->name, &sym->declared_at);
10969 switch (sym->attr.flavor)
10972 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
10977 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
10982 if (resolve_fl_namelist (sym) == FAILURE)
10987 if (resolve_fl_parameter (sym) == FAILURE)
10995 /* Resolve array specifier. Check as well some constraints
10996 on COMMON blocks. */
10998 check_constant = sym->attr.in_common && !sym->attr.pointer;
11000 /* Set the formal_arg_flag so that check_conflict will not throw
11001 an error for host associated variables in the specification
11002 expression for an array_valued function. */
11003 if (sym->attr.function && sym->as)
11004 formal_arg_flag = 1;
11006 gfc_resolve_array_spec (sym->as, check_constant);
11008 formal_arg_flag = 0;
11010 /* Resolve formal namespaces. */
11011 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
11012 && !sym->attr.contained && !sym->attr.intrinsic)
11013 gfc_resolve (sym->formal_ns);
11015 /* Make sure the formal namespace is present. */
11016 if (sym->formal && !sym->formal_ns)
11018 gfc_formal_arglist *formal = sym->formal;
11019 while (formal && !formal->sym)
11020 formal = formal->next;
11024 sym->formal_ns = formal->sym->ns;
11025 sym->formal_ns->refs++;
11029 /* Check threadprivate restrictions. */
11030 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
11031 && (!sym->attr.in_common
11032 && sym->module == NULL
11033 && (sym->ns->proc_name == NULL
11034 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
11035 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
11037 /* If we have come this far we can apply default-initializers, as
11038 described in 14.7.5, to those variables that have not already
11039 been assigned one. */
11040 if (sym->ts.type == BT_DERIVED
11041 && sym->attr.referenced
11042 && sym->ns == gfc_current_ns
11044 && !sym->attr.allocatable
11045 && !sym->attr.alloc_comp)
11047 symbol_attribute *a = &sym->attr;
11049 if ((!a->save && !a->dummy && !a->pointer
11050 && !a->in_common && !a->use_assoc
11051 && !(a->function && sym != sym->result))
11052 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
11053 apply_default_init (sym);
11056 /* If this symbol has a type-spec, check it. */
11057 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
11058 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
11059 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
11065 /************* Resolve DATA statements *************/
11069 gfc_data_value *vnode;
11075 /* Advance the values structure to point to the next value in the data list. */
11078 next_data_value (void)
11080 while (mpz_cmp_ui (values.left, 0) == 0)
11083 if (values.vnode->next == NULL)
11086 values.vnode = values.vnode->next;
11087 mpz_set (values.left, values.vnode->repeat);
11095 check_data_variable (gfc_data_variable *var, locus *where)
11101 ar_type mark = AR_UNKNOWN;
11103 mpz_t section_index[GFC_MAX_DIMENSIONS];
11109 if (gfc_resolve_expr (var->expr) == FAILURE)
11113 mpz_init_set_si (offset, 0);
11116 if (e->expr_type != EXPR_VARIABLE)
11117 gfc_internal_error ("check_data_variable(): Bad expression");
11119 sym = e->symtree->n.sym;
11121 if (sym->ns->is_block_data && !sym->attr.in_common)
11123 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
11124 sym->name, &sym->declared_at);
11127 if (e->ref == NULL && sym->as)
11129 gfc_error ("DATA array '%s' at %L must be specified in a previous"
11130 " declaration", sym->name, where);
11134 has_pointer = sym->attr.pointer;
11136 for (ref = e->ref; ref; ref = ref->next)
11138 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
11142 && ref->type == REF_ARRAY
11143 && ref->u.ar.type != AR_FULL)
11145 gfc_error ("DATA element '%s' at %L is a pointer and so must "
11146 "be a full array", sym->name, where);
11151 if (e->rank == 0 || has_pointer)
11153 mpz_init_set_ui (size, 1);
11160 /* Find the array section reference. */
11161 for (ref = e->ref; ref; ref = ref->next)
11163 if (ref->type != REF_ARRAY)
11165 if (ref->u.ar.type == AR_ELEMENT)
11171 /* Set marks according to the reference pattern. */
11172 switch (ref->u.ar.type)
11180 /* Get the start position of array section. */
11181 gfc_get_section_index (ar, section_index, &offset);
11186 gcc_unreachable ();
11189 if (gfc_array_size (e, &size) == FAILURE)
11191 gfc_error ("Nonconstant array section at %L in DATA statement",
11193 mpz_clear (offset);
11200 while (mpz_cmp_ui (size, 0) > 0)
11202 if (next_data_value () == FAILURE)
11204 gfc_error ("DATA statement at %L has more variables than values",
11210 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
11214 /* If we have more than one element left in the repeat count,
11215 and we have more than one element left in the target variable,
11216 then create a range assignment. */
11217 /* FIXME: Only done for full arrays for now, since array sections
11219 if (mark == AR_FULL && ref && ref->next == NULL
11220 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
11224 if (mpz_cmp (size, values.left) >= 0)
11226 mpz_init_set (range, values.left);
11227 mpz_sub (size, size, values.left);
11228 mpz_set_ui (values.left, 0);
11232 mpz_init_set (range, size);
11233 mpz_sub (values.left, values.left, size);
11234 mpz_set_ui (size, 0);
11237 gfc_assign_data_value_range (var->expr, values.vnode->expr,
11240 mpz_add (offset, offset, range);
11244 /* Assign initial value to symbol. */
11247 mpz_sub_ui (values.left, values.left, 1);
11248 mpz_sub_ui (size, size, 1);
11250 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
11254 if (mark == AR_FULL)
11255 mpz_add_ui (offset, offset, 1);
11257 /* Modify the array section indexes and recalculate the offset
11258 for next element. */
11259 else if (mark == AR_SECTION)
11260 gfc_advance_section (section_index, ar, &offset);
11264 if (mark == AR_SECTION)
11266 for (i = 0; i < ar->dimen; i++)
11267 mpz_clear (section_index[i]);
11271 mpz_clear (offset);
11277 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
11279 /* Iterate over a list of elements in a DATA statement. */
11282 traverse_data_list (gfc_data_variable *var, locus *where)
11285 iterator_stack frame;
11286 gfc_expr *e, *start, *end, *step;
11287 gfc_try retval = SUCCESS;
11289 mpz_init (frame.value);
11291 start = gfc_copy_expr (var->iter.start);
11292 end = gfc_copy_expr (var->iter.end);
11293 step = gfc_copy_expr (var->iter.step);
11295 if (gfc_simplify_expr (start, 1) == FAILURE
11296 || start->expr_type != EXPR_CONSTANT)
11298 gfc_error ("iterator start at %L does not simplify", &start->where);
11302 if (gfc_simplify_expr (end, 1) == FAILURE
11303 || end->expr_type != EXPR_CONSTANT)
11305 gfc_error ("iterator end at %L does not simplify", &end->where);
11309 if (gfc_simplify_expr (step, 1) == FAILURE
11310 || step->expr_type != EXPR_CONSTANT)
11312 gfc_error ("iterator step at %L does not simplify", &step->where);
11317 mpz_init_set (trip, end->value.integer);
11318 mpz_sub (trip, trip, start->value.integer);
11319 mpz_add (trip, trip, step->value.integer);
11321 mpz_div (trip, trip, step->value.integer);
11323 mpz_set (frame.value, start->value.integer);
11325 frame.prev = iter_stack;
11326 frame.variable = var->iter.var->symtree;
11327 iter_stack = &frame;
11329 while (mpz_cmp_ui (trip, 0) > 0)
11331 if (traverse_data_var (var->list, where) == FAILURE)
11338 e = gfc_copy_expr (var->expr);
11339 if (gfc_simplify_expr (e, 1) == FAILURE)
11347 mpz_add (frame.value, frame.value, step->value.integer);
11349 mpz_sub_ui (trip, trip, 1);
11354 mpz_clear (frame.value);
11356 gfc_free_expr (start);
11357 gfc_free_expr (end);
11358 gfc_free_expr (step);
11360 iter_stack = frame.prev;
11365 /* Type resolve variables in the variable list of a DATA statement. */
11368 traverse_data_var (gfc_data_variable *var, locus *where)
11372 for (; var; var = var->next)
11374 if (var->expr == NULL)
11375 t = traverse_data_list (var, where);
11377 t = check_data_variable (var, where);
11387 /* Resolve the expressions and iterators associated with a data statement.
11388 This is separate from the assignment checking because data lists should
11389 only be resolved once. */
11392 resolve_data_variables (gfc_data_variable *d)
11394 for (; d; d = d->next)
11396 if (d->list == NULL)
11398 if (gfc_resolve_expr (d->expr) == FAILURE)
11403 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
11406 if (resolve_data_variables (d->list) == FAILURE)
11415 /* Resolve a single DATA statement. We implement this by storing a pointer to
11416 the value list into static variables, and then recursively traversing the
11417 variables list, expanding iterators and such. */
11420 resolve_data (gfc_data *d)
11423 if (resolve_data_variables (d->var) == FAILURE)
11426 values.vnode = d->value;
11427 if (d->value == NULL)
11428 mpz_set_ui (values.left, 0);
11430 mpz_set (values.left, d->value->repeat);
11432 if (traverse_data_var (d->var, &d->where) == FAILURE)
11435 /* At this point, we better not have any values left. */
11437 if (next_data_value () == SUCCESS)
11438 gfc_error ("DATA statement at %L has more values than variables",
11443 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
11444 accessed by host or use association, is a dummy argument to a pure function,
11445 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
11446 is storage associated with any such variable, shall not be used in the
11447 following contexts: (clients of this function). */
11449 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
11450 procedure. Returns zero if assignment is OK, nonzero if there is a
11453 gfc_impure_variable (gfc_symbol *sym)
11457 if (sym->attr.use_assoc || sym->attr.in_common)
11460 if (sym->ns != gfc_current_ns)
11461 return !sym->attr.function;
11463 proc = sym->ns->proc_name;
11464 if (sym->attr.dummy && gfc_pure (proc)
11465 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
11467 proc->attr.function))
11470 /* TODO: Sort out what can be storage associated, if anything, and include
11471 it here. In principle equivalences should be scanned but it does not
11472 seem to be possible to storage associate an impure variable this way. */
11477 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
11478 symbol of the current procedure. */
11481 gfc_pure (gfc_symbol *sym)
11483 symbol_attribute attr;
11486 sym = gfc_current_ns->proc_name;
11492 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
11496 /* Test whether the current procedure is elemental or not. */
11499 gfc_elemental (gfc_symbol *sym)
11501 symbol_attribute attr;
11504 sym = gfc_current_ns->proc_name;
11509 return attr.flavor == FL_PROCEDURE && attr.elemental;
11513 /* Warn about unused labels. */
11516 warn_unused_fortran_label (gfc_st_label *label)
11521 warn_unused_fortran_label (label->left);
11523 if (label->defined == ST_LABEL_UNKNOWN)
11526 switch (label->referenced)
11528 case ST_LABEL_UNKNOWN:
11529 gfc_warning ("Label %d at %L defined but not used", label->value,
11533 case ST_LABEL_BAD_TARGET:
11534 gfc_warning ("Label %d at %L defined but cannot be used",
11535 label->value, &label->where);
11542 warn_unused_fortran_label (label->right);
11546 /* Returns the sequence type of a symbol or sequence. */
11549 sequence_type (gfc_typespec ts)
11558 if (ts.u.derived->components == NULL)
11559 return SEQ_NONDEFAULT;
11561 result = sequence_type (ts.u.derived->components->ts);
11562 for (c = ts.u.derived->components->next; c; c = c->next)
11563 if (sequence_type (c->ts) != result)
11569 if (ts.kind != gfc_default_character_kind)
11570 return SEQ_NONDEFAULT;
11572 return SEQ_CHARACTER;
11575 if (ts.kind != gfc_default_integer_kind)
11576 return SEQ_NONDEFAULT;
11578 return SEQ_NUMERIC;
11581 if (!(ts.kind == gfc_default_real_kind
11582 || ts.kind == gfc_default_double_kind))
11583 return SEQ_NONDEFAULT;
11585 return SEQ_NUMERIC;
11588 if (ts.kind != gfc_default_complex_kind)
11589 return SEQ_NONDEFAULT;
11591 return SEQ_NUMERIC;
11594 if (ts.kind != gfc_default_logical_kind)
11595 return SEQ_NONDEFAULT;
11597 return SEQ_NUMERIC;
11600 return SEQ_NONDEFAULT;
11605 /* Resolve derived type EQUIVALENCE object. */
11608 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
11610 gfc_component *c = derived->components;
11615 /* Shall not be an object of nonsequence derived type. */
11616 if (!derived->attr.sequence)
11618 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
11619 "attribute to be an EQUIVALENCE object", sym->name,
11624 /* Shall not have allocatable components. */
11625 if (derived->attr.alloc_comp)
11627 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
11628 "components to be an EQUIVALENCE object",sym->name,
11633 if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived))
11635 gfc_error ("Derived type variable '%s' at %L with default "
11636 "initialization cannot be in EQUIVALENCE with a variable "
11637 "in COMMON", sym->name, &e->where);
11641 for (; c ; c = c->next)
11643 if (c->ts.type == BT_DERIVED
11644 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
11647 /* Shall not be an object of sequence derived type containing a pointer
11648 in the structure. */
11649 if (c->attr.pointer)
11651 gfc_error ("Derived type variable '%s' at %L with pointer "
11652 "component(s) cannot be an EQUIVALENCE object",
11653 sym->name, &e->where);
11661 /* Resolve equivalence object.
11662 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
11663 an allocatable array, an object of nonsequence derived type, an object of
11664 sequence derived type containing a pointer at any level of component
11665 selection, an automatic object, a function name, an entry name, a result
11666 name, a named constant, a structure component, or a subobject of any of
11667 the preceding objects. A substring shall not have length zero. A
11668 derived type shall not have components with default initialization nor
11669 shall two objects of an equivalence group be initialized.
11670 Either all or none of the objects shall have an protected attribute.
11671 The simple constraints are done in symbol.c(check_conflict) and the rest
11672 are implemented here. */
11675 resolve_equivalence (gfc_equiv *eq)
11678 gfc_symbol *first_sym;
11681 locus *last_where = NULL;
11682 seq_type eq_type, last_eq_type;
11683 gfc_typespec *last_ts;
11684 int object, cnt_protected;
11687 last_ts = &eq->expr->symtree->n.sym->ts;
11689 first_sym = eq->expr->symtree->n.sym;
11693 for (object = 1; eq; eq = eq->eq, object++)
11697 e->ts = e->symtree->n.sym->ts;
11698 /* match_varspec might not know yet if it is seeing
11699 array reference or substring reference, as it doesn't
11701 if (e->ref && e->ref->type == REF_ARRAY)
11703 gfc_ref *ref = e->ref;
11704 sym = e->symtree->n.sym;
11706 if (sym->attr.dimension)
11708 ref->u.ar.as = sym->as;
11712 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
11713 if (e->ts.type == BT_CHARACTER
11715 && ref->type == REF_ARRAY
11716 && ref->u.ar.dimen == 1
11717 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
11718 && ref->u.ar.stride[0] == NULL)
11720 gfc_expr *start = ref->u.ar.start[0];
11721 gfc_expr *end = ref->u.ar.end[0];
11724 /* Optimize away the (:) reference. */
11725 if (start == NULL && end == NULL)
11728 e->ref = ref->next;
11730 e->ref->next = ref->next;
11735 ref->type = REF_SUBSTRING;
11737 start = gfc_int_expr (1);
11738 ref->u.ss.start = start;
11739 if (end == NULL && e->ts.u.cl)
11740 end = gfc_copy_expr (e->ts.u.cl->length);
11741 ref->u.ss.end = end;
11742 ref->u.ss.length = e->ts.u.cl;
11749 /* Any further ref is an error. */
11752 gcc_assert (ref->type == REF_ARRAY);
11753 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
11759 if (gfc_resolve_expr (e) == FAILURE)
11762 sym = e->symtree->n.sym;
11764 if (sym->attr.is_protected)
11766 if (cnt_protected > 0 && cnt_protected != object)
11768 gfc_error ("Either all or none of the objects in the "
11769 "EQUIVALENCE set at %L shall have the "
11770 "PROTECTED attribute",
11775 /* Shall not equivalence common block variables in a PURE procedure. */
11776 if (sym->ns->proc_name
11777 && sym->ns->proc_name->attr.pure
11778 && sym->attr.in_common)
11780 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
11781 "object in the pure procedure '%s'",
11782 sym->name, &e->where, sym->ns->proc_name->name);
11786 /* Shall not be a named constant. */
11787 if (e->expr_type == EXPR_CONSTANT)
11789 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
11790 "object", sym->name, &e->where);
11794 if (e->ts.type == BT_DERIVED
11795 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
11798 /* Check that the types correspond correctly:
11800 A numeric sequence structure may be equivalenced to another sequence
11801 structure, an object of default integer type, default real type, double
11802 precision real type, default logical type such that components of the
11803 structure ultimately only become associated to objects of the same
11804 kind. A character sequence structure may be equivalenced to an object
11805 of default character kind or another character sequence structure.
11806 Other objects may be equivalenced only to objects of the same type and
11807 kind parameters. */
11809 /* Identical types are unconditionally OK. */
11810 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
11811 goto identical_types;
11813 last_eq_type = sequence_type (*last_ts);
11814 eq_type = sequence_type (sym->ts);
11816 /* Since the pair of objects is not of the same type, mixed or
11817 non-default sequences can be rejected. */
11819 msg = "Sequence %s with mixed components in EQUIVALENCE "
11820 "statement at %L with different type objects";
11822 && last_eq_type == SEQ_MIXED
11823 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
11825 || (eq_type == SEQ_MIXED
11826 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11827 &e->where) == FAILURE))
11830 msg = "Non-default type object or sequence %s in EQUIVALENCE "
11831 "statement at %L with objects of different type";
11833 && last_eq_type == SEQ_NONDEFAULT
11834 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
11835 last_where) == FAILURE)
11836 || (eq_type == SEQ_NONDEFAULT
11837 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11838 &e->where) == FAILURE))
11841 msg ="Non-CHARACTER object '%s' in default CHARACTER "
11842 "EQUIVALENCE statement at %L";
11843 if (last_eq_type == SEQ_CHARACTER
11844 && eq_type != SEQ_CHARACTER
11845 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11846 &e->where) == FAILURE)
11849 msg ="Non-NUMERIC object '%s' in default NUMERIC "
11850 "EQUIVALENCE statement at %L";
11851 if (last_eq_type == SEQ_NUMERIC
11852 && eq_type != SEQ_NUMERIC
11853 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11854 &e->where) == FAILURE)
11859 last_where = &e->where;
11864 /* Shall not be an automatic array. */
11865 if (e->ref->type == REF_ARRAY
11866 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
11868 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
11869 "an EQUIVALENCE object", sym->name, &e->where);
11876 /* Shall not be a structure component. */
11877 if (r->type == REF_COMPONENT)
11879 gfc_error ("Structure component '%s' at %L cannot be an "
11880 "EQUIVALENCE object",
11881 r->u.c.component->name, &e->where);
11885 /* A substring shall not have length zero. */
11886 if (r->type == REF_SUBSTRING)
11888 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
11890 gfc_error ("Substring at %L has length zero",
11891 &r->u.ss.start->where);
11901 /* Resolve function and ENTRY types, issue diagnostics if needed. */
11904 resolve_fntype (gfc_namespace *ns)
11906 gfc_entry_list *el;
11909 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
11912 /* If there are any entries, ns->proc_name is the entry master
11913 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
11915 sym = ns->entries->sym;
11917 sym = ns->proc_name;
11918 if (sym->result == sym
11919 && sym->ts.type == BT_UNKNOWN
11920 && gfc_set_default_type (sym, 0, NULL) == FAILURE
11921 && !sym->attr.untyped)
11923 gfc_error ("Function '%s' at %L has no IMPLICIT type",
11924 sym->name, &sym->declared_at);
11925 sym->attr.untyped = 1;
11928 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
11929 && !sym->attr.contained
11930 && !gfc_check_access (sym->ts.u.derived->attr.access,
11931 sym->ts.u.derived->ns->default_access)
11932 && gfc_check_access (sym->attr.access, sym->ns->default_access))
11934 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
11935 "%L of PRIVATE type '%s'", sym->name,
11936 &sym->declared_at, sym->ts.u.derived->name);
11940 for (el = ns->entries->next; el; el = el->next)
11942 if (el->sym->result == el->sym
11943 && el->sym->ts.type == BT_UNKNOWN
11944 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
11945 && !el->sym->attr.untyped)
11947 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
11948 el->sym->name, &el->sym->declared_at);
11949 el->sym->attr.untyped = 1;
11955 /* 12.3.2.1.1 Defined operators. */
11958 check_uop_procedure (gfc_symbol *sym, locus where)
11960 gfc_formal_arglist *formal;
11962 if (!sym->attr.function)
11964 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
11965 sym->name, &where);
11969 if (sym->ts.type == BT_CHARACTER
11970 && !(sym->ts.u.cl && sym->ts.u.cl->length)
11971 && !(sym->result && sym->result->ts.u.cl
11972 && sym->result->ts.u.cl->length))
11974 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
11975 "character length", sym->name, &where);
11979 formal = sym->formal;
11980 if (!formal || !formal->sym)
11982 gfc_error ("User operator procedure '%s' at %L must have at least "
11983 "one argument", sym->name, &where);
11987 if (formal->sym->attr.intent != INTENT_IN)
11989 gfc_error ("First argument of operator interface at %L must be "
11990 "INTENT(IN)", &where);
11994 if (formal->sym->attr.optional)
11996 gfc_error ("First argument of operator interface at %L cannot be "
11997 "optional", &where);
12001 formal = formal->next;
12002 if (!formal || !formal->sym)
12005 if (formal->sym->attr.intent != INTENT_IN)
12007 gfc_error ("Second argument of operator interface at %L must be "
12008 "INTENT(IN)", &where);
12012 if (formal->sym->attr.optional)
12014 gfc_error ("Second argument of operator interface at %L cannot be "
12015 "optional", &where);
12021 gfc_error ("Operator interface at %L must have, at most, two "
12022 "arguments", &where);
12030 gfc_resolve_uops (gfc_symtree *symtree)
12032 gfc_interface *itr;
12034 if (symtree == NULL)
12037 gfc_resolve_uops (symtree->left);
12038 gfc_resolve_uops (symtree->right);
12040 for (itr = symtree->n.uop->op; itr; itr = itr->next)
12041 check_uop_procedure (itr->sym, itr->sym->declared_at);
12045 /* Examine all of the expressions associated with a program unit,
12046 assign types to all intermediate expressions, make sure that all
12047 assignments are to compatible types and figure out which names
12048 refer to which functions or subroutines. It doesn't check code
12049 block, which is handled by resolve_code. */
12052 resolve_types (gfc_namespace *ns)
12058 gfc_namespace* old_ns = gfc_current_ns;
12060 /* Check that all IMPLICIT types are ok. */
12061 if (!ns->seen_implicit_none)
12064 for (letter = 0; letter != GFC_LETTERS; ++letter)
12065 if (ns->set_flag[letter]
12066 && resolve_typespec_used (&ns->default_type[letter],
12067 &ns->implicit_loc[letter],
12072 gfc_current_ns = ns;
12074 resolve_entries (ns);
12076 resolve_common_vars (ns->blank_common.head, false);
12077 resolve_common_blocks (ns->common_root);
12079 resolve_contained_functions (ns);
12081 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
12083 for (cl = ns->cl_list; cl; cl = cl->next)
12084 resolve_charlen (cl);
12086 gfc_traverse_ns (ns, resolve_symbol);
12088 resolve_fntype (ns);
12090 for (n = ns->contained; n; n = n->sibling)
12092 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
12093 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
12094 "also be PURE", n->proc_name->name,
12095 &n->proc_name->declared_at);
12101 gfc_check_interfaces (ns);
12103 gfc_traverse_ns (ns, resolve_values);
12109 for (d = ns->data; d; d = d->next)
12113 gfc_traverse_ns (ns, gfc_formalize_init_value);
12115 gfc_traverse_ns (ns, gfc_verify_binding_labels);
12117 if (ns->common_root != NULL)
12118 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
12120 for (eq = ns->equiv; eq; eq = eq->next)
12121 resolve_equivalence (eq);
12123 /* Warn about unused labels. */
12124 if (warn_unused_label)
12125 warn_unused_fortran_label (ns->st_labels);
12127 gfc_resolve_uops (ns->uop_root);
12129 gfc_current_ns = old_ns;
12133 /* Call resolve_code recursively. */
12136 resolve_codes (gfc_namespace *ns)
12139 bitmap_obstack old_obstack;
12141 for (n = ns->contained; n; n = n->sibling)
12144 gfc_current_ns = ns;
12146 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
12147 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
12150 /* Set to an out of range value. */
12151 current_entry_id = -1;
12153 old_obstack = labels_obstack;
12154 bitmap_obstack_initialize (&labels_obstack);
12156 resolve_code (ns->code, ns);
12158 bitmap_obstack_release (&labels_obstack);
12159 labels_obstack = old_obstack;
12163 /* This function is called after a complete program unit has been compiled.
12164 Its purpose is to examine all of the expressions associated with a program
12165 unit, assign types to all intermediate expressions, make sure that all
12166 assignments are to compatible types and figure out which names refer to
12167 which functions or subroutines. */
12170 gfc_resolve (gfc_namespace *ns)
12172 gfc_namespace *old_ns;
12173 code_stack *old_cs_base;
12179 old_ns = gfc_current_ns;
12180 old_cs_base = cs_base;
12182 resolve_types (ns);
12183 resolve_codes (ns);
12185 gfc_current_ns = old_ns;
12186 cs_base = old_cs_base;