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 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
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;
1327 if (e->expr_type == EXPR_VARIABLE
1328 && e->symtree->n.sym->attr.generic
1330 && count_specific_procs (e) != 1)
1333 if (e->ts.type != BT_PROCEDURE)
1335 save_need_full_assumed_size = need_full_assumed_size;
1336 if (e->expr_type != EXPR_VARIABLE)
1337 need_full_assumed_size = 0;
1338 if (gfc_resolve_expr (e) != SUCCESS)
1340 need_full_assumed_size = save_need_full_assumed_size;
1344 /* See if the expression node should really be a variable reference. */
1346 sym = e->symtree->n.sym;
1348 if (sym->attr.flavor == FL_PROCEDURE
1349 || sym->attr.intrinsic
1350 || sym->attr.external)
1354 /* If a procedure is not already determined to be something else
1355 check if it is intrinsic. */
1356 if (!sym->attr.intrinsic
1357 && !(sym->attr.external || sym->attr.use_assoc
1358 || sym->attr.if_source == IFSRC_IFBODY)
1359 && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1360 sym->attr.intrinsic = 1;
1362 if (sym->attr.proc == PROC_ST_FUNCTION)
1364 gfc_error ("Statement function '%s' at %L is not allowed as an "
1365 "actual argument", sym->name, &e->where);
1368 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1369 sym->attr.subroutine);
1370 if (sym->attr.intrinsic && actual_ok == 0)
1372 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1373 "actual argument", sym->name, &e->where);
1376 if (sym->attr.contained && !sym->attr.use_assoc
1377 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1379 gfc_error ("Internal procedure '%s' is not allowed as an "
1380 "actual argument at %L", sym->name, &e->where);
1383 if (sym->attr.elemental && !sym->attr.intrinsic)
1385 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1386 "allowed as an actual argument at %L", sym->name,
1390 /* Check if a generic interface has a specific procedure
1391 with the same name before emitting an error. */
1392 if (sym->attr.generic && count_specific_procs (e) != 1)
1395 /* Just in case a specific was found for the expression. */
1396 sym = e->symtree->n.sym;
1398 /* If the symbol is the function that names the current (or
1399 parent) scope, then we really have a variable reference. */
1401 if (sym->attr.function && sym->result == sym
1402 && (sym->ns->proc_name == sym
1403 || (sym->ns->parent != NULL
1404 && sym->ns->parent->proc_name == sym)))
1407 /* If all else fails, see if we have a specific intrinsic. */
1408 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1410 gfc_intrinsic_sym *isym;
1412 isym = gfc_find_function (sym->name);
1413 if (isym == NULL || !isym->specific)
1415 gfc_error ("Unable to find a specific INTRINSIC procedure "
1416 "for the reference '%s' at %L", sym->name,
1421 sym->attr.intrinsic = 1;
1422 sym->attr.function = 1;
1425 if (gfc_resolve_expr (e) == FAILURE)
1430 /* See if the name is a module procedure in a parent unit. */
1432 if (was_declared (sym) || sym->ns->parent == NULL)
1435 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1437 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1441 if (parent_st == NULL)
1444 sym = parent_st->n.sym;
1445 e->symtree = parent_st; /* Point to the right thing. */
1447 if (sym->attr.flavor == FL_PROCEDURE
1448 || sym->attr.intrinsic
1449 || sym->attr.external)
1451 if (gfc_resolve_expr (e) == FAILURE)
1457 e->expr_type = EXPR_VARIABLE;
1459 if (sym->as != NULL)
1461 e->rank = sym->as->rank;
1462 e->ref = gfc_get_ref ();
1463 e->ref->type = REF_ARRAY;
1464 e->ref->u.ar.type = AR_FULL;
1465 e->ref->u.ar.as = sym->as;
1468 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1469 primary.c (match_actual_arg). If above code determines that it
1470 is a variable instead, it needs to be resolved as it was not
1471 done at the beginning of this function. */
1472 save_need_full_assumed_size = need_full_assumed_size;
1473 if (e->expr_type != EXPR_VARIABLE)
1474 need_full_assumed_size = 0;
1475 if (gfc_resolve_expr (e) != SUCCESS)
1477 need_full_assumed_size = save_need_full_assumed_size;
1480 /* Check argument list functions %VAL, %LOC and %REF. There is
1481 nothing to do for %REF. */
1482 if (arg->name && arg->name[0] == '%')
1484 if (strncmp ("%VAL", arg->name, 4) == 0)
1486 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1488 gfc_error ("By-value argument at %L is not of numeric "
1495 gfc_error ("By-value argument at %L cannot be an array or "
1496 "an array section", &e->where);
1500 /* Intrinsics are still PROC_UNKNOWN here. However,
1501 since same file external procedures are not resolvable
1502 in gfortran, it is a good deal easier to leave them to
1504 if (ptype != PROC_UNKNOWN
1505 && ptype != PROC_DUMMY
1506 && ptype != PROC_EXTERNAL
1507 && ptype != PROC_MODULE)
1509 gfc_error ("By-value argument at %L is not allowed "
1510 "in this context", &e->where);
1515 /* Statement functions have already been excluded above. */
1516 else if (strncmp ("%LOC", arg->name, 4) == 0
1517 && e->ts.type == BT_PROCEDURE)
1519 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1521 gfc_error ("Passing internal procedure at %L by location "
1522 "not allowed", &e->where);
1533 /* Do the checks of the actual argument list that are specific to elemental
1534 procedures. If called with c == NULL, we have a function, otherwise if
1535 expr == NULL, we have a subroutine. */
1538 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1540 gfc_actual_arglist *arg0;
1541 gfc_actual_arglist *arg;
1542 gfc_symbol *esym = NULL;
1543 gfc_intrinsic_sym *isym = NULL;
1545 gfc_intrinsic_arg *iformal = NULL;
1546 gfc_formal_arglist *eformal = NULL;
1547 bool formal_optional = false;
1548 bool set_by_optional = false;
1552 /* Is this an elemental procedure? */
1553 if (expr && expr->value.function.actual != NULL)
1555 if (expr->value.function.esym != NULL
1556 && expr->value.function.esym->attr.elemental)
1558 arg0 = expr->value.function.actual;
1559 esym = expr->value.function.esym;
1561 else if (expr->value.function.isym != NULL
1562 && expr->value.function.isym->elemental)
1564 arg0 = expr->value.function.actual;
1565 isym = expr->value.function.isym;
1570 else if (c && c->ext.actual != NULL)
1572 arg0 = c->ext.actual;
1574 if (c->resolved_sym)
1575 esym = c->resolved_sym;
1577 esym = c->symtree->n.sym;
1580 if (!esym->attr.elemental)
1586 /* The rank of an elemental is the rank of its array argument(s). */
1587 for (arg = arg0; arg; arg = arg->next)
1589 if (arg->expr != NULL && arg->expr->rank > 0)
1591 rank = arg->expr->rank;
1592 if (arg->expr->expr_type == EXPR_VARIABLE
1593 && arg->expr->symtree->n.sym->attr.optional)
1594 set_by_optional = true;
1596 /* Function specific; set the result rank and shape. */
1600 if (!expr->shape && arg->expr->shape)
1602 expr->shape = gfc_get_shape (rank);
1603 for (i = 0; i < rank; i++)
1604 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1611 /* If it is an array, it shall not be supplied as an actual argument
1612 to an elemental procedure unless an array of the same rank is supplied
1613 as an actual argument corresponding to a nonoptional dummy argument of
1614 that elemental procedure(12.4.1.5). */
1615 formal_optional = false;
1617 iformal = isym->formal;
1619 eformal = esym->formal;
1621 for (arg = arg0; arg; arg = arg->next)
1625 if (eformal->sym && eformal->sym->attr.optional)
1626 formal_optional = true;
1627 eformal = eformal->next;
1629 else if (isym && iformal)
1631 if (iformal->optional)
1632 formal_optional = true;
1633 iformal = iformal->next;
1636 formal_optional = true;
1638 if (pedantic && arg->expr != NULL
1639 && arg->expr->expr_type == EXPR_VARIABLE
1640 && arg->expr->symtree->n.sym->attr.optional
1643 && (set_by_optional || arg->expr->rank != rank)
1644 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1646 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1647 "MISSING, it cannot be the actual argument of an "
1648 "ELEMENTAL procedure unless there is a non-optional "
1649 "argument with the same rank (12.4.1.5)",
1650 arg->expr->symtree->n.sym->name, &arg->expr->where);
1655 for (arg = arg0; arg; arg = arg->next)
1657 if (arg->expr == NULL || arg->expr->rank == 0)
1660 /* Being elemental, the last upper bound of an assumed size array
1661 argument must be present. */
1662 if (resolve_assumed_size_actual (arg->expr))
1665 /* Elemental procedure's array actual arguments must conform. */
1668 if (gfc_check_conformance (arg->expr, e,
1669 "elemental procedure") == FAILURE)
1676 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1677 is an array, the intent inout/out variable needs to be also an array. */
1678 if (rank > 0 && esym && expr == NULL)
1679 for (eformal = esym->formal, arg = arg0; arg && eformal;
1680 arg = arg->next, eformal = eformal->next)
1681 if ((eformal->sym->attr.intent == INTENT_OUT
1682 || eformal->sym->attr.intent == INTENT_INOUT)
1683 && arg->expr && arg->expr->rank == 0)
1685 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1686 "ELEMENTAL subroutine '%s' is a scalar, but another "
1687 "actual argument is an array", &arg->expr->where,
1688 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1689 : "INOUT", eformal->sym->name, esym->name);
1696 /* Go through each actual argument in ACTUAL and see if it can be
1697 implemented as an inlined, non-copying intrinsic. FNSYM is the
1698 function being called, or NULL if not known. */
1701 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1703 gfc_actual_arglist *ap;
1706 for (ap = actual; ap; ap = ap->next)
1708 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1709 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1711 ap->expr->inline_noncopying_intrinsic = 1;
1715 /* This function does the checking of references to global procedures
1716 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1717 77 and 95 standards. It checks for a gsymbol for the name, making
1718 one if it does not already exist. If it already exists, then the
1719 reference being resolved must correspond to the type of gsymbol.
1720 Otherwise, the new symbol is equipped with the attributes of the
1721 reference. The corresponding code that is called in creating
1722 global entities is parse.c.
1724 In addition, for all but -std=legacy, the gsymbols are used to
1725 check the interfaces of external procedures from the same file.
1726 The namespace of the gsymbol is resolved and then, once this is
1727 done the interface is checked. */
1731 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1733 if (!gsym_ns->proc_name->attr.recursive)
1736 if (sym->ns == gsym_ns)
1739 if (sym->ns->parent && sym->ns->parent == gsym_ns)
1746 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
1748 if (gsym_ns->entries)
1750 gfc_entry_list *entry = gsym_ns->entries;
1752 for (; entry; entry = entry->next)
1754 if (strcmp (sym->name, entry->sym->name) == 0)
1756 if (strcmp (gsym_ns->proc_name->name,
1757 sym->ns->proc_name->name) == 0)
1761 && strcmp (gsym_ns->proc_name->name,
1762 sym->ns->parent->proc_name->name) == 0)
1771 resolve_global_procedure (gfc_symbol *sym, locus *where,
1772 gfc_actual_arglist **actual, int sub)
1776 enum gfc_symbol_type type;
1778 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1780 gsym = gfc_get_gsymbol (sym->name);
1782 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1783 gfc_global_used (gsym, where);
1785 if (gfc_option.flag_whole_file
1786 && sym->attr.if_source == IFSRC_UNKNOWN
1787 && gsym->type != GSYM_UNKNOWN
1789 && gsym->ns->resolved != -1
1790 && gsym->ns->proc_name
1791 && not_in_recursive (sym, gsym->ns)
1792 && not_entry_self_reference (sym, gsym->ns))
1794 /* Make sure that translation for the gsymbol occurs before
1795 the procedure currently being resolved. */
1796 ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
1797 for (; ns && ns != gsym->ns; ns = ns->sibling)
1799 if (ns->sibling == gsym->ns)
1801 ns->sibling = gsym->ns->sibling;
1802 gsym->ns->sibling = gfc_global_ns_list;
1803 gfc_global_ns_list = gsym->ns;
1808 if (!gsym->ns->resolved)
1810 gfc_dt_list *old_dt_list;
1812 /* Stash away derived types so that the backend_decls do not
1814 old_dt_list = gfc_derived_types;
1815 gfc_derived_types = NULL;
1817 gfc_resolve (gsym->ns);
1819 /* Store the new derived types with the global namespace. */
1820 if (gfc_derived_types)
1821 gsym->ns->derived_types = gfc_derived_types;
1823 /* Restore the derived types of this namespace. */
1824 gfc_derived_types = old_dt_list;
1827 if (gsym->ns->proc_name->attr.function
1828 && gsym->ns->proc_name->as
1829 && gsym->ns->proc_name->as->rank
1830 && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
1831 gfc_error ("The reference to function '%s' at %L either needs an "
1832 "explicit INTERFACE or the rank is incorrect", sym->name,
1835 if (gfc_option.flag_whole_file == 1
1836 || ((gfc_option.warn_std & GFC_STD_LEGACY)
1838 !(gfc_option.warn_std & GFC_STD_GNU)))
1839 gfc_errors_to_warnings (1);
1841 gfc_procedure_use (gsym->ns->proc_name, actual, where);
1843 gfc_errors_to_warnings (0);
1846 if (gsym->type == GSYM_UNKNOWN)
1849 gsym->where = *where;
1856 /************* Function resolution *************/
1858 /* Resolve a function call known to be generic.
1859 Section 14.1.2.4.1. */
1862 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1866 if (sym->attr.generic)
1868 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1871 expr->value.function.name = s->name;
1872 expr->value.function.esym = s;
1874 if (s->ts.type != BT_UNKNOWN)
1876 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1877 expr->ts = s->result->ts;
1880 expr->rank = s->as->rank;
1881 else if (s->result != NULL && s->result->as != NULL)
1882 expr->rank = s->result->as->rank;
1884 gfc_set_sym_referenced (expr->value.function.esym);
1889 /* TODO: Need to search for elemental references in generic
1893 if (sym->attr.intrinsic)
1894 return gfc_intrinsic_func_interface (expr, 0);
1901 resolve_generic_f (gfc_expr *expr)
1906 sym = expr->symtree->n.sym;
1910 m = resolve_generic_f0 (expr, sym);
1913 else if (m == MATCH_ERROR)
1917 if (sym->ns->parent == NULL)
1919 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1923 if (!generic_sym (sym))
1927 /* Last ditch attempt. See if the reference is to an intrinsic
1928 that possesses a matching interface. 14.1.2.4 */
1929 if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1931 gfc_error ("There is no specific function for the generic '%s' at %L",
1932 expr->symtree->n.sym->name, &expr->where);
1936 m = gfc_intrinsic_func_interface (expr, 0);
1940 gfc_error ("Generic function '%s' at %L is not consistent with a "
1941 "specific intrinsic interface", expr->symtree->n.sym->name,
1948 /* Resolve a function call known to be specific. */
1951 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1955 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1957 if (sym->attr.dummy)
1959 sym->attr.proc = PROC_DUMMY;
1963 sym->attr.proc = PROC_EXTERNAL;
1967 if (sym->attr.proc == PROC_MODULE
1968 || sym->attr.proc == PROC_ST_FUNCTION
1969 || sym->attr.proc == PROC_INTERNAL)
1972 if (sym->attr.intrinsic)
1974 m = gfc_intrinsic_func_interface (expr, 1);
1978 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1979 "with an intrinsic", sym->name, &expr->where);
1987 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1990 expr->ts = sym->result->ts;
1993 expr->value.function.name = sym->name;
1994 expr->value.function.esym = sym;
1995 if (sym->as != NULL)
1996 expr->rank = sym->as->rank;
2003 resolve_specific_f (gfc_expr *expr)
2008 sym = expr->symtree->n.sym;
2012 m = resolve_specific_f0 (sym, expr);
2015 if (m == MATCH_ERROR)
2018 if (sym->ns->parent == NULL)
2021 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2027 gfc_error ("Unable to resolve the specific function '%s' at %L",
2028 expr->symtree->n.sym->name, &expr->where);
2034 /* Resolve a procedure call not known to be generic nor specific. */
2037 resolve_unknown_f (gfc_expr *expr)
2042 sym = expr->symtree->n.sym;
2044 if (sym->attr.dummy)
2046 sym->attr.proc = PROC_DUMMY;
2047 expr->value.function.name = sym->name;
2051 /* See if we have an intrinsic function reference. */
2053 if (gfc_is_intrinsic (sym, 0, expr->where))
2055 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2060 /* The reference is to an external name. */
2062 sym->attr.proc = PROC_EXTERNAL;
2063 expr->value.function.name = sym->name;
2064 expr->value.function.esym = expr->symtree->n.sym;
2066 if (sym->as != NULL)
2067 expr->rank = sym->as->rank;
2069 /* Type of the expression is either the type of the symbol or the
2070 default type of the symbol. */
2073 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2075 if (sym->ts.type != BT_UNKNOWN)
2079 ts = gfc_get_default_type (sym->name, sym->ns);
2081 if (ts->type == BT_UNKNOWN)
2083 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2084 sym->name, &expr->where);
2095 /* Return true, if the symbol is an external procedure. */
2097 is_external_proc (gfc_symbol *sym)
2099 if (!sym->attr.dummy && !sym->attr.contained
2100 && !(sym->attr.intrinsic
2101 || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2102 && sym->attr.proc != PROC_ST_FUNCTION
2103 && !sym->attr.use_assoc
2111 /* Figure out if a function reference is pure or not. Also set the name
2112 of the function for a potential error message. Return nonzero if the
2113 function is PURE, zero if not. */
2115 pure_stmt_function (gfc_expr *, gfc_symbol *);
2118 pure_function (gfc_expr *e, const char **name)
2124 if (e->symtree != NULL
2125 && e->symtree->n.sym != NULL
2126 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2127 return pure_stmt_function (e, e->symtree->n.sym);
2129 if (e->value.function.esym)
2131 pure = gfc_pure (e->value.function.esym);
2132 *name = e->value.function.esym->name;
2134 else if (e->value.function.isym)
2136 pure = e->value.function.isym->pure
2137 || e->value.function.isym->elemental;
2138 *name = e->value.function.isym->name;
2142 /* Implicit functions are not pure. */
2144 *name = e->value.function.name;
2152 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2153 int *f ATTRIBUTE_UNUSED)
2157 /* Don't bother recursing into other statement functions
2158 since they will be checked individually for purity. */
2159 if (e->expr_type != EXPR_FUNCTION
2161 || e->symtree->n.sym == sym
2162 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2165 return pure_function (e, &name) ? false : true;
2170 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2172 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2177 is_scalar_expr_ptr (gfc_expr *expr)
2179 gfc_try retval = SUCCESS;
2184 /* See if we have a gfc_ref, which means we have a substring, array
2185 reference, or a component. */
2186 if (expr->ref != NULL)
2189 while (ref->next != NULL)
2195 if (ref->u.ss.length != NULL
2196 && ref->u.ss.length->length != NULL
2198 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2200 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2202 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2203 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2204 if (end - start + 1 != 1)
2211 if (ref->u.ar.type == AR_ELEMENT)
2213 else if (ref->u.ar.type == AR_FULL)
2215 /* The user can give a full array if the array is of size 1. */
2216 if (ref->u.ar.as != NULL
2217 && ref->u.ar.as->rank == 1
2218 && ref->u.ar.as->type == AS_EXPLICIT
2219 && ref->u.ar.as->lower[0] != NULL
2220 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2221 && ref->u.ar.as->upper[0] != NULL
2222 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2224 /* If we have a character string, we need to check if
2225 its length is one. */
2226 if (expr->ts.type == BT_CHARACTER)
2228 if (expr->ts.u.cl == NULL
2229 || expr->ts.u.cl->length == NULL
2230 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2236 /* We have constant lower and upper bounds. If the
2237 difference between is 1, it can be considered a
2239 start = (int) mpz_get_si
2240 (ref->u.ar.as->lower[0]->value.integer);
2241 end = (int) mpz_get_si
2242 (ref->u.ar.as->upper[0]->value.integer);
2243 if (end - start + 1 != 1)
2258 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2260 /* Character string. Make sure it's of length 1. */
2261 if (expr->ts.u.cl == NULL
2262 || expr->ts.u.cl->length == NULL
2263 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2266 else if (expr->rank != 0)
2273 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2274 and, in the case of c_associated, set the binding label based on
2278 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2279 gfc_symbol **new_sym)
2281 char name[GFC_MAX_SYMBOL_LEN + 1];
2282 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2283 int optional_arg = 0, is_pointer = 0;
2284 gfc_try retval = SUCCESS;
2285 gfc_symbol *args_sym;
2286 gfc_typespec *arg_ts;
2288 if (args->expr->expr_type == EXPR_CONSTANT
2289 || args->expr->expr_type == EXPR_OP
2290 || args->expr->expr_type == EXPR_NULL)
2292 gfc_error ("Argument to '%s' at %L is not a variable",
2293 sym->name, &(args->expr->where));
2297 args_sym = args->expr->symtree->n.sym;
2299 /* The typespec for the actual arg should be that stored in the expr
2300 and not necessarily that of the expr symbol (args_sym), because
2301 the actual expression could be a part-ref of the expr symbol. */
2302 arg_ts = &(args->expr->ts);
2304 is_pointer = gfc_is_data_pointer (args->expr);
2306 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2308 /* If the user gave two args then they are providing something for
2309 the optional arg (the second cptr). Therefore, set the name and
2310 binding label to the c_associated for two cptrs. Otherwise,
2311 set c_associated to expect one cptr. */
2315 sprintf (name, "%s_2", sym->name);
2316 sprintf (binding_label, "%s_2", sym->binding_label);
2322 sprintf (name, "%s_1", sym->name);
2323 sprintf (binding_label, "%s_1", sym->binding_label);
2327 /* Get a new symbol for the version of c_associated that
2329 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2331 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2332 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2334 sprintf (name, "%s", sym->name);
2335 sprintf (binding_label, "%s", sym->binding_label);
2337 /* Error check the call. */
2338 if (args->next != NULL)
2340 gfc_error_now ("More actual than formal arguments in '%s' "
2341 "call at %L", name, &(args->expr->where));
2344 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2346 /* Make sure we have either the target or pointer attribute. */
2347 if (!args_sym->attr.target && !is_pointer)
2349 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2350 "a TARGET or an associated pointer",
2352 sym->name, &(args->expr->where));
2356 /* See if we have interoperable type and type param. */
2357 if (verify_c_interop (arg_ts) == SUCCESS
2358 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2360 if (args_sym->attr.target == 1)
2362 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2363 has the target attribute and is interoperable. */
2364 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2365 allocatable variable that has the TARGET attribute and
2366 is not an array of zero size. */
2367 if (args_sym->attr.allocatable == 1)
2369 if (args_sym->attr.dimension != 0
2370 && (args_sym->as && args_sym->as->rank == 0))
2372 gfc_error_now ("Allocatable variable '%s' used as a "
2373 "parameter to '%s' at %L must not be "
2374 "an array of zero size",
2375 args_sym->name, sym->name,
2376 &(args->expr->where));
2382 /* A non-allocatable target variable with C
2383 interoperable type and type parameters must be
2385 if (args_sym && args_sym->attr.dimension)
2387 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2389 gfc_error ("Assumed-shape array '%s' at %L "
2390 "cannot be an argument to the "
2391 "procedure '%s' because "
2392 "it is not C interoperable",
2394 &(args->expr->where), sym->name);
2397 else if (args_sym->as->type == AS_DEFERRED)
2399 gfc_error ("Deferred-shape array '%s' at %L "
2400 "cannot be an argument to the "
2401 "procedure '%s' because "
2402 "it is not C interoperable",
2404 &(args->expr->where), sym->name);
2409 /* Make sure it's not a character string. Arrays of
2410 any type should be ok if the variable is of a C
2411 interoperable type. */
2412 if (arg_ts->type == BT_CHARACTER)
2413 if (arg_ts->u.cl != NULL
2414 && (arg_ts->u.cl->length == NULL
2415 || arg_ts->u.cl->length->expr_type
2418 (arg_ts->u.cl->length->value.integer, 1)
2420 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2422 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2423 "at %L must have a length of 1",
2424 args_sym->name, sym->name,
2425 &(args->expr->where));
2431 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2433 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2435 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2436 "associated scalar POINTER", args_sym->name,
2437 sym->name, &(args->expr->where));
2443 /* The parameter is not required to be C interoperable. If it
2444 is not C interoperable, it must be a nonpolymorphic scalar
2445 with no length type parameters. It still must have either
2446 the pointer or target attribute, and it can be
2447 allocatable (but must be allocated when c_loc is called). */
2448 if (args->expr->rank != 0
2449 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2451 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2452 "scalar", args_sym->name, sym->name,
2453 &(args->expr->where));
2456 else if (arg_ts->type == BT_CHARACTER
2457 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2459 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2460 "%L must have a length of 1",
2461 args_sym->name, sym->name,
2462 &(args->expr->where));
2467 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2469 if (args_sym->attr.flavor != FL_PROCEDURE)
2471 /* TODO: Update this error message to allow for procedure
2472 pointers once they are implemented. */
2473 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2475 args_sym->name, sym->name,
2476 &(args->expr->where));
2479 else if (args_sym->attr.is_bind_c != 1)
2481 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2483 args_sym->name, sym->name,
2484 &(args->expr->where));
2489 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2494 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2495 "iso_c_binding function: '%s'!\n", sym->name);
2502 /* Resolve a function call, which means resolving the arguments, then figuring
2503 out which entity the name refers to. */
2504 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2505 to INTENT(OUT) or INTENT(INOUT). */
2508 resolve_function (gfc_expr *expr)
2510 gfc_actual_arglist *arg;
2515 procedure_type p = PROC_INTRINSIC;
2516 bool no_formal_args;
2520 sym = expr->symtree->n.sym;
2522 if (sym && sym->attr.intrinsic
2523 && resolve_intrinsic (sym, &expr->where) == FAILURE)
2526 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2528 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2532 /* If this ia a deferred TBP with an abstract interface (which may
2533 of course be referenced), expr->value.function.name will be set. */
2534 if (sym && sym->attr.abstract && !expr->value.function.name)
2536 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2537 sym->name, &expr->where);
2541 /* Switch off assumed size checking and do this again for certain kinds
2542 of procedure, once the procedure itself is resolved. */
2543 need_full_assumed_size++;
2545 if (expr->symtree && expr->symtree->n.sym)
2546 p = expr->symtree->n.sym->attr.proc;
2548 no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2549 if (resolve_actual_arglist (expr->value.function.actual,
2550 p, no_formal_args) == FAILURE)
2553 /* Need to setup the call to the correct c_associated, depending on
2554 the number of cptrs to user gives to compare. */
2555 if (sym && sym->attr.is_iso_c == 1)
2557 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2561 /* Get the symtree for the new symbol (resolved func).
2562 the old one will be freed later, when it's no longer used. */
2563 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2566 /* Resume assumed_size checking. */
2567 need_full_assumed_size--;
2569 /* If the procedure is external, check for usage. */
2570 if (sym && is_external_proc (sym))
2571 resolve_global_procedure (sym, &expr->where,
2572 &expr->value.function.actual, 0);
2574 if (sym && sym->ts.type == BT_CHARACTER
2576 && sym->ts.u.cl->length == NULL
2578 && expr->value.function.esym == NULL
2579 && !sym->attr.contained)
2581 /* Internal procedures are taken care of in resolve_contained_fntype. */
2582 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2583 "be used at %L since it is not a dummy argument",
2584 sym->name, &expr->where);
2588 /* See if function is already resolved. */
2590 if (expr->value.function.name != NULL)
2592 if (expr->ts.type == BT_UNKNOWN)
2598 /* Apply the rules of section 14.1.2. */
2600 switch (procedure_kind (sym))
2603 t = resolve_generic_f (expr);
2606 case PTYPE_SPECIFIC:
2607 t = resolve_specific_f (expr);
2611 t = resolve_unknown_f (expr);
2615 gfc_internal_error ("resolve_function(): bad function type");
2619 /* If the expression is still a function (it might have simplified),
2620 then we check to see if we are calling an elemental function. */
2622 if (expr->expr_type != EXPR_FUNCTION)
2625 temp = need_full_assumed_size;
2626 need_full_assumed_size = 0;
2628 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2631 if (omp_workshare_flag
2632 && expr->value.function.esym
2633 && ! gfc_elemental (expr->value.function.esym))
2635 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2636 "in WORKSHARE construct", expr->value.function.esym->name,
2641 #define GENERIC_ID expr->value.function.isym->id
2642 else if (expr->value.function.actual != NULL
2643 && expr->value.function.isym != NULL
2644 && GENERIC_ID != GFC_ISYM_LBOUND
2645 && GENERIC_ID != GFC_ISYM_LEN
2646 && GENERIC_ID != GFC_ISYM_LOC
2647 && GENERIC_ID != GFC_ISYM_PRESENT)
2649 /* Array intrinsics must also have the last upper bound of an
2650 assumed size array argument. UBOUND and SIZE have to be
2651 excluded from the check if the second argument is anything
2654 for (arg = expr->value.function.actual; arg; arg = arg->next)
2656 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2657 && arg->next != NULL && arg->next->expr)
2659 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2662 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2665 if ((int)mpz_get_si (arg->next->expr->value.integer)
2670 if (arg->expr != NULL
2671 && arg->expr->rank > 0
2672 && resolve_assumed_size_actual (arg->expr))
2678 need_full_assumed_size = temp;
2681 if (!pure_function (expr, &name) && name)
2685 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2686 "FORALL %s", name, &expr->where,
2687 forall_flag == 2 ? "mask" : "block");
2690 else if (gfc_pure (NULL))
2692 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2693 "procedure within a PURE procedure", name, &expr->where);
2698 /* Functions without the RECURSIVE attribution are not allowed to
2699 * call themselves. */
2700 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2703 esym = expr->value.function.esym;
2705 if (is_illegal_recursion (esym, gfc_current_ns))
2707 if (esym->attr.entry && esym->ns->entries)
2708 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2709 " function '%s' is not RECURSIVE",
2710 esym->name, &expr->where, esym->ns->entries->sym->name);
2712 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
2713 " is not RECURSIVE", esym->name, &expr->where);
2719 /* Character lengths of use associated functions may contains references to
2720 symbols not referenced from the current program unit otherwise. Make sure
2721 those symbols are marked as referenced. */
2723 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2724 && expr->value.function.esym->attr.use_assoc)
2726 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
2730 && !((expr->value.function.esym
2731 && expr->value.function.esym->attr.elemental)
2733 (expr->value.function.isym
2734 && expr->value.function.isym->elemental)))
2735 find_noncopying_intrinsics (expr->value.function.esym,
2736 expr->value.function.actual);
2738 /* Make sure that the expression has a typespec that works. */
2739 if (expr->ts.type == BT_UNKNOWN)
2741 if (expr->symtree->n.sym->result
2742 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
2743 && !expr->symtree->n.sym->result->attr.proc_pointer)
2744 expr->ts = expr->symtree->n.sym->result->ts;
2751 /************* Subroutine resolution *************/
2754 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2760 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2761 sym->name, &c->loc);
2762 else if (gfc_pure (NULL))
2763 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2769 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2773 if (sym->attr.generic)
2775 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2778 c->resolved_sym = s;
2779 pure_subroutine (c, s);
2783 /* TODO: Need to search for elemental references in generic interface. */
2786 if (sym->attr.intrinsic)
2787 return gfc_intrinsic_sub_interface (c, 0);
2794 resolve_generic_s (gfc_code *c)
2799 sym = c->symtree->n.sym;
2803 m = resolve_generic_s0 (c, sym);
2806 else if (m == MATCH_ERROR)
2810 if (sym->ns->parent == NULL)
2812 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2816 if (!generic_sym (sym))
2820 /* Last ditch attempt. See if the reference is to an intrinsic
2821 that possesses a matching interface. 14.1.2.4 */
2822 sym = c->symtree->n.sym;
2824 if (!gfc_is_intrinsic (sym, 1, c->loc))
2826 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2827 sym->name, &c->loc);
2831 m = gfc_intrinsic_sub_interface (c, 0);
2835 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2836 "intrinsic subroutine interface", sym->name, &c->loc);
2842 /* Set the name and binding label of the subroutine symbol in the call
2843 expression represented by 'c' to include the type and kind of the
2844 second parameter. This function is for resolving the appropriate
2845 version of c_f_pointer() and c_f_procpointer(). For example, a
2846 call to c_f_pointer() for a default integer pointer could have a
2847 name of c_f_pointer_i4. If no second arg exists, which is an error
2848 for these two functions, it defaults to the generic symbol's name
2849 and binding label. */
2852 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2853 char *name, char *binding_label)
2855 gfc_expr *arg = NULL;
2859 /* The second arg of c_f_pointer and c_f_procpointer determines
2860 the type and kind for the procedure name. */
2861 arg = c->ext.actual->next->expr;
2865 /* Set up the name to have the given symbol's name,
2866 plus the type and kind. */
2867 /* a derived type is marked with the type letter 'u' */
2868 if (arg->ts.type == BT_DERIVED)
2871 kind = 0; /* set the kind as 0 for now */
2875 type = gfc_type_letter (arg->ts.type);
2876 kind = arg->ts.kind;
2879 if (arg->ts.type == BT_CHARACTER)
2880 /* Kind info for character strings not needed. */
2883 sprintf (name, "%s_%c%d", sym->name, type, kind);
2884 /* Set up the binding label as the given symbol's label plus
2885 the type and kind. */
2886 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2890 /* If the second arg is missing, set the name and label as
2891 was, cause it should at least be found, and the missing
2892 arg error will be caught by compare_parameters(). */
2893 sprintf (name, "%s", sym->name);
2894 sprintf (binding_label, "%s", sym->binding_label);
2901 /* Resolve a generic version of the iso_c_binding procedure given
2902 (sym) to the specific one based on the type and kind of the
2903 argument(s). Currently, this function resolves c_f_pointer() and
2904 c_f_procpointer based on the type and kind of the second argument
2905 (FPTR). Other iso_c_binding procedures aren't specially handled.
2906 Upon successfully exiting, c->resolved_sym will hold the resolved
2907 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2911 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2913 gfc_symbol *new_sym;
2914 /* this is fine, since we know the names won't use the max */
2915 char name[GFC_MAX_SYMBOL_LEN + 1];
2916 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2917 /* default to success; will override if find error */
2918 match m = MATCH_YES;
2920 /* Make sure the actual arguments are in the necessary order (based on the
2921 formal args) before resolving. */
2922 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2924 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2925 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2927 set_name_and_label (c, sym, name, binding_label);
2929 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2931 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2933 /* Make sure we got a third arg if the second arg has non-zero
2934 rank. We must also check that the type and rank are
2935 correct since we short-circuit this check in
2936 gfc_procedure_use() (called above to sort actual args). */
2937 if (c->ext.actual->next->expr->rank != 0)
2939 if(c->ext.actual->next->next == NULL
2940 || c->ext.actual->next->next->expr == NULL)
2943 gfc_error ("Missing SHAPE parameter for call to %s "
2944 "at %L", sym->name, &(c->loc));
2946 else if (c->ext.actual->next->next->expr->ts.type
2948 || c->ext.actual->next->next->expr->rank != 1)
2951 gfc_error ("SHAPE parameter for call to %s at %L must "
2952 "be a rank 1 INTEGER array", sym->name,
2959 if (m != MATCH_ERROR)
2961 /* the 1 means to add the optional arg to formal list */
2962 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2964 /* for error reporting, say it's declared where the original was */
2965 new_sym->declared_at = sym->declared_at;
2970 /* no differences for c_loc or c_funloc */
2974 /* set the resolved symbol */
2975 if (m != MATCH_ERROR)
2976 c->resolved_sym = new_sym;
2978 c->resolved_sym = sym;
2984 /* Resolve a subroutine call known to be specific. */
2987 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2991 if(sym->attr.is_iso_c)
2993 m = gfc_iso_c_sub_interface (c,sym);
2997 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2999 if (sym->attr.dummy)
3001 sym->attr.proc = PROC_DUMMY;
3005 sym->attr.proc = PROC_EXTERNAL;
3009 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3012 if (sym->attr.intrinsic)
3014 m = gfc_intrinsic_sub_interface (c, 1);
3018 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3019 "with an intrinsic", sym->name, &c->loc);
3027 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3029 c->resolved_sym = sym;
3030 pure_subroutine (c, sym);
3037 resolve_specific_s (gfc_code *c)
3042 sym = c->symtree->n.sym;
3046 m = resolve_specific_s0 (c, sym);
3049 if (m == MATCH_ERROR)
3052 if (sym->ns->parent == NULL)
3055 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3061 sym = c->symtree->n.sym;
3062 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3063 sym->name, &c->loc);
3069 /* Resolve a subroutine call not known to be generic nor specific. */
3072 resolve_unknown_s (gfc_code *c)
3076 sym = c->symtree->n.sym;
3078 if (sym->attr.dummy)
3080 sym->attr.proc = PROC_DUMMY;
3084 /* See if we have an intrinsic function reference. */
3086 if (gfc_is_intrinsic (sym, 1, c->loc))
3088 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3093 /* The reference is to an external name. */
3096 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3098 c->resolved_sym = sym;
3100 pure_subroutine (c, sym);
3106 /* Resolve a subroutine call. Although it was tempting to use the same code
3107 for functions, subroutines and functions are stored differently and this
3108 makes things awkward. */
3111 resolve_call (gfc_code *c)
3114 procedure_type ptype = PROC_INTRINSIC;
3115 gfc_symbol *csym, *sym;
3116 bool no_formal_args;
3118 csym = c->symtree ? c->symtree->n.sym : NULL;
3120 if (csym && csym->ts.type != BT_UNKNOWN)
3122 gfc_error ("'%s' at %L has a type, which is not consistent with "
3123 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3127 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3130 gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3131 sym = st ? st->n.sym : NULL;
3132 if (sym && csym != sym
3133 && sym->ns == gfc_current_ns
3134 && sym->attr.flavor == FL_PROCEDURE
3135 && sym->attr.contained)
3138 if (csym->attr.generic)
3139 c->symtree->n.sym = sym;
3142 csym = c->symtree->n.sym;
3146 /* If this ia a deferred TBP with an abstract interface
3147 (which may of course be referenced), c->expr1 will be set. */
3148 if (csym && csym->attr.abstract && !c->expr1)
3150 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3151 csym->name, &c->loc);
3155 /* Subroutines without the RECURSIVE attribution are not allowed to
3156 * call themselves. */
3157 if (csym && is_illegal_recursion (csym, gfc_current_ns))
3159 if (csym->attr.entry && csym->ns->entries)
3160 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3161 " subroutine '%s' is not RECURSIVE",
3162 csym->name, &c->loc, csym->ns->entries->sym->name);
3164 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3165 " is not RECURSIVE", csym->name, &c->loc);
3170 /* Switch off assumed size checking and do this again for certain kinds
3171 of procedure, once the procedure itself is resolved. */
3172 need_full_assumed_size++;
3175 ptype = csym->attr.proc;
3177 no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3178 if (resolve_actual_arglist (c->ext.actual, ptype,
3179 no_formal_args) == FAILURE)
3182 /* Resume assumed_size checking. */
3183 need_full_assumed_size--;
3185 /* If external, check for usage. */
3186 if (csym && is_external_proc (csym))
3187 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3190 if (c->resolved_sym == NULL)
3192 c->resolved_isym = NULL;
3193 switch (procedure_kind (csym))
3196 t = resolve_generic_s (c);
3199 case PTYPE_SPECIFIC:
3200 t = resolve_specific_s (c);
3204 t = resolve_unknown_s (c);
3208 gfc_internal_error ("resolve_subroutine(): bad function type");
3212 /* Some checks of elemental subroutine actual arguments. */
3213 if (resolve_elemental_actual (NULL, c) == FAILURE)
3216 if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
3217 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
3222 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3223 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3224 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3225 if their shapes do not match. If either op1->shape or op2->shape is
3226 NULL, return SUCCESS. */
3229 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3236 if (op1->shape != NULL && op2->shape != NULL)
3238 for (i = 0; i < op1->rank; i++)
3240 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3242 gfc_error ("Shapes for operands at %L and %L are not conformable",
3243 &op1->where, &op2->where);
3254 /* Resolve an operator expression node. This can involve replacing the
3255 operation with a user defined function call. */
3258 resolve_operator (gfc_expr *e)
3260 gfc_expr *op1, *op2;
3262 bool dual_locus_error;
3265 /* Resolve all subnodes-- give them types. */
3267 switch (e->value.op.op)
3270 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3273 /* Fall through... */
3276 case INTRINSIC_UPLUS:
3277 case INTRINSIC_UMINUS:
3278 case INTRINSIC_PARENTHESES:
3279 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3284 /* Typecheck the new node. */
3286 op1 = e->value.op.op1;
3287 op2 = e->value.op.op2;
3288 dual_locus_error = false;
3290 if ((op1 && op1->expr_type == EXPR_NULL)
3291 || (op2 && op2->expr_type == EXPR_NULL))
3293 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3297 switch (e->value.op.op)
3299 case INTRINSIC_UPLUS:
3300 case INTRINSIC_UMINUS:
3301 if (op1->ts.type == BT_INTEGER
3302 || op1->ts.type == BT_REAL
3303 || op1->ts.type == BT_COMPLEX)
3309 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3310 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3313 case INTRINSIC_PLUS:
3314 case INTRINSIC_MINUS:
3315 case INTRINSIC_TIMES:
3316 case INTRINSIC_DIVIDE:
3317 case INTRINSIC_POWER:
3318 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3320 gfc_type_convert_binary (e);
3325 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3326 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3327 gfc_typename (&op2->ts));
3330 case INTRINSIC_CONCAT:
3331 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3332 && op1->ts.kind == op2->ts.kind)
3334 e->ts.type = BT_CHARACTER;
3335 e->ts.kind = op1->ts.kind;
3340 _("Operands of string concatenation operator at %%L are %s/%s"),
3341 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3347 case INTRINSIC_NEQV:
3348 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3350 e->ts.type = BT_LOGICAL;
3351 e->ts.kind = gfc_kind_max (op1, op2);
3352 if (op1->ts.kind < e->ts.kind)
3353 gfc_convert_type (op1, &e->ts, 2);
3354 else if (op2->ts.kind < e->ts.kind)
3355 gfc_convert_type (op2, &e->ts, 2);
3359 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3360 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3361 gfc_typename (&op2->ts));
3366 if (op1->ts.type == BT_LOGICAL)
3368 e->ts.type = BT_LOGICAL;
3369 e->ts.kind = op1->ts.kind;
3373 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3374 gfc_typename (&op1->ts));
3378 case INTRINSIC_GT_OS:
3380 case INTRINSIC_GE_OS:
3382 case INTRINSIC_LT_OS:
3384 case INTRINSIC_LE_OS:
3385 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3387 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3391 /* Fall through... */
3394 case INTRINSIC_EQ_OS:
3396 case INTRINSIC_NE_OS:
3397 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3398 && op1->ts.kind == op2->ts.kind)
3400 e->ts.type = BT_LOGICAL;
3401 e->ts.kind = gfc_default_logical_kind;
3405 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3407 gfc_type_convert_binary (e);
3409 e->ts.type = BT_LOGICAL;
3410 e->ts.kind = gfc_default_logical_kind;
3414 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3416 _("Logicals at %%L must be compared with %s instead of %s"),
3417 (e->value.op.op == INTRINSIC_EQ
3418 || e->value.op.op == INTRINSIC_EQ_OS)
3419 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3422 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3423 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3424 gfc_typename (&op2->ts));
3428 case INTRINSIC_USER:
3429 if (e->value.op.uop->op == NULL)
3430 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3431 else if (op2 == NULL)
3432 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3433 e->value.op.uop->name, gfc_typename (&op1->ts));
3435 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3436 e->value.op.uop->name, gfc_typename (&op1->ts),
3437 gfc_typename (&op2->ts));
3441 case INTRINSIC_PARENTHESES:
3443 if (e->ts.type == BT_CHARACTER)
3444 e->ts.u.cl = op1->ts.u.cl;
3448 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3451 /* Deal with arrayness of an operand through an operator. */
3455 switch (e->value.op.op)
3457 case INTRINSIC_PLUS:
3458 case INTRINSIC_MINUS:
3459 case INTRINSIC_TIMES:
3460 case INTRINSIC_DIVIDE:
3461 case INTRINSIC_POWER:
3462 case INTRINSIC_CONCAT:
3466 case INTRINSIC_NEQV:
3468 case INTRINSIC_EQ_OS:
3470 case INTRINSIC_NE_OS:
3472 case INTRINSIC_GT_OS:
3474 case INTRINSIC_GE_OS:
3476 case INTRINSIC_LT_OS:
3478 case INTRINSIC_LE_OS:
3480 if (op1->rank == 0 && op2->rank == 0)
3483 if (op1->rank == 0 && op2->rank != 0)
3485 e->rank = op2->rank;
3487 if (e->shape == NULL)
3488 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3491 if (op1->rank != 0 && op2->rank == 0)
3493 e->rank = op1->rank;
3495 if (e->shape == NULL)
3496 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3499 if (op1->rank != 0 && op2->rank != 0)
3501 if (op1->rank == op2->rank)
3503 e->rank = op1->rank;
3504 if (e->shape == NULL)
3506 t = compare_shapes(op1, op2);
3510 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3515 /* Allow higher level expressions to work. */
3518 /* Try user-defined operators, and otherwise throw an error. */
3519 dual_locus_error = true;
3521 _("Inconsistent ranks for operator at %%L and %%L"));
3528 case INTRINSIC_PARENTHESES:
3530 case INTRINSIC_UPLUS:
3531 case INTRINSIC_UMINUS:
3532 /* Simply copy arrayness attribute */
3533 e->rank = op1->rank;
3535 if (e->shape == NULL)
3536 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3544 /* Attempt to simplify the expression. */
3547 t = gfc_simplify_expr (e, 0);
3548 /* Some calls do not succeed in simplification and return FAILURE
3549 even though there is no error; e.g. variable references to
3550 PARAMETER arrays. */
3551 if (!gfc_is_constant_expr (e))
3560 if (gfc_extend_expr (e, &real_error) == SUCCESS)
3567 if (dual_locus_error)
3568 gfc_error (msg, &op1->where, &op2->where);
3570 gfc_error (msg, &e->where);
3576 /************** Array resolution subroutines **************/
3579 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3582 /* Compare two integer expressions. */
3585 compare_bound (gfc_expr *a, gfc_expr *b)
3589 if (a == NULL || a->expr_type != EXPR_CONSTANT
3590 || b == NULL || b->expr_type != EXPR_CONSTANT)
3593 /* If either of the types isn't INTEGER, we must have
3594 raised an error earlier. */
3596 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3599 i = mpz_cmp (a->value.integer, b->value.integer);
3609 /* Compare an integer expression with an integer. */
3612 compare_bound_int (gfc_expr *a, int b)
3616 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3619 if (a->ts.type != BT_INTEGER)
3620 gfc_internal_error ("compare_bound_int(): Bad expression");
3622 i = mpz_cmp_si (a->value.integer, b);
3632 /* Compare an integer expression with a mpz_t. */
3635 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3639 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3642 if (a->ts.type != BT_INTEGER)
3643 gfc_internal_error ("compare_bound_int(): Bad expression");
3645 i = mpz_cmp (a->value.integer, b);
3655 /* Compute the last value of a sequence given by a triplet.
3656 Return 0 if it wasn't able to compute the last value, or if the
3657 sequence if empty, and 1 otherwise. */
3660 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3661 gfc_expr *stride, mpz_t last)
3665 if (start == NULL || start->expr_type != EXPR_CONSTANT
3666 || end == NULL || end->expr_type != EXPR_CONSTANT
3667 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3670 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3671 || (stride != NULL && stride->ts.type != BT_INTEGER))
3674 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3676 if (compare_bound (start, end) == CMP_GT)
3678 mpz_set (last, end->value.integer);
3682 if (compare_bound_int (stride, 0) == CMP_GT)
3684 /* Stride is positive */
3685 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3690 /* Stride is negative */
3691 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3696 mpz_sub (rem, end->value.integer, start->value.integer);
3697 mpz_tdiv_r (rem, rem, stride->value.integer);
3698 mpz_sub (last, end->value.integer, rem);
3705 /* Compare a single dimension of an array reference to the array
3709 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3713 /* Given start, end and stride values, calculate the minimum and
3714 maximum referenced indexes. */
3716 switch (ar->dimen_type[i])
3722 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3724 gfc_warning ("Array reference at %L is out of bounds "
3725 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3726 mpz_get_si (ar->start[i]->value.integer),
3727 mpz_get_si (as->lower[i]->value.integer), i+1);
3730 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3732 gfc_warning ("Array reference at %L is out of bounds "
3733 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3734 mpz_get_si (ar->start[i]->value.integer),
3735 mpz_get_si (as->upper[i]->value.integer), i+1);
3743 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3744 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3746 comparison comp_start_end = compare_bound (AR_START, AR_END);
3748 /* Check for zero stride, which is not allowed. */
3749 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3751 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3755 /* if start == len || (stride > 0 && start < len)
3756 || (stride < 0 && start > len),
3757 then the array section contains at least one element. In this
3758 case, there is an out-of-bounds access if
3759 (start < lower || start > upper). */
3760 if (compare_bound (AR_START, AR_END) == CMP_EQ
3761 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3762 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3763 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3764 && comp_start_end == CMP_GT))
3766 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3768 gfc_warning ("Lower array reference at %L is out of bounds "
3769 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3770 mpz_get_si (AR_START->value.integer),
3771 mpz_get_si (as->lower[i]->value.integer), i+1);
3774 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3776 gfc_warning ("Lower array reference at %L is out of bounds "
3777 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3778 mpz_get_si (AR_START->value.integer),
3779 mpz_get_si (as->upper[i]->value.integer), i+1);
3784 /* If we can compute the highest index of the array section,
3785 then it also has to be between lower and upper. */
3786 mpz_init (last_value);
3787 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3790 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3792 gfc_warning ("Upper array reference at %L is out of bounds "
3793 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3794 mpz_get_si (last_value),
3795 mpz_get_si (as->lower[i]->value.integer), i+1);
3796 mpz_clear (last_value);
3799 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3801 gfc_warning ("Upper array reference at %L is out of bounds "
3802 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3803 mpz_get_si (last_value),
3804 mpz_get_si (as->upper[i]->value.integer), i+1);
3805 mpz_clear (last_value);
3809 mpz_clear (last_value);
3817 gfc_internal_error ("check_dimension(): Bad array reference");
3824 /* Compare an array reference with an array specification. */
3827 compare_spec_to_ref (gfc_array_ref *ar)
3834 /* TODO: Full array sections are only allowed as actual parameters. */
3835 if (as->type == AS_ASSUMED_SIZE
3836 && (/*ar->type == AR_FULL
3837 ||*/ (ar->type == AR_SECTION
3838 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3840 gfc_error ("Rightmost upper bound of assumed size array section "
3841 "not specified at %L", &ar->where);
3845 if (ar->type == AR_FULL)
3848 if (as->rank != ar->dimen)
3850 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3851 &ar->where, ar->dimen, as->rank);
3855 for (i = 0; i < as->rank; i++)
3856 if (check_dimension (i, ar, as) == FAILURE)
3863 /* Resolve one part of an array index. */
3866 gfc_resolve_index (gfc_expr *index, int check_scalar)
3873 if (gfc_resolve_expr (index) == FAILURE)
3876 if (check_scalar && index->rank != 0)
3878 gfc_error ("Array index at %L must be scalar", &index->where);
3882 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3884 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3885 &index->where, gfc_basic_typename (index->ts.type));
3889 if (index->ts.type == BT_REAL)
3890 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3891 &index->where) == FAILURE)
3894 if (index->ts.kind != gfc_index_integer_kind
3895 || index->ts.type != BT_INTEGER)
3898 ts.type = BT_INTEGER;
3899 ts.kind = gfc_index_integer_kind;
3901 gfc_convert_type_warn (index, &ts, 2, 0);
3907 /* Resolve a dim argument to an intrinsic function. */
3910 gfc_resolve_dim_arg (gfc_expr *dim)
3915 if (gfc_resolve_expr (dim) == FAILURE)
3920 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3925 if (dim->ts.type != BT_INTEGER)
3927 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3931 if (dim->ts.kind != gfc_index_integer_kind)
3935 ts.type = BT_INTEGER;
3936 ts.kind = gfc_index_integer_kind;
3938 gfc_convert_type_warn (dim, &ts, 2, 0);
3944 /* Given an expression that contains array references, update those array
3945 references to point to the right array specifications. While this is
3946 filled in during matching, this information is difficult to save and load
3947 in a module, so we take care of it here.
3949 The idea here is that the original array reference comes from the
3950 base symbol. We traverse the list of reference structures, setting
3951 the stored reference to references. Component references can
3952 provide an additional array specification. */
3955 find_array_spec (gfc_expr *e)
3959 gfc_symbol *derived;
3962 if (e->symtree->n.sym->ts.type == BT_CLASS)
3963 as = e->symtree->n.sym->ts.u.derived->components->as;
3965 as = e->symtree->n.sym->as;
3968 for (ref = e->ref; ref; ref = ref->next)
3973 gfc_internal_error ("find_array_spec(): Missing spec");
3980 if (derived == NULL)
3981 derived = e->symtree->n.sym->ts.u.derived;
3983 c = derived->components;
3985 for (; c; c = c->next)
3986 if (c == ref->u.c.component)
3988 /* Track the sequence of component references. */
3989 if (c->ts.type == BT_DERIVED)
3990 derived = c->ts.u.derived;
3995 gfc_internal_error ("find_array_spec(): Component not found");
3997 if (c->attr.dimension)
4000 gfc_internal_error ("find_array_spec(): unused as(1)");
4011 gfc_internal_error ("find_array_spec(): unused as(2)");
4015 /* Resolve an array reference. */
4018 resolve_array_ref (gfc_array_ref *ar)
4020 int i, check_scalar;
4023 for (i = 0; i < ar->dimen; i++)
4025 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4027 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
4029 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4031 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4036 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4040 ar->dimen_type[i] = DIMEN_ELEMENT;
4044 ar->dimen_type[i] = DIMEN_VECTOR;
4045 if (e->expr_type == EXPR_VARIABLE
4046 && e->symtree->n.sym->ts.type == BT_DERIVED)
4047 ar->start[i] = gfc_get_parentheses (e);
4051 gfc_error ("Array index at %L is an array of rank %d",
4052 &ar->c_where[i], e->rank);
4057 /* If the reference type is unknown, figure out what kind it is. */
4059 if (ar->type == AR_UNKNOWN)
4061 ar->type = AR_ELEMENT;
4062 for (i = 0; i < ar->dimen; i++)
4063 if (ar->dimen_type[i] == DIMEN_RANGE
4064 || ar->dimen_type[i] == DIMEN_VECTOR)
4066 ar->type = AR_SECTION;
4071 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4079 resolve_substring (gfc_ref *ref)
4081 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4083 if (ref->u.ss.start != NULL)
4085 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4088 if (ref->u.ss.start->ts.type != BT_INTEGER)
4090 gfc_error ("Substring start index at %L must be of type INTEGER",
4091 &ref->u.ss.start->where);
4095 if (ref->u.ss.start->rank != 0)
4097 gfc_error ("Substring start index at %L must be scalar",
4098 &ref->u.ss.start->where);
4102 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4103 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4104 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4106 gfc_error ("Substring start index at %L is less than one",
4107 &ref->u.ss.start->where);
4112 if (ref->u.ss.end != NULL)
4114 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4117 if (ref->u.ss.end->ts.type != BT_INTEGER)
4119 gfc_error ("Substring end index at %L must be of type INTEGER",
4120 &ref->u.ss.end->where);
4124 if (ref->u.ss.end->rank != 0)
4126 gfc_error ("Substring end index at %L must be scalar",
4127 &ref->u.ss.end->where);
4131 if (ref->u.ss.length != NULL
4132 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4133 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4134 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4136 gfc_error ("Substring end index at %L exceeds the string length",
4137 &ref->u.ss.start->where);
4141 if (compare_bound_mpz_t (ref->u.ss.end,
4142 gfc_integer_kinds[k].huge) == CMP_GT
4143 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4144 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4146 gfc_error ("Substring end index at %L is too large",
4147 &ref->u.ss.end->where);
4156 /* This function supplies missing substring charlens. */
4159 gfc_resolve_substring_charlen (gfc_expr *e)
4162 gfc_expr *start, *end;
4164 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4165 if (char_ref->type == REF_SUBSTRING)
4171 gcc_assert (char_ref->next == NULL);
4175 if (e->ts.u.cl->length)
4176 gfc_free_expr (e->ts.u.cl->length);
4177 else if (e->expr_type == EXPR_VARIABLE
4178 && e->symtree->n.sym->attr.dummy)
4182 e->ts.type = BT_CHARACTER;
4183 e->ts.kind = gfc_default_character_kind;
4186 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4188 if (char_ref->u.ss.start)
4189 start = gfc_copy_expr (char_ref->u.ss.start);
4191 start = gfc_int_expr (1);
4193 if (char_ref->u.ss.end)
4194 end = gfc_copy_expr (char_ref->u.ss.end);
4195 else if (e->expr_type == EXPR_VARIABLE)
4196 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4203 /* Length = (end - start +1). */
4204 e->ts.u.cl->length = gfc_subtract (end, start);
4205 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1));
4207 e->ts.u.cl->length->ts.type = BT_INTEGER;
4208 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4210 /* Make sure that the length is simplified. */
4211 gfc_simplify_expr (e->ts.u.cl->length, 1);
4212 gfc_resolve_expr (e->ts.u.cl->length);
4216 /* Resolve subtype references. */
4219 resolve_ref (gfc_expr *expr)
4221 int current_part_dimension, n_components, seen_part_dimension;
4224 for (ref = expr->ref; ref; ref = ref->next)
4225 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4227 find_array_spec (expr);
4231 for (ref = expr->ref; ref; ref = ref->next)
4235 if (resolve_array_ref (&ref->u.ar) == FAILURE)
4243 resolve_substring (ref);
4247 /* Check constraints on part references. */
4249 current_part_dimension = 0;
4250 seen_part_dimension = 0;
4253 for (ref = expr->ref; ref; ref = ref->next)
4258 switch (ref->u.ar.type)
4262 current_part_dimension = 1;
4266 current_part_dimension = 0;
4270 gfc_internal_error ("resolve_ref(): Bad array reference");
4276 if (current_part_dimension || seen_part_dimension)
4279 if (ref->u.c.component->attr.pointer
4280 || ref->u.c.component->attr.proc_pointer)
4282 gfc_error ("Component to the right of a part reference "
4283 "with nonzero rank must not have the POINTER "
4284 "attribute at %L", &expr->where);
4287 else if (ref->u.c.component->attr.allocatable)
4289 gfc_error ("Component to the right of a part reference "
4290 "with nonzero rank must not have the ALLOCATABLE "
4291 "attribute at %L", &expr->where);
4303 if (((ref->type == REF_COMPONENT && n_components > 1)
4304 || ref->next == NULL)
4305 && current_part_dimension
4306 && seen_part_dimension)
4308 gfc_error ("Two or more part references with nonzero rank must "
4309 "not be specified at %L", &expr->where);
4313 if (ref->type == REF_COMPONENT)
4315 if (current_part_dimension)
4316 seen_part_dimension = 1;
4318 /* reset to make sure */
4319 current_part_dimension = 0;
4327 /* Given an expression, determine its shape. This is easier than it sounds.
4328 Leaves the shape array NULL if it is not possible to determine the shape. */
4331 expression_shape (gfc_expr *e)
4333 mpz_t array[GFC_MAX_DIMENSIONS];
4336 if (e->rank == 0 || e->shape != NULL)
4339 for (i = 0; i < e->rank; i++)
4340 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4343 e->shape = gfc_get_shape (e->rank);
4345 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4350 for (i--; i >= 0; i--)
4351 mpz_clear (array[i]);
4355 /* Given a variable expression node, compute the rank of the expression by
4356 examining the base symbol and any reference structures it may have. */
4359 expression_rank (gfc_expr *e)
4364 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4365 could lead to serious confusion... */
4366 gcc_assert (e->expr_type != EXPR_COMPCALL);
4370 if (e->expr_type == EXPR_ARRAY)
4372 /* Constructors can have a rank different from one via RESHAPE(). */
4374 if (e->symtree == NULL)
4380 e->rank = (e->symtree->n.sym->as == NULL)
4381 ? 0 : e->symtree->n.sym->as->rank;
4387 for (ref = e->ref; ref; ref = ref->next)
4389 if (ref->type != REF_ARRAY)
4392 if (ref->u.ar.type == AR_FULL)
4394 rank = ref->u.ar.as->rank;
4398 if (ref->u.ar.type == AR_SECTION)
4400 /* Figure out the rank of the section. */
4402 gfc_internal_error ("expression_rank(): Two array specs");
4404 for (i = 0; i < ref->u.ar.dimen; i++)
4405 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4406 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4416 expression_shape (e);
4420 /* Resolve a variable expression. */
4423 resolve_variable (gfc_expr *e)
4430 if (e->symtree == NULL)
4433 if (e->ref && resolve_ref (e) == FAILURE)
4436 sym = e->symtree->n.sym;
4437 if (sym->attr.flavor == FL_PROCEDURE
4438 && (!sym->attr.function
4439 || (sym->attr.function && sym->result
4440 && sym->result->attr.proc_pointer
4441 && !sym->result->attr.function)))
4443 e->ts.type = BT_PROCEDURE;
4444 goto resolve_procedure;
4447 if (sym->ts.type != BT_UNKNOWN)
4448 gfc_variable_attr (e, &e->ts);
4451 /* Must be a simple variable reference. */
4452 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
4457 if (check_assumed_size_reference (sym, e))
4460 /* Deal with forward references to entries during resolve_code, to
4461 satisfy, at least partially, 12.5.2.5. */
4462 if (gfc_current_ns->entries
4463 && current_entry_id == sym->entry_id
4466 && cs_base->current->op != EXEC_ENTRY)
4468 gfc_entry_list *entry;
4469 gfc_formal_arglist *formal;
4473 /* If the symbol is a dummy... */
4474 if (sym->attr.dummy && sym->ns == gfc_current_ns)
4476 entry = gfc_current_ns->entries;
4479 /* ...test if the symbol is a parameter of previous entries. */
4480 for (; entry && entry->id <= current_entry_id; entry = entry->next)
4481 for (formal = entry->sym->formal; formal; formal = formal->next)
4483 if (formal->sym && sym->name == formal->sym->name)
4487 /* If it has not been seen as a dummy, this is an error. */
4490 if (specification_expr)
4491 gfc_error ("Variable '%s', used in a specification expression"
4492 ", is referenced at %L before the ENTRY statement "
4493 "in which it is a parameter",
4494 sym->name, &cs_base->current->loc);
4496 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4497 "statement in which it is a parameter",
4498 sym->name, &cs_base->current->loc);
4503 /* Now do the same check on the specification expressions. */
4504 specification_expr = 1;
4505 if (sym->ts.type == BT_CHARACTER
4506 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
4510 for (n = 0; n < sym->as->rank; n++)
4512 specification_expr = 1;
4513 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4515 specification_expr = 1;
4516 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4519 specification_expr = 0;
4522 /* Update the symbol's entry level. */
4523 sym->entry_id = current_entry_id + 1;
4527 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
4534 /* Checks to see that the correct symbol has been host associated.
4535 The only situation where this arises is that in which a twice
4536 contained function is parsed after the host association is made.
4537 Therefore, on detecting this, change the symbol in the expression
4538 and convert the array reference into an actual arglist if the old
4539 symbol is a variable. */
4541 check_host_association (gfc_expr *e)
4543 gfc_symbol *sym, *old_sym;
4547 gfc_actual_arglist *arg, *tail = NULL;
4548 bool retval = e->expr_type == EXPR_FUNCTION;
4550 /* If the expression is the result of substitution in
4551 interface.c(gfc_extend_expr) because there is no way in
4552 which the host association can be wrong. */
4553 if (e->symtree == NULL
4554 || e->symtree->n.sym == NULL
4555 || e->user_operator)
4558 old_sym = e->symtree->n.sym;
4560 if (gfc_current_ns->parent
4561 && old_sym->ns != gfc_current_ns)
4563 /* Use the 'USE' name so that renamed module symbols are
4564 correctly handled. */
4565 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
4567 if (sym && old_sym != sym
4568 && sym->ts.type == old_sym->ts.type
4569 && sym->attr.flavor == FL_PROCEDURE
4570 && sym->attr.contained)
4572 /* Clear the shape, since it might not be valid. */
4573 if (e->shape != NULL)
4575 for (n = 0; n < e->rank; n++)
4576 mpz_clear (e->shape[n]);
4578 gfc_free (e->shape);
4581 /* Give the expression the right symtree! */
4582 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
4583 gcc_assert (st != NULL);
4585 if (old_sym->attr.flavor == FL_PROCEDURE
4586 || e->expr_type == EXPR_FUNCTION)
4588 /* Original was function so point to the new symbol, since
4589 the actual argument list is already attached to the
4591 e->value.function.esym = NULL;
4596 /* Original was variable so convert array references into
4597 an actual arglist. This does not need any checking now
4598 since gfc_resolve_function will take care of it. */
4599 e->value.function.actual = NULL;
4600 e->expr_type = EXPR_FUNCTION;
4603 /* Ambiguity will not arise if the array reference is not
4604 the last reference. */
4605 for (ref = e->ref; ref; ref = ref->next)
4606 if (ref->type == REF_ARRAY && ref->next == NULL)
4609 gcc_assert (ref->type == REF_ARRAY);
4611 /* Grab the start expressions from the array ref and
4612 copy them into actual arguments. */
4613 for (n = 0; n < ref->u.ar.dimen; n++)
4615 arg = gfc_get_actual_arglist ();
4616 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
4617 if (e->value.function.actual == NULL)
4618 tail = e->value.function.actual = arg;
4626 /* Dump the reference list and set the rank. */
4627 gfc_free_ref_list (e->ref);
4629 e->rank = sym->as ? sym->as->rank : 0;
4632 gfc_resolve_expr (e);
4636 /* This might have changed! */
4637 return e->expr_type == EXPR_FUNCTION;
4642 gfc_resolve_character_operator (gfc_expr *e)
4644 gfc_expr *op1 = e->value.op.op1;
4645 gfc_expr *op2 = e->value.op.op2;
4646 gfc_expr *e1 = NULL;
4647 gfc_expr *e2 = NULL;
4649 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
4651 if (op1->ts.u.cl && op1->ts.u.cl->length)
4652 e1 = gfc_copy_expr (op1->ts.u.cl->length);
4653 else if (op1->expr_type == EXPR_CONSTANT)
4654 e1 = gfc_int_expr (op1->value.character.length);
4656 if (op2->ts.u.cl && op2->ts.u.cl->length)
4657 e2 = gfc_copy_expr (op2->ts.u.cl->length);
4658 else if (op2->expr_type == EXPR_CONSTANT)
4659 e2 = gfc_int_expr (op2->value.character.length);
4661 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4666 e->ts.u.cl->length = gfc_add (e1, e2);
4667 e->ts.u.cl->length->ts.type = BT_INTEGER;
4668 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4669 gfc_simplify_expr (e->ts.u.cl->length, 0);
4670 gfc_resolve_expr (e->ts.u.cl->length);
4676 /* Ensure that an character expression has a charlen and, if possible, a
4677 length expression. */
4680 fixup_charlen (gfc_expr *e)
4682 /* The cases fall through so that changes in expression type and the need
4683 for multiple fixes are picked up. In all circumstances, a charlen should
4684 be available for the middle end to hang a backend_decl on. */
4685 switch (e->expr_type)
4688 gfc_resolve_character_operator (e);
4691 if (e->expr_type == EXPR_ARRAY)
4692 gfc_resolve_character_array_constructor (e);
4694 case EXPR_SUBSTRING:
4695 if (!e->ts.u.cl && e->ref)
4696 gfc_resolve_substring_charlen (e);
4700 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4707 /* Update an actual argument to include the passed-object for type-bound
4708 procedures at the right position. */
4710 static gfc_actual_arglist*
4711 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
4714 gcc_assert (argpos > 0);
4718 gfc_actual_arglist* result;
4720 result = gfc_get_actual_arglist ();
4724 result->name = name;
4730 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
4732 lst = update_arglist_pass (NULL, po, argpos - 1, name);
4737 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4740 extract_compcall_passed_object (gfc_expr* e)
4744 gcc_assert (e->expr_type == EXPR_COMPCALL);
4746 if (e->value.compcall.base_object)
4747 po = gfc_copy_expr (e->value.compcall.base_object);
4750 po = gfc_get_expr ();
4751 po->expr_type = EXPR_VARIABLE;
4752 po->symtree = e->symtree;
4753 po->ref = gfc_copy_ref (e->ref);
4756 if (gfc_resolve_expr (po) == FAILURE)
4763 /* Update the arglist of an EXPR_COMPCALL expression to include the
4767 update_compcall_arglist (gfc_expr* e)
4770 gfc_typebound_proc* tbp;
4772 tbp = e->value.compcall.tbp;
4777 po = extract_compcall_passed_object (e);
4783 gfc_error ("Passed-object at %L must be scalar", &e->where);
4787 if (tbp->nopass || e->value.compcall.ignore_pass)
4793 gcc_assert (tbp->pass_arg_num > 0);
4794 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4802 /* Extract the passed object from a PPC call (a copy of it). */
4805 extract_ppc_passed_object (gfc_expr *e)
4810 po = gfc_get_expr ();
4811 po->expr_type = EXPR_VARIABLE;
4812 po->symtree = e->symtree;
4813 po->ref = gfc_copy_ref (e->ref);
4815 /* Remove PPC reference. */
4817 while ((*ref)->next)
4818 (*ref) = (*ref)->next;
4819 gfc_free_ref_list (*ref);
4822 if (gfc_resolve_expr (po) == FAILURE)
4829 /* Update the actual arglist of a procedure pointer component to include the
4833 update_ppc_arglist (gfc_expr* e)
4837 gfc_typebound_proc* tb;
4839 if (!gfc_is_proc_ptr_comp (e, &ppc))
4846 else if (tb->nopass)
4849 po = extract_ppc_passed_object (e);
4855 gfc_error ("Passed-object at %L must be scalar", &e->where);
4859 gcc_assert (tb->pass_arg_num > 0);
4860 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
4868 /* Check that the object a TBP is called on is valid, i.e. it must not be
4869 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
4872 check_typebound_baseobject (gfc_expr* e)
4876 base = extract_compcall_passed_object (e);
4880 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
4882 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
4884 gfc_error ("Base object for type-bound procedure call at %L is of"
4885 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
4893 /* Resolve a call to a type-bound procedure, either function or subroutine,
4894 statically from the data in an EXPR_COMPCALL expression. The adapted
4895 arglist and the target-procedure symtree are returned. */
4898 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
4899 gfc_actual_arglist** actual)
4901 gcc_assert (e->expr_type == EXPR_COMPCALL);
4902 gcc_assert (!e->value.compcall.tbp->is_generic);
4904 /* Update the actual arglist for PASS. */
4905 if (update_compcall_arglist (e) == FAILURE)
4908 *actual = e->value.compcall.actual;
4909 *target = e->value.compcall.tbp->u.specific;
4911 gfc_free_ref_list (e->ref);
4913 e->value.compcall.actual = NULL;
4919 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4920 which of the specific bindings (if any) matches the arglist and transform
4921 the expression into a call of that binding. */
4924 resolve_typebound_generic_call (gfc_expr* e)
4926 gfc_typebound_proc* genproc;
4927 const char* genname;
4929 gcc_assert (e->expr_type == EXPR_COMPCALL);
4930 genname = e->value.compcall.name;
4931 genproc = e->value.compcall.tbp;
4933 if (!genproc->is_generic)
4936 /* Try the bindings on this type and in the inheritance hierarchy. */
4937 for (; genproc; genproc = genproc->overridden)
4941 gcc_assert (genproc->is_generic);
4942 for (g = genproc->u.generic; g; g = g->next)
4945 gfc_actual_arglist* args;
4948 gcc_assert (g->specific);
4950 if (g->specific->error)
4953 target = g->specific->u.specific->n.sym;
4955 /* Get the right arglist by handling PASS/NOPASS. */
4956 args = gfc_copy_actual_arglist (e->value.compcall.actual);
4957 if (!g->specific->nopass)
4960 po = extract_compcall_passed_object (e);
4964 gcc_assert (g->specific->pass_arg_num > 0);
4965 gcc_assert (!g->specific->error);
4966 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
4967 g->specific->pass_arg);
4969 resolve_actual_arglist (args, target->attr.proc,
4970 is_external_proc (target) && !target->formal);
4972 /* Check if this arglist matches the formal. */
4973 matches = gfc_arglist_matches_symbol (&args, target);
4975 /* Clean up and break out of the loop if we've found it. */
4976 gfc_free_actual_arglist (args);
4979 e->value.compcall.tbp = g->specific;
4985 /* Nothing matching found! */
4986 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4987 " '%s' at %L", genname, &e->where);
4995 /* Resolve a call to a type-bound subroutine. */
4998 resolve_typebound_call (gfc_code* c)
5000 gfc_actual_arglist* newactual;
5001 gfc_symtree* target;
5003 /* Check that's really a SUBROUTINE. */
5004 if (!c->expr1->value.compcall.tbp->subroutine)
5006 gfc_error ("'%s' at %L should be a SUBROUTINE",
5007 c->expr1->value.compcall.name, &c->loc);
5011 if (check_typebound_baseobject (c->expr1) == FAILURE)
5014 if (resolve_typebound_generic_call (c->expr1) == FAILURE)
5017 /* Transform into an ordinary EXEC_CALL for now. */
5019 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5022 c->ext.actual = newactual;
5023 c->symtree = target;
5024 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5026 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5028 gfc_free_expr (c->expr1);
5029 c->expr1 = gfc_get_expr ();
5030 c->expr1->expr_type = EXPR_FUNCTION;
5031 c->expr1->symtree = target;
5032 c->expr1->where = c->loc;
5034 return resolve_call (c);
5038 /* Resolve a component-call expression. This originally was intended
5039 only to see functions. However, it is convenient to use it in
5040 resolving subroutine class methods, since we do not have to add a
5041 gfc_code each time. */
5043 resolve_compcall (gfc_expr* e, bool fcn)
5045 gfc_actual_arglist* newactual;
5046 gfc_symtree* target;
5048 /* Check that's really a FUNCTION. */
5049 if (fcn && !e->value.compcall.tbp->function)
5051 gfc_error ("'%s' at %L should be a FUNCTION",
5052 e->value.compcall.name, &e->where);
5055 else if (!fcn && !e->value.compcall.tbp->subroutine)
5057 /* To resolve class member calls, we borrow this bit
5058 of code to select the specific procedures. */
5059 gfc_error ("'%s' at %L should be a SUBROUTINE",
5060 e->value.compcall.name, &e->where);
5064 /* These must not be assign-calls! */
5065 gcc_assert (!e->value.compcall.assign);
5067 if (check_typebound_baseobject (e) == FAILURE)
5070 if (resolve_typebound_generic_call (e) == FAILURE)
5072 gcc_assert (!e->value.compcall.tbp->is_generic);
5074 /* Take the rank from the function's symbol. */
5075 if (e->value.compcall.tbp->u.specific->n.sym->as)
5076 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5078 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5079 arglist to the TBP's binding target. */
5081 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5084 e->value.function.actual = newactual;
5085 e->value.function.name = e->value.compcall.name;
5086 e->value.function.esym = target->n.sym;
5087 e->value.function.class_esym = NULL;
5088 e->value.function.isym = NULL;
5089 e->symtree = target;
5090 e->ts = target->n.sym->ts;
5091 e->expr_type = EXPR_FUNCTION;
5093 /* Resolution is not necessary if this is a class subroutine; this
5094 function only has to identify the specific proc. Resolution of
5095 the call will be done next in resolve_typebound_call. */
5096 return fcn ? gfc_resolve_expr (e) : SUCCESS;
5100 /* Resolve a typebound call for the members in a class. This group of
5101 functions implements dynamic dispatch in the provisional version
5102 of f03 OOP. As soon as vtables are in place and contain pointers
5103 to methods, this will no longer be necessary. */
5104 static gfc_expr *list_e;
5105 static void check_class_members (gfc_symbol *);
5106 static gfc_try class_try;
5107 static bool fcn_flag;
5108 static gfc_symbol *class_object;
5112 check_members (gfc_symbol *derived)
5114 if (derived->attr.flavor == FL_DERIVED)
5115 check_class_members (derived);
5120 check_class_members (gfc_symbol *derived)
5122 gfc_symbol* tbp_sym;
5125 gfc_class_esym_list *etmp;
5127 e = gfc_copy_expr (list_e);
5129 tbp = gfc_find_typebound_proc (derived, &class_try,
5130 e->value.compcall.name,
5135 gfc_error ("no typebound available procedure named '%s' at %L",
5136 e->value.compcall.name, &e->where);
5140 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 tbp_sym = tbp->n.tb->u.specific->n.sym;
5159 e->value.compcall.tbp = tbp->n.tb;
5160 e->value.compcall.name = tbp->name;
5162 /* Let the original expresssion catch the assertion in
5163 resolve_compcall, since this flag does not appear to be reset or
5164 copied in some systems. */
5165 e->value.compcall.assign = 0;
5167 /* Do the renaming, PASSing, generic => specific and other
5168 good things for each class member. */
5169 class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
5170 ? class_try : FAILURE;
5172 /* Now transfer the found symbol to the esym list. */
5173 if (class_try == SUCCESS)
5175 etmp = list_e->value.function.class_esym;
5176 list_e->value.function.class_esym
5177 = gfc_get_class_esym_list();
5178 list_e->value.function.class_esym->next = etmp;
5179 list_e->value.function.class_esym->derived = derived;
5180 list_e->value.function.class_esym->esym
5181 = e->value.function.esym;
5186 /* Burrow down into grandchildren types. */
5187 if (derived->f2k_derived)
5188 gfc_traverse_ns (derived->f2k_derived, check_members);
5192 /* Eliminate esym_lists where all the members point to the
5193 typebound procedure of the declared type; ie. one where
5194 type selection has no effect.. */
5196 resolve_class_esym (gfc_expr *e)
5198 gfc_class_esym_list *p, *q;
5201 gcc_assert (e && e->expr_type == EXPR_FUNCTION);
5203 p = e->value.function.class_esym;
5207 for (; p; p = p->next)
5208 empty = empty && (e->value.function.esym == p->esym);
5212 p = e->value.function.class_esym;
5218 e->value.function.class_esym = NULL;
5223 /* Generate an expression for the vindex, given the reference to
5224 the class of the final expression (class_ref), the base of the
5225 full reference list (new_ref), the declared type and the class
5228 vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref,
5229 gfc_symbol *declared, gfc_symtree *st)
5234 /* Build an expression for the correct vindex; ie. that of the last
5236 ref = gfc_get_ref();
5237 ref->type = REF_COMPONENT;
5238 ref->u.c.component = declared->components->next;
5239 ref->u.c.sym = declared;
5243 class_ref->next = ref;
5247 gfc_free_ref_list (new_ref);
5250 vindex = gfc_get_expr ();
5251 vindex->expr_type = EXPR_VARIABLE;
5252 vindex->symtree = st;
5253 vindex->symtree->n.sym->refs++;
5254 vindex->ts = ref->u.c.component->ts;
5255 vindex->ref = new_ref;
5261 /* Get the ultimate declared type from an expression. In addition,
5262 return the last class/derived type reference and the copy of the
5265 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5268 gfc_symbol *declared;
5273 *new_ref = gfc_copy_ref (e->ref);
5274 for (ref = *new_ref; ref; ref = ref->next)
5276 if (ref->type != REF_COMPONENT)
5279 if (ref->u.c.component->ts.type == BT_CLASS
5280 || ref->u.c.component->ts.type == BT_DERIVED)
5282 declared = ref->u.c.component->ts.u.derived;
5287 if (declared == NULL)
5288 declared = e->symtree->n.sym->ts.u.derived;
5294 /* Resolve the argument expressions so that any arguments expressions
5295 that include class methods are resolved before the current call.
5296 This is necessary because of the static variables used in CLASS
5297 method resolution. */
5299 resolve_arg_exprs (gfc_actual_arglist *arg)
5301 /* Resolve the actual arglist expressions. */
5302 for (; arg; arg = arg->next)
5305 gfc_resolve_expr (arg->expr);
5310 /* Resolve a CLASS typebound function, or 'method'. */
5312 resolve_class_compcall (gfc_expr* e)
5314 gfc_symbol *derived, *declared;
5320 class_object = st->n.sym;
5322 /* Get the CLASS declared type. */
5323 declared = get_declared_from_expr (&class_ref, &new_ref, e);
5325 /* Weed out cases of the ultimate component being a derived type. */
5326 if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5328 gfc_free_ref_list (new_ref);
5329 return resolve_compcall (e, true);
5332 /* Resolve the argument expressions, */
5333 resolve_arg_exprs (e->value.function.actual);
5335 /* Get the data component, which is of the declared type. */
5336 derived = declared->components->ts.u.derived;
5338 /* Resolve the function call for each member of the class. */
5339 class_try = SUCCESS;
5341 list_e = gfc_copy_expr (e);
5342 check_class_members (derived);
5344 class_try = (resolve_compcall (e, true) == SUCCESS)
5345 ? class_try : FAILURE;
5347 /* Transfer the class list to the original expression. Note that
5348 the class_esym list is cleaned up in trans-expr.c, as the calls
5350 e->value.function.class_esym = list_e->value.function.class_esym;
5351 list_e->value.function.class_esym = NULL;
5352 gfc_free_expr (list_e);
5354 resolve_class_esym (e);
5356 /* More than one typebound procedure so transmit an expression for
5357 the vindex as the selector. */
5358 if (e->value.function.class_esym != NULL)
5359 e->value.function.class_esym->vindex
5360 = vindex_expr (class_ref, new_ref, declared, st);
5365 /* Resolve a CLASS typebound subroutine, or 'method'. */
5367 resolve_class_typebound_call (gfc_code *code)
5369 gfc_symbol *derived, *declared;
5374 st = code->expr1->symtree;
5375 class_object = st->n.sym;
5377 /* Get the CLASS declared type. */
5378 declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5380 /* Weed out cases of the ultimate component being a derived type. */
5381 if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5383 gfc_free_ref_list (new_ref);
5384 return resolve_typebound_call (code);
5387 /* Resolve the argument expressions, */
5388 resolve_arg_exprs (code->expr1->value.compcall.actual);
5390 /* Get the data component, which is of the declared type. */
5391 derived = declared->components->ts.u.derived;
5393 class_try = SUCCESS;
5395 list_e = gfc_copy_expr (code->expr1);
5396 check_class_members (derived);
5398 class_try = (resolve_typebound_call (code) == SUCCESS)
5399 ? class_try : FAILURE;
5401 /* Transfer the class list to the original expression. Note that
5402 the class_esym list is cleaned up in trans-expr.c, as the calls
5404 code->expr1->value.function.class_esym
5405 = list_e->value.function.class_esym;
5406 list_e->value.function.class_esym = NULL;
5407 gfc_free_expr (list_e);
5409 resolve_class_esym (code->expr1);
5411 /* More than one typebound procedure so transmit an expression for
5412 the vindex as the selector. */
5413 if (code->expr1->value.function.class_esym != NULL)
5414 code->expr1->value.function.class_esym->vindex
5415 = vindex_expr (class_ref, new_ref, declared, st);
5421 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5424 resolve_ppc_call (gfc_code* c)
5426 gfc_component *comp;
5429 b = gfc_is_proc_ptr_comp (c->expr1, &comp);
5432 c->resolved_sym = c->expr1->symtree->n.sym;
5433 c->expr1->expr_type = EXPR_VARIABLE;
5435 if (!comp->attr.subroutine)
5436 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
5438 if (resolve_ref (c->expr1) == FAILURE)
5441 if (update_ppc_arglist (c->expr1) == FAILURE)
5444 c->ext.actual = c->expr1->value.compcall.actual;
5446 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
5447 comp->formal == NULL) == FAILURE)
5450 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
5456 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5459 resolve_expr_ppc (gfc_expr* e)
5461 gfc_component *comp;
5464 b = gfc_is_proc_ptr_comp (e, &comp);
5467 /* Convert to EXPR_FUNCTION. */
5468 e->expr_type = EXPR_FUNCTION;
5469 e->value.function.isym = NULL;
5470 e->value.function.actual = e->value.compcall.actual;
5472 if (comp->as != NULL)
5473 e->rank = comp->as->rank;
5475 if (!comp->attr.function)
5476 gfc_add_function (&comp->attr, comp->name, &e->where);
5478 if (resolve_ref (e) == FAILURE)
5481 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
5482 comp->formal == NULL) == FAILURE)
5485 if (update_ppc_arglist (e) == FAILURE)
5488 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
5494 /* Resolve an expression. That is, make sure that types of operands agree
5495 with their operators, intrinsic operators are converted to function calls
5496 for overloaded types and unresolved function references are resolved. */
5499 gfc_resolve_expr (gfc_expr *e)
5506 switch (e->expr_type)
5509 t = resolve_operator (e);
5515 if (check_host_association (e))
5516 t = resolve_function (e);
5519 t = resolve_variable (e);
5521 expression_rank (e);
5524 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
5525 && e->ref->type != REF_SUBSTRING)
5526 gfc_resolve_substring_charlen (e);
5531 if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
5532 t = resolve_class_compcall (e);
5534 t = resolve_compcall (e, true);
5537 case EXPR_SUBSTRING:
5538 t = resolve_ref (e);
5547 t = resolve_expr_ppc (e);
5552 if (resolve_ref (e) == FAILURE)
5555 t = gfc_resolve_array_constructor (e);
5556 /* Also try to expand a constructor. */
5559 expression_rank (e);
5560 gfc_expand_constructor (e);
5563 /* This provides the opportunity for the length of constructors with
5564 character valued function elements to propagate the string length
5565 to the expression. */
5566 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
5567 t = gfc_resolve_character_array_constructor (e);
5571 case EXPR_STRUCTURE:
5572 t = resolve_ref (e);
5576 t = resolve_structure_cons (e);
5580 t = gfc_simplify_expr (e, 0);
5584 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
5587 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
5594 /* Resolve an expression from an iterator. They must be scalar and have
5595 INTEGER or (optionally) REAL type. */
5598 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
5599 const char *name_msgid)
5601 if (gfc_resolve_expr (expr) == FAILURE)
5604 if (expr->rank != 0)
5606 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
5610 if (expr->ts.type != BT_INTEGER)
5612 if (expr->ts.type == BT_REAL)
5615 return gfc_notify_std (GFC_STD_F95_DEL,
5616 "Deleted feature: %s at %L must be integer",
5617 _(name_msgid), &expr->where);
5620 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
5627 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
5635 /* Resolve the expressions in an iterator structure. If REAL_OK is
5636 false allow only INTEGER type iterators, otherwise allow REAL types. */
5639 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
5641 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
5645 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
5647 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
5652 if (gfc_resolve_iterator_expr (iter->start, real_ok,
5653 "Start expression in DO loop") == FAILURE)
5656 if (gfc_resolve_iterator_expr (iter->end, real_ok,
5657 "End expression in DO loop") == FAILURE)
5660 if (gfc_resolve_iterator_expr (iter->step, real_ok,
5661 "Step expression in DO loop") == FAILURE)
5664 if (iter->step->expr_type == EXPR_CONSTANT)
5666 if ((iter->step->ts.type == BT_INTEGER
5667 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
5668 || (iter->step->ts.type == BT_REAL
5669 && mpfr_sgn (iter->step->value.real) == 0))
5671 gfc_error ("Step expression in DO loop at %L cannot be zero",
5672 &iter->step->where);
5677 /* Convert start, end, and step to the same type as var. */
5678 if (iter->start->ts.kind != iter->var->ts.kind
5679 || iter->start->ts.type != iter->var->ts.type)
5680 gfc_convert_type (iter->start, &iter->var->ts, 2);
5682 if (iter->end->ts.kind != iter->var->ts.kind
5683 || iter->end->ts.type != iter->var->ts.type)
5684 gfc_convert_type (iter->end, &iter->var->ts, 2);
5686 if (iter->step->ts.kind != iter->var->ts.kind
5687 || iter->step->ts.type != iter->var->ts.type)
5688 gfc_convert_type (iter->step, &iter->var->ts, 2);
5690 if (iter->start->expr_type == EXPR_CONSTANT
5691 && iter->end->expr_type == EXPR_CONSTANT
5692 && iter->step->expr_type == EXPR_CONSTANT)
5695 if (iter->start->ts.type == BT_INTEGER)
5697 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
5698 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
5702 sgn = mpfr_sgn (iter->step->value.real);
5703 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
5705 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
5706 gfc_warning ("DO loop at %L will be executed zero times",
5707 &iter->step->where);
5714 /* Traversal function for find_forall_index. f == 2 signals that
5715 that variable itself is not to be checked - only the references. */
5718 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
5720 if (expr->expr_type != EXPR_VARIABLE)
5723 /* A scalar assignment */
5724 if (!expr->ref || *f == 1)
5726 if (expr->symtree->n.sym == sym)
5738 /* Check whether the FORALL index appears in the expression or not.
5739 Returns SUCCESS if SYM is found in EXPR. */
5742 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
5744 if (gfc_traverse_expr (expr, sym, forall_index, f))
5751 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
5752 to be a scalar INTEGER variable. The subscripts and stride are scalar
5753 INTEGERs, and if stride is a constant it must be nonzero.
5754 Furthermore "A subscript or stride in a forall-triplet-spec shall
5755 not contain a reference to any index-name in the
5756 forall-triplet-spec-list in which it appears." (7.5.4.1) */
5759 resolve_forall_iterators (gfc_forall_iterator *it)
5761 gfc_forall_iterator *iter, *iter2;
5763 for (iter = it; iter; iter = iter->next)
5765 if (gfc_resolve_expr (iter->var) == SUCCESS
5766 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
5767 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
5770 if (gfc_resolve_expr (iter->start) == SUCCESS
5771 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
5772 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
5773 &iter->start->where);
5774 if (iter->var->ts.kind != iter->start->ts.kind)
5775 gfc_convert_type (iter->start, &iter->var->ts, 2);
5777 if (gfc_resolve_expr (iter->end) == SUCCESS
5778 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
5779 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
5781 if (iter->var->ts.kind != iter->end->ts.kind)
5782 gfc_convert_type (iter->end, &iter->var->ts, 2);
5784 if (gfc_resolve_expr (iter->stride) == SUCCESS)
5786 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
5787 gfc_error ("FORALL stride expression at %L must be a scalar %s",
5788 &iter->stride->where, "INTEGER");
5790 if (iter->stride->expr_type == EXPR_CONSTANT
5791 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
5792 gfc_error ("FORALL stride expression at %L cannot be zero",
5793 &iter->stride->where);
5795 if (iter->var->ts.kind != iter->stride->ts.kind)
5796 gfc_convert_type (iter->stride, &iter->var->ts, 2);
5799 for (iter = it; iter; iter = iter->next)
5800 for (iter2 = iter; iter2; iter2 = iter2->next)
5802 if (find_forall_index (iter2->start,
5803 iter->var->symtree->n.sym, 0) == SUCCESS
5804 || find_forall_index (iter2->end,
5805 iter->var->symtree->n.sym, 0) == SUCCESS
5806 || find_forall_index (iter2->stride,
5807 iter->var->symtree->n.sym, 0) == SUCCESS)
5808 gfc_error ("FORALL index '%s' may not appear in triplet "
5809 "specification at %L", iter->var->symtree->name,
5810 &iter2->start->where);
5815 /* Given a pointer to a symbol that is a derived type, see if it's
5816 inaccessible, i.e. if it's defined in another module and the components are
5817 PRIVATE. The search is recursive if necessary. Returns zero if no
5818 inaccessible components are found, nonzero otherwise. */
5821 derived_inaccessible (gfc_symbol *sym)
5825 if (sym->attr.use_assoc && sym->attr.private_comp)
5828 for (c = sym->components; c; c = c->next)
5830 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
5838 /* Resolve the argument of a deallocate expression. The expression must be
5839 a pointer or a full array. */
5842 resolve_deallocate_expr (gfc_expr *e)
5844 symbol_attribute attr;
5845 int allocatable, pointer, check_intent_in;
5850 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5851 check_intent_in = 1;
5853 if (gfc_resolve_expr (e) == FAILURE)
5856 if (e->expr_type != EXPR_VARIABLE)
5859 sym = e->symtree->n.sym;
5861 if (sym->ts.type == BT_CLASS)
5863 allocatable = sym->ts.u.derived->components->attr.allocatable;
5864 pointer = sym->ts.u.derived->components->attr.pointer;
5868 allocatable = sym->attr.allocatable;
5869 pointer = sym->attr.pointer;
5871 for (ref = e->ref; ref; ref = ref->next)
5874 check_intent_in = 0;
5879 if (ref->u.ar.type != AR_FULL)
5884 c = ref->u.c.component;
5885 if (c->ts.type == BT_CLASS)
5887 allocatable = c->ts.u.derived->components->attr.allocatable;
5888 pointer = c->ts.u.derived->components->attr.pointer;
5892 allocatable = c->attr.allocatable;
5893 pointer = c->attr.pointer;
5903 attr = gfc_expr_attr (e);
5905 if (allocatable == 0 && attr.pointer == 0)
5908 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
5912 if (check_intent_in && sym->attr.intent == INTENT_IN)
5914 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5915 sym->name, &e->where);
5919 if (e->ts.type == BT_CLASS)
5921 /* Only deallocate the DATA component. */
5922 gfc_add_component_ref (e, "$data");
5929 /* Returns true if the expression e contains a reference to the symbol sym. */
5931 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5933 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
5940 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
5942 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
5946 /* Given the expression node e for an allocatable/pointer of derived type to be
5947 allocated, get the expression node to be initialized afterwards (needed for
5948 derived types with default initializers, and derived types with allocatable
5949 components that need nullification.) */
5952 gfc_expr_to_initialize (gfc_expr *e)
5958 result = gfc_copy_expr (e);
5960 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5961 for (ref = result->ref; ref; ref = ref->next)
5962 if (ref->type == REF_ARRAY && ref->next == NULL)
5964 ref->u.ar.type = AR_FULL;
5966 for (i = 0; i < ref->u.ar.dimen; i++)
5967 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
5969 result->rank = ref->u.ar.dimen;
5977 /* Used in resolve_allocate_expr to check that a allocation-object and
5978 a source-expr are conformable. This does not catch all possible
5979 cases; in particular a runtime checking is needed. */
5982 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
5984 /* First compare rank. */
5985 if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
5987 gfc_error ("Source-expr at %L must be scalar or have the "
5988 "same rank as the allocate-object at %L",
5989 &e1->where, &e2->where);
6000 for (i = 0; i < e1->rank; i++)
6002 if (e2->ref->u.ar.end[i])
6004 mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
6005 mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
6006 mpz_add_ui (s, s, 1);
6010 mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
6013 if (mpz_cmp (e1->shape[i], s) != 0)
6015 gfc_error ("Source-expr at %L and allocate-object at %L must "
6016 "have the same shape", &e1->where, &e2->where);
6029 /* Resolve the expression in an ALLOCATE statement, doing the additional
6030 checks to see whether the expression is OK or not. The expression must
6031 have a trailing array reference that gives the size of the array. */
6034 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6036 int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
6037 symbol_attribute attr;
6038 gfc_ref *ref, *ref2;
6044 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
6045 check_intent_in = 1;
6047 if (gfc_resolve_expr (e) == FAILURE)
6050 /* Make sure the expression is allocatable or a pointer. If it is
6051 pointer, the next-to-last reference must be a pointer. */
6055 sym = e->symtree->n.sym;
6057 /* Check whether ultimate component is abstract and CLASS. */
6060 if (e->expr_type != EXPR_VARIABLE)
6063 attr = gfc_expr_attr (e);
6064 pointer = attr.pointer;
6065 dimension = attr.dimension;
6069 if (sym->ts.type == BT_CLASS)
6071 allocatable = sym->ts.u.derived->components->attr.allocatable;
6072 pointer = sym->ts.u.derived->components->attr.pointer;
6073 dimension = sym->ts.u.derived->components->attr.dimension;
6074 is_abstract = sym->ts.u.derived->components->attr.abstract;
6078 allocatable = sym->attr.allocatable;
6079 pointer = sym->attr.pointer;
6080 dimension = sym->attr.dimension;
6083 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6086 check_intent_in = 0;
6091 if (ref->next != NULL)
6096 c = ref->u.c.component;
6097 if (c->ts.type == BT_CLASS)
6099 allocatable = c->ts.u.derived->components->attr.allocatable;
6100 pointer = c->ts.u.derived->components->attr.pointer;
6101 dimension = c->ts.u.derived->components->attr.dimension;
6102 is_abstract = c->ts.u.derived->components->attr.abstract;
6106 allocatable = c->attr.allocatable;
6107 pointer = c->attr.pointer;
6108 dimension = c->attr.dimension;
6109 is_abstract = c->attr.abstract;
6121 if (allocatable == 0 && pointer == 0)
6123 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6128 /* Some checks for the SOURCE tag. */
6131 /* Check F03:C631. */
6132 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6134 gfc_error ("Type of entity at %L is type incompatible with "
6135 "source-expr at %L", &e->where, &code->expr3->where);
6139 /* Check F03:C632 and restriction following Note 6.18. */
6140 if (code->expr3->rank > 0
6141 && conformable_arrays (code->expr3, e) == FAILURE)
6144 /* Check F03:C633. */
6145 if (code->expr3->ts.kind != e->ts.kind)
6147 gfc_error ("The allocate-object at %L and the source-expr at %L "
6148 "shall have the same kind type parameter",
6149 &e->where, &code->expr3->where);
6153 else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
6155 gcc_assert (e->ts.type == BT_CLASS);
6156 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6157 "type-spec or SOURCE=", sym->name, &e->where);
6161 if (check_intent_in && sym->attr.intent == INTENT_IN)
6163 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
6164 sym->name, &e->where);
6168 if (pointer || dimension == 0)
6171 /* Make sure the next-to-last reference node is an array specification. */
6173 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
6175 gfc_error ("Array specification required in ALLOCATE statement "
6176 "at %L", &e->where);
6180 /* Make sure that the array section reference makes sense in the
6181 context of an ALLOCATE specification. */
6185 for (i = 0; i < ar->dimen; i++)
6187 if (ref2->u.ar.type == AR_ELEMENT)
6190 switch (ar->dimen_type[i])
6196 if (ar->start[i] != NULL
6197 && ar->end[i] != NULL
6198 && ar->stride[i] == NULL)
6201 /* Fall Through... */
6205 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6212 for (a = code->ext.alloc.list; a; a = a->next)
6214 sym = a->expr->symtree->n.sym;
6216 /* TODO - check derived type components. */
6217 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6220 if ((ar->start[i] != NULL
6221 && gfc_find_sym_in_expr (sym, ar->start[i]))
6222 || (ar->end[i] != NULL
6223 && gfc_find_sym_in_expr (sym, ar->end[i])))
6225 gfc_error ("'%s' must not appear in the array specification at "
6226 "%L in the same ALLOCATE statement where it is "
6227 "itself allocated", sym->name, &ar->where);
6237 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
6239 gfc_expr *stat, *errmsg, *pe, *qe;
6240 gfc_alloc *a, *p, *q;
6242 stat = code->expr1 ? code->expr1 : NULL;
6244 errmsg = code->expr2 ? code->expr2 : NULL;
6246 /* Check the stat variable. */
6249 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
6250 gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
6251 stat->symtree->n.sym->name, &stat->where);
6253 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
6254 gfc_error ("Illegal stat-variable at %L for a PURE procedure",
6257 if ((stat->ts.type != BT_INTEGER
6258 && !(stat->ref && (stat->ref->type == REF_ARRAY
6259 || stat->ref->type == REF_COMPONENT)))
6261 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6262 "variable", &stat->where);
6264 for (p = code->ext.alloc.list; p; p = p->next)
6265 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
6266 gfc_error ("Stat-variable at %L shall not be %sd within "
6267 "the same %s statement", &stat->where, fcn, fcn);
6270 /* Check the errmsg variable. */
6274 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6277 if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
6278 gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
6279 errmsg->symtree->n.sym->name, &errmsg->where);
6281 if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
6282 gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
6285 if ((errmsg->ts.type != BT_CHARACTER
6287 && (errmsg->ref->type == REF_ARRAY
6288 || errmsg->ref->type == REF_COMPONENT)))
6289 || errmsg->rank > 0 )
6290 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6291 "variable", &errmsg->where);
6293 for (p = code->ext.alloc.list; p; p = p->next)
6294 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
6295 gfc_error ("Errmsg-variable at %L shall not be %sd within "
6296 "the same %s statement", &errmsg->where, fcn, fcn);
6299 /* Check that an allocate-object appears only once in the statement.
6300 FIXME: Checking derived types is disabled. */
6301 for (p = code->ext.alloc.list; p; p = p->next)
6304 if ((pe->ref && pe->ref->type != REF_COMPONENT)
6305 && (pe->symtree->n.sym->ts.type != BT_DERIVED))
6307 for (q = p->next; q; q = q->next)
6310 if ((qe->ref && qe->ref->type != REF_COMPONENT)
6311 && (qe->symtree->n.sym->ts.type != BT_DERIVED)
6312 && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
6313 gfc_error ("Allocate-object at %L also appears at %L",
6314 &pe->where, &qe->where);
6319 if (strcmp (fcn, "ALLOCATE") == 0)
6321 for (a = code->ext.alloc.list; a; a = a->next)
6322 resolve_allocate_expr (a->expr, code);
6326 for (a = code->ext.alloc.list; a; a = a->next)
6327 resolve_deallocate_expr (a->expr);
6332 /************ SELECT CASE resolution subroutines ************/
6334 /* Callback function for our mergesort variant. Determines interval
6335 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
6336 op1 > op2. Assumes we're not dealing with the default case.
6337 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
6338 There are nine situations to check. */
6341 compare_cases (const gfc_case *op1, const gfc_case *op2)
6345 if (op1->low == NULL) /* op1 = (:L) */
6347 /* op2 = (:N), so overlap. */
6349 /* op2 = (M:) or (M:N), L < M */
6350 if (op2->low != NULL
6351 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6354 else if (op1->high == NULL) /* op1 = (K:) */
6356 /* op2 = (M:), so overlap. */
6358 /* op2 = (:N) or (M:N), K > N */
6359 if (op2->high != NULL
6360 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6363 else /* op1 = (K:L) */
6365 if (op2->low == NULL) /* op2 = (:N), K > N */
6366 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6368 else if (op2->high == NULL) /* op2 = (M:), L < M */
6369 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6371 else /* op2 = (M:N) */
6375 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
6378 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
6387 /* Merge-sort a double linked case list, detecting overlap in the
6388 process. LIST is the head of the double linked case list before it
6389 is sorted. Returns the head of the sorted list if we don't see any
6390 overlap, or NULL otherwise. */
6393 check_case_overlap (gfc_case *list)
6395 gfc_case *p, *q, *e, *tail;
6396 int insize, nmerges, psize, qsize, cmp, overlap_seen;
6398 /* If the passed list was empty, return immediately. */
6405 /* Loop unconditionally. The only exit from this loop is a return
6406 statement, when we've finished sorting the case list. */
6413 /* Count the number of merges we do in this pass. */
6416 /* Loop while there exists a merge to be done. */
6421 /* Count this merge. */
6424 /* Cut the list in two pieces by stepping INSIZE places
6425 forward in the list, starting from P. */
6428 for (i = 0; i < insize; i++)
6437 /* Now we have two lists. Merge them! */
6438 while (psize > 0 || (qsize > 0 && q != NULL))
6440 /* See from which the next case to merge comes from. */
6443 /* P is empty so the next case must come from Q. */
6448 else if (qsize == 0 || q == NULL)
6457 cmp = compare_cases (p, q);
6460 /* The whole case range for P is less than the
6468 /* The whole case range for Q is greater than
6469 the case range for P. */
6476 /* The cases overlap, or they are the same
6477 element in the list. Either way, we must
6478 issue an error and get the next case from P. */
6479 /* FIXME: Sort P and Q by line number. */
6480 gfc_error ("CASE label at %L overlaps with CASE "
6481 "label at %L", &p->where, &q->where);
6489 /* Add the next element to the merged list. */
6498 /* P has now stepped INSIZE places along, and so has Q. So
6499 they're the same. */
6504 /* If we have done only one merge or none at all, we've
6505 finished sorting the cases. */
6514 /* Otherwise repeat, merging lists twice the size. */
6520 /* Check to see if an expression is suitable for use in a CASE statement.
6521 Makes sure that all case expressions are scalar constants of the same
6522 type. Return FAILURE if anything is wrong. */
6525 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
6527 if (e == NULL) return SUCCESS;
6529 if (e->ts.type != case_expr->ts.type)
6531 gfc_error ("Expression in CASE statement at %L must be of type %s",
6532 &e->where, gfc_basic_typename (case_expr->ts.type));
6536 /* C805 (R808) For a given case-construct, each case-value shall be of
6537 the same type as case-expr. For character type, length differences
6538 are allowed, but the kind type parameters shall be the same. */
6540 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
6542 gfc_error ("Expression in CASE statement at %L must be of kind %d",
6543 &e->where, case_expr->ts.kind);
6547 /* Convert the case value kind to that of case expression kind, if needed.
6548 FIXME: Should a warning be issued? */
6549 if (e->ts.kind != case_expr->ts.kind)
6550 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
6554 gfc_error ("Expression in CASE statement at %L must be scalar",
6563 /* Given a completely parsed select statement, we:
6565 - Validate all expressions and code within the SELECT.
6566 - Make sure that the selection expression is not of the wrong type.
6567 - Make sure that no case ranges overlap.
6568 - Eliminate unreachable cases and unreachable code resulting from
6569 removing case labels.
6571 The standard does allow unreachable cases, e.g. CASE (5:3). But
6572 they are a hassle for code generation, and to prevent that, we just
6573 cut them out here. This is not necessary for overlapping cases
6574 because they are illegal and we never even try to generate code.
6576 We have the additional caveat that a SELECT construct could have
6577 been a computed GOTO in the source code. Fortunately we can fairly
6578 easily work around that here: The case_expr for a "real" SELECT CASE
6579 is in code->expr1, but for a computed GOTO it is in code->expr2. All
6580 we have to do is make sure that the case_expr is a scalar integer
6584 resolve_select (gfc_code *code)
6587 gfc_expr *case_expr;
6588 gfc_case *cp, *default_case, *tail, *head;
6589 int seen_unreachable;
6595 if (code->expr1 == NULL)
6597 /* This was actually a computed GOTO statement. */
6598 case_expr = code->expr2;
6599 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
6600 gfc_error ("Selection expression in computed GOTO statement "
6601 "at %L must be a scalar integer expression",
6604 /* Further checking is not necessary because this SELECT was built
6605 by the compiler, so it should always be OK. Just move the
6606 case_expr from expr2 to expr so that we can handle computed
6607 GOTOs as normal SELECTs from here on. */
6608 code->expr1 = code->expr2;
6613 case_expr = code->expr1;
6615 type = case_expr->ts.type;
6616 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
6618 gfc_error ("Argument of SELECT statement at %L cannot be %s",
6619 &case_expr->where, gfc_typename (&case_expr->ts));
6621 /* Punt. Going on here just produce more garbage error messages. */
6625 if (case_expr->rank != 0)
6627 gfc_error ("Argument of SELECT statement at %L must be a scalar "
6628 "expression", &case_expr->where);
6634 /* PR 19168 has a long discussion concerning a mismatch of the kinds
6635 of the SELECT CASE expression and its CASE values. Walk the lists
6636 of case values, and if we find a mismatch, promote case_expr to
6637 the appropriate kind. */
6639 if (type == BT_LOGICAL || type == BT_INTEGER)
6641 for (body = code->block; body; body = body->block)
6643 /* Walk the case label list. */
6644 for (cp = body->ext.case_list; cp; cp = cp->next)
6646 /* Intercept the DEFAULT case. It does not have a kind. */
6647 if (cp->low == NULL && cp->high == NULL)
6650 /* Unreachable case ranges are discarded, so ignore. */
6651 if (cp->low != NULL && cp->high != NULL
6652 && cp->low != cp->high
6653 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
6656 /* FIXME: Should a warning be issued? */
6658 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
6659 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
6661 if (cp->high != NULL
6662 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
6663 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
6668 /* Assume there is no DEFAULT case. */
6669 default_case = NULL;
6674 for (body = code->block; body; body = body->block)
6676 /* Assume the CASE list is OK, and all CASE labels can be matched. */
6678 seen_unreachable = 0;
6680 /* Walk the case label list, making sure that all case labels
6682 for (cp = body->ext.case_list; cp; cp = cp->next)
6684 /* Count the number of cases in the whole construct. */
6687 /* Intercept the DEFAULT case. */
6688 if (cp->low == NULL && cp->high == NULL)
6690 if (default_case != NULL)
6692 gfc_error ("The DEFAULT CASE at %L cannot be followed "
6693 "by a second DEFAULT CASE at %L",
6694 &default_case->where, &cp->where);
6705 /* Deal with single value cases and case ranges. Errors are
6706 issued from the validation function. */
6707 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
6708 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
6714 if (type == BT_LOGICAL
6715 && ((cp->low == NULL || cp->high == NULL)
6716 || cp->low != cp->high))
6718 gfc_error ("Logical range in CASE statement at %L is not "
6719 "allowed", &cp->low->where);
6724 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
6727 value = cp->low->value.logical == 0 ? 2 : 1;
6728 if (value & seen_logical)
6730 gfc_error ("constant logical value in CASE statement "
6731 "is repeated at %L",
6736 seen_logical |= value;
6739 if (cp->low != NULL && cp->high != NULL
6740 && cp->low != cp->high
6741 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
6743 if (gfc_option.warn_surprising)
6744 gfc_warning ("Range specification at %L can never "
6745 "be matched", &cp->where);
6747 cp->unreachable = 1;
6748 seen_unreachable = 1;
6752 /* If the case range can be matched, it can also overlap with
6753 other cases. To make sure it does not, we put it in a
6754 double linked list here. We sort that with a merge sort
6755 later on to detect any overlapping cases. */
6759 head->right = head->left = NULL;
6764 tail->right->left = tail;
6771 /* It there was a failure in the previous case label, give up
6772 for this case label list. Continue with the next block. */
6776 /* See if any case labels that are unreachable have been seen.
6777 If so, we eliminate them. This is a bit of a kludge because
6778 the case lists for a single case statement (label) is a
6779 single forward linked lists. */
6780 if (seen_unreachable)
6782 /* Advance until the first case in the list is reachable. */
6783 while (body->ext.case_list != NULL
6784 && body->ext.case_list->unreachable)
6786 gfc_case *n = body->ext.case_list;
6787 body->ext.case_list = body->ext.case_list->next;
6789 gfc_free_case_list (n);
6792 /* Strip all other unreachable cases. */
6793 if (body->ext.case_list)
6795 for (cp = body->ext.case_list; cp->next; cp = cp->next)
6797 if (cp->next->unreachable)
6799 gfc_case *n = cp->next;
6800 cp->next = cp->next->next;
6802 gfc_free_case_list (n);
6809 /* See if there were overlapping cases. If the check returns NULL,
6810 there was overlap. In that case we don't do anything. If head
6811 is non-NULL, we prepend the DEFAULT case. The sorted list can
6812 then used during code generation for SELECT CASE constructs with
6813 a case expression of a CHARACTER type. */
6816 head = check_case_overlap (head);
6818 /* Prepend the default_case if it is there. */
6819 if (head != NULL && default_case)
6821 default_case->left = NULL;
6822 default_case->right = head;
6823 head->left = default_case;
6827 /* Eliminate dead blocks that may be the result if we've seen
6828 unreachable case labels for a block. */
6829 for (body = code; body && body->block; body = body->block)
6831 if (body->block->ext.case_list == NULL)
6833 /* Cut the unreachable block from the code chain. */
6834 gfc_code *c = body->block;
6835 body->block = c->block;
6837 /* Kill the dead block, but not the blocks below it. */
6839 gfc_free_statements (c);
6843 /* More than two cases is legal but insane for logical selects.
6844 Issue a warning for it. */
6845 if (gfc_option.warn_surprising && type == BT_LOGICAL
6847 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
6852 /* Check if a derived type is extensible. */
6855 gfc_type_is_extensible (gfc_symbol *sym)
6857 return !(sym->attr.is_bind_c || sym->attr.sequence);
6861 /* Resolve a SELECT TYPE statement. */
6864 resolve_select_type (gfc_code *code)
6866 gfc_symbol *selector_type;
6867 gfc_code *body, *new_st;
6868 gfc_case *c, *default_case;
6870 char name[GFC_MAX_SYMBOL_LEN];
6877 selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
6879 selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
6881 /* Assume there is no DEFAULT case. */
6882 default_case = NULL;
6884 /* Loop over TYPE IS / CLASS IS cases. */
6885 for (body = code->block; body; body = body->block)
6887 c = body->ext.case_list;
6889 /* Check F03:C815. */
6890 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
6891 && !gfc_type_is_extensible (c->ts.u.derived))
6893 gfc_error ("Derived type '%s' at %L must be extensible",
6894 c->ts.u.derived->name, &c->where);
6898 /* Check F03:C816. */
6899 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
6900 && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
6902 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
6903 c->ts.u.derived->name, &c->where, selector_type->name);
6907 /* Intercept the DEFAULT case. */
6908 if (c->ts.type == BT_UNKNOWN)
6910 /* Check F03:C818. */
6911 if (default_case != NULL)
6912 gfc_error ("The DEFAULT CASE at %L cannot be followed "
6913 "by a second DEFAULT CASE at %L",
6914 &default_case->where, &c->where);
6923 /* Insert assignment for selector variable. */
6924 new_st = gfc_get_code ();
6925 new_st->op = EXEC_ASSIGN;
6926 new_st->expr1 = gfc_copy_expr (code->expr1);
6927 new_st->expr2 = gfc_copy_expr (code->expr2);
6931 /* Put SELECT TYPE statement inside a BLOCK. */
6932 new_st = gfc_get_code ();
6933 new_st->op = code->op;
6934 new_st->expr1 = code->expr1;
6935 new_st->expr2 = code->expr2;
6936 new_st->block = code->block;
6940 ns->code->next = new_st;
6941 code->op = EXEC_BLOCK;
6942 code->expr1 = code->expr2 = NULL;
6947 /* Transform to EXEC_SELECT. */
6948 code->op = EXEC_SELECT;
6949 gfc_add_component_ref (code->expr1, "$vindex");
6951 /* Loop over TYPE IS / CLASS IS cases. */
6952 for (body = code->block; body; body = body->block)
6954 c = body->ext.case_list;
6955 if (c->ts.type == BT_DERIVED)
6956 c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex);
6957 else if (c->ts.type == BT_CLASS)
6958 /* Currently IS CLASS blocks are simply ignored.
6959 TODO: Implement IS CLASS. */
6962 if (c->ts.type != BT_DERIVED)
6964 /* Assign temporary to selector. */
6965 sprintf (name, "tmp$%s", c->ts.u.derived->name);
6966 st = gfc_find_symtree (ns->sym_root, name);
6967 new_st = gfc_get_code ();
6968 new_st->op = EXEC_POINTER_ASSIGN;
6969 new_st->expr1 = gfc_get_variable_expr (st);
6970 new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
6971 gfc_add_component_ref (new_st->expr2, "$data");
6972 new_st->next = body->next;
6973 body->next = new_st;
6976 /* Eliminate dead blocks. */
6977 for (body = code; body && body->block; body = body->block)
6979 if (body->block->ext.case_list->unreachable)
6981 /* Cut the unreachable block from the code chain. */
6982 gfc_code *cd = body->block;
6983 body->block = cd->block;
6984 /* Kill the dead block, but not the blocks below it. */
6986 gfc_free_statements (cd);
6990 resolve_select (code);
6995 /* Resolve a transfer statement. This is making sure that:
6996 -- a derived type being transferred has only non-pointer components
6997 -- a derived type being transferred doesn't have private components, unless
6998 it's being transferred from the module where the type was defined
6999 -- we're not trying to transfer a whole assumed size array. */
7002 resolve_transfer (gfc_code *code)
7011 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
7014 sym = exp->symtree->n.sym;
7017 /* Go to actual component transferred. */
7018 for (ref = code->expr1->ref; ref; ref = ref->next)
7019 if (ref->type == REF_COMPONENT)
7020 ts = &ref->u.c.component->ts;
7022 if (ts->type == BT_DERIVED)
7024 /* Check that transferred derived type doesn't contain POINTER
7026 if (ts->u.derived->attr.pointer_comp)
7028 gfc_error ("Data transfer element at %L cannot have "
7029 "POINTER components", &code->loc);
7033 if (ts->u.derived->attr.alloc_comp)
7035 gfc_error ("Data transfer element at %L cannot have "
7036 "ALLOCATABLE components", &code->loc);
7040 if (derived_inaccessible (ts->u.derived))
7042 gfc_error ("Data transfer element at %L cannot have "
7043 "PRIVATE components",&code->loc);
7048 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
7049 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
7051 gfc_error ("Data transfer element at %L cannot be a full reference to "
7052 "an assumed-size array", &code->loc);
7058 /*********** Toplevel code resolution subroutines ***********/
7060 /* Find the set of labels that are reachable from this block. We also
7061 record the last statement in each block. */
7064 find_reachable_labels (gfc_code *block)
7071 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
7073 /* Collect labels in this block. We don't keep those corresponding
7074 to END {IF|SELECT}, these are checked in resolve_branch by going
7075 up through the code_stack. */
7076 for (c = block; c; c = c->next)
7078 if (c->here && c->op != EXEC_END_BLOCK)
7079 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
7082 /* Merge with labels from parent block. */
7085 gcc_assert (cs_base->prev->reachable_labels);
7086 bitmap_ior_into (cs_base->reachable_labels,
7087 cs_base->prev->reachable_labels);
7091 /* Given a branch to a label, see if the branch is conforming.
7092 The code node describes where the branch is located. */
7095 resolve_branch (gfc_st_label *label, gfc_code *code)
7102 /* Step one: is this a valid branching target? */
7104 if (label->defined == ST_LABEL_UNKNOWN)
7106 gfc_error ("Label %d referenced at %L is never defined", label->value,
7111 if (label->defined != ST_LABEL_TARGET)
7113 gfc_error ("Statement at %L is not a valid branch target statement "
7114 "for the branch statement at %L", &label->where, &code->loc);
7118 /* Step two: make sure this branch is not a branch to itself ;-) */
7120 if (code->here == label)
7122 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
7126 /* Step three: See if the label is in the same block as the
7127 branching statement. The hard work has been done by setting up
7128 the bitmap reachable_labels. */
7130 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
7133 /* Step four: If we haven't found the label in the bitmap, it may
7134 still be the label of the END of the enclosing block, in which
7135 case we find it by going up the code_stack. */
7137 for (stack = cs_base; stack; stack = stack->prev)
7138 if (stack->current->next && stack->current->next->here == label)
7143 gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
7147 /* The label is not in an enclosing block, so illegal. This was
7148 allowed in Fortran 66, so we allow it as extension. No
7149 further checks are necessary in this case. */
7150 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
7151 "as the GOTO statement at %L", &label->where,
7157 /* Check whether EXPR1 has the same shape as EXPR2. */
7160 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
7162 mpz_t shape[GFC_MAX_DIMENSIONS];
7163 mpz_t shape2[GFC_MAX_DIMENSIONS];
7164 gfc_try result = FAILURE;
7167 /* Compare the rank. */
7168 if (expr1->rank != expr2->rank)
7171 /* Compare the size of each dimension. */
7172 for (i=0; i<expr1->rank; i++)
7174 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
7177 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
7180 if (mpz_cmp (shape[i], shape2[i]))
7184 /* When either of the two expression is an assumed size array, we
7185 ignore the comparison of dimension sizes. */
7190 for (i--; i >= 0; i--)
7192 mpz_clear (shape[i]);
7193 mpz_clear (shape2[i]);
7199 /* Check whether a WHERE assignment target or a WHERE mask expression
7200 has the same shape as the outmost WHERE mask expression. */
7203 resolve_where (gfc_code *code, gfc_expr *mask)
7209 cblock = code->block;
7211 /* Store the first WHERE mask-expr of the WHERE statement or construct.
7212 In case of nested WHERE, only the outmost one is stored. */
7213 if (mask == NULL) /* outmost WHERE */
7215 else /* inner WHERE */
7222 /* Check if the mask-expr has a consistent shape with the
7223 outmost WHERE mask-expr. */
7224 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
7225 gfc_error ("WHERE mask at %L has inconsistent shape",
7226 &cblock->expr1->where);
7229 /* the assignment statement of a WHERE statement, or the first
7230 statement in where-body-construct of a WHERE construct */
7231 cnext = cblock->next;
7236 /* WHERE assignment statement */
7239 /* Check shape consistent for WHERE assignment target. */
7240 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
7241 gfc_error ("WHERE assignment target at %L has "
7242 "inconsistent shape", &cnext->expr1->where);
7246 case EXEC_ASSIGN_CALL:
7247 resolve_call (cnext);
7248 if (!cnext->resolved_sym->attr.elemental)
7249 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
7250 &cnext->ext.actual->expr->where);
7253 /* WHERE or WHERE construct is part of a where-body-construct */
7255 resolve_where (cnext, e);
7259 gfc_error ("Unsupported statement inside WHERE at %L",
7262 /* the next statement within the same where-body-construct */
7263 cnext = cnext->next;
7265 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
7266 cblock = cblock->block;
7271 /* Resolve assignment in FORALL construct.
7272 NVAR is the number of FORALL index variables, and VAR_EXPR records the
7273 FORALL index variables. */
7276 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
7280 for (n = 0; n < nvar; n++)
7282 gfc_symbol *forall_index;
7284 forall_index = var_expr[n]->symtree->n.sym;
7286 /* Check whether the assignment target is one of the FORALL index
7288 if ((code->expr1->expr_type == EXPR_VARIABLE)
7289 && (code->expr1->symtree->n.sym == forall_index))
7290 gfc_error ("Assignment to a FORALL index variable at %L",
7291 &code->expr1->where);
7294 /* If one of the FORALL index variables doesn't appear in the
7295 assignment variable, then there could be a many-to-one
7296 assignment. Emit a warning rather than an error because the
7297 mask could be resolving this problem. */
7298 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
7299 gfc_warning ("The FORALL with index '%s' is not used on the "
7300 "left side of the assignment at %L and so might "
7301 "cause multiple assignment to this object",
7302 var_expr[n]->symtree->name, &code->expr1->where);
7308 /* Resolve WHERE statement in FORALL construct. */
7311 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
7312 gfc_expr **var_expr)
7317 cblock = code->block;
7320 /* the assignment statement of a WHERE statement, or the first
7321 statement in where-body-construct of a WHERE construct */
7322 cnext = cblock->next;
7327 /* WHERE assignment statement */
7329 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
7332 /* WHERE operator assignment statement */
7333 case EXEC_ASSIGN_CALL:
7334 resolve_call (cnext);
7335 if (!cnext->resolved_sym->attr.elemental)
7336 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
7337 &cnext->ext.actual->expr->where);
7340 /* WHERE or WHERE construct is part of a where-body-construct */
7342 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
7346 gfc_error ("Unsupported statement inside WHERE at %L",
7349 /* the next statement within the same where-body-construct */
7350 cnext = cnext->next;
7352 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
7353 cblock = cblock->block;
7358 /* Traverse the FORALL body to check whether the following errors exist:
7359 1. For assignment, check if a many-to-one assignment happens.
7360 2. For WHERE statement, check the WHERE body to see if there is any
7361 many-to-one assignment. */
7364 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
7368 c = code->block->next;
7374 case EXEC_POINTER_ASSIGN:
7375 gfc_resolve_assign_in_forall (c, nvar, var_expr);
7378 case EXEC_ASSIGN_CALL:
7382 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
7383 there is no need to handle it here. */
7387 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
7392 /* The next statement in the FORALL body. */
7398 /* Counts the number of iterators needed inside a forall construct, including
7399 nested forall constructs. This is used to allocate the needed memory
7400 in gfc_resolve_forall. */
7403 gfc_count_forall_iterators (gfc_code *code)
7405 int max_iters, sub_iters, current_iters;
7406 gfc_forall_iterator *fa;
7408 gcc_assert(code->op == EXEC_FORALL);
7412 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
7415 code = code->block->next;
7419 if (code->op == EXEC_FORALL)
7421 sub_iters = gfc_count_forall_iterators (code);
7422 if (sub_iters > max_iters)
7423 max_iters = sub_iters;
7428 return current_iters + max_iters;
7432 /* Given a FORALL construct, first resolve the FORALL iterator, then call
7433 gfc_resolve_forall_body to resolve the FORALL body. */
7436 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
7438 static gfc_expr **var_expr;
7439 static int total_var = 0;
7440 static int nvar = 0;
7442 gfc_forall_iterator *fa;
7447 /* Start to resolve a FORALL construct */
7448 if (forall_save == 0)
7450 /* Count the total number of FORALL index in the nested FORALL
7451 construct in order to allocate the VAR_EXPR with proper size. */
7452 total_var = gfc_count_forall_iterators (code);
7454 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
7455 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
7458 /* The information about FORALL iterator, including FORALL index start, end
7459 and stride. The FORALL index can not appear in start, end or stride. */
7460 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
7462 /* Check if any outer FORALL index name is the same as the current
7464 for (i = 0; i < nvar; i++)
7466 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
7468 gfc_error ("An outer FORALL construct already has an index "
7469 "with this name %L", &fa->var->where);
7473 /* Record the current FORALL index. */
7474 var_expr[nvar] = gfc_copy_expr (fa->var);
7478 /* No memory leak. */
7479 gcc_assert (nvar <= total_var);
7482 /* Resolve the FORALL body. */
7483 gfc_resolve_forall_body (code, nvar, var_expr);
7485 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
7486 gfc_resolve_blocks (code->block, ns);
7490 /* Free only the VAR_EXPRs allocated in this frame. */
7491 for (i = nvar; i < tmp; i++)
7492 gfc_free_expr (var_expr[i]);
7496 /* We are in the outermost FORALL construct. */
7497 gcc_assert (forall_save == 0);
7499 /* VAR_EXPR is not needed any more. */
7500 gfc_free (var_expr);
7506 /* Resolve a BLOCK construct statement. */
7509 resolve_block_construct (gfc_code* code)
7511 /* Eventually, we may want to do some checks here or handle special stuff.
7512 But so far the only thing we can do is resolving the local namespace. */
7514 gfc_resolve (code->ext.ns);
7518 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
7521 static void resolve_code (gfc_code *, gfc_namespace *);
7524 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
7528 for (; b; b = b->block)
7530 t = gfc_resolve_expr (b->expr1);
7531 if (gfc_resolve_expr (b->expr2) == FAILURE)
7537 if (t == SUCCESS && b->expr1 != NULL
7538 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
7539 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7546 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
7547 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
7552 resolve_branch (b->label1, b);
7556 resolve_block_construct (b);
7560 case EXEC_SELECT_TYPE:
7570 case EXEC_OMP_ATOMIC:
7571 case EXEC_OMP_CRITICAL:
7573 case EXEC_OMP_MASTER:
7574 case EXEC_OMP_ORDERED:
7575 case EXEC_OMP_PARALLEL:
7576 case EXEC_OMP_PARALLEL_DO:
7577 case EXEC_OMP_PARALLEL_SECTIONS:
7578 case EXEC_OMP_PARALLEL_WORKSHARE:
7579 case EXEC_OMP_SECTIONS:
7580 case EXEC_OMP_SINGLE:
7582 case EXEC_OMP_TASKWAIT:
7583 case EXEC_OMP_WORKSHARE:
7587 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
7590 resolve_code (b->next, ns);
7595 /* Does everything to resolve an ordinary assignment. Returns true
7596 if this is an interface assignment. */
7598 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
7608 if (gfc_extend_assign (code, ns) == SUCCESS)
7610 gfc_symbol* assign_proc;
7613 if (code->op == EXEC_ASSIGN_CALL)
7615 lhs = code->ext.actual->expr;
7616 rhsptr = &code->ext.actual->next->expr;
7617 assign_proc = code->symtree->n.sym;
7621 gfc_actual_arglist* args;
7622 gfc_typebound_proc* tbp;
7624 gcc_assert (code->op == EXEC_COMPCALL);
7626 args = code->expr1->value.compcall.actual;
7628 rhsptr = &args->next->expr;
7630 tbp = code->expr1->value.compcall.tbp;
7631 gcc_assert (!tbp->is_generic);
7632 assign_proc = tbp->u.specific->n.sym;
7635 /* Make a temporary rhs when there is a default initializer
7636 and rhs is the same symbol as the lhs. */
7637 if ((*rhsptr)->expr_type == EXPR_VARIABLE
7638 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
7639 && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
7640 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
7641 *rhsptr = gfc_get_parentheses (*rhsptr);
7650 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
7651 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
7652 &code->loc) == FAILURE)
7655 /* Handle the case of a BOZ literal on the RHS. */
7656 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
7659 if (gfc_option.warn_surprising)
7660 gfc_warning ("BOZ literal at %L is bitwise transferred "
7661 "non-integer symbol '%s'", &code->loc,
7662 lhs->symtree->n.sym->name);
7664 if (!gfc_convert_boz (rhs, &lhs->ts))
7666 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
7668 if (rc == ARITH_UNDERFLOW)
7669 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
7670 ". This check can be disabled with the option "
7671 "-fno-range-check", &rhs->where);
7672 else if (rc == ARITH_OVERFLOW)
7673 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
7674 ". This check can be disabled with the option "
7675 "-fno-range-check", &rhs->where);
7676 else if (rc == ARITH_NAN)
7677 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
7678 ". This check can be disabled with the option "
7679 "-fno-range-check", &rhs->where);
7685 if (lhs->ts.type == BT_CHARACTER
7686 && gfc_option.warn_character_truncation)
7688 if (lhs->ts.u.cl != NULL
7689 && lhs->ts.u.cl->length != NULL
7690 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7691 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
7693 if (rhs->expr_type == EXPR_CONSTANT)
7694 rlen = rhs->value.character.length;
7696 else if (rhs->ts.u.cl != NULL
7697 && rhs->ts.u.cl->length != NULL
7698 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7699 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
7701 if (rlen && llen && rlen > llen)
7702 gfc_warning_now ("CHARACTER expression will be truncated "
7703 "in assignment (%d/%d) at %L",
7704 llen, rlen, &code->loc);
7707 /* Ensure that a vector index expression for the lvalue is evaluated
7708 to a temporary if the lvalue symbol is referenced in it. */
7711 for (ref = lhs->ref; ref; ref= ref->next)
7712 if (ref->type == REF_ARRAY)
7714 for (n = 0; n < ref->u.ar.dimen; n++)
7715 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
7716 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
7717 ref->u.ar.start[n]))
7719 = gfc_get_parentheses (ref->u.ar.start[n]);
7723 if (gfc_pure (NULL))
7725 if (gfc_impure_variable (lhs->symtree->n.sym))
7727 gfc_error ("Cannot assign to variable '%s' in PURE "
7729 lhs->symtree->n.sym->name,
7734 if (lhs->ts.type == BT_DERIVED
7735 && lhs->expr_type == EXPR_VARIABLE
7736 && lhs->ts.u.derived->attr.pointer_comp
7737 && gfc_impure_variable (rhs->symtree->n.sym))
7739 gfc_error ("The impure variable at %L is assigned to "
7740 "a derived type variable with a POINTER "
7741 "component in a PURE procedure (12.6)",
7748 if (lhs->ts.type == BT_CLASS)
7750 gfc_error ("Variable must not be polymorphic in assignment at %L",
7755 gfc_check_assign (lhs, rhs, 1);
7760 /* Given a block of code, recursively resolve everything pointed to by this
7764 resolve_code (gfc_code *code, gfc_namespace *ns)
7766 int omp_workshare_save;
7771 frame.prev = cs_base;
7775 find_reachable_labels (code);
7777 for (; code; code = code->next)
7779 frame.current = code;
7780 forall_save = forall_flag;
7782 if (code->op == EXEC_FORALL)
7785 gfc_resolve_forall (code, ns, forall_save);
7788 else if (code->block)
7790 omp_workshare_save = -1;
7793 case EXEC_OMP_PARALLEL_WORKSHARE:
7794 omp_workshare_save = omp_workshare_flag;
7795 omp_workshare_flag = 1;
7796 gfc_resolve_omp_parallel_blocks (code, ns);
7798 case EXEC_OMP_PARALLEL:
7799 case EXEC_OMP_PARALLEL_DO:
7800 case EXEC_OMP_PARALLEL_SECTIONS:
7802 omp_workshare_save = omp_workshare_flag;
7803 omp_workshare_flag = 0;
7804 gfc_resolve_omp_parallel_blocks (code, ns);
7807 gfc_resolve_omp_do_blocks (code, ns);
7809 case EXEC_OMP_WORKSHARE:
7810 omp_workshare_save = omp_workshare_flag;
7811 omp_workshare_flag = 1;
7814 gfc_resolve_blocks (code->block, ns);
7818 if (omp_workshare_save != -1)
7819 omp_workshare_flag = omp_workshare_save;
7823 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
7824 t = gfc_resolve_expr (code->expr1);
7825 forall_flag = forall_save;
7827 if (gfc_resolve_expr (code->expr2) == FAILURE)
7830 if (code->op == EXEC_ALLOCATE
7831 && gfc_resolve_expr (code->expr3) == FAILURE)
7837 case EXEC_END_BLOCK:
7844 case EXEC_ASSIGN_CALL:
7848 /* Keep track of which entry we are up to. */
7849 current_entry_id = code->ext.entry->id;
7853 resolve_where (code, NULL);
7857 if (code->expr1 != NULL)
7859 if (code->expr1->ts.type != BT_INTEGER)
7860 gfc_error ("ASSIGNED GOTO statement at %L requires an "
7861 "INTEGER variable", &code->expr1->where);
7862 else if (code->expr1->symtree->n.sym->attr.assign != 1)
7863 gfc_error ("Variable '%s' has not been assigned a target "
7864 "label at %L", code->expr1->symtree->n.sym->name,
7865 &code->expr1->where);
7868 resolve_branch (code->label1, code);
7872 if (code->expr1 != NULL
7873 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
7874 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
7875 "INTEGER return specifier", &code->expr1->where);
7878 case EXEC_INIT_ASSIGN:
7879 case EXEC_END_PROCEDURE:
7886 if (resolve_ordinary_assign (code, ns))
7888 if (code->op == EXEC_COMPCALL)
7895 case EXEC_LABEL_ASSIGN:
7896 if (code->label1->defined == ST_LABEL_UNKNOWN)
7897 gfc_error ("Label %d referenced at %L is never defined",
7898 code->label1->value, &code->label1->where);
7900 && (code->expr1->expr_type != EXPR_VARIABLE
7901 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
7902 || code->expr1->symtree->n.sym->ts.kind
7903 != gfc_default_integer_kind
7904 || code->expr1->symtree->n.sym->as != NULL))
7905 gfc_error ("ASSIGN statement at %L requires a scalar "
7906 "default INTEGER variable", &code->expr1->where);
7909 case EXEC_POINTER_ASSIGN:
7913 gfc_check_pointer_assign (code->expr1, code->expr2);
7916 case EXEC_ARITHMETIC_IF:
7918 && code->expr1->ts.type != BT_INTEGER
7919 && code->expr1->ts.type != BT_REAL)
7920 gfc_error ("Arithmetic IF statement at %L requires a numeric "
7921 "expression", &code->expr1->where);
7923 resolve_branch (code->label1, code);
7924 resolve_branch (code->label2, code);
7925 resolve_branch (code->label3, code);
7929 if (t == SUCCESS && code->expr1 != NULL
7930 && (code->expr1->ts.type != BT_LOGICAL
7931 || code->expr1->rank != 0))
7932 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7933 &code->expr1->where);
7938 resolve_call (code);
7943 if (code->expr1->symtree
7944 && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
7945 resolve_class_typebound_call (code);
7947 resolve_typebound_call (code);
7951 resolve_ppc_call (code);
7955 /* Select is complicated. Also, a SELECT construct could be
7956 a transformed computed GOTO. */
7957 resolve_select (code);
7960 case EXEC_SELECT_TYPE:
7961 resolve_select_type (code);
7965 gfc_resolve (code->ext.ns);
7969 if (code->ext.iterator != NULL)
7971 gfc_iterator *iter = code->ext.iterator;
7972 if (gfc_resolve_iterator (iter, true) != FAILURE)
7973 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
7978 if (code->expr1 == NULL)
7979 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
7981 && (code->expr1->rank != 0
7982 || code->expr1->ts.type != BT_LOGICAL))
7983 gfc_error ("Exit condition of DO WHILE loop at %L must be "
7984 "a scalar LOGICAL expression", &code->expr1->where);
7989 resolve_allocate_deallocate (code, "ALLOCATE");
7993 case EXEC_DEALLOCATE:
7995 resolve_allocate_deallocate (code, "DEALLOCATE");
8000 if (gfc_resolve_open (code->ext.open) == FAILURE)
8003 resolve_branch (code->ext.open->err, code);
8007 if (gfc_resolve_close (code->ext.close) == FAILURE)
8010 resolve_branch (code->ext.close->err, code);
8013 case EXEC_BACKSPACE:
8017 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
8020 resolve_branch (code->ext.filepos->err, code);
8024 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8027 resolve_branch (code->ext.inquire->err, code);
8031 gcc_assert (code->ext.inquire != NULL);
8032 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
8035 resolve_branch (code->ext.inquire->err, code);
8039 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
8042 resolve_branch (code->ext.wait->err, code);
8043 resolve_branch (code->ext.wait->end, code);
8044 resolve_branch (code->ext.wait->eor, code);
8049 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
8052 resolve_branch (code->ext.dt->err, code);
8053 resolve_branch (code->ext.dt->end, code);
8054 resolve_branch (code->ext.dt->eor, code);
8058 resolve_transfer (code);
8062 resolve_forall_iterators (code->ext.forall_iterator);
8064 if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
8065 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
8066 "expression", &code->expr1->where);
8069 case EXEC_OMP_ATOMIC:
8070 case EXEC_OMP_BARRIER:
8071 case EXEC_OMP_CRITICAL:
8072 case EXEC_OMP_FLUSH:
8074 case EXEC_OMP_MASTER:
8075 case EXEC_OMP_ORDERED:
8076 case EXEC_OMP_SECTIONS:
8077 case EXEC_OMP_SINGLE:
8078 case EXEC_OMP_TASKWAIT:
8079 case EXEC_OMP_WORKSHARE:
8080 gfc_resolve_omp_directive (code, ns);
8083 case EXEC_OMP_PARALLEL:
8084 case EXEC_OMP_PARALLEL_DO:
8085 case EXEC_OMP_PARALLEL_SECTIONS:
8086 case EXEC_OMP_PARALLEL_WORKSHARE:
8088 omp_workshare_save = omp_workshare_flag;
8089 omp_workshare_flag = 0;
8090 gfc_resolve_omp_directive (code, ns);
8091 omp_workshare_flag = omp_workshare_save;
8095 gfc_internal_error ("resolve_code(): Bad statement code");
8099 cs_base = frame.prev;
8103 /* Resolve initial values and make sure they are compatible with
8107 resolve_values (gfc_symbol *sym)
8109 if (sym->value == NULL)
8112 if (gfc_resolve_expr (sym->value) == FAILURE)
8115 gfc_check_assign_symbol (sym, sym->value);
8119 /* Verify the binding labels for common blocks that are BIND(C). The label
8120 for a BIND(C) common block must be identical in all scoping units in which
8121 the common block is declared. Further, the binding label can not collide
8122 with any other global entity in the program. */
8125 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
8127 if (comm_block_tree->n.common->is_bind_c == 1)
8129 gfc_gsymbol *binding_label_gsym;
8130 gfc_gsymbol *comm_name_gsym;
8132 /* See if a global symbol exists by the common block's name. It may
8133 be NULL if the common block is use-associated. */
8134 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
8135 comm_block_tree->n.common->name);
8136 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
8137 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
8138 "with the global entity '%s' at %L",
8139 comm_block_tree->n.common->binding_label,
8140 comm_block_tree->n.common->name,
8141 &(comm_block_tree->n.common->where),
8142 comm_name_gsym->name, &(comm_name_gsym->where));
8143 else if (comm_name_gsym != NULL
8144 && strcmp (comm_name_gsym->name,
8145 comm_block_tree->n.common->name) == 0)
8147 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
8149 if (comm_name_gsym->binding_label == NULL)
8150 /* No binding label for common block stored yet; save this one. */
8151 comm_name_gsym->binding_label =
8152 comm_block_tree->n.common->binding_label;
8154 if (strcmp (comm_name_gsym->binding_label,
8155 comm_block_tree->n.common->binding_label) != 0)
8157 /* Common block names match but binding labels do not. */
8158 gfc_error ("Binding label '%s' for common block '%s' at %L "
8159 "does not match the binding label '%s' for common "
8161 comm_block_tree->n.common->binding_label,
8162 comm_block_tree->n.common->name,
8163 &(comm_block_tree->n.common->where),
8164 comm_name_gsym->binding_label,
8165 comm_name_gsym->name,
8166 &(comm_name_gsym->where));
8171 /* There is no binding label (NAME="") so we have nothing further to
8172 check and nothing to add as a global symbol for the label. */
8173 if (comm_block_tree->n.common->binding_label[0] == '\0' )
8176 binding_label_gsym =
8177 gfc_find_gsymbol (gfc_gsym_root,
8178 comm_block_tree->n.common->binding_label);
8179 if (binding_label_gsym == NULL)
8181 /* Need to make a global symbol for the binding label to prevent
8182 it from colliding with another. */
8183 binding_label_gsym =
8184 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
8185 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
8186 binding_label_gsym->type = GSYM_COMMON;
8190 /* If comm_name_gsym is NULL, the name common block is use
8191 associated and the name could be colliding. */
8192 if (binding_label_gsym->type != GSYM_COMMON)
8193 gfc_error ("Binding label '%s' for common block '%s' at %L "
8194 "collides with the global entity '%s' at %L",
8195 comm_block_tree->n.common->binding_label,
8196 comm_block_tree->n.common->name,
8197 &(comm_block_tree->n.common->where),
8198 binding_label_gsym->name,
8199 &(binding_label_gsym->where));
8200 else if (comm_name_gsym != NULL
8201 && (strcmp (binding_label_gsym->name,
8202 comm_name_gsym->binding_label) != 0)
8203 && (strcmp (binding_label_gsym->sym_name,
8204 comm_name_gsym->name) != 0))
8205 gfc_error ("Binding label '%s' for common block '%s' at %L "
8206 "collides with global entity '%s' at %L",
8207 binding_label_gsym->name, binding_label_gsym->sym_name,
8208 &(comm_block_tree->n.common->where),
8209 comm_name_gsym->name, &(comm_name_gsym->where));
8217 /* Verify any BIND(C) derived types in the namespace so we can report errors
8218 for them once, rather than for each variable declared of that type. */
8221 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
8223 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
8224 && derived_sym->attr.is_bind_c == 1)
8225 verify_bind_c_derived_type (derived_sym);
8231 /* Verify that any binding labels used in a given namespace do not collide
8232 with the names or binding labels of any global symbols. */
8235 gfc_verify_binding_labels (gfc_symbol *sym)
8239 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
8240 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
8242 gfc_gsymbol *bind_c_sym;
8244 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
8245 if (bind_c_sym != NULL
8246 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
8248 if (sym->attr.if_source == IFSRC_DECL
8249 && (bind_c_sym->type != GSYM_SUBROUTINE
8250 && bind_c_sym->type != GSYM_FUNCTION)
8251 && ((sym->attr.contained == 1
8252 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
8253 || (sym->attr.use_assoc == 1
8254 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
8256 /* Make sure global procedures don't collide with anything. */
8257 gfc_error ("Binding label '%s' at %L collides with the global "
8258 "entity '%s' at %L", sym->binding_label,
8259 &(sym->declared_at), bind_c_sym->name,
8260 &(bind_c_sym->where));
8263 else if (sym->attr.contained == 0
8264 && (sym->attr.if_source == IFSRC_IFBODY
8265 && sym->attr.flavor == FL_PROCEDURE)
8266 && (bind_c_sym->sym_name != NULL
8267 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
8269 /* Make sure procedures in interface bodies don't collide. */
8270 gfc_error ("Binding label '%s' in interface body at %L collides "
8271 "with the global entity '%s' at %L",
8273 &(sym->declared_at), bind_c_sym->name,
8274 &(bind_c_sym->where));
8277 else if (sym->attr.contained == 0
8278 && sym->attr.if_source == IFSRC_UNKNOWN)
8279 if ((sym->attr.use_assoc && bind_c_sym->mod_name
8280 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
8281 || sym->attr.use_assoc == 0)
8283 gfc_error ("Binding label '%s' at %L collides with global "
8284 "entity '%s' at %L", sym->binding_label,
8285 &(sym->declared_at), bind_c_sym->name,
8286 &(bind_c_sym->where));
8291 /* Clear the binding label to prevent checking multiple times. */
8292 sym->binding_label[0] = '\0';
8294 else if (bind_c_sym == NULL)
8296 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
8297 bind_c_sym->where = sym->declared_at;
8298 bind_c_sym->sym_name = sym->name;
8300 if (sym->attr.use_assoc == 1)
8301 bind_c_sym->mod_name = sym->module;
8303 if (sym->ns->proc_name != NULL)
8304 bind_c_sym->mod_name = sym->ns->proc_name->name;
8306 if (sym->attr.contained == 0)
8308 if (sym->attr.subroutine)
8309 bind_c_sym->type = GSYM_SUBROUTINE;
8310 else if (sym->attr.function)
8311 bind_c_sym->type = GSYM_FUNCTION;
8319 /* Resolve an index expression. */
8322 resolve_index_expr (gfc_expr *e)
8324 if (gfc_resolve_expr (e) == FAILURE)
8327 if (gfc_simplify_expr (e, 0) == FAILURE)
8330 if (gfc_specification_expr (e) == FAILURE)
8336 /* Resolve a charlen structure. */
8339 resolve_charlen (gfc_charlen *cl)
8348 specification_expr = 1;
8350 if (resolve_index_expr (cl->length) == FAILURE)
8352 specification_expr = 0;
8356 /* "If the character length parameter value evaluates to a negative
8357 value, the length of character entities declared is zero." */
8358 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
8360 gfc_warning_now ("CHARACTER variable has zero length at %L",
8361 &cl->length->where);
8362 gfc_replace_expr (cl->length, gfc_int_expr (0));
8365 /* Check that the character length is not too large. */
8366 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
8367 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
8368 && cl->length->ts.type == BT_INTEGER
8369 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
8371 gfc_error ("String length at %L is too large", &cl->length->where);
8379 /* Test for non-constant shape arrays. */
8382 is_non_constant_shape_array (gfc_symbol *sym)
8388 not_constant = false;
8389 if (sym->as != NULL)
8391 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
8392 has not been simplified; parameter array references. Do the
8393 simplification now. */
8394 for (i = 0; i < sym->as->rank; i++)
8396 e = sym->as->lower[i];
8397 if (e && (resolve_index_expr (e) == FAILURE
8398 || !gfc_is_constant_expr (e)))
8399 not_constant = true;
8401 e = sym->as->upper[i];
8402 if (e && (resolve_index_expr (e) == FAILURE
8403 || !gfc_is_constant_expr (e)))
8404 not_constant = true;
8407 return not_constant;
8410 /* Given a symbol and an initialization expression, add code to initialize
8411 the symbol to the function entry. */
8413 build_init_assign (gfc_symbol *sym, gfc_expr *init)
8417 gfc_namespace *ns = sym->ns;
8419 /* Search for the function namespace if this is a contained
8420 function without an explicit result. */
8421 if (sym->attr.function && sym == sym->result
8422 && sym->name != sym->ns->proc_name->name)
8425 for (;ns; ns = ns->sibling)
8426 if (strcmp (ns->proc_name->name, sym->name) == 0)
8432 gfc_free_expr (init);
8436 /* Build an l-value expression for the result. */
8437 lval = gfc_lval_expr_from_sym (sym);
8439 /* Add the code at scope entry. */
8440 init_st = gfc_get_code ();
8441 init_st->next = ns->code;
8444 /* Assign the default initializer to the l-value. */
8445 init_st->loc = sym->declared_at;
8446 init_st->op = EXEC_INIT_ASSIGN;
8447 init_st->expr1 = lval;
8448 init_st->expr2 = init;
8451 /* Assign the default initializer to a derived type variable or result. */
8454 apply_default_init (gfc_symbol *sym)
8456 gfc_expr *init = NULL;
8458 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
8461 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
8462 init = gfc_default_initializer (&sym->ts);
8467 build_init_assign (sym, init);
8470 /* Build an initializer for a local integer, real, complex, logical, or
8471 character variable, based on the command line flags finit-local-zero,
8472 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
8473 null if the symbol should not have a default initialization. */
8475 build_default_init_expr (gfc_symbol *sym)
8478 gfc_expr *init_expr;
8481 /* These symbols should never have a default initialization. */
8482 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
8483 || sym->attr.external
8485 || sym->attr.pointer
8486 || sym->attr.in_equivalence
8487 || sym->attr.in_common
8490 || sym->attr.cray_pointee
8491 || sym->attr.cray_pointer)
8494 /* Now we'll try to build an initializer expression. */
8495 init_expr = gfc_get_expr ();
8496 init_expr->expr_type = EXPR_CONSTANT;
8497 init_expr->ts.type = sym->ts.type;
8498 init_expr->ts.kind = sym->ts.kind;
8499 init_expr->where = sym->declared_at;
8501 /* We will only initialize integers, reals, complex, logicals, and
8502 characters, and only if the corresponding command-line flags
8503 were set. Otherwise, we free init_expr and return null. */
8504 switch (sym->ts.type)
8507 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
8508 mpz_init_set_si (init_expr->value.integer,
8509 gfc_option.flag_init_integer_value);
8512 gfc_free_expr (init_expr);
8518 mpfr_init (init_expr->value.real);
8519 switch (gfc_option.flag_init_real)
8521 case GFC_INIT_REAL_SNAN:
8522 init_expr->is_snan = 1;
8524 case GFC_INIT_REAL_NAN:
8525 mpfr_set_nan (init_expr->value.real);
8528 case GFC_INIT_REAL_INF:
8529 mpfr_set_inf (init_expr->value.real, 1);
8532 case GFC_INIT_REAL_NEG_INF:
8533 mpfr_set_inf (init_expr->value.real, -1);
8536 case GFC_INIT_REAL_ZERO:
8537 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
8541 gfc_free_expr (init_expr);
8549 mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
8551 mpfr_init (init_expr->value.complex.r);
8552 mpfr_init (init_expr->value.complex.i);
8554 switch (gfc_option.flag_init_real)
8556 case GFC_INIT_REAL_SNAN:
8557 init_expr->is_snan = 1;
8559 case GFC_INIT_REAL_NAN:
8560 mpfr_set_nan (mpc_realref (init_expr->value.complex));
8561 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
8564 case GFC_INIT_REAL_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_NEG_INF:
8570 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
8571 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
8574 case GFC_INIT_REAL_ZERO:
8576 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
8578 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
8579 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
8584 gfc_free_expr (init_expr);
8591 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
8592 init_expr->value.logical = 0;
8593 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
8594 init_expr->value.logical = 1;
8597 gfc_free_expr (init_expr);
8603 /* For characters, the length must be constant in order to
8604 create a default initializer. */
8605 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
8606 && sym->ts.u.cl->length
8607 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8609 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
8610 init_expr->value.character.length = char_len;
8611 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
8612 for (i = 0; i < char_len; i++)
8613 init_expr->value.character.string[i]
8614 = (unsigned char) gfc_option.flag_init_character_value;
8618 gfc_free_expr (init_expr);
8624 gfc_free_expr (init_expr);
8630 /* Add an initialization expression to a local variable. */
8632 apply_default_init_local (gfc_symbol *sym)
8634 gfc_expr *init = NULL;
8636 /* The symbol should be a variable or a function return value. */
8637 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
8638 || (sym->attr.function && sym->result != sym))
8641 /* Try to build the initializer expression. If we can't initialize
8642 this symbol, then init will be NULL. */
8643 init = build_default_init_expr (sym);
8647 /* For saved variables, we don't want to add an initializer at
8648 function entry, so we just add a static initializer. */
8649 if (sym->attr.save || sym->ns->save_all
8650 || gfc_option.flag_max_stack_var_size == 0)
8652 /* Don't clobber an existing initializer! */
8653 gcc_assert (sym->value == NULL);
8658 build_init_assign (sym, init);
8661 /* Resolution of common features of flavors variable and procedure. */
8664 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
8666 /* Constraints on deferred shape variable. */
8667 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
8669 if (sym->attr.allocatable)
8671 if (sym->attr.dimension)
8673 gfc_error ("Allocatable array '%s' at %L must have "
8674 "a deferred shape", sym->name, &sym->declared_at);
8677 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
8678 "may not be ALLOCATABLE", sym->name,
8679 &sym->declared_at) == FAILURE)
8683 if (sym->attr.pointer && sym->attr.dimension)
8685 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
8686 sym->name, &sym->declared_at);
8693 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
8694 && !sym->attr.dummy && sym->ts.type != BT_CLASS)
8696 gfc_error ("Array '%s' at %L cannot have a deferred shape",
8697 sym->name, &sym->declared_at);
8705 /* Additional checks for symbols with flavor variable and derived
8706 type. To be called from resolve_fl_variable. */
8709 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
8711 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
8713 /* Check to see if a derived type is blocked from being host
8714 associated by the presence of another class I symbol in the same
8715 namespace. 14.6.1.3 of the standard and the discussion on
8716 comp.lang.fortran. */
8717 if (sym->ns != sym->ts.u.derived->ns
8718 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
8721 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
8722 if (s && s->attr.flavor != FL_DERIVED)
8724 gfc_error ("The type '%s' cannot be host associated at %L "
8725 "because it is blocked by an incompatible object "
8726 "of the same name declared at %L",
8727 sym->ts.u.derived->name, &sym->declared_at,
8733 /* 4th constraint in section 11.3: "If an object of a type for which
8734 component-initialization is specified (R429) appears in the
8735 specification-part of a module and does not have the ALLOCATABLE
8736 or POINTER attribute, the object shall have the SAVE attribute."
8738 The check for initializers is performed with
8739 has_default_initializer because gfc_default_initializer generates
8740 a hidden default for allocatable components. */
8741 if (!(sym->value || no_init_flag) && sym->ns->proc_name
8742 && sym->ns->proc_name->attr.flavor == FL_MODULE
8743 && !sym->ns->save_all && !sym->attr.save
8744 && !sym->attr.pointer && !sym->attr.allocatable
8745 && has_default_initializer (sym->ts.u.derived))
8747 gfc_error("Object '%s' at %L must have the SAVE attribute for "
8748 "default initialization of a component",
8749 sym->name, &sym->declared_at);
8753 if (sym->ts.type == BT_CLASS)
8756 if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
8758 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
8759 sym->ts.u.derived->name, sym->name, &sym->declared_at);
8764 /* Assume that use associated symbols were checked in the module ns. */
8765 if (!sym->attr.class_ok && !sym->attr.use_assoc)
8767 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
8768 "or pointer", sym->name, &sym->declared_at);
8773 /* Assign default initializer. */
8774 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
8775 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
8777 sym->value = gfc_default_initializer (&sym->ts);
8784 /* Resolve symbols with flavor variable. */
8787 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
8789 int no_init_flag, automatic_flag;
8791 const char *auto_save_msg;
8793 auto_save_msg = "Automatic object '%s' at %L cannot have the "
8796 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
8799 /* Set this flag to check that variables are parameters of all entries.
8800 This check is effected by the call to gfc_resolve_expr through
8801 is_non_constant_shape_array. */
8802 specification_expr = 1;
8804 if (sym->ns->proc_name
8805 && (sym->ns->proc_name->attr.flavor == FL_MODULE
8806 || sym->ns->proc_name->attr.is_main_program)
8807 && !sym->attr.use_assoc
8808 && !sym->attr.allocatable
8809 && !sym->attr.pointer
8810 && is_non_constant_shape_array (sym))
8812 /* The shape of a main program or module array needs to be
8814 gfc_error ("The module or main program array '%s' at %L must "
8815 "have constant shape", sym->name, &sym->declared_at);
8816 specification_expr = 0;
8820 if (sym->ts.type == BT_CHARACTER)
8822 /* Make sure that character string variables with assumed length are
8824 e = sym->ts.u.cl->length;
8825 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
8827 gfc_error ("Entity with assumed character length at %L must be a "
8828 "dummy argument or a PARAMETER", &sym->declared_at);
8832 if (e && sym->attr.save && !gfc_is_constant_expr (e))
8834 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
8838 if (!gfc_is_constant_expr (e)
8839 && !(e->expr_type == EXPR_VARIABLE
8840 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
8841 && sym->ns->proc_name
8842 && (sym->ns->proc_name->attr.flavor == FL_MODULE
8843 || sym->ns->proc_name->attr.is_main_program)
8844 && !sym->attr.use_assoc)
8846 gfc_error ("'%s' at %L must have constant character length "
8847 "in this context", sym->name, &sym->declared_at);
8852 if (sym->value == NULL && sym->attr.referenced)
8853 apply_default_init_local (sym); /* Try to apply a default initialization. */
8855 /* Determine if the symbol may not have an initializer. */
8856 no_init_flag = automatic_flag = 0;
8857 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
8858 || sym->attr.intrinsic || sym->attr.result)
8860 else if (sym->attr.dimension && !sym->attr.pointer
8861 && is_non_constant_shape_array (sym))
8863 no_init_flag = automatic_flag = 1;
8865 /* Also, they must not have the SAVE attribute.
8866 SAVE_IMPLICIT is checked below. */
8867 if (sym->attr.save == SAVE_EXPLICIT)
8869 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
8874 /* Ensure that any initializer is simplified. */
8876 gfc_simplify_expr (sym->value, 1);
8878 /* Reject illegal initializers. */
8879 if (!sym->mark && sym->value)
8881 if (sym->attr.allocatable)
8882 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
8883 sym->name, &sym->declared_at);
8884 else if (sym->attr.external)
8885 gfc_error ("External '%s' at %L cannot have an initializer",
8886 sym->name, &sym->declared_at);
8887 else if (sym->attr.dummy
8888 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
8889 gfc_error ("Dummy '%s' at %L cannot have an initializer",
8890 sym->name, &sym->declared_at);
8891 else if (sym->attr.intrinsic)
8892 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
8893 sym->name, &sym->declared_at);
8894 else if (sym->attr.result)
8895 gfc_error ("Function result '%s' at %L cannot have an initializer",
8896 sym->name, &sym->declared_at);
8897 else if (automatic_flag)
8898 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
8899 sym->name, &sym->declared_at);
8906 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
8907 return resolve_fl_variable_derived (sym, no_init_flag);
8913 /* Resolve a procedure. */
8916 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
8918 gfc_formal_arglist *arg;
8920 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
8921 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
8922 "interfaces", sym->name, &sym->declared_at);
8924 if (sym->attr.function
8925 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
8928 if (sym->ts.type == BT_CHARACTER)
8930 gfc_charlen *cl = sym->ts.u.cl;
8932 if (cl && cl->length && gfc_is_constant_expr (cl->length)
8933 && resolve_charlen (cl) == FAILURE)
8936 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
8938 if (sym->attr.proc == PROC_ST_FUNCTION)
8940 gfc_error ("Character-valued statement function '%s' at %L must "
8941 "have constant length", sym->name, &sym->declared_at);
8945 if (sym->attr.external && sym->formal == NULL
8946 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
8948 gfc_error ("Automatic character length function '%s' at %L must "
8949 "have an explicit interface", sym->name,
8956 /* Ensure that derived type for are not of a private type. Internal
8957 module procedures are excluded by 2.2.3.3 - i.e., they are not
8958 externally accessible and can access all the objects accessible in
8960 if (!(sym->ns->parent
8961 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
8962 && gfc_check_access(sym->attr.access, sym->ns->default_access))
8964 gfc_interface *iface;
8966 for (arg = sym->formal; arg; arg = arg->next)
8969 && arg->sym->ts.type == BT_DERIVED
8970 && !arg->sym->ts.u.derived->attr.use_assoc
8971 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
8972 arg->sym->ts.u.derived->ns->default_access)
8973 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
8974 "PRIVATE type and cannot be a dummy argument"
8975 " of '%s', which is PUBLIC at %L",
8976 arg->sym->name, sym->name, &sym->declared_at)
8979 /* Stop this message from recurring. */
8980 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
8985 /* PUBLIC interfaces may expose PRIVATE procedures that take types
8986 PRIVATE to the containing module. */
8987 for (iface = sym->generic; iface; iface = iface->next)
8989 for (arg = iface->sym->formal; arg; arg = arg->next)
8992 && arg->sym->ts.type == BT_DERIVED
8993 && !arg->sym->ts.u.derived->attr.use_assoc
8994 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
8995 arg->sym->ts.u.derived->ns->default_access)
8996 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
8997 "'%s' in PUBLIC interface '%s' at %L "
8998 "takes dummy arguments of '%s' which is "
8999 "PRIVATE", iface->sym->name, sym->name,
9000 &iface->sym->declared_at,
9001 gfc_typename (&arg->sym->ts)) == FAILURE)
9003 /* Stop this message from recurring. */
9004 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9010 /* PUBLIC interfaces may expose PRIVATE procedures that take types
9011 PRIVATE to the containing module. */
9012 for (iface = sym->generic; iface; iface = iface->next)
9014 for (arg = iface->sym->formal; arg; arg = arg->next)
9017 && arg->sym->ts.type == BT_DERIVED
9018 && !arg->sym->ts.u.derived->attr.use_assoc
9019 && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
9020 arg->sym->ts.u.derived->ns->default_access)
9021 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
9022 "'%s' in PUBLIC interface '%s' at %L "
9023 "takes dummy arguments of '%s' which is "
9024 "PRIVATE", iface->sym->name, sym->name,
9025 &iface->sym->declared_at,
9026 gfc_typename (&arg->sym->ts)) == FAILURE)
9028 /* Stop this message from recurring. */
9029 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
9036 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
9037 && !sym->attr.proc_pointer)
9039 gfc_error ("Function '%s' at %L cannot have an initializer",
9040 sym->name, &sym->declared_at);
9044 /* An external symbol may not have an initializer because it is taken to be
9045 a procedure. Exception: Procedure Pointers. */
9046 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
9048 gfc_error ("External object '%s' at %L may not have an initializer",
9049 sym->name, &sym->declared_at);
9053 /* An elemental function is required to return a scalar 12.7.1 */
9054 if (sym->attr.elemental && sym->attr.function && sym->as)
9056 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
9057 "result", sym->name, &sym->declared_at);
9058 /* Reset so that the error only occurs once. */
9059 sym->attr.elemental = 0;
9063 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
9064 char-len-param shall not be array-valued, pointer-valued, recursive
9065 or pure. ....snip... A character value of * may only be used in the
9066 following ways: (i) Dummy arg of procedure - dummy associates with
9067 actual length; (ii) To declare a named constant; or (iii) External
9068 function - but length must be declared in calling scoping unit. */
9069 if (sym->attr.function
9070 && sym->ts.type == BT_CHARACTER
9071 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
9073 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
9074 || (sym->attr.recursive) || (sym->attr.pure))
9076 if (sym->as && sym->as->rank)
9077 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9078 "array-valued", sym->name, &sym->declared_at);
9080 if (sym->attr.pointer)
9081 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9082 "pointer-valued", sym->name, &sym->declared_at);
9085 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9086 "pure", sym->name, &sym->declared_at);
9088 if (sym->attr.recursive)
9089 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
9090 "recursive", sym->name, &sym->declared_at);
9095 /* Appendix B.2 of the standard. Contained functions give an
9096 error anyway. Fixed-form is likely to be F77/legacy. */
9097 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
9098 gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
9099 "CHARACTER(*) function '%s' at %L",
9100 sym->name, &sym->declared_at);
9103 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
9105 gfc_formal_arglist *curr_arg;
9106 int has_non_interop_arg = 0;
9108 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
9109 sym->common_block) == FAILURE)
9111 /* Clear these to prevent looking at them again if there was an
9113 sym->attr.is_bind_c = 0;
9114 sym->attr.is_c_interop = 0;
9115 sym->ts.is_c_interop = 0;
9119 /* So far, no errors have been found. */
9120 sym->attr.is_c_interop = 1;
9121 sym->ts.is_c_interop = 1;
9124 curr_arg = sym->formal;
9125 while (curr_arg != NULL)
9127 /* Skip implicitly typed dummy args here. */
9128 if (curr_arg->sym->attr.implicit_type == 0)
9129 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
9130 /* If something is found to fail, record the fact so we
9131 can mark the symbol for the procedure as not being
9132 BIND(C) to try and prevent multiple errors being
9134 has_non_interop_arg = 1;
9136 curr_arg = curr_arg->next;
9139 /* See if any of the arguments were not interoperable and if so, clear
9140 the procedure symbol to prevent duplicate error messages. */
9141 if (has_non_interop_arg != 0)
9143 sym->attr.is_c_interop = 0;
9144 sym->ts.is_c_interop = 0;
9145 sym->attr.is_bind_c = 0;
9149 if (!sym->attr.proc_pointer)
9151 if (sym->attr.save == SAVE_EXPLICIT)
9153 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
9154 "in '%s' at %L", sym->name, &sym->declared_at);
9157 if (sym->attr.intent)
9159 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
9160 "in '%s' at %L", sym->name, &sym->declared_at);
9163 if (sym->attr.subroutine && sym->attr.result)
9165 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
9166 "in '%s' at %L", sym->name, &sym->declared_at);
9169 if (sym->attr.external && sym->attr.function
9170 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
9171 || sym->attr.contained))
9173 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
9174 "in '%s' at %L", sym->name, &sym->declared_at);
9177 if (strcmp ("ppr@", sym->name) == 0)
9179 gfc_error ("Procedure pointer result '%s' at %L "
9180 "is missing the pointer attribute",
9181 sym->ns->proc_name->name, &sym->declared_at);
9190 /* Resolve a list of finalizer procedures. That is, after they have hopefully
9191 been defined and we now know their defined arguments, check that they fulfill
9192 the requirements of the standard for procedures used as finalizers. */
9195 gfc_resolve_finalizers (gfc_symbol* derived)
9197 gfc_finalizer* list;
9198 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
9199 gfc_try result = SUCCESS;
9200 bool seen_scalar = false;
9202 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
9205 /* Walk over the list of finalizer-procedures, check them, and if any one
9206 does not fit in with the standard's definition, print an error and remove
9207 it from the list. */
9208 prev_link = &derived->f2k_derived->finalizers;
9209 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
9215 /* Skip this finalizer if we already resolved it. */
9216 if (list->proc_tree)
9218 prev_link = &(list->next);
9222 /* Check this exists and is a SUBROUTINE. */
9223 if (!list->proc_sym->attr.subroutine)
9225 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
9226 list->proc_sym->name, &list->where);
9230 /* We should have exactly one argument. */
9231 if (!list->proc_sym->formal || list->proc_sym->formal->next)
9233 gfc_error ("FINAL procedure at %L must have exactly one argument",
9237 arg = list->proc_sym->formal->sym;
9239 /* This argument must be of our type. */
9240 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
9242 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
9243 &arg->declared_at, derived->name);
9247 /* It must neither be a pointer nor allocatable nor optional. */
9248 if (arg->attr.pointer)
9250 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
9254 if (arg->attr.allocatable)
9256 gfc_error ("Argument of FINAL procedure at %L must not be"
9257 " ALLOCATABLE", &arg->declared_at);
9260 if (arg->attr.optional)
9262 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
9267 /* It must not be INTENT(OUT). */
9268 if (arg->attr.intent == INTENT_OUT)
9270 gfc_error ("Argument of FINAL procedure at %L must not be"
9271 " INTENT(OUT)", &arg->declared_at);
9275 /* Warn if the procedure is non-scalar and not assumed shape. */
9276 if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
9277 && arg->as->type != AS_ASSUMED_SHAPE)
9278 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
9279 " shape argument", &arg->declared_at);
9281 /* Check that it does not match in kind and rank with a FINAL procedure
9282 defined earlier. To really loop over the *earlier* declarations,
9283 we need to walk the tail of the list as new ones were pushed at the
9285 /* TODO: Handle kind parameters once they are implemented. */
9286 my_rank = (arg->as ? arg->as->rank : 0);
9287 for (i = list->next; i; i = i->next)
9289 /* Argument list might be empty; that is an error signalled earlier,
9290 but we nevertheless continued resolving. */
9291 if (i->proc_sym->formal)
9293 gfc_symbol* i_arg = i->proc_sym->formal->sym;
9294 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
9295 if (i_rank == my_rank)
9297 gfc_error ("FINAL procedure '%s' declared at %L has the same"
9298 " rank (%d) as '%s'",
9299 list->proc_sym->name, &list->where, my_rank,
9306 /* Is this the/a scalar finalizer procedure? */
9307 if (!arg->as || arg->as->rank == 0)
9310 /* Find the symtree for this procedure. */
9311 gcc_assert (!list->proc_tree);
9312 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
9314 prev_link = &list->next;
9317 /* Remove wrong nodes immediately from the list so we don't risk any
9318 troubles in the future when they might fail later expectations. */
9322 *prev_link = list->next;
9323 gfc_free_finalizer (i);
9326 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
9327 were nodes in the list, must have been for arrays. It is surely a good
9328 idea to have a scalar version there if there's something to finalize. */
9329 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
9330 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
9331 " defined at %L, suggest also scalar one",
9332 derived->name, &derived->declared_at);
9334 /* TODO: Remove this error when finalization is finished. */
9335 gfc_error ("Finalization at %L is not yet implemented",
9336 &derived->declared_at);
9342 /* Check that it is ok for the typebound procedure proc to override the
9346 check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
9349 const gfc_symbol* proc_target;
9350 const gfc_symbol* old_target;
9351 unsigned proc_pass_arg, old_pass_arg, argpos;
9352 gfc_formal_arglist* proc_formal;
9353 gfc_formal_arglist* old_formal;
9355 /* This procedure should only be called for non-GENERIC proc. */
9356 gcc_assert (!proc->n.tb->is_generic);
9358 /* If the overwritten procedure is GENERIC, this is an error. */
9359 if (old->n.tb->is_generic)
9361 gfc_error ("Can't overwrite GENERIC '%s' at %L",
9362 old->name, &proc->n.tb->where);
9366 where = proc->n.tb->where;
9367 proc_target = proc->n.tb->u.specific->n.sym;
9368 old_target = old->n.tb->u.specific->n.sym;
9370 /* Check that overridden binding is not NON_OVERRIDABLE. */
9371 if (old->n.tb->non_overridable)
9373 gfc_error ("'%s' at %L overrides a procedure binding declared"
9374 " NON_OVERRIDABLE", proc->name, &where);
9378 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
9379 if (!old->n.tb->deferred && proc->n.tb->deferred)
9381 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
9382 " non-DEFERRED binding", proc->name, &where);
9386 /* If the overridden binding is PURE, the overriding must be, too. */
9387 if (old_target->attr.pure && !proc_target->attr.pure)
9389 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
9390 proc->name, &where);
9394 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
9395 is not, the overriding must not be either. */
9396 if (old_target->attr.elemental && !proc_target->attr.elemental)
9398 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
9399 " ELEMENTAL", proc->name, &where);
9402 if (!old_target->attr.elemental && proc_target->attr.elemental)
9404 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
9405 " be ELEMENTAL, either", proc->name, &where);
9409 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
9411 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
9413 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
9414 " SUBROUTINE", proc->name, &where);
9418 /* If the overridden binding is a FUNCTION, the overriding must also be a
9419 FUNCTION and have the same characteristics. */
9420 if (old_target->attr.function)
9422 if (!proc_target->attr.function)
9424 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
9425 " FUNCTION", proc->name, &where);
9429 /* FIXME: Do more comprehensive checking (including, for instance, the
9430 rank and array-shape). */
9431 gcc_assert (proc_target->result && old_target->result);
9432 if (!gfc_compare_types (&proc_target->result->ts,
9433 &old_target->result->ts))
9435 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
9436 " matching result types", proc->name, &where);
9441 /* If the overridden binding is PUBLIC, the overriding one must not be
9443 if (old->n.tb->access == ACCESS_PUBLIC
9444 && proc->n.tb->access == ACCESS_PRIVATE)
9446 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
9447 " PRIVATE", proc->name, &where);
9451 /* Compare the formal argument lists of both procedures. This is also abused
9452 to find the position of the passed-object dummy arguments of both
9453 bindings as at least the overridden one might not yet be resolved and we
9454 need those positions in the check below. */
9455 proc_pass_arg = old_pass_arg = 0;
9456 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
9458 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
9461 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
9462 proc_formal && old_formal;
9463 proc_formal = proc_formal->next, old_formal = old_formal->next)
9465 if (proc->n.tb->pass_arg
9466 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
9467 proc_pass_arg = argpos;
9468 if (old->n.tb->pass_arg
9469 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
9470 old_pass_arg = argpos;
9472 /* Check that the names correspond. */
9473 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
9475 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
9476 " to match the corresponding argument of the overridden"
9477 " procedure", proc_formal->sym->name, proc->name, &where,
9478 old_formal->sym->name);
9482 /* Check that the types correspond if neither is the passed-object
9484 /* FIXME: Do more comprehensive testing here. */
9485 if (proc_pass_arg != argpos && old_pass_arg != argpos
9486 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
9488 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
9489 "in respect to the overridden procedure",
9490 proc_formal->sym->name, proc->name, &where);
9496 if (proc_formal || old_formal)
9498 gfc_error ("'%s' at %L must have the same number of formal arguments as"
9499 " the overridden procedure", proc->name, &where);
9503 /* If the overridden binding is NOPASS, the overriding one must also be
9505 if (old->n.tb->nopass && !proc->n.tb->nopass)
9507 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
9508 " NOPASS", proc->name, &where);
9512 /* If the overridden binding is PASS(x), the overriding one must also be
9513 PASS and the passed-object dummy arguments must correspond. */
9514 if (!old->n.tb->nopass)
9516 if (proc->n.tb->nopass)
9518 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
9519 " PASS", proc->name, &where);
9523 if (proc_pass_arg != old_pass_arg)
9525 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
9526 " the same position as the passed-object dummy argument of"
9527 " the overridden procedure", proc->name, &where);
9536 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
9539 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
9540 const char* generic_name, locus where)
9545 gcc_assert (t1->specific && t2->specific);
9546 gcc_assert (!t1->specific->is_generic);
9547 gcc_assert (!t2->specific->is_generic);
9549 sym1 = t1->specific->u.specific->n.sym;
9550 sym2 = t2->specific->u.specific->n.sym;
9555 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
9556 if (sym1->attr.subroutine != sym2->attr.subroutine
9557 || sym1->attr.function != sym2->attr.function)
9559 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
9560 " GENERIC '%s' at %L",
9561 sym1->name, sym2->name, generic_name, &where);
9565 /* Compare the interfaces. */
9566 if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0))
9568 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
9569 sym1->name, sym2->name, generic_name, &where);
9577 /* Worker function for resolving a generic procedure binding; this is used to
9578 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
9580 The difference between those cases is finding possible inherited bindings
9581 that are overridden, as one has to look for them in tb_sym_root,
9582 tb_uop_root or tb_op, respectively. Thus the caller must already find
9583 the super-type and set p->overridden correctly. */
9586 resolve_tb_generic_targets (gfc_symbol* super_type,
9587 gfc_typebound_proc* p, const char* name)
9589 gfc_tbp_generic* target;
9590 gfc_symtree* first_target;
9591 gfc_symtree* inherited;
9593 gcc_assert (p && p->is_generic);
9595 /* Try to find the specific bindings for the symtrees in our target-list. */
9596 gcc_assert (p->u.generic);
9597 for (target = p->u.generic; target; target = target->next)
9598 if (!target->specific)
9600 gfc_typebound_proc* overridden_tbp;
9602 const char* target_name;
9604 target_name = target->specific_st->name;
9606 /* Defined for this type directly. */
9607 if (target->specific_st->n.tb)
9609 target->specific = target->specific_st->n.tb;
9610 goto specific_found;
9613 /* Look for an inherited specific binding. */
9616 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
9621 gcc_assert (inherited->n.tb);
9622 target->specific = inherited->n.tb;
9623 goto specific_found;
9627 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
9628 " at %L", target_name, name, &p->where);
9631 /* Once we've found the specific binding, check it is not ambiguous with
9632 other specifics already found or inherited for the same GENERIC. */
9634 gcc_assert (target->specific);
9636 /* This must really be a specific binding! */
9637 if (target->specific->is_generic)
9639 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
9640 " '%s' is GENERIC, too", name, &p->where, target_name);
9644 /* Check those already resolved on this type directly. */
9645 for (g = p->u.generic; g; g = g->next)
9646 if (g != target && g->specific
9647 && check_generic_tbp_ambiguity (target, g, name, p->where)
9651 /* Check for ambiguity with inherited specific targets. */
9652 for (overridden_tbp = p->overridden; overridden_tbp;
9653 overridden_tbp = overridden_tbp->overridden)
9654 if (overridden_tbp->is_generic)
9656 for (g = overridden_tbp->u.generic; g; g = g->next)
9658 gcc_assert (g->specific);
9659 if (check_generic_tbp_ambiguity (target, g,
9660 name, p->where) == FAILURE)
9666 /* If we attempt to "overwrite" a specific binding, this is an error. */
9667 if (p->overridden && !p->overridden->is_generic)
9669 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
9670 " the same name", name, &p->where);
9674 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
9675 all must have the same attributes here. */
9676 first_target = p->u.generic->specific->u.specific;
9677 gcc_assert (first_target);
9678 p->subroutine = first_target->n.sym->attr.subroutine;
9679 p->function = first_target->n.sym->attr.function;
9685 /* Resolve a GENERIC procedure binding for a derived type. */
9688 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
9690 gfc_symbol* super_type;
9692 /* Find the overridden binding if any. */
9693 st->n.tb->overridden = NULL;
9694 super_type = gfc_get_derived_super_type (derived);
9697 gfc_symtree* overridden;
9698 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
9701 if (overridden && overridden->n.tb)
9702 st->n.tb->overridden = overridden->n.tb;
9705 /* Resolve using worker function. */
9706 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
9710 /* Retrieve the target-procedure of an operator binding and do some checks in
9711 common for intrinsic and user-defined type-bound operators. */
9714 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
9716 gfc_symbol* target_proc;
9718 gcc_assert (target->specific && !target->specific->is_generic);
9719 target_proc = target->specific->u.specific->n.sym;
9720 gcc_assert (target_proc);
9722 /* All operator bindings must have a passed-object dummy argument. */
9723 if (target->specific->nopass)
9725 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
9733 /* Resolve a type-bound intrinsic operator. */
9736 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
9737 gfc_typebound_proc* p)
9739 gfc_symbol* super_type;
9740 gfc_tbp_generic* target;
9742 /* If there's already an error here, do nothing (but don't fail again). */
9746 /* Operators should always be GENERIC bindings. */
9747 gcc_assert (p->is_generic);
9749 /* Look for an overridden binding. */
9750 super_type = gfc_get_derived_super_type (derived);
9751 if (super_type && super_type->f2k_derived)
9752 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
9755 p->overridden = NULL;
9757 /* Resolve general GENERIC properties using worker function. */
9758 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
9761 /* Check the targets to be procedures of correct interface. */
9762 for (target = p->u.generic; target; target = target->next)
9764 gfc_symbol* target_proc;
9766 target_proc = get_checked_tb_operator_target (target, p->where);
9770 if (!gfc_check_operator_interface (target_proc, op, p->where))
9782 /* Resolve a type-bound user operator (tree-walker callback). */
9784 static gfc_symbol* resolve_bindings_derived;
9785 static gfc_try resolve_bindings_result;
9787 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
9790 resolve_typebound_user_op (gfc_symtree* stree)
9792 gfc_symbol* super_type;
9793 gfc_tbp_generic* target;
9795 gcc_assert (stree && stree->n.tb);
9797 if (stree->n.tb->error)
9800 /* Operators should always be GENERIC bindings. */
9801 gcc_assert (stree->n.tb->is_generic);
9803 /* Find overridden procedure, if any. */
9804 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
9805 if (super_type && super_type->f2k_derived)
9807 gfc_symtree* overridden;
9808 overridden = gfc_find_typebound_user_op (super_type, NULL,
9809 stree->name, true, NULL);
9811 if (overridden && overridden->n.tb)
9812 stree->n.tb->overridden = overridden->n.tb;
9815 stree->n.tb->overridden = NULL;
9817 /* Resolve basically using worker function. */
9818 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
9822 /* Check the targets to be functions of correct interface. */
9823 for (target = stree->n.tb->u.generic; target; target = target->next)
9825 gfc_symbol* target_proc;
9827 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
9831 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
9838 resolve_bindings_result = FAILURE;
9839 stree->n.tb->error = 1;
9843 /* Resolve the type-bound procedures for a derived type. */
9846 resolve_typebound_procedure (gfc_symtree* stree)
9851 gfc_symbol* super_type;
9852 gfc_component* comp;
9856 /* Undefined specific symbol from GENERIC target definition. */
9860 if (stree->n.tb->error)
9863 /* If this is a GENERIC binding, use that routine. */
9864 if (stree->n.tb->is_generic)
9866 if (resolve_typebound_generic (resolve_bindings_derived, stree)
9872 /* Get the target-procedure to check it. */
9873 gcc_assert (!stree->n.tb->is_generic);
9874 gcc_assert (stree->n.tb->u.specific);
9875 proc = stree->n.tb->u.specific->n.sym;
9876 where = stree->n.tb->where;
9878 /* Default access should already be resolved from the parser. */
9879 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
9881 /* It should be a module procedure or an external procedure with explicit
9882 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
9883 if ((!proc->attr.subroutine && !proc->attr.function)
9884 || (proc->attr.proc != PROC_MODULE
9885 && proc->attr.if_source != IFSRC_IFBODY)
9886 || (proc->attr.abstract && !stree->n.tb->deferred))
9888 gfc_error ("'%s' must be a module procedure or an external procedure with"
9889 " an explicit interface at %L", proc->name, &where);
9892 stree->n.tb->subroutine = proc->attr.subroutine;
9893 stree->n.tb->function = proc->attr.function;
9895 /* Find the super-type of the current derived type. We could do this once and
9896 store in a global if speed is needed, but as long as not I believe this is
9897 more readable and clearer. */
9898 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
9900 /* If PASS, resolve and check arguments if not already resolved / loaded
9901 from a .mod file. */
9902 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
9904 if (stree->n.tb->pass_arg)
9906 gfc_formal_arglist* i;
9908 /* If an explicit passing argument name is given, walk the arg-list
9912 stree->n.tb->pass_arg_num = 1;
9913 for (i = proc->formal; i; i = i->next)
9915 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
9920 ++stree->n.tb->pass_arg_num;
9925 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
9927 proc->name, stree->n.tb->pass_arg, &where,
9928 stree->n.tb->pass_arg);
9934 /* Otherwise, take the first one; there should in fact be at least
9936 stree->n.tb->pass_arg_num = 1;
9939 gfc_error ("Procedure '%s' with PASS at %L must have at"
9940 " least one argument", proc->name, &where);
9943 me_arg = proc->formal->sym;
9946 /* Now check that the argument-type matches. */
9947 gcc_assert (me_arg);
9948 if (me_arg->ts.type != BT_CLASS)
9950 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
9951 " at %L", proc->name, &where);
9955 if (me_arg->ts.u.derived->components->ts.u.derived
9956 != resolve_bindings_derived)
9958 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
9959 " the derived-type '%s'", me_arg->name, proc->name,
9960 me_arg->name, &where, resolve_bindings_derived->name);
9966 /* If we are extending some type, check that we don't override a procedure
9967 flagged NON_OVERRIDABLE. */
9968 stree->n.tb->overridden = NULL;
9971 gfc_symtree* overridden;
9972 overridden = gfc_find_typebound_proc (super_type, NULL,
9973 stree->name, true, NULL);
9975 if (overridden && overridden->n.tb)
9976 stree->n.tb->overridden = overridden->n.tb;
9978 if (overridden && check_typebound_override (stree, overridden) == FAILURE)
9982 /* See if there's a name collision with a component directly in this type. */
9983 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
9984 if (!strcmp (comp->name, stree->name))
9986 gfc_error ("Procedure '%s' at %L has the same name as a component of"
9988 stree->name, &where, resolve_bindings_derived->name);
9992 /* Try to find a name collision with an inherited component. */
9993 if (super_type && gfc_find_component (super_type, stree->name, true, true))
9995 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
9996 " component of '%s'",
9997 stree->name, &where, resolve_bindings_derived->name);
10001 stree->n.tb->error = 0;
10005 resolve_bindings_result = FAILURE;
10006 stree->n.tb->error = 1;
10010 resolve_typebound_procedures (gfc_symbol* derived)
10014 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
10017 resolve_bindings_derived = derived;
10018 resolve_bindings_result = SUCCESS;
10020 if (derived->f2k_derived->tb_sym_root)
10021 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
10022 &resolve_typebound_procedure);
10024 if (derived->f2k_derived->tb_uop_root)
10025 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
10026 &resolve_typebound_user_op);
10028 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
10030 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
10031 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
10033 resolve_bindings_result = FAILURE;
10036 return resolve_bindings_result;
10040 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
10041 to give all identical derived types the same backend_decl. */
10043 add_dt_to_dt_list (gfc_symbol *derived)
10045 gfc_dt_list *dt_list;
10047 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
10048 if (derived == dt_list->derived)
10051 if (dt_list == NULL)
10053 dt_list = gfc_get_dt_list ();
10054 dt_list->next = gfc_derived_types;
10055 dt_list->derived = derived;
10056 gfc_derived_types = dt_list;
10061 /* Ensure that a derived-type is really not abstract, meaning that every
10062 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
10065 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
10070 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
10072 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
10075 if (st->n.tb && st->n.tb->deferred)
10077 gfc_symtree* overriding;
10078 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
10079 gcc_assert (overriding && overriding->n.tb);
10080 if (overriding->n.tb->deferred)
10082 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
10083 " '%s' is DEFERRED and not overridden",
10084 sub->name, &sub->declared_at, st->name);
10093 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
10095 /* The algorithm used here is to recursively travel up the ancestry of sub
10096 and for each ancestor-type, check all bindings. If any of them is
10097 DEFERRED, look it up starting from sub and see if the found (overriding)
10098 binding is not DEFERRED.
10099 This is not the most efficient way to do this, but it should be ok and is
10100 clearer than something sophisticated. */
10102 gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
10104 /* Walk bindings of this ancestor. */
10105 if (ancestor->f2k_derived)
10108 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
10113 /* Find next ancestor type and recurse on it. */
10114 ancestor = gfc_get_derived_super_type (ancestor);
10116 return ensure_not_abstract (sub, ancestor);
10122 static void resolve_symbol (gfc_symbol *sym);
10125 /* Resolve the components of a derived type. */
10128 resolve_fl_derived (gfc_symbol *sym)
10130 gfc_symbol* super_type;
10134 super_type = gfc_get_derived_super_type (sym);
10136 /* Ensure the extended type gets resolved before we do. */
10137 if (super_type && resolve_fl_derived (super_type) == FAILURE)
10140 /* An ABSTRACT type must be extensible. */
10141 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
10143 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
10144 sym->name, &sym->declared_at);
10148 for (c = sym->components; c != NULL; c = c->next)
10150 if (c->attr.proc_pointer && c->ts.interface)
10152 if (c->ts.interface->attr.procedure)
10153 gfc_error ("Interface '%s', used by procedure pointer component "
10154 "'%s' at %L, is declared in a later PROCEDURE statement",
10155 c->ts.interface->name, c->name, &c->loc);
10157 /* Get the attributes from the interface (now resolved). */
10158 if (c->ts.interface->attr.if_source
10159 || c->ts.interface->attr.intrinsic)
10161 gfc_symbol *ifc = c->ts.interface;
10163 if (ifc->formal && !ifc->formal_ns)
10164 resolve_symbol (ifc);
10166 if (ifc->attr.intrinsic)
10167 resolve_intrinsic (ifc, &ifc->declared_at);
10171 c->ts = ifc->result->ts;
10172 c->attr.allocatable = ifc->result->attr.allocatable;
10173 c->attr.pointer = ifc->result->attr.pointer;
10174 c->attr.dimension = ifc->result->attr.dimension;
10175 c->as = gfc_copy_array_spec (ifc->result->as);
10180 c->attr.allocatable = ifc->attr.allocatable;
10181 c->attr.pointer = ifc->attr.pointer;
10182 c->attr.dimension = ifc->attr.dimension;
10183 c->as = gfc_copy_array_spec (ifc->as);
10185 c->ts.interface = ifc;
10186 c->attr.function = ifc->attr.function;
10187 c->attr.subroutine = ifc->attr.subroutine;
10188 gfc_copy_formal_args_ppc (c, ifc);
10190 c->attr.pure = ifc->attr.pure;
10191 c->attr.elemental = ifc->attr.elemental;
10192 c->attr.recursive = ifc->attr.recursive;
10193 c->attr.always_explicit = ifc->attr.always_explicit;
10194 c->attr.ext_attr |= ifc->attr.ext_attr;
10195 /* Replace symbols in array spec. */
10199 for (i = 0; i < c->as->rank; i++)
10201 gfc_expr_replace_comp (c->as->lower[i], c);
10202 gfc_expr_replace_comp (c->as->upper[i], c);
10205 /* Copy char length. */
10206 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
10208 c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
10209 gfc_expr_replace_comp (c->ts.u.cl->length, c);
10212 else if (c->ts.interface->name[0] != '\0')
10214 gfc_error ("Interface '%s' of procedure pointer component "
10215 "'%s' at %L must be explicit", c->ts.interface->name,
10220 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
10222 c->ts = *gfc_get_default_type (c->name, NULL);
10223 c->attr.implicit_type = 1;
10226 /* Procedure pointer components: Check PASS arg. */
10227 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
10229 gfc_symbol* me_arg;
10231 if (c->tb->pass_arg)
10233 gfc_formal_arglist* i;
10235 /* If an explicit passing argument name is given, walk the arg-list
10236 and look for it. */
10239 c->tb->pass_arg_num = 1;
10240 for (i = c->formal; i; i = i->next)
10242 if (!strcmp (i->sym->name, c->tb->pass_arg))
10247 c->tb->pass_arg_num++;
10252 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
10253 "at %L has no argument '%s'", c->name,
10254 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
10261 /* Otherwise, take the first one; there should in fact be at least
10263 c->tb->pass_arg_num = 1;
10266 gfc_error ("Procedure pointer component '%s' with PASS at %L "
10267 "must have at least one argument",
10272 me_arg = c->formal->sym;
10275 /* Now check that the argument-type matches. */
10276 gcc_assert (me_arg);
10277 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
10278 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
10279 || (me_arg->ts.type == BT_CLASS
10280 && me_arg->ts.u.derived->components->ts.u.derived != sym))
10282 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10283 " the derived type '%s'", me_arg->name, c->name,
10284 me_arg->name, &c->loc, sym->name);
10289 /* Check for C453. */
10290 if (me_arg->attr.dimension)
10292 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10293 "must be scalar", me_arg->name, c->name, me_arg->name,
10299 if (me_arg->attr.pointer)
10301 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10302 "may not have the POINTER attribute", me_arg->name,
10303 c->name, me_arg->name, &c->loc);
10308 if (me_arg->attr.allocatable)
10310 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
10311 "may not be ALLOCATABLE", me_arg->name, c->name,
10312 me_arg->name, &c->loc);
10317 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
10318 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
10319 " at %L", c->name, &c->loc);
10323 /* Check type-spec if this is not the parent-type component. */
10324 if ((!sym->attr.extension || c != sym->components)
10325 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
10328 /* If this type is an extension, see if this component has the same name
10329 as an inherited type-bound procedure. */
10331 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
10333 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
10334 " inherited type-bound procedure",
10335 c->name, sym->name, &c->loc);
10339 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
10341 if (c->ts.u.cl->length == NULL
10342 || (resolve_charlen (c->ts.u.cl) == FAILURE)
10343 || !gfc_is_constant_expr (c->ts.u.cl->length))
10345 gfc_error ("Character length of component '%s' needs to "
10346 "be a constant specification expression at %L",
10348 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
10353 if (c->ts.type == BT_DERIVED
10354 && sym->component_access != ACCESS_PRIVATE
10355 && gfc_check_access (sym->attr.access, sym->ns->default_access)
10356 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
10357 && !c->ts.u.derived->attr.use_assoc
10358 && !gfc_check_access (c->ts.u.derived->attr.access,
10359 c->ts.u.derived->ns->default_access)
10360 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
10361 "is a PRIVATE type and cannot be a component of "
10362 "'%s', which is PUBLIC at %L", c->name,
10363 sym->name, &sym->declared_at) == FAILURE)
10366 if (sym->attr.sequence)
10368 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
10370 gfc_error ("Component %s of SEQUENCE type declared at %L does "
10371 "not have the SEQUENCE attribute",
10372 c->ts.u.derived->name, &sym->declared_at);
10377 if (c->ts.type == BT_DERIVED && c->attr.pointer
10378 && c->ts.u.derived->components == NULL
10379 && !c->ts.u.derived->attr.zero_comp)
10381 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10382 "that has not been declared", c->name, sym->name,
10388 if (c->ts.type == BT_CLASS
10389 && !(c->ts.u.derived->components->attr.pointer
10390 || c->ts.u.derived->components->attr.allocatable))
10392 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
10393 "or pointer", c->name, &c->loc);
10397 /* Ensure that all the derived type components are put on the
10398 derived type list; even in formal namespaces, where derived type
10399 pointer components might not have been declared. */
10400 if (c->ts.type == BT_DERIVED
10402 && c->ts.u.derived->components
10404 && sym != c->ts.u.derived)
10405 add_dt_to_dt_list (c->ts.u.derived);
10407 if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
10411 for (i = 0; i < c->as->rank; i++)
10413 if (c->as->lower[i] == NULL
10414 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
10415 || !gfc_is_constant_expr (c->as->lower[i])
10416 || c->as->upper[i] == NULL
10417 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
10418 || !gfc_is_constant_expr (c->as->upper[i]))
10420 gfc_error ("Component '%s' of '%s' at %L must have "
10421 "constant array bounds",
10422 c->name, sym->name, &c->loc);
10428 /* Resolve the type-bound procedures. */
10429 if (resolve_typebound_procedures (sym) == FAILURE)
10432 /* Resolve the finalizer procedures. */
10433 if (gfc_resolve_finalizers (sym) == FAILURE)
10436 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
10437 all DEFERRED bindings are overridden. */
10438 if (super_type && super_type->attr.abstract && !sym->attr.abstract
10439 && ensure_not_abstract (sym, super_type) == FAILURE)
10442 /* Add derived type to the derived type list. */
10443 add_dt_to_dt_list (sym);
10450 resolve_fl_namelist (gfc_symbol *sym)
10455 /* Reject PRIVATE objects in a PUBLIC namelist. */
10456 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
10458 for (nl = sym->namelist; nl; nl = nl->next)
10460 if (!nl->sym->attr.use_assoc
10461 && !is_sym_host_assoc (nl->sym, sym->ns)
10462 && !gfc_check_access(nl->sym->attr.access,
10463 nl->sym->ns->default_access))
10465 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
10466 "cannot be member of PUBLIC namelist '%s' at %L",
10467 nl->sym->name, sym->name, &sym->declared_at);
10471 /* Types with private components that came here by USE-association. */
10472 if (nl->sym->ts.type == BT_DERIVED
10473 && derived_inaccessible (nl->sym->ts.u.derived))
10475 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
10476 "components and cannot be member of namelist '%s' at %L",
10477 nl->sym->name, sym->name, &sym->declared_at);
10481 /* Types with private components that are defined in the same module. */
10482 if (nl->sym->ts.type == BT_DERIVED
10483 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
10484 && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
10485 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
10486 nl->sym->ns->default_access))
10488 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
10489 "cannot be a member of PUBLIC namelist '%s' at %L",
10490 nl->sym->name, sym->name, &sym->declared_at);
10496 for (nl = sym->namelist; nl; nl = nl->next)
10498 /* Reject namelist arrays of assumed shape. */
10499 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
10500 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
10501 "must not have assumed shape in namelist "
10502 "'%s' at %L", nl->sym->name, sym->name,
10503 &sym->declared_at) == FAILURE)
10506 /* Reject namelist arrays that are not constant shape. */
10507 if (is_non_constant_shape_array (nl->sym))
10509 gfc_error ("NAMELIST array object '%s' must have constant "
10510 "shape in namelist '%s' at %L", nl->sym->name,
10511 sym->name, &sym->declared_at);
10515 /* Namelist objects cannot have allocatable or pointer components. */
10516 if (nl->sym->ts.type != BT_DERIVED)
10519 if (nl->sym->ts.u.derived->attr.alloc_comp)
10521 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
10522 "have ALLOCATABLE components",
10523 nl->sym->name, sym->name, &sym->declared_at);
10527 if (nl->sym->ts.u.derived->attr.pointer_comp)
10529 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
10530 "have POINTER components",
10531 nl->sym->name, sym->name, &sym->declared_at);
10537 /* 14.1.2 A module or internal procedure represent local entities
10538 of the same type as a namelist member and so are not allowed. */
10539 for (nl = sym->namelist; nl; nl = nl->next)
10541 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
10544 if (nl->sym->attr.function && nl->sym == nl->sym->result)
10545 if ((nl->sym == sym->ns->proc_name)
10547 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
10551 if (nl->sym && nl->sym->name)
10552 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
10553 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
10555 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
10556 "attribute in '%s' at %L", nlsym->name,
10557 &sym->declared_at);
10567 resolve_fl_parameter (gfc_symbol *sym)
10569 /* A parameter array's shape needs to be constant. */
10570 if (sym->as != NULL
10571 && (sym->as->type == AS_DEFERRED
10572 || is_non_constant_shape_array (sym)))
10574 gfc_error ("Parameter array '%s' at %L cannot be automatic "
10575 "or of deferred shape", sym->name, &sym->declared_at);
10579 /* Make sure a parameter that has been implicitly typed still
10580 matches the implicit type, since PARAMETER statements can precede
10581 IMPLICIT statements. */
10582 if (sym->attr.implicit_type
10583 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
10586 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
10587 "later IMPLICIT type", sym->name, &sym->declared_at);
10591 /* Make sure the types of derived parameters are consistent. This
10592 type checking is deferred until resolution because the type may
10593 refer to a derived type from the host. */
10594 if (sym->ts.type == BT_DERIVED
10595 && !gfc_compare_types (&sym->ts, &sym->value->ts))
10597 gfc_error ("Incompatible derived type in PARAMETER at %L",
10598 &sym->value->where);
10605 /* Do anything necessary to resolve a symbol. Right now, we just
10606 assume that an otherwise unknown symbol is a variable. This sort
10607 of thing commonly happens for symbols in module. */
10610 resolve_symbol (gfc_symbol *sym)
10612 int check_constant, mp_flag;
10613 gfc_symtree *symtree;
10614 gfc_symtree *this_symtree;
10618 if (sym->attr.flavor == FL_UNKNOWN)
10621 /* If we find that a flavorless symbol is an interface in one of the
10622 parent namespaces, find its symtree in this namespace, free the
10623 symbol and set the symtree to point to the interface symbol. */
10624 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
10626 symtree = gfc_find_symtree (ns->sym_root, sym->name);
10627 if (symtree && symtree->n.sym->generic)
10629 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
10633 gfc_free_symbol (sym);
10634 symtree->n.sym->refs++;
10635 this_symtree->n.sym = symtree->n.sym;
10640 /* Otherwise give it a flavor according to such attributes as
10642 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
10643 sym->attr.flavor = FL_VARIABLE;
10646 sym->attr.flavor = FL_PROCEDURE;
10647 if (sym->attr.dimension)
10648 sym->attr.function = 1;
10652 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
10653 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
10655 if (sym->attr.procedure && sym->ts.interface
10656 && sym->attr.if_source != IFSRC_DECL)
10658 if (sym->ts.interface == sym)
10660 gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
10661 "interface", sym->name, &sym->declared_at);
10664 if (sym->ts.interface->attr.procedure)
10666 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
10667 " in a later PROCEDURE statement", sym->ts.interface->name,
10668 sym->name,&sym->declared_at);
10672 /* Get the attributes from the interface (now resolved). */
10673 if (sym->ts.interface->attr.if_source
10674 || sym->ts.interface->attr.intrinsic)
10676 gfc_symbol *ifc = sym->ts.interface;
10677 resolve_symbol (ifc);
10679 if (ifc->attr.intrinsic)
10680 resolve_intrinsic (ifc, &ifc->declared_at);
10683 sym->ts = ifc->result->ts;
10686 sym->ts.interface = ifc;
10687 sym->attr.function = ifc->attr.function;
10688 sym->attr.subroutine = ifc->attr.subroutine;
10689 gfc_copy_formal_args (sym, ifc);
10691 sym->attr.allocatable = ifc->attr.allocatable;
10692 sym->attr.pointer = ifc->attr.pointer;
10693 sym->attr.pure = ifc->attr.pure;
10694 sym->attr.elemental = ifc->attr.elemental;
10695 sym->attr.dimension = ifc->attr.dimension;
10696 sym->attr.recursive = ifc->attr.recursive;
10697 sym->attr.always_explicit = ifc->attr.always_explicit;
10698 sym->attr.ext_attr |= ifc->attr.ext_attr;
10699 /* Copy array spec. */
10700 sym->as = gfc_copy_array_spec (ifc->as);
10704 for (i = 0; i < sym->as->rank; i++)
10706 gfc_expr_replace_symbols (sym->as->lower[i], sym);
10707 gfc_expr_replace_symbols (sym->as->upper[i], sym);
10710 /* Copy char length. */
10711 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
10713 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
10714 gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
10717 else if (sym->ts.interface->name[0] != '\0')
10719 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
10720 sym->ts.interface->name, sym->name, &sym->declared_at);
10725 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
10728 /* Symbols that are module procedures with results (functions) have
10729 the types and array specification copied for type checking in
10730 procedures that call them, as well as for saving to a module
10731 file. These symbols can't stand the scrutiny that their results
10733 mp_flag = (sym->result != NULL && sym->result != sym);
10736 /* Make sure that the intrinsic is consistent with its internal
10737 representation. This needs to be done before assigning a default
10738 type to avoid spurious warnings. */
10739 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
10740 && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
10743 /* Assign default type to symbols that need one and don't have one. */
10744 if (sym->ts.type == BT_UNKNOWN)
10746 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
10747 gfc_set_default_type (sym, 1, NULL);
10749 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
10750 && !sym->attr.function && !sym->attr.subroutine
10751 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
10752 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
10754 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
10756 /* The specific case of an external procedure should emit an error
10757 in the case that there is no implicit type. */
10759 gfc_set_default_type (sym, sym->attr.external, NULL);
10762 /* Result may be in another namespace. */
10763 resolve_symbol (sym->result);
10765 if (!sym->result->attr.proc_pointer)
10767 sym->ts = sym->result->ts;
10768 sym->as = gfc_copy_array_spec (sym->result->as);
10769 sym->attr.dimension = sym->result->attr.dimension;
10770 sym->attr.pointer = sym->result->attr.pointer;
10771 sym->attr.allocatable = sym->result->attr.allocatable;
10777 /* Assumed size arrays and assumed shape arrays must be dummy
10780 if (sym->as != NULL
10781 && (sym->as->type == AS_ASSUMED_SIZE
10782 || sym->as->type == AS_ASSUMED_SHAPE)
10783 && sym->attr.dummy == 0)
10785 if (sym->as->type == AS_ASSUMED_SIZE)
10786 gfc_error ("Assumed size array at %L must be a dummy argument",
10787 &sym->declared_at);
10789 gfc_error ("Assumed shape array at %L must be a dummy argument",
10790 &sym->declared_at);
10794 /* Make sure symbols with known intent or optional are really dummy
10795 variable. Because of ENTRY statement, this has to be deferred
10796 until resolution time. */
10798 if (!sym->attr.dummy
10799 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
10801 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
10805 if (sym->attr.value && !sym->attr.dummy)
10807 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
10808 "it is not a dummy argument", sym->name, &sym->declared_at);
10812 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
10814 gfc_charlen *cl = sym->ts.u.cl;
10815 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10817 gfc_error ("Character dummy variable '%s' at %L with VALUE "
10818 "attribute must have constant length",
10819 sym->name, &sym->declared_at);
10823 if (sym->ts.is_c_interop
10824 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
10826 gfc_error ("C interoperable character dummy variable '%s' at %L "
10827 "with VALUE attribute must have length one",
10828 sym->name, &sym->declared_at);
10833 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
10834 do this for something that was implicitly typed because that is handled
10835 in gfc_set_default_type. Handle dummy arguments and procedure
10836 definitions separately. Also, anything that is use associated is not
10837 handled here but instead is handled in the module it is declared in.
10838 Finally, derived type definitions are allowed to be BIND(C) since that
10839 only implies that they're interoperable, and they are checked fully for
10840 interoperability when a variable is declared of that type. */
10841 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
10842 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
10843 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
10845 gfc_try t = SUCCESS;
10847 /* First, make sure the variable is declared at the
10848 module-level scope (J3/04-007, Section 15.3). */
10849 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
10850 sym->attr.in_common == 0)
10852 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
10853 "is neither a COMMON block nor declared at the "
10854 "module level scope", sym->name, &(sym->declared_at));
10857 else if (sym->common_head != NULL)
10859 t = verify_com_block_vars_c_interop (sym->common_head);
10863 /* If type() declaration, we need to verify that the components
10864 of the given type are all C interoperable, etc. */
10865 if (sym->ts.type == BT_DERIVED &&
10866 sym->ts.u.derived->attr.is_c_interop != 1)
10868 /* Make sure the user marked the derived type as BIND(C). If
10869 not, call the verify routine. This could print an error
10870 for the derived type more than once if multiple variables
10871 of that type are declared. */
10872 if (sym->ts.u.derived->attr.is_bind_c != 1)
10873 verify_bind_c_derived_type (sym->ts.u.derived);
10877 /* Verify the variable itself as C interoperable if it
10878 is BIND(C). It is not possible for this to succeed if
10879 the verify_bind_c_derived_type failed, so don't have to handle
10880 any error returned by verify_bind_c_derived_type. */
10881 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10882 sym->common_block);
10887 /* clear the is_bind_c flag to prevent reporting errors more than
10888 once if something failed. */
10889 sym->attr.is_bind_c = 0;
10894 /* If a derived type symbol has reached this point, without its
10895 type being declared, we have an error. Notice that most
10896 conditions that produce undefined derived types have already
10897 been dealt with. However, the likes of:
10898 implicit type(t) (t) ..... call foo (t) will get us here if
10899 the type is not declared in the scope of the implicit
10900 statement. Change the type to BT_UNKNOWN, both because it is so
10901 and to prevent an ICE. */
10902 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
10903 && !sym->ts.u.derived->attr.zero_comp)
10905 gfc_error ("The derived type '%s' at %L is of type '%s', "
10906 "which has not been defined", sym->name,
10907 &sym->declared_at, sym->ts.u.derived->name);
10908 sym->ts.type = BT_UNKNOWN;
10912 /* Make sure that the derived type has been resolved and that the
10913 derived type is visible in the symbol's namespace, if it is a
10914 module function and is not PRIVATE. */
10915 if (sym->ts.type == BT_DERIVED
10916 && sym->ts.u.derived->attr.use_assoc
10917 && sym->ns->proc_name
10918 && sym->ns->proc_name->attr.flavor == FL_MODULE)
10922 if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
10925 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
10926 if (!ds && sym->attr.function
10927 && gfc_check_access (sym->attr.access, sym->ns->default_access))
10929 symtree = gfc_new_symtree (&sym->ns->sym_root,
10930 sym->ts.u.derived->name);
10931 symtree->n.sym = sym->ts.u.derived;
10932 sym->ts.u.derived->refs++;
10936 /* Unless the derived-type declaration is use associated, Fortran 95
10937 does not allow public entries of private derived types.
10938 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
10939 161 in 95-006r3. */
10940 if (sym->ts.type == BT_DERIVED
10941 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
10942 && !sym->ts.u.derived->attr.use_assoc
10943 && gfc_check_access (sym->attr.access, sym->ns->default_access)
10944 && !gfc_check_access (sym->ts.u.derived->attr.access,
10945 sym->ts.u.derived->ns->default_access)
10946 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
10947 "of PRIVATE derived type '%s'",
10948 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
10949 : "variable", sym->name, &sym->declared_at,
10950 sym->ts.u.derived->name) == FAILURE)
10953 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
10954 default initialization is defined (5.1.2.4.4). */
10955 if (sym->ts.type == BT_DERIVED
10957 && sym->attr.intent == INTENT_OUT
10959 && sym->as->type == AS_ASSUMED_SIZE)
10961 for (c = sym->ts.u.derived->components; c; c = c->next)
10963 if (c->initializer)
10965 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
10966 "ASSUMED SIZE and so cannot have a default initializer",
10967 sym->name, &sym->declared_at);
10973 switch (sym->attr.flavor)
10976 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
10981 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
10986 if (resolve_fl_namelist (sym) == FAILURE)
10991 if (resolve_fl_parameter (sym) == FAILURE)
10999 /* Resolve array specifier. Check as well some constraints
11000 on COMMON blocks. */
11002 check_constant = sym->attr.in_common && !sym->attr.pointer;
11004 /* Set the formal_arg_flag so that check_conflict will not throw
11005 an error for host associated variables in the specification
11006 expression for an array_valued function. */
11007 if (sym->attr.function && sym->as)
11008 formal_arg_flag = 1;
11010 gfc_resolve_array_spec (sym->as, check_constant);
11012 formal_arg_flag = 0;
11014 /* Resolve formal namespaces. */
11015 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
11016 && !sym->attr.contained && !sym->attr.intrinsic)
11017 gfc_resolve (sym->formal_ns);
11019 /* Make sure the formal namespace is present. */
11020 if (sym->formal && !sym->formal_ns)
11022 gfc_formal_arglist *formal = sym->formal;
11023 while (formal && !formal->sym)
11024 formal = formal->next;
11028 sym->formal_ns = formal->sym->ns;
11029 sym->formal_ns->refs++;
11033 /* Check threadprivate restrictions. */
11034 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
11035 && (!sym->attr.in_common
11036 && sym->module == NULL
11037 && (sym->ns->proc_name == NULL
11038 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
11039 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
11041 /* If we have come this far we can apply default-initializers, as
11042 described in 14.7.5, to those variables that have not already
11043 been assigned one. */
11044 if (sym->ts.type == BT_DERIVED
11045 && sym->attr.referenced
11046 && sym->ns == gfc_current_ns
11048 && !sym->attr.allocatable
11049 && !sym->attr.alloc_comp)
11051 symbol_attribute *a = &sym->attr;
11053 if ((!a->save && !a->dummy && !a->pointer
11054 && !a->in_common && !a->use_assoc
11055 && !(a->function && sym != sym->result))
11056 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
11057 apply_default_init (sym);
11060 /* If this symbol has a type-spec, check it. */
11061 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
11062 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
11063 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
11069 /************* Resolve DATA statements *************/
11073 gfc_data_value *vnode;
11079 /* Advance the values structure to point to the next value in the data list. */
11082 next_data_value (void)
11084 while (mpz_cmp_ui (values.left, 0) == 0)
11086 if (!gfc_is_constant_expr (values.vnode->expr))
11087 gfc_error ("non-constant DATA value at %L",
11088 &values.vnode->expr->where);
11090 if (values.vnode->next == NULL)
11093 values.vnode = values.vnode->next;
11094 mpz_set (values.left, values.vnode->repeat);
11102 check_data_variable (gfc_data_variable *var, locus *where)
11108 ar_type mark = AR_UNKNOWN;
11110 mpz_t section_index[GFC_MAX_DIMENSIONS];
11116 if (gfc_resolve_expr (var->expr) == FAILURE)
11120 mpz_init_set_si (offset, 0);
11123 if (e->expr_type != EXPR_VARIABLE)
11124 gfc_internal_error ("check_data_variable(): Bad expression");
11126 sym = e->symtree->n.sym;
11128 if (sym->ns->is_block_data && !sym->attr.in_common)
11130 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
11131 sym->name, &sym->declared_at);
11134 if (e->ref == NULL && sym->as)
11136 gfc_error ("DATA array '%s' at %L must be specified in a previous"
11137 " declaration", sym->name, where);
11141 has_pointer = sym->attr.pointer;
11143 for (ref = e->ref; ref; ref = ref->next)
11145 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
11149 && ref->type == REF_ARRAY
11150 && ref->u.ar.type != AR_FULL)
11152 gfc_error ("DATA element '%s' at %L is a pointer and so must "
11153 "be a full array", sym->name, where);
11158 if (e->rank == 0 || has_pointer)
11160 mpz_init_set_ui (size, 1);
11167 /* Find the array section reference. */
11168 for (ref = e->ref; ref; ref = ref->next)
11170 if (ref->type != REF_ARRAY)
11172 if (ref->u.ar.type == AR_ELEMENT)
11178 /* Set marks according to the reference pattern. */
11179 switch (ref->u.ar.type)
11187 /* Get the start position of array section. */
11188 gfc_get_section_index (ar, section_index, &offset);
11193 gcc_unreachable ();
11196 if (gfc_array_size (e, &size) == FAILURE)
11198 gfc_error ("Nonconstant array section at %L in DATA statement",
11200 mpz_clear (offset);
11207 while (mpz_cmp_ui (size, 0) > 0)
11209 if (next_data_value () == FAILURE)
11211 gfc_error ("DATA statement at %L has more variables than values",
11217 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
11221 /* If we have more than one element left in the repeat count,
11222 and we have more than one element left in the target variable,
11223 then create a range assignment. */
11224 /* FIXME: Only done for full arrays for now, since array sections
11226 if (mark == AR_FULL && ref && ref->next == NULL
11227 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
11231 if (mpz_cmp (size, values.left) >= 0)
11233 mpz_init_set (range, values.left);
11234 mpz_sub (size, size, values.left);
11235 mpz_set_ui (values.left, 0);
11239 mpz_init_set (range, size);
11240 mpz_sub (values.left, values.left, size);
11241 mpz_set_ui (size, 0);
11244 gfc_assign_data_value_range (var->expr, values.vnode->expr,
11247 mpz_add (offset, offset, range);
11251 /* Assign initial value to symbol. */
11254 mpz_sub_ui (values.left, values.left, 1);
11255 mpz_sub_ui (size, size, 1);
11257 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
11261 if (mark == AR_FULL)
11262 mpz_add_ui (offset, offset, 1);
11264 /* Modify the array section indexes and recalculate the offset
11265 for next element. */
11266 else if (mark == AR_SECTION)
11267 gfc_advance_section (section_index, ar, &offset);
11271 if (mark == AR_SECTION)
11273 for (i = 0; i < ar->dimen; i++)
11274 mpz_clear (section_index[i]);
11278 mpz_clear (offset);
11284 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
11286 /* Iterate over a list of elements in a DATA statement. */
11289 traverse_data_list (gfc_data_variable *var, locus *where)
11292 iterator_stack frame;
11293 gfc_expr *e, *start, *end, *step;
11294 gfc_try retval = SUCCESS;
11296 mpz_init (frame.value);
11298 start = gfc_copy_expr (var->iter.start);
11299 end = gfc_copy_expr (var->iter.end);
11300 step = gfc_copy_expr (var->iter.step);
11302 if (gfc_simplify_expr (start, 1) == FAILURE
11303 || start->expr_type != EXPR_CONSTANT)
11305 gfc_error ("iterator start at %L does not simplify", &start->where);
11309 if (gfc_simplify_expr (end, 1) == FAILURE
11310 || end->expr_type != EXPR_CONSTANT)
11312 gfc_error ("iterator end at %L does not simplify", &end->where);
11316 if (gfc_simplify_expr (step, 1) == FAILURE
11317 || step->expr_type != EXPR_CONSTANT)
11319 gfc_error ("iterator step at %L does not simplify", &step->where);
11324 mpz_init_set (trip, end->value.integer);
11325 mpz_sub (trip, trip, start->value.integer);
11326 mpz_add (trip, trip, step->value.integer);
11328 mpz_div (trip, trip, step->value.integer);
11330 mpz_set (frame.value, start->value.integer);
11332 frame.prev = iter_stack;
11333 frame.variable = var->iter.var->symtree;
11334 iter_stack = &frame;
11336 while (mpz_cmp_ui (trip, 0) > 0)
11338 if (traverse_data_var (var->list, where) == FAILURE)
11345 e = gfc_copy_expr (var->expr);
11346 if (gfc_simplify_expr (e, 1) == FAILURE)
11354 mpz_add (frame.value, frame.value, step->value.integer);
11356 mpz_sub_ui (trip, trip, 1);
11361 mpz_clear (frame.value);
11363 gfc_free_expr (start);
11364 gfc_free_expr (end);
11365 gfc_free_expr (step);
11367 iter_stack = frame.prev;
11372 /* Type resolve variables in the variable list of a DATA statement. */
11375 traverse_data_var (gfc_data_variable *var, locus *where)
11379 for (; var; var = var->next)
11381 if (var->expr == NULL)
11382 t = traverse_data_list (var, where);
11384 t = check_data_variable (var, where);
11394 /* Resolve the expressions and iterators associated with a data statement.
11395 This is separate from the assignment checking because data lists should
11396 only be resolved once. */
11399 resolve_data_variables (gfc_data_variable *d)
11401 for (; d; d = d->next)
11403 if (d->list == NULL)
11405 if (gfc_resolve_expr (d->expr) == FAILURE)
11410 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
11413 if (resolve_data_variables (d->list) == FAILURE)
11422 /* Resolve a single DATA statement. We implement this by storing a pointer to
11423 the value list into static variables, and then recursively traversing the
11424 variables list, expanding iterators and such. */
11427 resolve_data (gfc_data *d)
11430 if (resolve_data_variables (d->var) == FAILURE)
11433 values.vnode = d->value;
11434 if (d->value == NULL)
11435 mpz_set_ui (values.left, 0);
11437 mpz_set (values.left, d->value->repeat);
11439 if (traverse_data_var (d->var, &d->where) == FAILURE)
11442 /* At this point, we better not have any values left. */
11444 if (next_data_value () == SUCCESS)
11445 gfc_error ("DATA statement at %L has more values than variables",
11450 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
11451 accessed by host or use association, is a dummy argument to a pure function,
11452 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
11453 is storage associated with any such variable, shall not be used in the
11454 following contexts: (clients of this function). */
11456 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
11457 procedure. Returns zero if assignment is OK, nonzero if there is a
11460 gfc_impure_variable (gfc_symbol *sym)
11464 if (sym->attr.use_assoc || sym->attr.in_common)
11467 if (sym->ns != gfc_current_ns)
11468 return !sym->attr.function;
11470 proc = sym->ns->proc_name;
11471 if (sym->attr.dummy && gfc_pure (proc)
11472 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
11474 proc->attr.function))
11477 /* TODO: Sort out what can be storage associated, if anything, and include
11478 it here. In principle equivalences should be scanned but it does not
11479 seem to be possible to storage associate an impure variable this way. */
11484 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
11485 symbol of the current procedure. */
11488 gfc_pure (gfc_symbol *sym)
11490 symbol_attribute attr;
11493 sym = gfc_current_ns->proc_name;
11499 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
11503 /* Test whether the current procedure is elemental or not. */
11506 gfc_elemental (gfc_symbol *sym)
11508 symbol_attribute attr;
11511 sym = gfc_current_ns->proc_name;
11516 return attr.flavor == FL_PROCEDURE && attr.elemental;
11520 /* Warn about unused labels. */
11523 warn_unused_fortran_label (gfc_st_label *label)
11528 warn_unused_fortran_label (label->left);
11530 if (label->defined == ST_LABEL_UNKNOWN)
11533 switch (label->referenced)
11535 case ST_LABEL_UNKNOWN:
11536 gfc_warning ("Label %d at %L defined but not used", label->value,
11540 case ST_LABEL_BAD_TARGET:
11541 gfc_warning ("Label %d at %L defined but cannot be used",
11542 label->value, &label->where);
11549 warn_unused_fortran_label (label->right);
11553 /* Returns the sequence type of a symbol or sequence. */
11556 sequence_type (gfc_typespec ts)
11565 if (ts.u.derived->components == NULL)
11566 return SEQ_NONDEFAULT;
11568 result = sequence_type (ts.u.derived->components->ts);
11569 for (c = ts.u.derived->components->next; c; c = c->next)
11570 if (sequence_type (c->ts) != result)
11576 if (ts.kind != gfc_default_character_kind)
11577 return SEQ_NONDEFAULT;
11579 return SEQ_CHARACTER;
11582 if (ts.kind != gfc_default_integer_kind)
11583 return SEQ_NONDEFAULT;
11585 return SEQ_NUMERIC;
11588 if (!(ts.kind == gfc_default_real_kind
11589 || ts.kind == gfc_default_double_kind))
11590 return SEQ_NONDEFAULT;
11592 return SEQ_NUMERIC;
11595 if (ts.kind != gfc_default_complex_kind)
11596 return SEQ_NONDEFAULT;
11598 return SEQ_NUMERIC;
11601 if (ts.kind != gfc_default_logical_kind)
11602 return SEQ_NONDEFAULT;
11604 return SEQ_NUMERIC;
11607 return SEQ_NONDEFAULT;
11612 /* Resolve derived type EQUIVALENCE object. */
11615 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
11617 gfc_component *c = derived->components;
11622 /* Shall not be an object of nonsequence derived type. */
11623 if (!derived->attr.sequence)
11625 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
11626 "attribute to be an EQUIVALENCE object", sym->name,
11631 /* Shall not have allocatable components. */
11632 if (derived->attr.alloc_comp)
11634 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
11635 "components to be an EQUIVALENCE object",sym->name,
11640 if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived))
11642 gfc_error ("Derived type variable '%s' at %L with default "
11643 "initialization cannot be in EQUIVALENCE with a variable "
11644 "in COMMON", sym->name, &e->where);
11648 for (; c ; c = c->next)
11650 if (c->ts.type == BT_DERIVED
11651 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
11654 /* Shall not be an object of sequence derived type containing a pointer
11655 in the structure. */
11656 if (c->attr.pointer)
11658 gfc_error ("Derived type variable '%s' at %L with pointer "
11659 "component(s) cannot be an EQUIVALENCE object",
11660 sym->name, &e->where);
11668 /* Resolve equivalence object.
11669 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
11670 an allocatable array, an object of nonsequence derived type, an object of
11671 sequence derived type containing a pointer at any level of component
11672 selection, an automatic object, a function name, an entry name, a result
11673 name, a named constant, a structure component, or a subobject of any of
11674 the preceding objects. A substring shall not have length zero. A
11675 derived type shall not have components with default initialization nor
11676 shall two objects of an equivalence group be initialized.
11677 Either all or none of the objects shall have an protected attribute.
11678 The simple constraints are done in symbol.c(check_conflict) and the rest
11679 are implemented here. */
11682 resolve_equivalence (gfc_equiv *eq)
11685 gfc_symbol *first_sym;
11688 locus *last_where = NULL;
11689 seq_type eq_type, last_eq_type;
11690 gfc_typespec *last_ts;
11691 int object, cnt_protected;
11692 const char *value_name;
11696 last_ts = &eq->expr->symtree->n.sym->ts;
11698 first_sym = eq->expr->symtree->n.sym;
11702 for (object = 1; eq; eq = eq->eq, object++)
11706 e->ts = e->symtree->n.sym->ts;
11707 /* match_varspec might not know yet if it is seeing
11708 array reference or substring reference, as it doesn't
11710 if (e->ref && e->ref->type == REF_ARRAY)
11712 gfc_ref *ref = e->ref;
11713 sym = e->symtree->n.sym;
11715 if (sym->attr.dimension)
11717 ref->u.ar.as = sym->as;
11721 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
11722 if (e->ts.type == BT_CHARACTER
11724 && ref->type == REF_ARRAY
11725 && ref->u.ar.dimen == 1
11726 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
11727 && ref->u.ar.stride[0] == NULL)
11729 gfc_expr *start = ref->u.ar.start[0];
11730 gfc_expr *end = ref->u.ar.end[0];
11733 /* Optimize away the (:) reference. */
11734 if (start == NULL && end == NULL)
11737 e->ref = ref->next;
11739 e->ref->next = ref->next;
11744 ref->type = REF_SUBSTRING;
11746 start = gfc_int_expr (1);
11747 ref->u.ss.start = start;
11748 if (end == NULL && e->ts.u.cl)
11749 end = gfc_copy_expr (e->ts.u.cl->length);
11750 ref->u.ss.end = end;
11751 ref->u.ss.length = e->ts.u.cl;
11758 /* Any further ref is an error. */
11761 gcc_assert (ref->type == REF_ARRAY);
11762 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
11768 if (gfc_resolve_expr (e) == FAILURE)
11771 sym = e->symtree->n.sym;
11773 if (sym->attr.is_protected)
11775 if (cnt_protected > 0 && cnt_protected != object)
11777 gfc_error ("Either all or none of the objects in the "
11778 "EQUIVALENCE set at %L shall have the "
11779 "PROTECTED attribute",
11784 /* Shall not equivalence common block variables in a PURE procedure. */
11785 if (sym->ns->proc_name
11786 && sym->ns->proc_name->attr.pure
11787 && sym->attr.in_common)
11789 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
11790 "object in the pure procedure '%s'",
11791 sym->name, &e->where, sym->ns->proc_name->name);
11795 /* Shall not be a named constant. */
11796 if (e->expr_type == EXPR_CONSTANT)
11798 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
11799 "object", sym->name, &e->where);
11803 if (e->ts.type == BT_DERIVED
11804 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
11807 /* Check that the types correspond correctly:
11809 A numeric sequence structure may be equivalenced to another sequence
11810 structure, an object of default integer type, default real type, double
11811 precision real type, default logical type such that components of the
11812 structure ultimately only become associated to objects of the same
11813 kind. A character sequence structure may be equivalenced to an object
11814 of default character kind or another character sequence structure.
11815 Other objects may be equivalenced only to objects of the same type and
11816 kind parameters. */
11818 /* Identical types are unconditionally OK. */
11819 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
11820 goto identical_types;
11822 last_eq_type = sequence_type (*last_ts);
11823 eq_type = sequence_type (sym->ts);
11825 /* Since the pair of objects is not of the same type, mixed or
11826 non-default sequences can be rejected. */
11828 msg = "Sequence %s with mixed components in EQUIVALENCE "
11829 "statement at %L with different type objects";
11831 && last_eq_type == SEQ_MIXED
11832 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
11834 || (eq_type == SEQ_MIXED
11835 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11836 &e->where) == FAILURE))
11839 msg = "Non-default type object or sequence %s in EQUIVALENCE "
11840 "statement at %L with objects of different type";
11842 && last_eq_type == SEQ_NONDEFAULT
11843 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
11844 last_where) == FAILURE)
11845 || (eq_type == SEQ_NONDEFAULT
11846 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11847 &e->where) == FAILURE))
11850 msg ="Non-CHARACTER object '%s' in default CHARACTER "
11851 "EQUIVALENCE statement at %L";
11852 if (last_eq_type == SEQ_CHARACTER
11853 && eq_type != SEQ_CHARACTER
11854 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11855 &e->where) == FAILURE)
11858 msg ="Non-NUMERIC object '%s' in default NUMERIC "
11859 "EQUIVALENCE statement at %L";
11860 if (last_eq_type == SEQ_NUMERIC
11861 && eq_type != SEQ_NUMERIC
11862 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
11863 &e->where) == FAILURE)
11868 last_where = &e->where;
11873 /* Shall not be an automatic array. */
11874 if (e->ref->type == REF_ARRAY
11875 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
11877 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
11878 "an EQUIVALENCE object", sym->name, &e->where);
11885 /* Shall not be a structure component. */
11886 if (r->type == REF_COMPONENT)
11888 gfc_error ("Structure component '%s' at %L cannot be an "
11889 "EQUIVALENCE object",
11890 r->u.c.component->name, &e->where);
11894 /* A substring shall not have length zero. */
11895 if (r->type == REF_SUBSTRING)
11897 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
11899 gfc_error ("Substring at %L has length zero",
11900 &r->u.ss.start->where);
11910 /* Resolve function and ENTRY types, issue diagnostics if needed. */
11913 resolve_fntype (gfc_namespace *ns)
11915 gfc_entry_list *el;
11918 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
11921 /* If there are any entries, ns->proc_name is the entry master
11922 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
11924 sym = ns->entries->sym;
11926 sym = ns->proc_name;
11927 if (sym->result == sym
11928 && sym->ts.type == BT_UNKNOWN
11929 && gfc_set_default_type (sym, 0, NULL) == FAILURE
11930 && !sym->attr.untyped)
11932 gfc_error ("Function '%s' at %L has no IMPLICIT type",
11933 sym->name, &sym->declared_at);
11934 sym->attr.untyped = 1;
11937 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
11938 && !sym->attr.contained
11939 && !gfc_check_access (sym->ts.u.derived->attr.access,
11940 sym->ts.u.derived->ns->default_access)
11941 && gfc_check_access (sym->attr.access, sym->ns->default_access))
11943 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
11944 "%L of PRIVATE type '%s'", sym->name,
11945 &sym->declared_at, sym->ts.u.derived->name);
11949 for (el = ns->entries->next; el; el = el->next)
11951 if (el->sym->result == el->sym
11952 && el->sym->ts.type == BT_UNKNOWN
11953 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
11954 && !el->sym->attr.untyped)
11956 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
11957 el->sym->name, &el->sym->declared_at);
11958 el->sym->attr.untyped = 1;
11964 /* 12.3.2.1.1 Defined operators. */
11967 check_uop_procedure (gfc_symbol *sym, locus where)
11969 gfc_formal_arglist *formal;
11971 if (!sym->attr.function)
11973 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
11974 sym->name, &where);
11978 if (sym->ts.type == BT_CHARACTER
11979 && !(sym->ts.u.cl && sym->ts.u.cl->length)
11980 && !(sym->result && sym->result->ts.u.cl
11981 && sym->result->ts.u.cl->length))
11983 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
11984 "character length", sym->name, &where);
11988 formal = sym->formal;
11989 if (!formal || !formal->sym)
11991 gfc_error ("User operator procedure '%s' at %L must have at least "
11992 "one argument", sym->name, &where);
11996 if (formal->sym->attr.intent != INTENT_IN)
11998 gfc_error ("First argument of operator interface at %L must be "
11999 "INTENT(IN)", &where);
12003 if (formal->sym->attr.optional)
12005 gfc_error ("First argument of operator interface at %L cannot be "
12006 "optional", &where);
12010 formal = formal->next;
12011 if (!formal || !formal->sym)
12014 if (formal->sym->attr.intent != INTENT_IN)
12016 gfc_error ("Second argument of operator interface at %L must be "
12017 "INTENT(IN)", &where);
12021 if (formal->sym->attr.optional)
12023 gfc_error ("Second argument of operator interface at %L cannot be "
12024 "optional", &where);
12030 gfc_error ("Operator interface at %L must have, at most, two "
12031 "arguments", &where);
12039 gfc_resolve_uops (gfc_symtree *symtree)
12041 gfc_interface *itr;
12043 if (symtree == NULL)
12046 gfc_resolve_uops (symtree->left);
12047 gfc_resolve_uops (symtree->right);
12049 for (itr = symtree->n.uop->op; itr; itr = itr->next)
12050 check_uop_procedure (itr->sym, itr->sym->declared_at);
12054 /* Examine all of the expressions associated with a program unit,
12055 assign types to all intermediate expressions, make sure that all
12056 assignments are to compatible types and figure out which names
12057 refer to which functions or subroutines. It doesn't check code
12058 block, which is handled by resolve_code. */
12061 resolve_types (gfc_namespace *ns)
12067 gfc_namespace* old_ns = gfc_current_ns;
12069 /* Check that all IMPLICIT types are ok. */
12070 if (!ns->seen_implicit_none)
12073 for (letter = 0; letter != GFC_LETTERS; ++letter)
12074 if (ns->set_flag[letter]
12075 && resolve_typespec_used (&ns->default_type[letter],
12076 &ns->implicit_loc[letter],
12081 gfc_current_ns = ns;
12083 resolve_entries (ns);
12085 resolve_common_vars (ns->blank_common.head, false);
12086 resolve_common_blocks (ns->common_root);
12088 resolve_contained_functions (ns);
12090 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
12092 for (cl = ns->cl_list; cl; cl = cl->next)
12093 resolve_charlen (cl);
12095 gfc_traverse_ns (ns, resolve_symbol);
12097 resolve_fntype (ns);
12099 for (n = ns->contained; n; n = n->sibling)
12101 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
12102 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
12103 "also be PURE", n->proc_name->name,
12104 &n->proc_name->declared_at);
12110 gfc_check_interfaces (ns);
12112 gfc_traverse_ns (ns, resolve_values);
12118 for (d = ns->data; d; d = d->next)
12122 gfc_traverse_ns (ns, gfc_formalize_init_value);
12124 gfc_traverse_ns (ns, gfc_verify_binding_labels);
12126 if (ns->common_root != NULL)
12127 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
12129 for (eq = ns->equiv; eq; eq = eq->next)
12130 resolve_equivalence (eq);
12132 /* Warn about unused labels. */
12133 if (warn_unused_label)
12134 warn_unused_fortran_label (ns->st_labels);
12136 gfc_resolve_uops (ns->uop_root);
12138 gfc_current_ns = old_ns;
12142 /* Call resolve_code recursively. */
12145 resolve_codes (gfc_namespace *ns)
12148 bitmap_obstack old_obstack;
12150 for (n = ns->contained; n; n = n->sibling)
12153 gfc_current_ns = ns;
12155 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
12156 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
12159 /* Set to an out of range value. */
12160 current_entry_id = -1;
12162 old_obstack = labels_obstack;
12163 bitmap_obstack_initialize (&labels_obstack);
12165 resolve_code (ns->code, ns);
12167 bitmap_obstack_release (&labels_obstack);
12168 labels_obstack = old_obstack;
12172 /* This function is called after a complete program unit has been compiled.
12173 Its purpose is to examine all of the expressions associated with a program
12174 unit, assign types to all intermediate expressions, make sure that all
12175 assignments are to compatible types and figure out which names refer to
12176 which functions or subroutines. */
12179 gfc_resolve (gfc_namespace *ns)
12181 gfc_namespace *old_ns;
12182 code_stack *old_cs_base;
12188 old_ns = gfc_current_ns;
12189 old_cs_base = cs_base;
12191 resolve_types (ns);
12192 resolve_codes (ns);
12194 gfc_current_ns = old_ns;
12195 cs_base = old_cs_base;