1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code *head, *current;
48 struct code_stack *prev;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels;
57 static code_stack *cs_base = NULL;
60 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
62 static int forall_flag;
63 static int do_concurrent_flag;
65 /* True when we are resolving an expression that is an actual argument to
67 static bool actual_arg = false;
68 /* True when we are resolving an expression that is the first actual argument
70 static bool first_actual_arg = false;
73 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
75 static int omp_workshare_flag;
77 /* Nonzero if we are processing a formal arglist. The corresponding function
78 resets the flag each time that it is read. */
79 static int formal_arg_flag = 0;
81 /* True if we are resolving a specification expression. */
82 static bool specification_expr = false;
84 /* The id of the last entry seen. */
85 static int current_entry_id;
87 /* We use bitmaps to determine if a branch target is valid. */
88 static bitmap_obstack labels_obstack;
90 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
91 static bool inquiry_argument = false;
95 gfc_is_formal_arg (void)
97 return formal_arg_flag;
100 /* Is the symbol host associated? */
102 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
104 for (ns = ns->parent; ns; ns = ns->parent)
113 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
114 an ABSTRACT derived-type. If where is not NULL, an error message with that
115 locus is printed, optionally using name. */
118 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
120 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
125 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
126 name, where, ts->u.derived->name);
128 gfc_error ("ABSTRACT type '%s' used at %L",
129 ts->u.derived->name, where);
140 check_proc_interface (gfc_symbol *ifc, locus *where)
142 /* Several checks for F08:C1216. */
143 if (ifc->attr.procedure)
145 gfc_error ("Interface '%s' at %L is declared "
146 "in a later PROCEDURE statement", ifc->name, where);
151 /* For generic interfaces, check if there is
152 a specific procedure with the same name. */
153 gfc_interface *gen = ifc->generic;
154 while (gen && strcmp (gen->sym->name, ifc->name) != 0)
158 gfc_error ("Interface '%s' at %L may not be generic",
163 if (ifc->attr.proc == PROC_ST_FUNCTION)
165 gfc_error ("Interface '%s' at %L may not be a statement function",
169 if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
170 || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
171 ifc->attr.intrinsic = 1;
172 if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
174 gfc_error ("Intrinsic procedure '%s' not allowed in "
175 "PROCEDURE statement at %L", ifc->name, where);
178 if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
180 gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where);
187 static void resolve_symbol (gfc_symbol *sym);
190 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
193 resolve_procedure_interface (gfc_symbol *sym)
195 gfc_symbol *ifc = sym->ts.interface;
202 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
203 sym->name, &sym->declared_at);
206 if (check_proc_interface (ifc, &sym->declared_at) == FAILURE)
209 if (ifc->attr.if_source || ifc->attr.intrinsic)
211 /* Resolve interface and copy attributes. */
212 resolve_symbol (ifc);
213 if (ifc->attr.intrinsic)
214 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
218 sym->ts = ifc->result->ts;
223 sym->ts.interface = ifc;
224 sym->attr.function = ifc->attr.function;
225 sym->attr.subroutine = ifc->attr.subroutine;
227 sym->attr.allocatable = ifc->attr.allocatable;
228 sym->attr.pointer = ifc->attr.pointer;
229 sym->attr.pure = ifc->attr.pure;
230 sym->attr.elemental = ifc->attr.elemental;
231 sym->attr.dimension = ifc->attr.dimension;
232 sym->attr.contiguous = ifc->attr.contiguous;
233 sym->attr.recursive = ifc->attr.recursive;
234 sym->attr.always_explicit = ifc->attr.always_explicit;
235 sym->attr.ext_attr |= ifc->attr.ext_attr;
236 sym->attr.is_bind_c = ifc->attr.is_bind_c;
237 sym->attr.class_ok = ifc->attr.class_ok;
238 /* Copy array spec. */
239 sym->as = gfc_copy_array_spec (ifc->as);
240 /* Copy char length. */
241 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
243 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
244 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
245 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
254 /* Resolve types of formal argument lists. These have to be done early so that
255 the formal argument lists of module procedures can be copied to the
256 containing module before the individual procedures are resolved
257 individually. We also resolve argument lists of procedures in interface
258 blocks because they are self-contained scoping units.
260 Since a dummy argument cannot be a non-dummy procedure, the only
261 resort left for untyped names are the IMPLICIT types. */
264 resolve_formal_arglist (gfc_symbol *proc)
266 gfc_formal_arglist *f;
268 bool saved_specification_expr;
271 if (proc->result != NULL)
276 if (gfc_elemental (proc)
277 || sym->attr.pointer || sym->attr.allocatable
278 || (sym->as && sym->as->rank != 0))
280 proc->attr.always_explicit = 1;
281 sym->attr.always_explicit = 1;
286 for (f = proc->formal; f; f = f->next)
294 /* Alternate return placeholder. */
295 if (gfc_elemental (proc))
296 gfc_error ("Alternate return specifier in elemental subroutine "
297 "'%s' at %L is not allowed", proc->name,
299 if (proc->attr.function)
300 gfc_error ("Alternate return specifier in function "
301 "'%s' at %L is not allowed", proc->name,
305 else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
306 && resolve_procedure_interface (sym) == FAILURE)
309 if (sym->attr.if_source != IFSRC_UNKNOWN)
310 resolve_formal_arglist (sym);
312 if (sym->attr.subroutine || sym->attr.external)
314 if (sym->attr.flavor == FL_UNKNOWN)
315 gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
319 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
320 && (!sym->attr.function || sym->result == sym))
321 gfc_set_default_type (sym, 1, sym->ns);
324 as = sym->ts.type == BT_CLASS && sym->attr.class_ok
325 ? CLASS_DATA (sym)->as : sym->as;
327 saved_specification_expr = specification_expr;
328 specification_expr = true;
329 gfc_resolve_array_spec (as, 0);
330 specification_expr = saved_specification_expr;
332 /* We can't tell if an array with dimension (:) is assumed or deferred
333 shape until we know if it has the pointer or allocatable attributes.
335 if (as && as->rank > 0 && as->type == AS_DEFERRED
336 && ((sym->ts.type != BT_CLASS
337 && !(sym->attr.pointer || sym->attr.allocatable))
338 || (sym->ts.type == BT_CLASS
339 && !(CLASS_DATA (sym)->attr.class_pointer
340 || CLASS_DATA (sym)->attr.allocatable)))
341 && sym->attr.flavor != FL_PROCEDURE)
343 as->type = AS_ASSUMED_SHAPE;
344 for (i = 0; i < as->rank; i++)
345 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
348 if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
349 || (as && as->type == AS_ASSUMED_RANK)
350 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
351 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
352 && (CLASS_DATA (sym)->attr.class_pointer
353 || CLASS_DATA (sym)->attr.allocatable
354 || CLASS_DATA (sym)->attr.target))
355 || sym->attr.optional)
357 proc->attr.always_explicit = 1;
359 proc->result->attr.always_explicit = 1;
362 /* If the flavor is unknown at this point, it has to be a variable.
363 A procedure specification would have already set the type. */
365 if (sym->attr.flavor == FL_UNKNOWN)
366 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
370 if (sym->attr.flavor == FL_PROCEDURE)
375 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
376 "also be PURE", sym->name, &sym->declared_at);
380 else if (!sym->attr.pointer)
382 if (proc->attr.function && sym->attr.intent != INTENT_IN)
385 gfc_notify_std (GFC_STD_F2008, "Argument '%s'"
386 " of pure function '%s' at %L with VALUE "
387 "attribute but without INTENT(IN)",
388 sym->name, proc->name, &sym->declared_at);
390 gfc_error ("Argument '%s' of pure function '%s' at %L must "
391 "be INTENT(IN) or VALUE", sym->name, proc->name,
395 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
398 gfc_notify_std (GFC_STD_F2008, "Argument '%s'"
399 " of pure subroutine '%s' at %L with VALUE "
400 "attribute but without INTENT", sym->name,
401 proc->name, &sym->declared_at);
403 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
404 "must have its INTENT specified or have the "
405 "VALUE attribute", sym->name, proc->name,
411 if (proc->attr.implicit_pure)
413 if (sym->attr.flavor == FL_PROCEDURE)
416 proc->attr.implicit_pure = 0;
418 else if (!sym->attr.pointer)
420 if (proc->attr.function && sym->attr.intent != INTENT_IN
422 proc->attr.implicit_pure = 0;
424 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
426 proc->attr.implicit_pure = 0;
430 if (gfc_elemental (proc))
433 if (sym->attr.codimension
434 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
435 && CLASS_DATA (sym)->attr.codimension))
437 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
438 "procedure", sym->name, &sym->declared_at);
442 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
443 && CLASS_DATA (sym)->as))
445 gfc_error ("Argument '%s' of elemental procedure at %L must "
446 "be scalar", sym->name, &sym->declared_at);
450 if (sym->attr.allocatable
451 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
452 && CLASS_DATA (sym)->attr.allocatable))
454 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
455 "have the ALLOCATABLE attribute", sym->name,
460 if (sym->attr.pointer
461 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
462 && CLASS_DATA (sym)->attr.class_pointer))
464 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
465 "have the POINTER attribute", sym->name,
470 if (sym->attr.flavor == FL_PROCEDURE)
472 gfc_error ("Dummy procedure '%s' not allowed in elemental "
473 "procedure '%s' at %L", sym->name, proc->name,
478 /* Fortran 2008 Corrigendum 1, C1290a. */
479 if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
481 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
482 "have its INTENT specified or have the VALUE "
483 "attribute", sym->name, proc->name,
489 /* Each dummy shall be specified to be scalar. */
490 if (proc->attr.proc == PROC_ST_FUNCTION)
494 gfc_error ("Argument '%s' of statement function at %L must "
495 "be scalar", sym->name, &sym->declared_at);
499 if (sym->ts.type == BT_CHARACTER)
501 gfc_charlen *cl = sym->ts.u.cl;
502 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
504 gfc_error ("Character-valued argument '%s' of statement "
505 "function at %L must have constant length",
506 sym->name, &sym->declared_at);
516 /* Work function called when searching for symbols that have argument lists
517 associated with them. */
520 find_arglists (gfc_symbol *sym)
522 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
523 || sym->attr.flavor == FL_DERIVED)
526 resolve_formal_arglist (sym);
530 /* Given a namespace, resolve all formal argument lists within the namespace.
534 resolve_formal_arglists (gfc_namespace *ns)
539 gfc_traverse_ns (ns, find_arglists);
544 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
548 /* If this namespace is not a function or an entry master function,
550 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
551 || sym->attr.entry_master)
554 /* Try to find out of what the return type is. */
555 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
557 t = gfc_set_default_type (sym->result, 0, ns);
559 if (t == FAILURE && !sym->result->attr.untyped)
561 if (sym->result == sym)
562 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
563 sym->name, &sym->declared_at);
564 else if (!sym->result->attr.proc_pointer)
565 gfc_error ("Result '%s' of contained function '%s' at %L has "
566 "no IMPLICIT type", sym->result->name, sym->name,
567 &sym->result->declared_at);
568 sym->result->attr.untyped = 1;
572 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
573 type, lists the only ways a character length value of * can be used:
574 dummy arguments of procedures, named constants, and function results
575 in external functions. Internal function results and results of module
576 procedures are not on this list, ergo, not permitted. */
578 if (sym->result->ts.type == BT_CHARACTER)
580 gfc_charlen *cl = sym->result->ts.u.cl;
581 if ((!cl || !cl->length) && !sym->result->ts.deferred)
583 /* See if this is a module-procedure and adapt error message
586 gcc_assert (ns->parent && ns->parent->proc_name);
587 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
589 gfc_error ("Character-valued %s '%s' at %L must not be"
591 module_proc ? _("module procedure")
592 : _("internal function"),
593 sym->name, &sym->declared_at);
599 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
600 introduce duplicates. */
603 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
605 gfc_formal_arglist *f, *new_arglist;
608 for (; new_args != NULL; new_args = new_args->next)
610 new_sym = new_args->sym;
611 /* See if this arg is already in the formal argument list. */
612 for (f = proc->formal; f; f = f->next)
614 if (new_sym == f->sym)
621 /* Add a new argument. Argument order is not important. */
622 new_arglist = gfc_get_formal_arglist ();
623 new_arglist->sym = new_sym;
624 new_arglist->next = proc->formal;
625 proc->formal = new_arglist;
630 /* Flag the arguments that are not present in all entries. */
633 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
635 gfc_formal_arglist *f, *head;
638 for (f = proc->formal; f; f = f->next)
643 for (new_args = head; new_args; new_args = new_args->next)
645 if (new_args->sym == f->sym)
652 f->sym->attr.not_always_present = 1;
657 /* Resolve alternate entry points. If a symbol has multiple entry points we
658 create a new master symbol for the main routine, and turn the existing
659 symbol into an entry point. */
662 resolve_entries (gfc_namespace *ns)
664 gfc_namespace *old_ns;
668 char name[GFC_MAX_SYMBOL_LEN + 1];
669 static int master_count = 0;
671 if (ns->proc_name == NULL)
674 /* No need to do anything if this procedure doesn't have alternate entry
679 /* We may already have resolved alternate entry points. */
680 if (ns->proc_name->attr.entry_master)
683 /* If this isn't a procedure something has gone horribly wrong. */
684 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
686 /* Remember the current namespace. */
687 old_ns = gfc_current_ns;
691 /* Add the main entry point to the list of entry points. */
692 el = gfc_get_entry_list ();
693 el->sym = ns->proc_name;
695 el->next = ns->entries;
697 ns->proc_name->attr.entry = 1;
699 /* If it is a module function, it needs to be in the right namespace
700 so that gfc_get_fake_result_decl can gather up the results. The
701 need for this arose in get_proc_name, where these beasts were
702 left in their own namespace, to keep prior references linked to
703 the entry declaration.*/
704 if (ns->proc_name->attr.function
705 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
708 /* Do the same for entries where the master is not a module
709 procedure. These are retained in the module namespace because
710 of the module procedure declaration. */
711 for (el = el->next; el; el = el->next)
712 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
713 && el->sym->attr.mod_proc)
717 /* Add an entry statement for it. */
724 /* Create a new symbol for the master function. */
725 /* Give the internal function a unique name (within this file).
726 Also include the function name so the user has some hope of figuring
727 out what is going on. */
728 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
729 master_count++, ns->proc_name->name);
730 gfc_get_ha_symbol (name, &proc);
731 gcc_assert (proc != NULL);
733 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
734 if (ns->proc_name->attr.subroutine)
735 gfc_add_subroutine (&proc->attr, proc->name, NULL);
739 gfc_typespec *ts, *fts;
740 gfc_array_spec *as, *fas;
741 gfc_add_function (&proc->attr, proc->name, NULL);
743 fas = ns->entries->sym->as;
744 fas = fas ? fas : ns->entries->sym->result->as;
745 fts = &ns->entries->sym->result->ts;
746 if (fts->type == BT_UNKNOWN)
747 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
748 for (el = ns->entries->next; el; el = el->next)
750 ts = &el->sym->result->ts;
752 as = as ? as : el->sym->result->as;
753 if (ts->type == BT_UNKNOWN)
754 ts = gfc_get_default_type (el->sym->result->name, NULL);
756 if (! gfc_compare_types (ts, fts)
757 || (el->sym->result->attr.dimension
758 != ns->entries->sym->result->attr.dimension)
759 || (el->sym->result->attr.pointer
760 != ns->entries->sym->result->attr.pointer))
762 else if (as && fas && ns->entries->sym->result != el->sym->result
763 && gfc_compare_array_spec (as, fas) == 0)
764 gfc_error ("Function %s at %L has entries with mismatched "
765 "array specifications", ns->entries->sym->name,
766 &ns->entries->sym->declared_at);
767 /* The characteristics need to match and thus both need to have
768 the same string length, i.e. both len=*, or both len=4.
769 Having both len=<variable> is also possible, but difficult to
770 check at compile time. */
771 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
772 && (((ts->u.cl->length && !fts->u.cl->length)
773 ||(!ts->u.cl->length && fts->u.cl->length))
775 && ts->u.cl->length->expr_type
776 != fts->u.cl->length->expr_type)
778 && ts->u.cl->length->expr_type == EXPR_CONSTANT
779 && mpz_cmp (ts->u.cl->length->value.integer,
780 fts->u.cl->length->value.integer) != 0)))
781 gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
782 "entries returning variables of different "
783 "string lengths", ns->entries->sym->name,
784 &ns->entries->sym->declared_at);
789 sym = ns->entries->sym->result;
790 /* All result types the same. */
792 if (sym->attr.dimension)
793 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
794 if (sym->attr.pointer)
795 gfc_add_pointer (&proc->attr, NULL);
799 /* Otherwise the result will be passed through a union by
801 proc->attr.mixed_entry_master = 1;
802 for (el = ns->entries; el; el = el->next)
804 sym = el->sym->result;
805 if (sym->attr.dimension)
807 if (el == ns->entries)
808 gfc_error ("FUNCTION result %s can't be an array in "
809 "FUNCTION %s at %L", sym->name,
810 ns->entries->sym->name, &sym->declared_at);
812 gfc_error ("ENTRY result %s can't be an array in "
813 "FUNCTION %s at %L", sym->name,
814 ns->entries->sym->name, &sym->declared_at);
816 else if (sym->attr.pointer)
818 if (el == ns->entries)
819 gfc_error ("FUNCTION result %s can't be a POINTER in "
820 "FUNCTION %s at %L", sym->name,
821 ns->entries->sym->name, &sym->declared_at);
823 gfc_error ("ENTRY result %s can't be a POINTER in "
824 "FUNCTION %s at %L", sym->name,
825 ns->entries->sym->name, &sym->declared_at);
830 if (ts->type == BT_UNKNOWN)
831 ts = gfc_get_default_type (sym->name, NULL);
835 if (ts->kind == gfc_default_integer_kind)
839 if (ts->kind == gfc_default_real_kind
840 || ts->kind == gfc_default_double_kind)
844 if (ts->kind == gfc_default_complex_kind)
848 if (ts->kind == gfc_default_logical_kind)
852 /* We will issue error elsewhere. */
860 if (el == ns->entries)
861 gfc_error ("FUNCTION result %s can't be of type %s "
862 "in FUNCTION %s at %L", sym->name,
863 gfc_typename (ts), ns->entries->sym->name,
866 gfc_error ("ENTRY result %s can't be of type %s "
867 "in FUNCTION %s at %L", sym->name,
868 gfc_typename (ts), ns->entries->sym->name,
875 proc->attr.access = ACCESS_PRIVATE;
876 proc->attr.entry_master = 1;
878 /* Merge all the entry point arguments. */
879 for (el = ns->entries; el; el = el->next)
880 merge_argument_lists (proc, el->sym->formal);
882 /* Check the master formal arguments for any that are not
883 present in all entry points. */
884 for (el = ns->entries; el; el = el->next)
885 check_argument_lists (proc, el->sym->formal);
887 /* Use the master function for the function body. */
888 ns->proc_name = proc;
890 /* Finalize the new symbols. */
891 gfc_commit_symbols ();
893 /* Restore the original namespace. */
894 gfc_current_ns = old_ns;
898 /* Resolve common variables. */
900 resolve_common_vars (gfc_symbol *sym, bool named_common)
902 gfc_symbol *csym = sym;
904 for (; csym; csym = csym->common_next)
906 if (csym->value || csym->attr.data)
908 if (!csym->ns->is_block_data)
909 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
910 "but only in BLOCK DATA initialization is "
911 "allowed", csym->name, &csym->declared_at);
912 else if (!named_common)
913 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
914 "in a blank COMMON but initialization is only "
915 "allowed in named common blocks", csym->name,
919 if (UNLIMITED_POLY (csym))
920 gfc_error_now ("'%s' in cannot appear in COMMON at %L "
921 "[F2008:C5100]", csym->name, &csym->declared_at);
923 if (csym->ts.type != BT_DERIVED)
926 if (!(csym->ts.u.derived->attr.sequence
927 || csym->ts.u.derived->attr.is_bind_c))
928 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
929 "has neither the SEQUENCE nor the BIND(C) "
930 "attribute", csym->name, &csym->declared_at);
931 if (csym->ts.u.derived->attr.alloc_comp)
932 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
933 "has an ultimate component that is "
934 "allocatable", csym->name, &csym->declared_at);
935 if (gfc_has_default_initializer (csym->ts.u.derived))
936 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
937 "may not have default initializer", csym->name,
940 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
941 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
945 /* Resolve common blocks. */
947 resolve_common_blocks (gfc_symtree *common_root)
951 if (common_root == NULL)
954 if (common_root->left)
955 resolve_common_blocks (common_root->left);
956 if (common_root->right)
957 resolve_common_blocks (common_root->right);
959 resolve_common_vars (common_root->n.common->head, true);
961 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
965 if (sym->attr.flavor == FL_PARAMETER)
966 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
967 sym->name, &common_root->n.common->where, &sym->declared_at);
969 if (sym->attr.external)
970 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
971 sym->name, &common_root->n.common->where);
973 if (sym->attr.intrinsic)
974 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
975 sym->name, &common_root->n.common->where);
976 else if (sym->attr.result
977 || gfc_is_function_return_value (sym, gfc_current_ns))
978 gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L "
979 "that is also a function result", sym->name,
980 &common_root->n.common->where);
981 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
982 && sym->attr.proc != PROC_ST_FUNCTION)
983 gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L "
984 "that is also a global procedure", sym->name,
985 &common_root->n.common->where);
989 /* Resolve contained function types. Because contained functions can call one
990 another, they have to be worked out before any of the contained procedures
993 The good news is that if a function doesn't already have a type, the only
994 way it can get one is through an IMPLICIT type or a RESULT variable, because
995 by definition contained functions are contained namespace they're contained
996 in, not in a sibling or parent namespace. */
999 resolve_contained_functions (gfc_namespace *ns)
1001 gfc_namespace *child;
1004 resolve_formal_arglists (ns);
1006 for (child = ns->contained; child; child = child->sibling)
1008 /* Resolve alternate entry points first. */
1009 resolve_entries (child);
1011 /* Then check function return types. */
1012 resolve_contained_fntype (child->proc_name, child);
1013 for (el = child->entries; el; el = el->next)
1014 resolve_contained_fntype (el->sym, child);
1019 static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
1022 /* Resolve all of the elements of a structure constructor and make sure that
1023 the types are correct. The 'init' flag indicates that the given
1024 constructor is an initializer. */
1027 resolve_structure_cons (gfc_expr *expr, int init)
1029 gfc_constructor *cons;
1030 gfc_component *comp;
1036 if (expr->ts.type == BT_DERIVED)
1037 resolve_fl_derived0 (expr->ts.u.derived);
1039 cons = gfc_constructor_first (expr->value.constructor);
1041 /* See if the user is trying to invoke a structure constructor for one of
1042 the iso_c_binding derived types. */
1043 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
1044 && expr->ts.u.derived->ts.is_iso_c && cons
1045 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
1047 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
1048 expr->ts.u.derived->name, &(expr->where));
1052 /* Return if structure constructor is c_null_(fun)prt. */
1053 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
1054 && expr->ts.u.derived->ts.is_iso_c && cons
1055 && cons->expr && cons->expr->expr_type == EXPR_NULL)
1058 /* A constructor may have references if it is the result of substituting a
1059 parameter variable. In this case we just pull out the component we
1062 comp = expr->ref->u.c.sym->components;
1064 comp = expr->ts.u.derived->components;
1066 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1073 if (gfc_resolve_expr (cons->expr) == FAILURE)
1079 rank = comp->as ? comp->as->rank : 0;
1080 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1081 && (comp->attr.allocatable || cons->expr->rank))
1083 gfc_error ("The rank of the element in the structure "
1084 "constructor at %L does not match that of the "
1085 "component (%d/%d)", &cons->expr->where,
1086 cons->expr->rank, rank);
1090 /* If we don't have the right type, try to convert it. */
1092 if (!comp->attr.proc_pointer &&
1093 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1095 if (strcmp (comp->name, "_extends") == 0)
1097 /* Can afford to be brutal with the _extends initializer.
1098 The derived type can get lost because it is PRIVATE
1099 but it is not usage constrained by the standard. */
1100 cons->expr->ts = comp->ts;
1102 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1104 gfc_error ("The element in the structure constructor at %L, "
1105 "for pointer component '%s', is %s but should be %s",
1106 &cons->expr->where, comp->name,
1107 gfc_basic_typename (cons->expr->ts.type),
1108 gfc_basic_typename (comp->ts.type));
1113 gfc_try t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1119 /* For strings, the length of the constructor should be the same as
1120 the one of the structure, ensure this if the lengths are known at
1121 compile time and when we are dealing with PARAMETER or structure
1123 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1124 && comp->ts.u.cl->length
1125 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1126 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1127 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1128 && cons->expr->rank != 0
1129 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1130 comp->ts.u.cl->length->value.integer) != 0)
1132 if (cons->expr->expr_type == EXPR_VARIABLE
1133 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1135 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1136 to make use of the gfc_resolve_character_array_constructor
1137 machinery. The expression is later simplified away to
1138 an array of string literals. */
1139 gfc_expr *para = cons->expr;
1140 cons->expr = gfc_get_expr ();
1141 cons->expr->ts = para->ts;
1142 cons->expr->where = para->where;
1143 cons->expr->expr_type = EXPR_ARRAY;
1144 cons->expr->rank = para->rank;
1145 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1146 gfc_constructor_append_expr (&cons->expr->value.constructor,
1147 para, &cons->expr->where);
1149 if (cons->expr->expr_type == EXPR_ARRAY)
1152 p = gfc_constructor_first (cons->expr->value.constructor);
1153 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1155 gfc_charlen *cl, *cl2;
1158 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1160 if (cl == cons->expr->ts.u.cl)
1168 cl2->next = cl->next;
1170 gfc_free_expr (cl->length);
1174 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1175 cons->expr->ts.u.cl->length_from_typespec = true;
1176 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1177 gfc_resolve_character_array_constructor (cons->expr);
1181 if (cons->expr->expr_type == EXPR_NULL
1182 && !(comp->attr.pointer || comp->attr.allocatable
1183 || comp->attr.proc_pointer
1184 || (comp->ts.type == BT_CLASS
1185 && (CLASS_DATA (comp)->attr.class_pointer
1186 || CLASS_DATA (comp)->attr.allocatable))))
1189 gfc_error ("The NULL in the structure constructor at %L is "
1190 "being applied to component '%s', which is neither "
1191 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1195 if (comp->attr.proc_pointer && comp->ts.interface)
1197 /* Check procedure pointer interface. */
1198 gfc_symbol *s2 = NULL;
1203 c2 = gfc_get_proc_ptr_comp (cons->expr);
1206 s2 = c2->ts.interface;
1209 else if (cons->expr->expr_type == EXPR_FUNCTION)
1211 s2 = cons->expr->symtree->n.sym->result;
1212 name = cons->expr->symtree->n.sym->result->name;
1214 else if (cons->expr->expr_type != EXPR_NULL)
1216 s2 = cons->expr->symtree->n.sym;
1217 name = cons->expr->symtree->n.sym->name;
1220 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1221 err, sizeof (err), NULL, NULL))
1223 gfc_error ("Interface mismatch for procedure-pointer component "
1224 "'%s' in structure constructor at %L: %s",
1225 comp->name, &cons->expr->where, err);
1230 if (!comp->attr.pointer || comp->attr.proc_pointer
1231 || cons->expr->expr_type == EXPR_NULL)
1234 a = gfc_expr_attr (cons->expr);
1236 if (!a.pointer && !a.target)
1239 gfc_error ("The element in the structure constructor at %L, "
1240 "for pointer component '%s' should be a POINTER or "
1241 "a TARGET", &cons->expr->where, comp->name);
1246 /* F08:C461. Additional checks for pointer initialization. */
1250 gfc_error ("Pointer initialization target at %L "
1251 "must not be ALLOCATABLE ", &cons->expr->where);
1256 gfc_error ("Pointer initialization target at %L "
1257 "must have the SAVE attribute", &cons->expr->where);
1261 /* F2003, C1272 (3). */
1262 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1263 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1264 || gfc_is_coindexed (cons->expr)))
1267 gfc_error ("Invalid expression in the structure constructor for "
1268 "pointer component '%s' at %L in PURE procedure",
1269 comp->name, &cons->expr->where);
1272 if (gfc_implicit_pure (NULL)
1273 && cons->expr->expr_type == EXPR_VARIABLE
1274 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1275 || gfc_is_coindexed (cons->expr)))
1276 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1284 /****************** Expression name resolution ******************/
1286 /* Returns 0 if a symbol was not declared with a type or
1287 attribute declaration statement, nonzero otherwise. */
1290 was_declared (gfc_symbol *sym)
1296 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1299 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1300 || a.optional || a.pointer || a.save || a.target || a.volatile_
1301 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1302 || a.asynchronous || a.codimension)
1309 /* Determine if a symbol is generic or not. */
1312 generic_sym (gfc_symbol *sym)
1316 if (sym->attr.generic ||
1317 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1320 if (was_declared (sym) || sym->ns->parent == NULL)
1323 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1330 return generic_sym (s);
1337 /* Determine if a symbol is specific or not. */
1340 specific_sym (gfc_symbol *sym)
1344 if (sym->attr.if_source == IFSRC_IFBODY
1345 || sym->attr.proc == PROC_MODULE
1346 || sym->attr.proc == PROC_INTERNAL
1347 || sym->attr.proc == PROC_ST_FUNCTION
1348 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1349 || sym->attr.external)
1352 if (was_declared (sym) || sym->ns->parent == NULL)
1355 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1357 return (s == NULL) ? 0 : specific_sym (s);
1361 /* Figure out if the procedure is specific, generic or unknown. */
1364 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1368 procedure_kind (gfc_symbol *sym)
1370 if (generic_sym (sym))
1371 return PTYPE_GENERIC;
1373 if (specific_sym (sym))
1374 return PTYPE_SPECIFIC;
1376 return PTYPE_UNKNOWN;
1379 /* Check references to assumed size arrays. The flag need_full_assumed_size
1380 is nonzero when matching actual arguments. */
1382 static int need_full_assumed_size = 0;
1385 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1387 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1390 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1391 What should it be? */
1392 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1393 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1394 && (e->ref->u.ar.type == AR_FULL))
1396 gfc_error ("The upper bound in the last dimension must "
1397 "appear in the reference to the assumed size "
1398 "array '%s' at %L", sym->name, &e->where);
1405 /* Look for bad assumed size array references in argument expressions
1406 of elemental and array valued intrinsic procedures. Since this is
1407 called from procedure resolution functions, it only recurses at
1411 resolve_assumed_size_actual (gfc_expr *e)
1416 switch (e->expr_type)
1419 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1424 if (resolve_assumed_size_actual (e->value.op.op1)
1425 || resolve_assumed_size_actual (e->value.op.op2))
1436 /* Check a generic procedure, passed as an actual argument, to see if
1437 there is a matching specific name. If none, it is an error, and if
1438 more than one, the reference is ambiguous. */
1440 count_specific_procs (gfc_expr *e)
1447 sym = e->symtree->n.sym;
1449 for (p = sym->generic; p; p = p->next)
1450 if (strcmp (sym->name, p->sym->name) == 0)
1452 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1458 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1462 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1463 "argument at %L", sym->name, &e->where);
1469 /* See if a call to sym could possibly be a not allowed RECURSION because of
1470 a missing RECURSIVE declaration. This means that either sym is the current
1471 context itself, or sym is the parent of a contained procedure calling its
1472 non-RECURSIVE containing procedure.
1473 This also works if sym is an ENTRY. */
1476 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1478 gfc_symbol* proc_sym;
1479 gfc_symbol* context_proc;
1480 gfc_namespace* real_context;
1482 if (sym->attr.flavor == FL_PROGRAM
1483 || sym->attr.flavor == FL_DERIVED)
1486 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1488 /* If we've got an ENTRY, find real procedure. */
1489 if (sym->attr.entry && sym->ns->entries)
1490 proc_sym = sym->ns->entries->sym;
1494 /* If sym is RECURSIVE, all is well of course. */
1495 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1498 /* Find the context procedure's "real" symbol if it has entries.
1499 We look for a procedure symbol, so recurse on the parents if we don't
1500 find one (like in case of a BLOCK construct). */
1501 for (real_context = context; ; real_context = real_context->parent)
1503 /* We should find something, eventually! */
1504 gcc_assert (real_context);
1506 context_proc = (real_context->entries ? real_context->entries->sym
1507 : real_context->proc_name);
1509 /* In some special cases, there may not be a proc_name, like for this
1511 real(bad_kind()) function foo () ...
1512 when checking the call to bad_kind ().
1513 In these cases, we simply return here and assume that the
1518 if (context_proc->attr.flavor != FL_LABEL)
1522 /* A call from sym's body to itself is recursion, of course. */
1523 if (context_proc == proc_sym)
1526 /* The same is true if context is a contained procedure and sym the
1528 if (context_proc->attr.contained)
1530 gfc_symbol* parent_proc;
1532 gcc_assert (context->parent);
1533 parent_proc = (context->parent->entries ? context->parent->entries->sym
1534 : context->parent->proc_name);
1536 if (parent_proc == proc_sym)
1544 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1545 its typespec and formal argument list. */
1548 gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1550 gfc_intrinsic_sym* isym = NULL;
1556 /* Already resolved. */
1557 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1560 /* We already know this one is an intrinsic, so we don't call
1561 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1562 gfc_find_subroutine directly to check whether it is a function or
1565 if (sym->intmod_sym_id)
1566 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1567 else if (!sym->attr.subroutine)
1568 isym = gfc_find_function (sym->name);
1572 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1573 && !sym->attr.implicit_type)
1574 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1575 " ignored", sym->name, &sym->declared_at);
1577 if (!sym->attr.function &&
1578 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1583 else if ((isym = gfc_find_subroutine (sym->name)))
1585 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1587 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1588 " specifier", sym->name, &sym->declared_at);
1592 if (!sym->attr.subroutine &&
1593 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1598 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1603 gfc_copy_formal_args_intr (sym, isym);
1605 /* Check it is actually available in the standard settings. */
1606 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1609 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1610 " available in the current standard settings but %s. Use"
1611 " an appropriate -std=* option or enable -fall-intrinsics"
1612 " in order to use it.",
1613 sym->name, &sym->declared_at, symstd);
1621 /* Resolve a procedure expression, like passing it to a called procedure or as
1622 RHS for a procedure pointer assignment. */
1625 resolve_procedure_expression (gfc_expr* expr)
1629 if (expr->expr_type != EXPR_VARIABLE)
1631 gcc_assert (expr->symtree);
1633 sym = expr->symtree->n.sym;
1635 if (sym->attr.intrinsic)
1636 gfc_resolve_intrinsic (sym, &expr->where);
1638 if (sym->attr.flavor != FL_PROCEDURE
1639 || (sym->attr.function && sym->result == sym))
1642 /* A non-RECURSIVE procedure that is used as procedure expression within its
1643 own body is in danger of being called recursively. */
1644 if (is_illegal_recursion (sym, gfc_current_ns))
1645 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1646 " itself recursively. Declare it RECURSIVE or use"
1647 " -frecursive", sym->name, &expr->where);
1653 /* Resolve an actual argument list. Most of the time, this is just
1654 resolving the expressions in the list.
1655 The exception is that we sometimes have to decide whether arguments
1656 that look like procedure arguments are really simple variable
1660 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1661 bool no_formal_args)
1664 gfc_symtree *parent_st;
1666 int save_need_full_assumed_size;
1667 gfc_try return_value = FAILURE;
1668 bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
1671 first_actual_arg = true;
1673 for (; arg; arg = arg->next)
1678 /* Check the label is a valid branching target. */
1681 if (arg->label->defined == ST_LABEL_UNKNOWN)
1683 gfc_error ("Label %d referenced at %L is never defined",
1684 arg->label->value, &arg->label->where);
1688 first_actual_arg = false;
1692 if (e->expr_type == EXPR_VARIABLE
1693 && e->symtree->n.sym->attr.generic
1695 && count_specific_procs (e) != 1)
1698 if (e->ts.type != BT_PROCEDURE)
1700 save_need_full_assumed_size = need_full_assumed_size;
1701 if (e->expr_type != EXPR_VARIABLE)
1702 need_full_assumed_size = 0;
1703 if (gfc_resolve_expr (e) != SUCCESS)
1705 need_full_assumed_size = save_need_full_assumed_size;
1709 /* See if the expression node should really be a variable reference. */
1711 sym = e->symtree->n.sym;
1713 if (sym->attr.flavor == FL_PROCEDURE
1714 || sym->attr.intrinsic
1715 || sym->attr.external)
1719 /* If a procedure is not already determined to be something else
1720 check if it is intrinsic. */
1721 if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1722 sym->attr.intrinsic = 1;
1724 if (sym->attr.proc == PROC_ST_FUNCTION)
1726 gfc_error ("Statement function '%s' at %L is not allowed as an "
1727 "actual argument", sym->name, &e->where);
1730 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1731 sym->attr.subroutine);
1732 if (sym->attr.intrinsic && actual_ok == 0)
1734 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1735 "actual argument", sym->name, &e->where);
1738 if (sym->attr.contained && !sym->attr.use_assoc
1739 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1741 if (gfc_notify_std (GFC_STD_F2008,
1742 "Internal procedure '%s' is"
1743 " used as actual argument at %L",
1744 sym->name, &e->where) == FAILURE)
1748 if (sym->attr.elemental && !sym->attr.intrinsic)
1750 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1751 "allowed as an actual argument at %L", sym->name,
1755 /* Check if a generic interface has a specific procedure
1756 with the same name before emitting an error. */
1757 if (sym->attr.generic && count_specific_procs (e) != 1)
1760 /* Just in case a specific was found for the expression. */
1761 sym = e->symtree->n.sym;
1763 /* If the symbol is the function that names the current (or
1764 parent) scope, then we really have a variable reference. */
1766 if (gfc_is_function_return_value (sym, sym->ns))
1769 /* If all else fails, see if we have a specific intrinsic. */
1770 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1772 gfc_intrinsic_sym *isym;
1774 isym = gfc_find_function (sym->name);
1775 if (isym == NULL || !isym->specific)
1777 gfc_error ("Unable to find a specific INTRINSIC procedure "
1778 "for the reference '%s' at %L", sym->name,
1783 sym->attr.intrinsic = 1;
1784 sym->attr.function = 1;
1787 if (gfc_resolve_expr (e) == FAILURE)
1792 /* See if the name is a module procedure in a parent unit. */
1794 if (was_declared (sym) || sym->ns->parent == NULL)
1797 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1799 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1803 if (parent_st == NULL)
1806 sym = parent_st->n.sym;
1807 e->symtree = parent_st; /* Point to the right thing. */
1809 if (sym->attr.flavor == FL_PROCEDURE
1810 || sym->attr.intrinsic
1811 || sym->attr.external)
1813 if (gfc_resolve_expr (e) == FAILURE)
1819 e->expr_type = EXPR_VARIABLE;
1821 if ((sym->as != NULL && sym->ts.type != BT_CLASS)
1822 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1823 && CLASS_DATA (sym)->as))
1825 e->rank = sym->ts.type == BT_CLASS
1826 ? CLASS_DATA (sym)->as->rank : sym->as->rank;
1827 e->ref = gfc_get_ref ();
1828 e->ref->type = REF_ARRAY;
1829 e->ref->u.ar.type = AR_FULL;
1830 e->ref->u.ar.as = sym->ts.type == BT_CLASS
1831 ? CLASS_DATA (sym)->as : sym->as;
1834 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1835 primary.c (match_actual_arg). If above code determines that it
1836 is a variable instead, it needs to be resolved as it was not
1837 done at the beginning of this function. */
1838 save_need_full_assumed_size = need_full_assumed_size;
1839 if (e->expr_type != EXPR_VARIABLE)
1840 need_full_assumed_size = 0;
1841 if (gfc_resolve_expr (e) != SUCCESS)
1843 need_full_assumed_size = save_need_full_assumed_size;
1846 /* Check argument list functions %VAL, %LOC and %REF. There is
1847 nothing to do for %REF. */
1848 if (arg->name && arg->name[0] == '%')
1850 if (strncmp ("%VAL", arg->name, 4) == 0)
1852 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1854 gfc_error ("By-value argument at %L is not of numeric "
1861 gfc_error ("By-value argument at %L cannot be an array or "
1862 "an array section", &e->where);
1866 /* Intrinsics are still PROC_UNKNOWN here. However,
1867 since same file external procedures are not resolvable
1868 in gfortran, it is a good deal easier to leave them to
1870 if (ptype != PROC_UNKNOWN
1871 && ptype != PROC_DUMMY
1872 && ptype != PROC_EXTERNAL
1873 && ptype != PROC_MODULE)
1875 gfc_error ("By-value argument at %L is not allowed "
1876 "in this context", &e->where);
1881 /* Statement functions have already been excluded above. */
1882 else if (strncmp ("%LOC", arg->name, 4) == 0
1883 && e->ts.type == BT_PROCEDURE)
1885 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1887 gfc_error ("Passing internal procedure at %L by location "
1888 "not allowed", &e->where);
1894 /* Fortran 2008, C1237. */
1895 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1896 && gfc_has_ultimate_pointer (e))
1898 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1899 "component", &e->where);
1903 first_actual_arg = false;
1906 return_value = SUCCESS;
1909 actual_arg = actual_arg_sav;
1910 first_actual_arg = first_actual_arg_sav;
1912 return return_value;
1916 /* Do the checks of the actual argument list that are specific to elemental
1917 procedures. If called with c == NULL, we have a function, otherwise if
1918 expr == NULL, we have a subroutine. */
1921 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1923 gfc_actual_arglist *arg0;
1924 gfc_actual_arglist *arg;
1925 gfc_symbol *esym = NULL;
1926 gfc_intrinsic_sym *isym = NULL;
1928 gfc_intrinsic_arg *iformal = NULL;
1929 gfc_formal_arglist *eformal = NULL;
1930 bool formal_optional = false;
1931 bool set_by_optional = false;
1935 /* Is this an elemental procedure? */
1936 if (expr && expr->value.function.actual != NULL)
1938 if (expr->value.function.esym != NULL
1939 && expr->value.function.esym->attr.elemental)
1941 arg0 = expr->value.function.actual;
1942 esym = expr->value.function.esym;
1944 else if (expr->value.function.isym != NULL
1945 && expr->value.function.isym->elemental)
1947 arg0 = expr->value.function.actual;
1948 isym = expr->value.function.isym;
1953 else if (c && c->ext.actual != NULL)
1955 arg0 = c->ext.actual;
1957 if (c->resolved_sym)
1958 esym = c->resolved_sym;
1960 esym = c->symtree->n.sym;
1963 if (!esym->attr.elemental)
1969 /* The rank of an elemental is the rank of its array argument(s). */
1970 for (arg = arg0; arg; arg = arg->next)
1972 if (arg->expr != NULL && arg->expr->rank != 0)
1974 rank = arg->expr->rank;
1975 if (arg->expr->expr_type == EXPR_VARIABLE
1976 && arg->expr->symtree->n.sym->attr.optional)
1977 set_by_optional = true;
1979 /* Function specific; set the result rank and shape. */
1983 if (!expr->shape && arg->expr->shape)
1985 expr->shape = gfc_get_shape (rank);
1986 for (i = 0; i < rank; i++)
1987 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1994 /* If it is an array, it shall not be supplied as an actual argument
1995 to an elemental procedure unless an array of the same rank is supplied
1996 as an actual argument corresponding to a nonoptional dummy argument of
1997 that elemental procedure(12.4.1.5). */
1998 formal_optional = false;
2000 iformal = isym->formal;
2002 eformal = esym->formal;
2004 for (arg = arg0; arg; arg = arg->next)
2008 if (eformal->sym && eformal->sym->attr.optional)
2009 formal_optional = true;
2010 eformal = eformal->next;
2012 else if (isym && iformal)
2014 if (iformal->optional)
2015 formal_optional = true;
2016 iformal = iformal->next;
2019 formal_optional = true;
2021 if (pedantic && arg->expr != NULL
2022 && arg->expr->expr_type == EXPR_VARIABLE
2023 && arg->expr->symtree->n.sym->attr.optional
2026 && (set_by_optional || arg->expr->rank != rank)
2027 && !(isym && isym->id == GFC_ISYM_CONVERSION))
2029 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2030 "MISSING, it cannot be the actual argument of an "
2031 "ELEMENTAL procedure unless there is a non-optional "
2032 "argument with the same rank (12.4.1.5)",
2033 arg->expr->symtree->n.sym->name, &arg->expr->where);
2037 for (arg = arg0; arg; arg = arg->next)
2039 if (arg->expr == NULL || arg->expr->rank == 0)
2042 /* Being elemental, the last upper bound of an assumed size array
2043 argument must be present. */
2044 if (resolve_assumed_size_actual (arg->expr))
2047 /* Elemental procedure's array actual arguments must conform. */
2050 if (gfc_check_conformance (arg->expr, e,
2051 "elemental procedure") == FAILURE)
2058 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2059 is an array, the intent inout/out variable needs to be also an array. */
2060 if (rank > 0 && esym && expr == NULL)
2061 for (eformal = esym->formal, arg = arg0; arg && eformal;
2062 arg = arg->next, eformal = eformal->next)
2063 if ((eformal->sym->attr.intent == INTENT_OUT
2064 || eformal->sym->attr.intent == INTENT_INOUT)
2065 && arg->expr && arg->expr->rank == 0)
2067 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2068 "ELEMENTAL subroutine '%s' is a scalar, but another "
2069 "actual argument is an array", &arg->expr->where,
2070 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2071 : "INOUT", eformal->sym->name, esym->name);
2078 /* This function does the checking of references to global procedures
2079 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2080 77 and 95 standards. It checks for a gsymbol for the name, making
2081 one if it does not already exist. If it already exists, then the
2082 reference being resolved must correspond to the type of gsymbol.
2083 Otherwise, the new symbol is equipped with the attributes of the
2084 reference. The corresponding code that is called in creating
2085 global entities is parse.c.
2087 In addition, for all but -std=legacy, the gsymbols are used to
2088 check the interfaces of external procedures from the same file.
2089 The namespace of the gsymbol is resolved and then, once this is
2090 done the interface is checked. */
2094 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2096 if (!gsym_ns->proc_name->attr.recursive)
2099 if (sym->ns == gsym_ns)
2102 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2109 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2111 if (gsym_ns->entries)
2113 gfc_entry_list *entry = gsym_ns->entries;
2115 for (; entry; entry = entry->next)
2117 if (strcmp (sym->name, entry->sym->name) == 0)
2119 if (strcmp (gsym_ns->proc_name->name,
2120 sym->ns->proc_name->name) == 0)
2124 && strcmp (gsym_ns->proc_name->name,
2125 sym->ns->parent->proc_name->name) == 0)
2134 resolve_global_procedure (gfc_symbol *sym, locus *where,
2135 gfc_actual_arglist **actual, int sub)
2139 enum gfc_symbol_type type;
2141 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2143 gsym = gfc_get_gsymbol (sym->name);
2145 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2146 gfc_global_used (gsym, where);
2148 if (gfc_option.flag_whole_file
2149 && (sym->attr.if_source == IFSRC_UNKNOWN
2150 || sym->attr.if_source == IFSRC_IFBODY)
2151 && gsym->type != GSYM_UNKNOWN
2153 && gsym->ns->resolved != -1
2154 && gsym->ns->proc_name
2155 && not_in_recursive (sym, gsym->ns)
2156 && not_entry_self_reference (sym, gsym->ns))
2158 gfc_symbol *def_sym;
2160 /* Resolve the gsymbol namespace if needed. */
2161 if (!gsym->ns->resolved)
2163 gfc_dt_list *old_dt_list;
2164 struct gfc_omp_saved_state old_omp_state;
2166 /* Stash away derived types so that the backend_decls do not
2168 old_dt_list = gfc_derived_types;
2169 gfc_derived_types = NULL;
2170 /* And stash away openmp state. */
2171 gfc_omp_save_and_clear_state (&old_omp_state);
2173 gfc_resolve (gsym->ns);
2175 /* Store the new derived types with the global namespace. */
2176 if (gfc_derived_types)
2177 gsym->ns->derived_types = gfc_derived_types;
2179 /* Restore the derived types of this namespace. */
2180 gfc_derived_types = old_dt_list;
2181 /* And openmp state. */
2182 gfc_omp_restore_state (&old_omp_state);
2185 /* Make sure that translation for the gsymbol occurs before
2186 the procedure currently being resolved. */
2187 ns = gfc_global_ns_list;
2188 for (; ns && ns != gsym->ns; ns = ns->sibling)
2190 if (ns->sibling == gsym->ns)
2192 ns->sibling = gsym->ns->sibling;
2193 gsym->ns->sibling = gfc_global_ns_list;
2194 gfc_global_ns_list = gsym->ns;
2199 def_sym = gsym->ns->proc_name;
2200 if (def_sym->attr.entry_master)
2202 gfc_entry_list *entry;
2203 for (entry = gsym->ns->entries; entry; entry = entry->next)
2204 if (strcmp (entry->sym->name, sym->name) == 0)
2206 def_sym = entry->sym;
2211 /* Differences in constant character lengths. */
2212 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2214 long int l1 = 0, l2 = 0;
2215 gfc_charlen *cl1 = sym->ts.u.cl;
2216 gfc_charlen *cl2 = def_sym->ts.u.cl;
2219 && cl1->length != NULL
2220 && cl1->length->expr_type == EXPR_CONSTANT)
2221 l1 = mpz_get_si (cl1->length->value.integer);
2224 && cl2->length != NULL
2225 && cl2->length->expr_type == EXPR_CONSTANT)
2226 l2 = mpz_get_si (cl2->length->value.integer);
2228 if (l1 && l2 && l1 != l2)
2229 gfc_error ("Character length mismatch in return type of "
2230 "function '%s' at %L (%ld/%ld)", sym->name,
2231 &sym->declared_at, l1, l2);
2234 /* Type mismatch of function return type and expected type. */
2235 if (sym->attr.function
2236 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2237 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2238 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2239 gfc_typename (&def_sym->ts));
2241 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2243 gfc_formal_arglist *arg = def_sym->formal;
2244 for ( ; arg; arg = arg->next)
2247 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2248 else if (arg->sym->attr.allocatable
2249 || arg->sym->attr.asynchronous
2250 || arg->sym->attr.optional
2251 || arg->sym->attr.pointer
2252 || arg->sym->attr.target
2253 || arg->sym->attr.value
2254 || arg->sym->attr.volatile_)
2256 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2257 "has an attribute that requires an explicit "
2258 "interface for this procedure", arg->sym->name,
2259 sym->name, &sym->declared_at);
2262 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2263 else if (arg->sym && arg->sym->as
2264 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2266 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2267 "argument '%s' must have an explicit interface",
2268 sym->name, &sym->declared_at, arg->sym->name);
2271 /* TS 29113, 6.2. */
2272 else if (arg->sym && arg->sym->as
2273 && arg->sym->as->type == AS_ASSUMED_RANK)
2275 gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
2276 "argument '%s' must have an explicit interface",
2277 sym->name, &sym->declared_at, arg->sym->name);
2280 /* F2008, 12.4.2.2 (2c) */
2281 else if (arg->sym->attr.codimension)
2283 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2284 "'%s' must have an explicit interface",
2285 sym->name, &sym->declared_at, arg->sym->name);
2288 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2289 else if (false) /* TODO: is a parametrized derived type */
2291 gfc_error ("Procedure '%s' at %L with parametrized derived "
2292 "type argument '%s' must have an explicit "
2293 "interface", sym->name, &sym->declared_at,
2297 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2298 else if (arg->sym->ts.type == BT_CLASS)
2300 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2301 "argument '%s' must have an explicit interface",
2302 sym->name, &sym->declared_at, arg->sym->name);
2305 /* As assumed-type is unlimited polymorphic (cf. above).
2306 See also TS 29113, Note 6.1. */
2307 else if (arg->sym->ts.type == BT_ASSUMED)
2309 gfc_error ("Procedure '%s' at %L with assumed-type dummy "
2310 "argument '%s' must have an explicit interface",
2311 sym->name, &sym->declared_at, arg->sym->name);
2316 if (def_sym->attr.function)
2318 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2319 if (def_sym->as && def_sym->as->rank
2320 && (!sym->as || sym->as->rank != def_sym->as->rank))
2321 gfc_error ("The reference to function '%s' at %L either needs an "
2322 "explicit INTERFACE or the rank is incorrect", sym->name,
2325 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2326 if ((def_sym->result->attr.pointer
2327 || def_sym->result->attr.allocatable)
2328 && (sym->attr.if_source != IFSRC_IFBODY
2329 || def_sym->result->attr.pointer
2330 != sym->result->attr.pointer
2331 || def_sym->result->attr.allocatable
2332 != sym->result->attr.allocatable))
2333 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2334 "result must have an explicit interface", sym->name,
2337 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2338 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2339 && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
2341 gfc_charlen *cl = sym->ts.u.cl;
2343 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2344 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2346 gfc_error ("Nonconstant character-length function '%s' at %L "
2347 "must have an explicit interface", sym->name,
2353 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2354 if (def_sym->attr.elemental && !sym->attr.elemental)
2356 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2357 "interface", sym->name, &sym->declared_at);
2360 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2361 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2363 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2364 "an explicit interface", sym->name, &sym->declared_at);
2367 if (gfc_option.flag_whole_file == 1
2368 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2369 && !(gfc_option.warn_std & GFC_STD_GNU)))
2370 gfc_errors_to_warnings (1);
2372 if (sym->attr.if_source != IFSRC_IFBODY)
2373 gfc_procedure_use (def_sym, actual, where);
2375 gfc_errors_to_warnings (0);
2378 if (gsym->type == GSYM_UNKNOWN)
2381 gsym->where = *where;
2388 /************* Function resolution *************/
2390 /* Resolve a function call known to be generic.
2391 Section 14.1.2.4.1. */
2394 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2398 if (sym->attr.generic)
2400 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2403 expr->value.function.name = s->name;
2404 expr->value.function.esym = s;
2406 if (s->ts.type != BT_UNKNOWN)
2408 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2409 expr->ts = s->result->ts;
2412 expr->rank = s->as->rank;
2413 else if (s->result != NULL && s->result->as != NULL)
2414 expr->rank = s->result->as->rank;
2416 gfc_set_sym_referenced (expr->value.function.esym);
2421 /* TODO: Need to search for elemental references in generic
2425 if (sym->attr.intrinsic)
2426 return gfc_intrinsic_func_interface (expr, 0);
2433 resolve_generic_f (gfc_expr *expr)
2437 gfc_interface *intr = NULL;
2439 sym = expr->symtree->n.sym;
2443 m = resolve_generic_f0 (expr, sym);
2446 else if (m == MATCH_ERROR)
2451 for (intr = sym->generic; intr; intr = intr->next)
2452 if (intr->sym->attr.flavor == FL_DERIVED)
2455 if (sym->ns->parent == NULL)
2457 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2461 if (!generic_sym (sym))
2465 /* Last ditch attempt. See if the reference is to an intrinsic
2466 that possesses a matching interface. 14.1.2.4 */
2467 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2469 gfc_error ("There is no specific function for the generic '%s' "
2470 "at %L", expr->symtree->n.sym->name, &expr->where);
2476 if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
2479 return resolve_structure_cons (expr, 0);
2482 m = gfc_intrinsic_func_interface (expr, 0);
2487 gfc_error ("Generic function '%s' at %L is not consistent with a "
2488 "specific intrinsic interface", expr->symtree->n.sym->name,
2495 /* Resolve a function call known to be specific. */
2498 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2502 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2504 if (sym->attr.dummy)
2506 sym->attr.proc = PROC_DUMMY;
2510 sym->attr.proc = PROC_EXTERNAL;
2514 if (sym->attr.proc == PROC_MODULE
2515 || sym->attr.proc == PROC_ST_FUNCTION
2516 || sym->attr.proc == PROC_INTERNAL)
2519 if (sym->attr.intrinsic)
2521 m = gfc_intrinsic_func_interface (expr, 1);
2525 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2526 "with an intrinsic", sym->name, &expr->where);
2534 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2537 expr->ts = sym->result->ts;
2540 expr->value.function.name = sym->name;
2541 expr->value.function.esym = sym;
2542 if (sym->as != NULL)
2543 expr->rank = sym->as->rank;
2550 resolve_specific_f (gfc_expr *expr)
2555 sym = expr->symtree->n.sym;
2559 m = resolve_specific_f0 (sym, expr);
2562 if (m == MATCH_ERROR)
2565 if (sym->ns->parent == NULL)
2568 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2574 gfc_error ("Unable to resolve the specific function '%s' at %L",
2575 expr->symtree->n.sym->name, &expr->where);
2581 /* Resolve a procedure call not known to be generic nor specific. */
2584 resolve_unknown_f (gfc_expr *expr)
2589 sym = expr->symtree->n.sym;
2591 if (sym->attr.dummy)
2593 sym->attr.proc = PROC_DUMMY;
2594 expr->value.function.name = sym->name;
2598 /* See if we have an intrinsic function reference. */
2600 if (gfc_is_intrinsic (sym, 0, expr->where))
2602 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2607 /* The reference is to an external name. */
2609 sym->attr.proc = PROC_EXTERNAL;
2610 expr->value.function.name = sym->name;
2611 expr->value.function.esym = expr->symtree->n.sym;
2613 if (sym->as != NULL)
2614 expr->rank = sym->as->rank;
2616 /* Type of the expression is either the type of the symbol or the
2617 default type of the symbol. */
2620 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2622 if (sym->ts.type != BT_UNKNOWN)
2626 ts = gfc_get_default_type (sym->name, sym->ns);
2628 if (ts->type == BT_UNKNOWN)
2630 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2631 sym->name, &expr->where);
2642 /* Return true, if the symbol is an external procedure. */
2644 is_external_proc (gfc_symbol *sym)
2646 if (!sym->attr.dummy && !sym->attr.contained
2647 && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
2648 && sym->attr.proc != PROC_ST_FUNCTION
2649 && !sym->attr.proc_pointer
2650 && !sym->attr.use_assoc
2658 /* Figure out if a function reference is pure or not. Also set the name
2659 of the function for a potential error message. Return nonzero if the
2660 function is PURE, zero if not. */
2662 pure_stmt_function (gfc_expr *, gfc_symbol *);
2665 pure_function (gfc_expr *e, const char **name)
2671 if (e->symtree != NULL
2672 && e->symtree->n.sym != NULL
2673 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2674 return pure_stmt_function (e, e->symtree->n.sym);
2676 if (e->value.function.esym)
2678 pure = gfc_pure (e->value.function.esym);
2679 *name = e->value.function.esym->name;
2681 else if (e->value.function.isym)
2683 pure = e->value.function.isym->pure
2684 || e->value.function.isym->elemental;
2685 *name = e->value.function.isym->name;
2689 /* Implicit functions are not pure. */
2691 *name = e->value.function.name;
2699 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2700 int *f ATTRIBUTE_UNUSED)
2704 /* Don't bother recursing into other statement functions
2705 since they will be checked individually for purity. */
2706 if (e->expr_type != EXPR_FUNCTION
2708 || e->symtree->n.sym == sym
2709 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2712 return pure_function (e, &name) ? false : true;
2717 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2719 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2724 is_scalar_expr_ptr (gfc_expr *expr)
2726 gfc_try retval = SUCCESS;
2731 /* See if we have a gfc_ref, which means we have a substring, array
2732 reference, or a component. */
2733 if (expr->ref != NULL)
2736 while (ref->next != NULL)
2742 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2743 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2748 if (ref->u.ar.type == AR_ELEMENT)
2750 else if (ref->u.ar.type == AR_FULL)
2752 /* The user can give a full array if the array is of size 1. */
2753 if (ref->u.ar.as != NULL
2754 && ref->u.ar.as->rank == 1
2755 && ref->u.ar.as->type == AS_EXPLICIT
2756 && ref->u.ar.as->lower[0] != NULL
2757 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2758 && ref->u.ar.as->upper[0] != NULL
2759 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2761 /* If we have a character string, we need to check if
2762 its length is one. */
2763 if (expr->ts.type == BT_CHARACTER)
2765 if (expr->ts.u.cl == NULL
2766 || expr->ts.u.cl->length == NULL
2767 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2773 /* We have constant lower and upper bounds. If the
2774 difference between is 1, it can be considered a
2776 FIXME: Use gfc_dep_compare_expr instead. */
2777 start = (int) mpz_get_si
2778 (ref->u.ar.as->lower[0]->value.integer);
2779 end = (int) mpz_get_si
2780 (ref->u.ar.as->upper[0]->value.integer);
2781 if (end - start + 1 != 1)
2796 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2798 /* Character string. Make sure it's of length 1. */
2799 if (expr->ts.u.cl == NULL
2800 || expr->ts.u.cl->length == NULL
2801 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2804 else if (expr->rank != 0)
2811 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2812 and, in the case of c_associated, set the binding label based on
2816 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2817 gfc_symbol **new_sym)
2819 char name[GFC_MAX_SYMBOL_LEN + 1];
2820 int optional_arg = 0;
2821 gfc_try retval = SUCCESS;
2822 gfc_symbol *args_sym;
2823 gfc_typespec *arg_ts;
2824 symbol_attribute arg_attr;
2826 if (args->expr->expr_type == EXPR_CONSTANT
2827 || args->expr->expr_type == EXPR_OP
2828 || args->expr->expr_type == EXPR_NULL)
2830 gfc_error ("Argument to '%s' at %L is not a variable",
2831 sym->name, &(args->expr->where));
2835 args_sym = args->expr->symtree->n.sym;
2837 /* The typespec for the actual arg should be that stored in the expr
2838 and not necessarily that of the expr symbol (args_sym), because
2839 the actual expression could be a part-ref of the expr symbol. */
2840 arg_ts = &(args->expr->ts);
2841 arg_attr = gfc_expr_attr (args->expr);
2843 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2845 /* If the user gave two args then they are providing something for
2846 the optional arg (the second cptr). Therefore, set the name and
2847 binding label to the c_associated for two cptrs. Otherwise,
2848 set c_associated to expect one cptr. */
2852 sprintf (name, "%s_2", sym->name);
2858 sprintf (name, "%s_1", sym->name);
2862 /* Get a new symbol for the version of c_associated that
2864 *new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
2866 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2867 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2869 sprintf (name, "%s", sym->name);
2871 /* Error check the call. */
2872 if (args->next != NULL)
2874 gfc_error_now ("More actual than formal arguments in '%s' "
2875 "call at %L", name, &(args->expr->where));
2878 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2883 /* Make sure we have either the target or pointer attribute. */
2884 if (!arg_attr.target && !arg_attr.pointer)
2886 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2887 "a TARGET or an associated pointer",
2889 sym->name, &(args->expr->where));
2893 if (gfc_is_coindexed (args->expr))
2895 gfc_error_now ("Coindexed argument not permitted"
2896 " in '%s' call at %L", name,
2897 &(args->expr->where));
2901 /* Follow references to make sure there are no array
2903 seen_section = false;
2905 for (ref=args->expr->ref; ref; ref = ref->next)
2907 if (ref->type == REF_ARRAY)
2909 if (ref->u.ar.type == AR_SECTION)
2910 seen_section = true;
2912 if (ref->u.ar.type != AR_ELEMENT)
2915 for (r = ref->next; r; r=r->next)
2916 if (r->type == REF_COMPONENT)
2918 gfc_error_now ("Array section not permitted"
2919 " in '%s' call at %L", name,
2920 &(args->expr->where));
2928 if (seen_section && retval == SUCCESS)
2929 gfc_warning ("Array section in '%s' call at %L", name,
2930 &(args->expr->where));
2932 /* See if we have interoperable type and type param. */
2933 if (gfc_verify_c_interop (arg_ts) == SUCCESS
2934 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2936 if (args_sym->attr.target == 1)
2938 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2939 has the target attribute and is interoperable. */
2940 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2941 allocatable variable that has the TARGET attribute and
2942 is not an array of zero size. */
2943 if (args_sym->attr.allocatable == 1)
2945 if (args_sym->attr.dimension != 0
2946 && (args_sym->as && args_sym->as->rank == 0))
2948 gfc_error_now ("Allocatable variable '%s' used as a "
2949 "parameter to '%s' at %L must not be "
2950 "an array of zero size",
2951 args_sym->name, sym->name,
2952 &(args->expr->where));
2958 /* A non-allocatable target variable with C
2959 interoperable type and type parameters must be
2961 if (args_sym && args_sym->attr.dimension)
2963 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2965 gfc_error ("Assumed-shape array '%s' at %L "
2966 "cannot be an argument to the "
2967 "procedure '%s' because "
2968 "it is not C interoperable",
2970 &(args->expr->where), sym->name);
2973 else if (args_sym->as->type == AS_DEFERRED)
2975 gfc_error ("Deferred-shape array '%s' at %L "
2976 "cannot be an argument to the "
2977 "procedure '%s' because "
2978 "it is not C interoperable",
2980 &(args->expr->where), sym->name);
2985 /* Make sure it's not a character string. Arrays of
2986 any type should be ok if the variable is of a C
2987 interoperable type. */
2988 if (arg_ts->type == BT_CHARACTER)
2989 if (arg_ts->u.cl != NULL
2990 && (arg_ts->u.cl->length == NULL
2991 || arg_ts->u.cl->length->expr_type
2994 (arg_ts->u.cl->length->value.integer, 1)
2996 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2998 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2999 "at %L must have a length of 1",
3000 args_sym->name, sym->name,
3001 &(args->expr->where));
3006 else if (arg_attr.pointer
3007 && is_scalar_expr_ptr (args->expr) != SUCCESS)
3009 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
3011 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
3012 "associated scalar POINTER", args_sym->name,
3013 sym->name, &(args->expr->where));
3019 /* The parameter is not required to be C interoperable. If it
3020 is not C interoperable, it must be a nonpolymorphic scalar
3021 with no length type parameters. It still must have either
3022 the pointer or target attribute, and it can be
3023 allocatable (but must be allocated when c_loc is called). */
3024 if (args->expr->rank != 0
3025 && is_scalar_expr_ptr (args->expr) != SUCCESS)
3027 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
3028 "scalar", args_sym->name, sym->name,
3029 &(args->expr->where));
3032 else if (arg_ts->type == BT_CHARACTER
3033 && is_scalar_expr_ptr (args->expr) != SUCCESS)
3035 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
3036 "%L must have a length of 1",
3037 args_sym->name, sym->name,
3038 &(args->expr->where));
3041 else if (arg_ts->type == BT_CLASS)
3043 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
3044 "polymorphic", args_sym->name, sym->name,
3045 &(args->expr->where));
3050 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
3052 if (args_sym->attr.flavor != FL_PROCEDURE)
3054 /* TODO: Update this error message to allow for procedure
3055 pointers once they are implemented. */
3056 gfc_error_now ("Argument '%s' to '%s' at %L must be a "
3058 args_sym->name, sym->name,
3059 &(args->expr->where));
3062 else if (args_sym->attr.is_bind_c != 1
3063 && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
3064 "argument '%s' to '%s' at %L",
3065 args_sym->name, sym->name,
3066 &(args->expr->where)) == FAILURE)
3070 /* for c_loc/c_funloc, the new symbol is the same as the old one */
3075 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
3076 "iso_c_binding function: '%s'!\n", sym->name);
3083 /* Resolve a function call, which means resolving the arguments, then figuring
3084 out which entity the name refers to. */
3087 resolve_function (gfc_expr *expr)
3089 gfc_actual_arglist *arg;
3094 procedure_type p = PROC_INTRINSIC;
3095 bool no_formal_args;
3099 sym = expr->symtree->n.sym;
3101 /* If this is a procedure pointer component, it has already been resolved. */
3102 if (gfc_is_proc_ptr_comp (expr))
3105 if (sym && sym->attr.intrinsic
3106 && gfc_resolve_intrinsic (sym, &expr->where) == FAILURE)
3109 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3111 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
3115 /* If this ia a deferred TBP with an abstract interface (which may
3116 of course be referenced), expr->value.function.esym will be set. */
3117 if (sym && sym->attr.abstract && !expr->value.function.esym)
3119 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3120 sym->name, &expr->where);
3124 /* Switch off assumed size checking and do this again for certain kinds
3125 of procedure, once the procedure itself is resolved. */
3126 need_full_assumed_size++;
3128 if (expr->symtree && expr->symtree->n.sym)
3129 p = expr->symtree->n.sym->attr.proc;
3131 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3132 inquiry_argument = true;
3133 no_formal_args = sym && is_external_proc (sym)
3134 && gfc_sym_get_dummy_args (sym) == NULL;
3136 if (resolve_actual_arglist (expr->value.function.actual,
3137 p, no_formal_args) == FAILURE)
3139 inquiry_argument = false;
3143 inquiry_argument = false;
3145 /* Need to setup the call to the correct c_associated, depending on
3146 the number of cptrs to user gives to compare. */
3147 if (sym && sym->attr.is_iso_c == 1)
3149 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
3153 /* Get the symtree for the new symbol (resolved func).
3154 the old one will be freed later, when it's no longer used. */
3155 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
3158 /* Resume assumed_size checking. */
3159 need_full_assumed_size--;
3161 /* If the procedure is external, check for usage. */
3162 if (sym && is_external_proc (sym))
3163 resolve_global_procedure (sym, &expr->where,
3164 &expr->value.function.actual, 0);
3166 if (sym && sym->ts.type == BT_CHARACTER
3168 && sym->ts.u.cl->length == NULL
3170 && !sym->ts.deferred
3171 && expr->value.function.esym == NULL
3172 && !sym->attr.contained)
3174 /* Internal procedures are taken care of in resolve_contained_fntype. */
3175 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3176 "be used at %L since it is not a dummy argument",
3177 sym->name, &expr->where);
3181 /* See if function is already resolved. */
3183 if (expr->value.function.name != NULL)
3185 if (expr->ts.type == BT_UNKNOWN)
3191 /* Apply the rules of section 14.1.2. */
3193 switch (procedure_kind (sym))
3196 t = resolve_generic_f (expr);
3199 case PTYPE_SPECIFIC:
3200 t = resolve_specific_f (expr);
3204 t = resolve_unknown_f (expr);
3208 gfc_internal_error ("resolve_function(): bad function type");
3212 /* If the expression is still a function (it might have simplified),
3213 then we check to see if we are calling an elemental function. */
3215 if (expr->expr_type != EXPR_FUNCTION)
3218 temp = need_full_assumed_size;
3219 need_full_assumed_size = 0;
3221 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3224 if (omp_workshare_flag
3225 && expr->value.function.esym
3226 && ! gfc_elemental (expr->value.function.esym))
3228 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3229 "in WORKSHARE construct", expr->value.function.esym->name,
3234 #define GENERIC_ID expr->value.function.isym->id
3235 else if (expr->value.function.actual != NULL
3236 && expr->value.function.isym != NULL
3237 && GENERIC_ID != GFC_ISYM_LBOUND
3238 && GENERIC_ID != GFC_ISYM_LEN
3239 && GENERIC_ID != GFC_ISYM_LOC
3240 && GENERIC_ID != GFC_ISYM_PRESENT)
3242 /* Array intrinsics must also have the last upper bound of an
3243 assumed size array argument. UBOUND and SIZE have to be
3244 excluded from the check if the second argument is anything
3247 for (arg = expr->value.function.actual; arg; arg = arg->next)
3249 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3250 && arg == expr->value.function.actual
3251 && arg->next != NULL && arg->next->expr)
3253 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3256 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3259 if ((int)mpz_get_si (arg->next->expr->value.integer)
3264 if (arg->expr != NULL
3265 && arg->expr->rank > 0
3266 && resolve_assumed_size_actual (arg->expr))
3272 need_full_assumed_size = temp;
3275 if (!pure_function (expr, &name) && name)
3279 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3280 "FORALL %s", name, &expr->where,
3281 forall_flag == 2 ? "mask" : "block");
3284 else if (do_concurrent_flag)
3286 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3287 "DO CONCURRENT %s", name, &expr->where,
3288 do_concurrent_flag == 2 ? "mask" : "block");
3291 else if (gfc_pure (NULL))
3293 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3294 "procedure within a PURE procedure", name, &expr->where);
3298 if (gfc_implicit_pure (NULL))
3299 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3302 /* Functions without the RECURSIVE attribution are not allowed to
3303 * call themselves. */
3304 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3307 esym = expr->value.function.esym;
3309 if (is_illegal_recursion (esym, gfc_current_ns))
3311 if (esym->attr.entry && esym->ns->entries)
3312 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3313 " function '%s' is not RECURSIVE",
3314 esym->name, &expr->where, esym->ns->entries->sym->name);
3316 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3317 " is not RECURSIVE", esym->name, &expr->where);
3323 /* Character lengths of use associated functions may contains references to
3324 symbols not referenced from the current program unit otherwise. Make sure
3325 those symbols are marked as referenced. */
3327 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3328 && expr->value.function.esym->attr.use_assoc)
3330 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3333 /* Make sure that the expression has a typespec that works. */
3334 if (expr->ts.type == BT_UNKNOWN)
3336 if (expr->symtree->n.sym->result
3337 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3338 && !expr->symtree->n.sym->result->attr.proc_pointer)
3339 expr->ts = expr->symtree->n.sym->result->ts;
3346 /************* Subroutine resolution *************/
3349 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3355 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3356 sym->name, &c->loc);
3357 else if (do_concurrent_flag)
3358 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3359 "PURE", sym->name, &c->loc);
3360 else if (gfc_pure (NULL))
3361 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3364 if (gfc_implicit_pure (NULL))
3365 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3370 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3374 if (sym->attr.generic)
3376 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3379 c->resolved_sym = s;
3380 pure_subroutine (c, s);
3384 /* TODO: Need to search for elemental references in generic interface. */
3387 if (sym->attr.intrinsic)
3388 return gfc_intrinsic_sub_interface (c, 0);
3395 resolve_generic_s (gfc_code *c)
3400 sym = c->symtree->n.sym;
3404 m = resolve_generic_s0 (c, sym);
3407 else if (m == MATCH_ERROR)
3411 if (sym->ns->parent == NULL)
3413 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3417 if (!generic_sym (sym))
3421 /* Last ditch attempt. See if the reference is to an intrinsic
3422 that possesses a matching interface. 14.1.2.4 */
3423 sym = c->symtree->n.sym;
3425 if (!gfc_is_intrinsic (sym, 1, c->loc))
3427 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3428 sym->name, &c->loc);
3432 m = gfc_intrinsic_sub_interface (c, 0);
3436 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3437 "intrinsic subroutine interface", sym->name, &c->loc);
3443 /* Set the name and binding label of the subroutine symbol in the call
3444 expression represented by 'c' to include the type and kind of the
3445 second parameter. This function is for resolving the appropriate
3446 version of c_f_pointer() and c_f_procpointer(). For example, a
3447 call to c_f_pointer() for a default integer pointer could have a
3448 name of c_f_pointer_i4. If no second arg exists, which is an error
3449 for these two functions, it defaults to the generic symbol's name
3450 and binding label. */
3453 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3454 char *name, const char **binding_label)
3456 gfc_expr *arg = NULL;
3460 /* The second arg of c_f_pointer and c_f_procpointer determines
3461 the type and kind for the procedure name. */
3462 arg = c->ext.actual->next->expr;
3466 /* Set up the name to have the given symbol's name,
3467 plus the type and kind. */
3468 /* a derived type is marked with the type letter 'u' */
3469 if (arg->ts.type == BT_DERIVED)
3472 kind = 0; /* set the kind as 0 for now */
3476 type = gfc_type_letter (arg->ts.type);
3477 kind = arg->ts.kind;
3480 if (arg->ts.type == BT_CHARACTER)
3481 /* Kind info for character strings not needed. */
3484 sprintf (name, "%s_%c%d", sym->name, type, kind);
3485 /* Set up the binding label as the given symbol's label plus
3486 the type and kind. */
3487 *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
3492 /* If the second arg is missing, set the name and label as
3493 was, cause it should at least be found, and the missing
3494 arg error will be caught by compare_parameters(). */
3495 sprintf (name, "%s", sym->name);
3496 *binding_label = sym->binding_label;
3503 /* Resolve a generic version of the iso_c_binding procedure given
3504 (sym) to the specific one based on the type and kind of the
3505 argument(s). Currently, this function resolves c_f_pointer() and
3506 c_f_procpointer based on the type and kind of the second argument
3507 (FPTR). Other iso_c_binding procedures aren't specially handled.
3508 Upon successfully exiting, c->resolved_sym will hold the resolved
3509 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3513 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3515 gfc_symbol *new_sym;
3516 /* this is fine, since we know the names won't use the max */
3517 char name[GFC_MAX_SYMBOL_LEN + 1];
3518 const char* binding_label;
3519 /* default to success; will override if find error */
3520 match m = MATCH_YES;
3522 /* Make sure the actual arguments are in the necessary order (based on the
3523 formal args) before resolving. */
3524 if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE)
3526 c->resolved_sym = sym;
3530 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3531 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3533 set_name_and_label (c, sym, name, &binding_label);
3535 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3537 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3539 gfc_actual_arglist *arg1 = c->ext.actual;
3540 gfc_actual_arglist *arg2 = c->ext.actual->next;
3541 gfc_actual_arglist *arg3 = c->ext.actual->next->next;
3543 /* Check first argument (CPTR). */
3544 if (arg1->expr->ts.type != BT_DERIVED
3545 || arg1->expr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
3547 gfc_error ("Argument CPTR to C_F_POINTER at %L shall have "
3548 "the type C_PTR", &arg1->expr->where);
3552 /* Check second argument (FPTR). */
3553 if (arg2->expr->ts.type == BT_CLASS)
3555 gfc_error ("Argument FPTR to C_F_POINTER at %L must not be "
3556 "polymorphic", &arg2->expr->where);
3560 /* Make sure we got a third arg (SHAPE) if the second arg has
3561 non-zero rank. We must also check that the type and rank are
3562 correct since we short-circuit this check in
3563 gfc_procedure_use() (called above to sort actual args). */
3564 if (arg2->expr->rank != 0)
3566 if (arg3 == NULL || arg3->expr == NULL)
3569 gfc_error ("Missing SHAPE argument for call to %s at %L",
3570 sym->name, &c->loc);
3572 else if (arg3->expr->ts.type != BT_INTEGER
3573 || arg3->expr->rank != 1)
3576 gfc_error ("SHAPE argument for call to %s at %L must be "
3577 "a rank 1 INTEGER array", sym->name, &c->loc);
3582 else /* ISOCBINDING_F_PROCPOINTER. */
3585 && (c->ext.actual->expr->ts.type != BT_DERIVED
3586 || c->ext.actual->expr->ts.u.derived->intmod_sym_id
3587 != ISOCBINDING_FUNPTR))
3589 gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
3590 "C_FUNPTR", &c->ext.actual->expr->where);
3593 if (c->ext.actual && c->ext.actual->next
3594 && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c
3595 && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
3596 "procedure-pointer at %L to C_F_FUNPOINTER",
3597 &c->ext.actual->next->expr->where)
3602 if (m != MATCH_ERROR)
3604 /* the 1 means to add the optional arg to formal list */
3605 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3607 /* for error reporting, say it's declared where the original was */
3608 new_sym->declared_at = sym->declared_at;
3613 /* no differences for c_loc or c_funloc */
3617 /* set the resolved symbol */
3618 if (m != MATCH_ERROR)
3619 c->resolved_sym = new_sym;
3621 c->resolved_sym = sym;
3627 /* Resolve a subroutine call known to be specific. */
3630 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3634 if(sym->attr.is_iso_c)
3636 m = gfc_iso_c_sub_interface (c,sym);
3640 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3642 if (sym->attr.dummy)
3644 sym->attr.proc = PROC_DUMMY;
3648 sym->attr.proc = PROC_EXTERNAL;
3652 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3655 if (sym->attr.intrinsic)
3657 m = gfc_intrinsic_sub_interface (c, 1);
3661 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3662 "with an intrinsic", sym->name, &c->loc);
3670 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3672 c->resolved_sym = sym;
3673 pure_subroutine (c, sym);
3680 resolve_specific_s (gfc_code *c)
3685 sym = c->symtree->n.sym;
3689 m = resolve_specific_s0 (c, sym);
3692 if (m == MATCH_ERROR)
3695 if (sym->ns->parent == NULL)
3698 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3704 sym = c->symtree->n.sym;
3705 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3706 sym->name, &c->loc);
3712 /* Resolve a subroutine call not known to be generic nor specific. */
3715 resolve_unknown_s (gfc_code *c)
3719 sym = c->symtree->n.sym;
3721 if (sym->attr.dummy)
3723 sym->attr.proc = PROC_DUMMY;
3727 /* See if we have an intrinsic function reference. */
3729 if (gfc_is_intrinsic (sym, 1, c->loc))
3731 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3736 /* The reference is to an external name. */
3739 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3741 c->resolved_sym = sym;
3743 pure_subroutine (c, sym);
3749 /* Resolve a subroutine call. Although it was tempting to use the same code
3750 for functions, subroutines and functions are stored differently and this
3751 makes things awkward. */
3754 resolve_call (gfc_code *c)
3757 procedure_type ptype = PROC_INTRINSIC;
3758 gfc_symbol *csym, *sym;
3759 bool no_formal_args;
3761 csym = c->symtree ? c->symtree->n.sym : NULL;
3763 if (csym && csym->ts.type != BT_UNKNOWN)
3765 gfc_error ("'%s' at %L has a type, which is not consistent with "
3766 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3770 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3773 gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
3774 sym = st ? st->n.sym : NULL;
3775 if (sym && csym != sym
3776 && sym->ns == gfc_current_ns
3777 && sym->attr.flavor == FL_PROCEDURE
3778 && sym->attr.contained)
3781 if (csym->attr.generic)
3782 c->symtree->n.sym = sym;
3785 csym = c->symtree->n.sym;
3789 /* If this ia a deferred TBP, c->expr1 will be set. */
3790 if (!c->expr1 && csym)
3792 if (csym->attr.abstract)
3794 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3795 csym->name, &c->loc);
3799 /* Subroutines without the RECURSIVE attribution are not allowed to
3801 if (is_illegal_recursion (csym, gfc_current_ns))
3803 if (csym->attr.entry && csym->ns->entries)
3804 gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
3805 "as subroutine '%s' is not RECURSIVE",
3806 csym->name, &c->loc, csym->ns->entries->sym->name);
3808 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
3809 "as it is not RECURSIVE", csym->name, &c->loc);
3815 /* Switch off assumed size checking and do this again for certain kinds
3816 of procedure, once the procedure itself is resolved. */
3817 need_full_assumed_size++;
3820 ptype = csym->attr.proc;
3822 no_formal_args = csym && is_external_proc (csym)
3823 && gfc_sym_get_dummy_args (csym) == NULL;
3824 if (resolve_actual_arglist (c->ext.actual, ptype,
3825 no_formal_args) == FAILURE)
3828 /* Resume assumed_size checking. */
3829 need_full_assumed_size--;
3831 /* If external, check for usage. */
3832 if (csym && is_external_proc (csym))
3833 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3836 if (c->resolved_sym == NULL)
3838 c->resolved_isym = NULL;
3839 switch (procedure_kind (csym))
3842 t = resolve_generic_s (c);
3845 case PTYPE_SPECIFIC:
3846 t = resolve_specific_s (c);
3850 t = resolve_unknown_s (c);
3854 gfc_internal_error ("resolve_subroutine(): bad function type");
3858 /* Some checks of elemental subroutine actual arguments. */
3859 if (resolve_elemental_actual (NULL, c) == FAILURE)
3866 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3867 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3868 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3869 if their shapes do not match. If either op1->shape or op2->shape is
3870 NULL, return SUCCESS. */
3873 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3880 if (op1->shape != NULL && op2->shape != NULL)
3882 for (i = 0; i < op1->rank; i++)
3884 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3886 gfc_error ("Shapes for operands at %L and %L are not conformable",
3887 &op1->where, &op2->where);
3898 /* Resolve an operator expression node. This can involve replacing the
3899 operation with a user defined function call. */
3902 resolve_operator (gfc_expr *e)
3904 gfc_expr *op1, *op2;
3906 bool dual_locus_error;
3909 /* Resolve all subnodes-- give them types. */
3911 switch (e->value.op.op)
3914 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3917 /* Fall through... */
3920 case INTRINSIC_UPLUS:
3921 case INTRINSIC_UMINUS:
3922 case INTRINSIC_PARENTHESES:
3923 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3928 /* Typecheck the new node. */
3930 op1 = e->value.op.op1;
3931 op2 = e->value.op.op2;
3932 dual_locus_error = false;
3934 if ((op1 && op1->expr_type == EXPR_NULL)
3935 || (op2 && op2->expr_type == EXPR_NULL))
3937 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3941 switch (e->value.op.op)
3943 case INTRINSIC_UPLUS:
3944 case INTRINSIC_UMINUS:
3945 if (op1->ts.type == BT_INTEGER
3946 || op1->ts.type == BT_REAL
3947 || op1->ts.type == BT_COMPLEX)
3953 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3954 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3957 case INTRINSIC_PLUS:
3958 case INTRINSIC_MINUS:
3959 case INTRINSIC_TIMES:
3960 case INTRINSIC_DIVIDE:
3961 case INTRINSIC_POWER:
3962 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3964 gfc_type_convert_binary (e, 1);
3969 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3970 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3971 gfc_typename (&op2->ts));
3974 case INTRINSIC_CONCAT:
3975 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3976 && op1->ts.kind == op2->ts.kind)
3978 e->ts.type = BT_CHARACTER;
3979 e->ts.kind = op1->ts.kind;
3984 _("Operands of string concatenation operator at %%L are %s/%s"),
3985 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3991 case INTRINSIC_NEQV:
3992 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3994 e->ts.type = BT_LOGICAL;
3995 e->ts.kind = gfc_kind_max (op1, op2);
3996 if (op1->ts.kind < e->ts.kind)
3997 gfc_convert_type (op1, &e->ts, 2);
3998 else if (op2->ts.kind < e->ts.kind)
3999 gfc_convert_type (op2, &e->ts, 2);
4003 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
4004 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
4005 gfc_typename (&op2->ts));
4010 if (op1->ts.type == BT_LOGICAL)
4012 e->ts.type = BT_LOGICAL;
4013 e->ts.kind = op1->ts.kind;
4017 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
4018 gfc_typename (&op1->ts));
4022 case INTRINSIC_GT_OS:
4024 case INTRINSIC_GE_OS:
4026 case INTRINSIC_LT_OS:
4028 case INTRINSIC_LE_OS:
4029 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4031 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
4035 /* Fall through... */
4038 case INTRINSIC_EQ_OS:
4040 case INTRINSIC_NE_OS:
4041 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4042 && op1->ts.kind == op2->ts.kind)
4044 e->ts.type = BT_LOGICAL;
4045 e->ts.kind = gfc_default_logical_kind;
4049 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4051 gfc_type_convert_binary (e, 1);
4053 e->ts.type = BT_LOGICAL;
4054 e->ts.kind = gfc_default_logical_kind;
4056 if (gfc_option.warn_compare_reals)
4058 gfc_intrinsic_op op = e->value.op.op;
4060 /* Type conversion has made sure that the types of op1 and op2
4061 agree, so it is only necessary to check the first one. */
4062 if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4063 && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4064 || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4068 if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4069 msg = "Equality comparison for %s at %L";
4071 msg = "Inequality comparison for %s at %L";
4073 gfc_warning (msg, gfc_typename (&op1->ts), &op1->where);
4080 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4082 _("Logicals at %%L must be compared with %s instead of %s"),
4083 (e->value.op.op == INTRINSIC_EQ
4084 || e->value.op.op == INTRINSIC_EQ_OS)
4085 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4088 _("Operands of comparison operator '%s' at %%L are %s/%s"),
4089 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
4090 gfc_typename (&op2->ts));
4094 case INTRINSIC_USER:
4095 if (e->value.op.uop->op == NULL)
4096 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
4097 else if (op2 == NULL)
4098 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
4099 e->value.op.uop->name, gfc_typename (&op1->ts));
4102 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
4103 e->value.op.uop->name, gfc_typename (&op1->ts),
4104 gfc_typename (&op2->ts));
4105 e->value.op.uop->op->sym->attr.referenced = 1;
4110 case INTRINSIC_PARENTHESES:
4112 if (e->ts.type == BT_CHARACTER)
4113 e->ts.u.cl = op1->ts.u.cl;
4117 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4120 /* Deal with arrayness of an operand through an operator. */
4124 switch (e->value.op.op)
4126 case INTRINSIC_PLUS:
4127 case INTRINSIC_MINUS:
4128 case INTRINSIC_TIMES:
4129 case INTRINSIC_DIVIDE:
4130 case INTRINSIC_POWER:
4131 case INTRINSIC_CONCAT:
4135 case INTRINSIC_NEQV:
4137 case INTRINSIC_EQ_OS:
4139 case INTRINSIC_NE_OS:
4141 case INTRINSIC_GT_OS:
4143 case INTRINSIC_GE_OS:
4145 case INTRINSIC_LT_OS:
4147 case INTRINSIC_LE_OS:
4149 if (op1->rank == 0 && op2->rank == 0)
4152 if (op1->rank == 0 && op2->rank != 0)
4154 e->rank = op2->rank;
4156 if (e->shape == NULL)
4157 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4160 if (op1->rank != 0 && op2->rank == 0)
4162 e->rank = op1->rank;
4164 if (e->shape == NULL)
4165 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4168 if (op1->rank != 0 && op2->rank != 0)
4170 if (op1->rank == op2->rank)
4172 e->rank = op1->rank;
4173 if (e->shape == NULL)
4175 t = compare_shapes (op1, op2);
4179 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4184 /* Allow higher level expressions to work. */
4187 /* Try user-defined operators, and otherwise throw an error. */
4188 dual_locus_error = true;
4190 _("Inconsistent ranks for operator at %%L and %%L"));
4197 case INTRINSIC_PARENTHESES:
4199 case INTRINSIC_UPLUS:
4200 case INTRINSIC_UMINUS:
4201 /* Simply copy arrayness attribute */
4202 e->rank = op1->rank;
4204 if (e->shape == NULL)
4205 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4213 /* Attempt to simplify the expression. */
4216 t = gfc_simplify_expr (e, 0);
4217 /* Some calls do not succeed in simplification and return FAILURE
4218 even though there is no error; e.g. variable references to
4219 PARAMETER arrays. */
4220 if (!gfc_is_constant_expr (e))
4228 match m = gfc_extend_expr (e);
4231 if (m == MATCH_ERROR)
4235 if (dual_locus_error)
4236 gfc_error (msg, &op1->where, &op2->where);
4238 gfc_error (msg, &e->where);
4244 /************** Array resolution subroutines **************/
4247 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4250 /* Compare two integer expressions. */
4253 compare_bound (gfc_expr *a, gfc_expr *b)
4257 if (a == NULL || a->expr_type != EXPR_CONSTANT
4258 || b == NULL || b->expr_type != EXPR_CONSTANT)
4261 /* If either of the types isn't INTEGER, we must have
4262 raised an error earlier. */
4264 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4267 i = mpz_cmp (a->value.integer, b->value.integer);
4277 /* Compare an integer expression with an integer. */
4280 compare_bound_int (gfc_expr *a, int b)
4284 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4287 if (a->ts.type != BT_INTEGER)
4288 gfc_internal_error ("compare_bound_int(): Bad expression");
4290 i = mpz_cmp_si (a->value.integer, b);
4300 /* Compare an integer expression with a mpz_t. */
4303 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4307 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4310 if (a->ts.type != BT_INTEGER)
4311 gfc_internal_error ("compare_bound_int(): Bad expression");
4313 i = mpz_cmp (a->value.integer, b);
4323 /* Compute the last value of a sequence given by a triplet.
4324 Return 0 if it wasn't able to compute the last value, or if the
4325 sequence if empty, and 1 otherwise. */
4328 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4329 gfc_expr *stride, mpz_t last)
4333 if (start == NULL || start->expr_type != EXPR_CONSTANT
4334 || end == NULL || end->expr_type != EXPR_CONSTANT
4335 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4338 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4339 || (stride != NULL && stride->ts.type != BT_INTEGER))
4342 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4344 if (compare_bound (start, end) == CMP_GT)
4346 mpz_set (last, end->value.integer);
4350 if (compare_bound_int (stride, 0) == CMP_GT)
4352 /* Stride is positive */
4353 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4358 /* Stride is negative */
4359 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4364 mpz_sub (rem, end->value.integer, start->value.integer);
4365 mpz_tdiv_r (rem, rem, stride->value.integer);
4366 mpz_sub (last, end->value.integer, rem);
4373 /* Compare a single dimension of an array reference to the array
4377 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4381 if (ar->dimen_type[i] == DIMEN_STAR)
4383 gcc_assert (ar->stride[i] == NULL);
4384 /* This implies [*] as [*:] and [*:3] are not possible. */
4385 if (ar->start[i] == NULL)
4387 gcc_assert (ar->end[i] == NULL);
4392 /* Given start, end and stride values, calculate the minimum and
4393 maximum referenced indexes. */
4395 switch (ar->dimen_type[i])
4398 case DIMEN_THIS_IMAGE:
4403 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4406 gfc_warning ("Array reference at %L is out of bounds "
4407 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4408 mpz_get_si (ar->start[i]->value.integer),
4409 mpz_get_si (as->lower[i]->value.integer), i+1);
4411 gfc_warning ("Array reference at %L is out of bounds "
4412 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4413 mpz_get_si (ar->start[i]->value.integer),
4414 mpz_get_si (as->lower[i]->value.integer),
4418 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4421 gfc_warning ("Array reference at %L is out of bounds "
4422 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4423 mpz_get_si (ar->start[i]->value.integer),
4424 mpz_get_si (as->upper[i]->value.integer), i+1);
4426 gfc_warning ("Array reference at %L is out of bounds "
4427 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4428 mpz_get_si (ar->start[i]->value.integer),
4429 mpz_get_si (as->upper[i]->value.integer),
4438 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4439 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4441 comparison comp_start_end = compare_bound (AR_START, AR_END);
4443 /* Check for zero stride, which is not allowed. */
4444 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4446 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4450 /* if start == len || (stride > 0 && start < len)
4451 || (stride < 0 && start > len),
4452 then the array section contains at least one element. In this
4453 case, there is an out-of-bounds access if
4454 (start < lower || start > upper). */
4455 if (compare_bound (AR_START, AR_END) == CMP_EQ
4456 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4457 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4458 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4459 && comp_start_end == CMP_GT))
4461 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4463 gfc_warning ("Lower array reference at %L is out of bounds "
4464 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4465 mpz_get_si (AR_START->value.integer),
4466 mpz_get_si (as->lower[i]->value.integer), i+1);
4469 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4471 gfc_warning ("Lower array reference at %L is out of bounds "
4472 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4473 mpz_get_si (AR_START->value.integer),
4474 mpz_get_si (as->upper[i]->value.integer), i+1);
4479 /* If we can compute the highest index of the array section,
4480 then it also has to be between lower and upper. */
4481 mpz_init (last_value);
4482 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4485 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4487 gfc_warning ("Upper array reference at %L is out of bounds "
4488 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4489 mpz_get_si (last_value),
4490 mpz_get_si (as->lower[i]->value.integer), i+1);
4491 mpz_clear (last_value);
4494 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4496 gfc_warning ("Upper array reference at %L is out of bounds "
4497 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4498 mpz_get_si (last_value),
4499 mpz_get_si (as->upper[i]->value.integer), i+1);
4500 mpz_clear (last_value);
4504 mpz_clear (last_value);
4512 gfc_internal_error ("check_dimension(): Bad array reference");
4519 /* Compare an array reference with an array specification. */
4522 compare_spec_to_ref (gfc_array_ref *ar)
4529 /* TODO: Full array sections are only allowed as actual parameters. */
4530 if (as->type == AS_ASSUMED_SIZE
4531 && (/*ar->type == AR_FULL
4532 ||*/ (ar->type == AR_SECTION
4533 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4535 gfc_error ("Rightmost upper bound of assumed size array section "
4536 "not specified at %L", &ar->where);
4540 if (ar->type == AR_FULL)
4543 if (as->rank != ar->dimen)
4545 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4546 &ar->where, ar->dimen, as->rank);
4550 /* ar->codimen == 0 is a local array. */
4551 if (as->corank != ar->codimen && ar->codimen != 0)
4553 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4554 &ar->where, ar->codimen, as->corank);
4558 for (i = 0; i < as->rank; i++)
4559 if (check_dimension (i, ar, as) == FAILURE)
4562 /* Local access has no coarray spec. */
4563 if (ar->codimen != 0)
4564 for (i = as->rank; i < as->rank + as->corank; i++)
4566 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4567 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4569 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4570 i + 1 - as->rank, &ar->where);
4573 if (check_dimension (i, ar, as) == FAILURE)
4581 /* Resolve one part of an array index. */
4584 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4585 int force_index_integer_kind)
4592 if (gfc_resolve_expr (index) == FAILURE)
4595 if (check_scalar && index->rank != 0)
4597 gfc_error ("Array index at %L must be scalar", &index->where);
4601 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4603 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4604 &index->where, gfc_basic_typename (index->ts.type));
4608 if (index->ts.type == BT_REAL)
4609 if (gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
4610 &index->where) == FAILURE)
4613 if ((index->ts.kind != gfc_index_integer_kind
4614 && force_index_integer_kind)
4615 || index->ts.type != BT_INTEGER)
4618 ts.type = BT_INTEGER;
4619 ts.kind = gfc_index_integer_kind;
4621 gfc_convert_type_warn (index, &ts, 2, 0);
4627 /* Resolve one part of an array index. */
4630 gfc_resolve_index (gfc_expr *index, int check_scalar)
4632 return gfc_resolve_index_1 (index, check_scalar, 1);
4635 /* Resolve a dim argument to an intrinsic function. */
4638 gfc_resolve_dim_arg (gfc_expr *dim)
4643 if (gfc_resolve_expr (dim) == FAILURE)
4648 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4653 if (dim->ts.type != BT_INTEGER)
4655 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4659 if (dim->ts.kind != gfc_index_integer_kind)
4664 ts.type = BT_INTEGER;
4665 ts.kind = gfc_index_integer_kind;
4667 gfc_convert_type_warn (dim, &ts, 2, 0);
4673 /* Given an expression that contains array references, update those array
4674 references to point to the right array specifications. While this is
4675 filled in during matching, this information is difficult to save and load
4676 in a module, so we take care of it here.
4678 The idea here is that the original array reference comes from the
4679 base symbol. We traverse the list of reference structures, setting
4680 the stored reference to references. Component references can
4681 provide an additional array specification. */
4684 find_array_spec (gfc_expr *e)
4690 if (e->symtree->n.sym->ts.type == BT_CLASS)
4691 as = CLASS_DATA (e->symtree->n.sym)->as;
4693 as = e->symtree->n.sym->as;
4695 for (ref = e->ref; ref; ref = ref->next)
4700 gfc_internal_error ("find_array_spec(): Missing spec");
4707 c = ref->u.c.component;
4708 if (c->attr.dimension)
4711 gfc_internal_error ("find_array_spec(): unused as(1)");
4722 gfc_internal_error ("find_array_spec(): unused as(2)");
4726 /* Resolve an array reference. */
4729 resolve_array_ref (gfc_array_ref *ar)
4731 int i, check_scalar;
4734 for (i = 0; i < ar->dimen + ar->codimen; i++)
4736 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4738 /* Do not force gfc_index_integer_kind for the start. We can
4739 do fine with any integer kind. This avoids temporary arrays
4740 created for indexing with a vector. */
4741 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4743 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4745 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4750 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4754 ar->dimen_type[i] = DIMEN_ELEMENT;
4758 ar->dimen_type[i] = DIMEN_VECTOR;
4759 if (e->expr_type == EXPR_VARIABLE
4760 && e->symtree->n.sym->ts.type == BT_DERIVED)
4761 ar->start[i] = gfc_get_parentheses (e);
4765 gfc_error ("Array index at %L is an array of rank %d",
4766 &ar->c_where[i], e->rank);
4770 /* Fill in the upper bound, which may be lower than the
4771 specified one for something like a(2:10:5), which is
4772 identical to a(2:7:5). Only relevant for strides not equal
4773 to one. Don't try a division by zero. */
4774 if (ar->dimen_type[i] == DIMEN_RANGE
4775 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4776 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4777 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4781 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4783 if (ar->end[i] == NULL)
4786 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4788 mpz_set (ar->end[i]->value.integer, end);
4790 else if (ar->end[i]->ts.type == BT_INTEGER
4791 && ar->end[i]->expr_type == EXPR_CONSTANT)
4793 mpz_set (ar->end[i]->value.integer, end);
4804 if (ar->type == AR_FULL)
4806 if (ar->as->rank == 0)
4807 ar->type = AR_ELEMENT;
4809 /* Make sure array is the same as array(:,:), this way
4810 we don't need to special case all the time. */
4811 ar->dimen = ar->as->rank;
4812 for (i = 0; i < ar->dimen; i++)
4814 ar->dimen_type[i] = DIMEN_RANGE;
4816 gcc_assert (ar->start[i] == NULL);
4817 gcc_assert (ar->end[i] == NULL);
4818 gcc_assert (ar->stride[i] == NULL);
4822 /* If the reference type is unknown, figure out what kind it is. */
4824 if (ar->type == AR_UNKNOWN)
4826 ar->type = AR_ELEMENT;
4827 for (i = 0; i < ar->dimen; i++)
4828 if (ar->dimen_type[i] == DIMEN_RANGE
4829 || ar->dimen_type[i] == DIMEN_VECTOR)
4831 ar->type = AR_SECTION;
4836 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4839 if (ar->as->corank && ar->codimen == 0)
4842 ar->codimen = ar->as->corank;
4843 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4844 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4852 resolve_substring (gfc_ref *ref)
4854 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4856 if (ref->u.ss.start != NULL)
4858 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4861 if (ref->u.ss.start->ts.type != BT_INTEGER)
4863 gfc_error ("Substring start index at %L must be of type INTEGER",
4864 &ref->u.ss.start->where);
4868 if (ref->u.ss.start->rank != 0)
4870 gfc_error ("Substring start index at %L must be scalar",
4871 &ref->u.ss.start->where);
4875 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4876 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4877 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4879 gfc_error ("Substring start index at %L is less than one",
4880 &ref->u.ss.start->where);
4885 if (ref->u.ss.end != NULL)
4887 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4890 if (ref->u.ss.end->ts.type != BT_INTEGER)
4892 gfc_error ("Substring end index at %L must be of type INTEGER",
4893 &ref->u.ss.end->where);
4897 if (ref->u.ss.end->rank != 0)
4899 gfc_error ("Substring end index at %L must be scalar",
4900 &ref->u.ss.end->where);
4904 if (ref->u.ss.length != NULL
4905 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4906 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4907 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4909 gfc_error ("Substring end index at %L exceeds the string length",
4910 &ref->u.ss.start->where);
4914 if (compare_bound_mpz_t (ref->u.ss.end,
4915 gfc_integer_kinds[k].huge) == CMP_GT
4916 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4917 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4919 gfc_error ("Substring end index at %L is too large",
4920 &ref->u.ss.end->where);
4929 /* This function supplies missing substring charlens. */
4932 gfc_resolve_substring_charlen (gfc_expr *e)
4935 gfc_expr *start, *end;
4937 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4938 if (char_ref->type == REF_SUBSTRING)
4944 gcc_assert (char_ref->next == NULL);
4948 if (e->ts.u.cl->length)
4949 gfc_free_expr (e->ts.u.cl->length);
4950 else if (e->expr_type == EXPR_VARIABLE
4951 && e->symtree->n.sym->attr.dummy)
4955 e->ts.type = BT_CHARACTER;
4956 e->ts.kind = gfc_default_character_kind;
4959 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4961 if (char_ref->u.ss.start)
4962 start = gfc_copy_expr (char_ref->u.ss.start);
4964 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4966 if (char_ref->u.ss.end)
4967 end = gfc_copy_expr (char_ref->u.ss.end);
4968 else if (e->expr_type == EXPR_VARIABLE)
4969 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4975 gfc_free_expr (start);
4976 gfc_free_expr (end);
4980 /* Length = (end - start +1). */
4981 e->ts.u.cl->length = gfc_subtract (end, start);
4982 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4983 gfc_get_int_expr (gfc_default_integer_kind,
4986 e->ts.u.cl->length->ts.type = BT_INTEGER;
4987 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4989 /* Make sure that the length is simplified. */
4990 gfc_simplify_expr (e->ts.u.cl->length, 1);
4991 gfc_resolve_expr (e->ts.u.cl->length);
4995 /* Resolve subtype references. */
4998 resolve_ref (gfc_expr *expr)
5000 int current_part_dimension, n_components, seen_part_dimension;
5003 for (ref = expr->ref; ref; ref = ref->next)
5004 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
5006 find_array_spec (expr);
5010 for (ref = expr->ref; ref; ref = ref->next)
5014 if (resolve_array_ref (&ref->u.ar) == FAILURE)
5022 if (resolve_substring (ref) == FAILURE)
5027 /* Check constraints on part references. */
5029 current_part_dimension = 0;
5030 seen_part_dimension = 0;
5033 for (ref = expr->ref; ref; ref = ref->next)
5038 switch (ref->u.ar.type)
5041 /* Coarray scalar. */
5042 if (ref->u.ar.as->rank == 0)
5044 current_part_dimension = 0;
5049 current_part_dimension = 1;
5053 current_part_dimension = 0;
5057 gfc_internal_error ("resolve_ref(): Bad array reference");
5063 if (current_part_dimension || seen_part_dimension)
5066 if (ref->u.c.component->attr.pointer
5067 || ref->u.c.component->attr.proc_pointer
5068 || (ref->u.c.component->ts.type == BT_CLASS
5069 && CLASS_DATA (ref->u.c.component)->attr.pointer))
5071 gfc_error ("Component to the right of a part reference "
5072 "with nonzero rank must not have the POINTER "
5073 "attribute at %L", &expr->where);
5076 else if (ref->u.c.component->attr.allocatable
5077 || (ref->u.c.component->ts.type == BT_CLASS
5078 && CLASS_DATA (ref->u.c.component)->attr.allocatable))
5081 gfc_error ("Component to the right of a part reference "
5082 "with nonzero rank must not have the ALLOCATABLE "
5083 "attribute at %L", &expr->where);
5095 if (((ref->type == REF_COMPONENT && n_components > 1)
5096 || ref->next == NULL)
5097 && current_part_dimension
5098 && seen_part_dimension)
5100 gfc_error ("Two or more part references with nonzero rank must "
5101 "not be specified at %L", &expr->where);
5105 if (ref->type == REF_COMPONENT)
5107 if (current_part_dimension)
5108 seen_part_dimension = 1;
5110 /* reset to make sure */
5111 current_part_dimension = 0;
5119 /* Given an expression, determine its shape. This is easier than it sounds.
5120 Leaves the shape array NULL if it is not possible to determine the shape. */
5123 expression_shape (gfc_expr *e)
5125 mpz_t array[GFC_MAX_DIMENSIONS];
5128 if (e->rank <= 0 || e->shape != NULL)
5131 for (i = 0; i < e->rank; i++)
5132 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
5135 e->shape = gfc_get_shape (e->rank);
5137 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
5142 for (i--; i >= 0; i--)
5143 mpz_clear (array[i]);
5147 /* Given a variable expression node, compute the rank of the expression by
5148 examining the base symbol and any reference structures it may have. */
5151 expression_rank (gfc_expr *e)
5156 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5157 could lead to serious confusion... */
5158 gcc_assert (e->expr_type != EXPR_COMPCALL);
5162 if (e->expr_type == EXPR_ARRAY)
5164 /* Constructors can have a rank different from one via RESHAPE(). */
5166 if (e->symtree == NULL)
5172 e->rank = (e->symtree->n.sym->as == NULL)
5173 ? 0 : e->symtree->n.sym->as->rank;
5179 for (ref = e->ref; ref; ref = ref->next)
5181 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5182 && ref->u.c.component->attr.function && !ref->next)
5183 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5185 if (ref->type != REF_ARRAY)
5188 if (ref->u.ar.type == AR_FULL)
5190 rank = ref->u.ar.as->rank;
5194 if (ref->u.ar.type == AR_SECTION)
5196 /* Figure out the rank of the section. */
5198 gfc_internal_error ("expression_rank(): Two array specs");
5200 for (i = 0; i < ref->u.ar.dimen; i++)
5201 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5202 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5212 expression_shape (e);
5216 /* Resolve a variable expression. */
5219 resolve_variable (gfc_expr *e)
5226 if (e->symtree == NULL)
5228 sym = e->symtree->n.sym;
5230 /* TS 29113, 407b. */
5231 if (e->ts.type == BT_ASSUMED)
5235 gfc_error ("Assumed-type variable %s at %L may only be used "
5236 "as actual argument", sym->name, &e->where);
5239 else if (inquiry_argument && !first_actual_arg)
5241 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5242 for all inquiry functions in resolve_function; the reason is
5243 that the function-name resolution happens too late in that
5245 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5246 "an inquiry function shall be the first argument",
5247 sym->name, &e->where);
5252 /* TS 29113, C535b. */
5253 if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
5254 && CLASS_DATA (sym)->as
5255 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5256 || (sym->ts.type != BT_CLASS && sym->as
5257 && sym->as->type == AS_ASSUMED_RANK))
5261 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5262 "actual argument", sym->name, &e->where);
5265 else if (inquiry_argument && !first_actual_arg)
5267 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5268 for all inquiry functions in resolve_function; the reason is
5269 that the function-name resolution happens too late in that
5271 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5272 "to an inquiry function shall be the first argument",
5273 sym->name, &e->where);
5278 /* TS 29113, 407b. */
5279 if (e->ts.type == BT_ASSUMED && e->ref
5280 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5281 && e->ref->next == NULL))
5283 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5284 "reference", sym->name, &e->ref->u.ar.where);
5288 /* TS 29113, C535b. */
5289 if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
5290 && CLASS_DATA (sym)->as
5291 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5292 || (sym->ts.type != BT_CLASS && sym->as
5293 && sym->as->type == AS_ASSUMED_RANK))
5295 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5296 && e->ref->next == NULL))
5298 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5299 "reference", sym->name, &e->ref->u.ar.where);
5304 /* If this is an associate-name, it may be parsed with an array reference
5305 in error even though the target is scalar. Fail directly in this case.
5306 TODO Understand why class scalar expressions must be excluded. */
5307 if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
5309 if (sym->ts.type == BT_CLASS)
5310 gfc_fix_class_refs (e);
5311 if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5315 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5316 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5318 /* On the other hand, the parser may not have known this is an array;
5319 in this case, we have to add a FULL reference. */
5320 if (sym->assoc && sym->attr.dimension && !e->ref)
5322 e->ref = gfc_get_ref ();
5323 e->ref->type = REF_ARRAY;
5324 e->ref->u.ar.type = AR_FULL;
5325 e->ref->u.ar.dimen = 0;
5328 if (e->ref && resolve_ref (e) == FAILURE)
5331 if (sym->attr.flavor == FL_PROCEDURE
5332 && (!sym->attr.function
5333 || (sym->attr.function && sym->result
5334 && sym->result->attr.proc_pointer
5335 && !sym->result->attr.function)))
5337 e->ts.type = BT_PROCEDURE;
5338 goto resolve_procedure;
5341 if (sym->ts.type != BT_UNKNOWN)
5342 gfc_variable_attr (e, &e->ts);
5345 /* Must be a simple variable reference. */
5346 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5351 if (check_assumed_size_reference (sym, e))
5354 /* Deal with forward references to entries during resolve_code, to
5355 satisfy, at least partially, 12.5.2.5. */
5356 if (gfc_current_ns->entries
5357 && current_entry_id == sym->entry_id
5360 && cs_base->current->op != EXEC_ENTRY)
5362 gfc_entry_list *entry;
5363 gfc_formal_arglist *formal;
5365 bool seen, saved_specification_expr;
5367 /* If the symbol is a dummy... */
5368 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5370 entry = gfc_current_ns->entries;
5373 /* ...test if the symbol is a parameter of previous entries. */
5374 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5375 for (formal = entry->sym->formal; formal; formal = formal->next)
5377 if (formal->sym && sym->name == formal->sym->name)
5381 /* If it has not been seen as a dummy, this is an error. */
5384 if (specification_expr)
5385 gfc_error ("Variable '%s', used in a specification expression"
5386 ", is referenced at %L before the ENTRY statement "
5387 "in which it is a parameter",
5388 sym->name, &cs_base->current->loc);
5390 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5391 "statement in which it is a parameter",
5392 sym->name, &cs_base->current->loc);
5397 /* Now do the same check on the specification expressions. */
5398 saved_specification_expr = specification_expr;
5399 specification_expr = true;
5400 if (sym->ts.type == BT_CHARACTER
5401 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5405 for (n = 0; n < sym->as->rank; n++)
5407 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5409 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5412 specification_expr = saved_specification_expr;
5415 /* Update the symbol's entry level. */
5416 sym->entry_id = current_entry_id + 1;
5419 /* If a symbol has been host_associated mark it. This is used latter,
5420 to identify if aliasing is possible via host association. */
5421 if (sym->attr.flavor == FL_VARIABLE
5422 && gfc_current_ns->parent
5423 && (gfc_current_ns->parent == sym->ns
5424 || (gfc_current_ns->parent->parent
5425 && gfc_current_ns->parent->parent == sym->ns)))
5426 sym->attr.host_assoc = 1;
5429 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5432 /* F2008, C617 and C1229. */
5433 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5434 && gfc_is_coindexed (e))
5436 gfc_ref *ref, *ref2 = NULL;
5438 for (ref = e->ref; ref; ref = ref->next)
5440 if (ref->type == REF_COMPONENT)
5442 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5446 for ( ; ref; ref = ref->next)
5447 if (ref->type == REF_COMPONENT)
5450 /* Expression itself is not coindexed object. */
5451 if (ref && e->ts.type == BT_CLASS)
5453 gfc_error ("Polymorphic subobject of coindexed object at %L",
5458 /* Expression itself is coindexed object. */
5462 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5463 for ( ; c; c = c->next)
5464 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5466 gfc_error ("Coindexed object with polymorphic allocatable "
5467 "subcomponent at %L", &e->where);
5478 /* Checks to see that the correct symbol has been host associated.
5479 The only situation where this arises is that in which a twice
5480 contained function is parsed after the host association is made.
5481 Therefore, on detecting this, change the symbol in the expression
5482 and convert the array reference into an actual arglist if the old
5483 symbol is a variable. */
5485 check_host_association (gfc_expr *e)
5487 gfc_symbol *sym, *old_sym;
5491 gfc_actual_arglist *arg, *tail = NULL;
5492 bool retval = e->expr_type == EXPR_FUNCTION;
5494 /* If the expression is the result of substitution in
5495 interface.c(gfc_extend_expr) because there is no way in
5496 which the host association can be wrong. */
5497 if (e->symtree == NULL
5498 || e->symtree->n.sym == NULL
5499 || e->user_operator)
5502 old_sym = e->symtree->n.sym;
5504 if (gfc_current_ns->parent
5505 && old_sym->ns != gfc_current_ns)
5507 /* Use the 'USE' name so that renamed module symbols are
5508 correctly handled. */
5509 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5511 if (sym && old_sym != sym
5512 && sym->ts.type == old_sym->ts.type
5513 && sym->attr.flavor == FL_PROCEDURE
5514 && sym->attr.contained)
5516 /* Clear the shape, since it might not be valid. */
5517 gfc_free_shape (&e->shape, e->rank);
5519 /* Give the expression the right symtree! */
5520 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5521 gcc_assert (st != NULL);
5523 if (old_sym->attr.flavor == FL_PROCEDURE
5524 || e->expr_type == EXPR_FUNCTION)
5526 /* Original was function so point to the new symbol, since
5527 the actual argument list is already attached to the
5529 e->value.function.esym = NULL;
5534 /* Original was variable so convert array references into
5535 an actual arglist. This does not need any checking now
5536 since resolve_function will take care of it. */
5537 e->value.function.actual = NULL;
5538 e->expr_type = EXPR_FUNCTION;
5541 /* Ambiguity will not arise if the array reference is not
5542 the last reference. */
5543 for (ref = e->ref; ref; ref = ref->next)
5544 if (ref->type == REF_ARRAY && ref->next == NULL)
5547 gcc_assert (ref->type == REF_ARRAY);
5549 /* Grab the start expressions from the array ref and
5550 copy them into actual arguments. */
5551 for (n = 0; n < ref->u.ar.dimen; n++)
5553 arg = gfc_get_actual_arglist ();
5554 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5555 if (e->value.function.actual == NULL)
5556 tail = e->value.function.actual = arg;
5564 /* Dump the reference list and set the rank. */
5565 gfc_free_ref_list (e->ref);
5567 e->rank = sym->as ? sym->as->rank : 0;
5570 gfc_resolve_expr (e);
5574 /* This might have changed! */
5575 return e->expr_type == EXPR_FUNCTION;
5580 gfc_resolve_character_operator (gfc_expr *e)
5582 gfc_expr *op1 = e->value.op.op1;
5583 gfc_expr *op2 = e->value.op.op2;
5584 gfc_expr *e1 = NULL;
5585 gfc_expr *e2 = NULL;
5587 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5589 if (op1->ts.u.cl && op1->ts.u.cl->length)
5590 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5591 else if (op1->expr_type == EXPR_CONSTANT)
5592 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5593 op1->value.character.length);
5595 if (op2->ts.u.cl && op2->ts.u.cl->length)
5596 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5597 else if (op2->expr_type == EXPR_CONSTANT)
5598 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5599 op2->value.character.length);
5601 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5611 e->ts.u.cl->length = gfc_add (e1, e2);
5612 e->ts.u.cl->length->ts.type = BT_INTEGER;
5613 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5614 gfc_simplify_expr (e->ts.u.cl->length, 0);
5615 gfc_resolve_expr (e->ts.u.cl->length);
5621 /* Ensure that an character expression has a charlen and, if possible, a
5622 length expression. */
5625 fixup_charlen (gfc_expr *e)
5627 /* The cases fall through so that changes in expression type and the need
5628 for multiple fixes are picked up. In all circumstances, a charlen should
5629 be available for the middle end to hang a backend_decl on. */
5630 switch (e->expr_type)
5633 gfc_resolve_character_operator (e);
5636 if (e->expr_type == EXPR_ARRAY)
5637 gfc_resolve_character_array_constructor (e);
5639 case EXPR_SUBSTRING:
5640 if (!e->ts.u.cl && e->ref)
5641 gfc_resolve_substring_charlen (e);
5645 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5652 /* Update an actual argument to include the passed-object for type-bound
5653 procedures at the right position. */
5655 static gfc_actual_arglist*
5656 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5659 gcc_assert (argpos > 0);
5663 gfc_actual_arglist* result;
5665 result = gfc_get_actual_arglist ();
5669 result->name = name;
5675 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5677 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5682 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5685 extract_compcall_passed_object (gfc_expr* e)
5689 gcc_assert (e->expr_type == EXPR_COMPCALL);
5691 if (e->value.compcall.base_object)
5692 po = gfc_copy_expr (e->value.compcall.base_object);
5695 po = gfc_get_expr ();
5696 po->expr_type = EXPR_VARIABLE;
5697 po->symtree = e->symtree;
5698 po->ref = gfc_copy_ref (e->ref);
5699 po->where = e->where;
5702 if (gfc_resolve_expr (po) == FAILURE)
5709 /* Update the arglist of an EXPR_COMPCALL expression to include the
5713 update_compcall_arglist (gfc_expr* e)
5716 gfc_typebound_proc* tbp;
5718 tbp = e->value.compcall.tbp;
5723 po = extract_compcall_passed_object (e);
5727 if (tbp->nopass || e->value.compcall.ignore_pass)
5733 gcc_assert (tbp->pass_arg_num > 0);
5734 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5742 /* Extract the passed object from a PPC call (a copy of it). */
5745 extract_ppc_passed_object (gfc_expr *e)
5750 po = gfc_get_expr ();
5751 po->expr_type = EXPR_VARIABLE;
5752 po->symtree = e->symtree;
5753 po->ref = gfc_copy_ref (e->ref);
5754 po->where = e->where;
5756 /* Remove PPC reference. */
5758 while ((*ref)->next)
5759 ref = &(*ref)->next;
5760 gfc_free_ref_list (*ref);
5763 if (gfc_resolve_expr (po) == FAILURE)
5770 /* Update the actual arglist of a procedure pointer component to include the
5774 update_ppc_arglist (gfc_expr* e)
5778 gfc_typebound_proc* tb;
5780 ppc = gfc_get_proc_ptr_comp (e);
5788 else if (tb->nopass)
5791 po = extract_ppc_passed_object (e);
5798 gfc_error ("Passed-object at %L must be scalar", &e->where);
5803 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5805 gfc_error ("Base object for procedure-pointer component call at %L is of"
5806 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5810 gcc_assert (tb->pass_arg_num > 0);
5811 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5819 /* Check that the object a TBP is called on is valid, i.e. it must not be
5820 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5823 check_typebound_baseobject (gfc_expr* e)
5826 gfc_try return_value = FAILURE;
5828 base = extract_compcall_passed_object (e);
5832 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5834 if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
5838 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5840 gfc_error ("Base object for type-bound procedure call at %L is of"
5841 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5845 /* F08:C1230. If the procedure called is NOPASS,
5846 the base object must be scalar. */
5847 if (e->value.compcall.tbp->nopass && base->rank != 0)
5849 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5850 " be scalar", &e->where);
5854 return_value = SUCCESS;
5857 gfc_free_expr (base);
5858 return return_value;
5862 /* Resolve a call to a type-bound procedure, either function or subroutine,
5863 statically from the data in an EXPR_COMPCALL expression. The adapted
5864 arglist and the target-procedure symtree are returned. */
5867 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5868 gfc_actual_arglist** actual)
5870 gcc_assert (e->expr_type == EXPR_COMPCALL);
5871 gcc_assert (!e->value.compcall.tbp->is_generic);
5873 /* Update the actual arglist for PASS. */
5874 if (update_compcall_arglist (e) == FAILURE)
5877 *actual = e->value.compcall.actual;
5878 *target = e->value.compcall.tbp->u.specific;
5880 gfc_free_ref_list (e->ref);
5882 e->value.compcall.actual = NULL;
5884 /* If we find a deferred typebound procedure, check for derived types
5885 that an overriding typebound procedure has not been missed. */
5886 if (e->value.compcall.name
5887 && !e->value.compcall.tbp->non_overridable
5888 && e->value.compcall.base_object
5889 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5892 gfc_symbol *derived;
5894 /* Use the derived type of the base_object. */
5895 derived = e->value.compcall.base_object->ts.u.derived;
5898 /* If necessary, go through the inheritance chain. */
5899 while (!st && derived)
5901 /* Look for the typebound procedure 'name'. */
5902 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5903 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5904 e->value.compcall.name);
5906 derived = gfc_get_derived_super_type (derived);
5909 /* Now find the specific name in the derived type namespace. */
5910 if (st && st->n.tb && st->n.tb->u.specific)
5911 gfc_find_sym_tree (st->n.tb->u.specific->name,
5912 derived->ns, 1, &st);
5920 /* Get the ultimate declared type from an expression. In addition,
5921 return the last class/derived type reference and the copy of the
5922 reference list. If check_types is set true, derived types are
5923 identified as well as class references. */
5925 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5926 gfc_expr *e, bool check_types)
5928 gfc_symbol *declared;
5935 *new_ref = gfc_copy_ref (e->ref);
5937 for (ref = e->ref; ref; ref = ref->next)
5939 if (ref->type != REF_COMPONENT)
5942 if ((ref->u.c.component->ts.type == BT_CLASS
5943 || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
5944 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5946 declared = ref->u.c.component->ts.u.derived;
5952 if (declared == NULL)
5953 declared = e->symtree->n.sym->ts.u.derived;
5959 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5960 which of the specific bindings (if any) matches the arglist and transform
5961 the expression into a call of that binding. */
5964 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5966 gfc_typebound_proc* genproc;
5967 const char* genname;
5969 gfc_symbol *derived;
5971 gcc_assert (e->expr_type == EXPR_COMPCALL);
5972 genname = e->value.compcall.name;
5973 genproc = e->value.compcall.tbp;
5975 if (!genproc->is_generic)
5978 /* Try the bindings on this type and in the inheritance hierarchy. */
5979 for (; genproc; genproc = genproc->overridden)
5983 gcc_assert (genproc->is_generic);
5984 for (g = genproc->u.generic; g; g = g->next)
5987 gfc_actual_arglist* args;
5990 gcc_assert (g->specific);
5992 if (g->specific->error)
5995 target = g->specific->u.specific->n.sym;
5997 /* Get the right arglist by handling PASS/NOPASS. */
5998 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5999 if (!g->specific->nopass)
6002 po = extract_compcall_passed_object (e);
6005 gfc_free_actual_arglist (args);
6009 gcc_assert (g->specific->pass_arg_num > 0);
6010 gcc_assert (!g->specific->error);
6011 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
6012 g->specific->pass_arg);
6014 resolve_actual_arglist (args, target->attr.proc,
6015 is_external_proc (target)
6016 && gfc_sym_get_dummy_args (target) == NULL);
6018 /* Check if this arglist matches the formal. */
6019 matches = gfc_arglist_matches_symbol (&args, target);
6021 /* Clean up and break out of the loop if we've found it. */
6022 gfc_free_actual_arglist (args);
6025 e->value.compcall.tbp = g->specific;
6026 genname = g->specific_st->name;
6027 /* Pass along the name for CLASS methods, where the vtab
6028 procedure pointer component has to be referenced. */
6036 /* Nothing matching found! */
6037 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6038 " '%s' at %L", genname, &e->where);
6042 /* Make sure that we have the right specific instance for the name. */
6043 derived = get_declared_from_expr (NULL, NULL, e, true);
6045 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
6047 e->value.compcall.tbp = st->n.tb;
6053 /* Resolve a call to a type-bound subroutine. */
6056 resolve_typebound_call (gfc_code* c, const char **name)
6058 gfc_actual_arglist* newactual;
6059 gfc_symtree* target;
6061 /* Check that's really a SUBROUTINE. */
6062 if (!c->expr1->value.compcall.tbp->subroutine)
6064 gfc_error ("'%s' at %L should be a SUBROUTINE",
6065 c->expr1->value.compcall.name, &c->loc);
6069 if (check_typebound_baseobject (c->expr1) == FAILURE)
6072 /* Pass along the name for CLASS methods, where the vtab
6073 procedure pointer component has to be referenced. */
6075 *name = c->expr1->value.compcall.name;
6077 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
6080 /* Transform into an ordinary EXEC_CALL for now. */
6082 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
6085 c->ext.actual = newactual;
6086 c->symtree = target;
6087 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
6089 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
6091 gfc_free_expr (c->expr1);
6092 c->expr1 = gfc_get_expr ();
6093 c->expr1->expr_type = EXPR_FUNCTION;
6094 c->expr1->symtree = target;
6095 c->expr1->where = c->loc;
6097 return resolve_call (c);
6101 /* Resolve a component-call expression. */
6103 resolve_compcall (gfc_expr* e, const char **name)
6105 gfc_actual_arglist* newactual;
6106 gfc_symtree* target;
6108 /* Check that's really a FUNCTION. */
6109 if (!e->value.compcall.tbp->function)
6111 gfc_error ("'%s' at %L should be a FUNCTION",
6112 e->value.compcall.name, &e->where);
6116 /* These must not be assign-calls! */
6117 gcc_assert (!e->value.compcall.assign);
6119 if (check_typebound_baseobject (e) == FAILURE)
6122 /* Pass along the name for CLASS methods, where the vtab
6123 procedure pointer component has to be referenced. */
6125 *name = e->value.compcall.name;
6127 if (resolve_typebound_generic_call (e, name) == FAILURE)
6129 gcc_assert (!e->value.compcall.tbp->is_generic);
6131 /* Take the rank from the function's symbol. */
6132 if (e->value.compcall.tbp->u.specific->n.sym->as)
6133 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
6135 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6136 arglist to the TBP's binding target. */
6138 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
6141 e->value.function.actual = newactual;
6142 e->value.function.name = NULL;
6143 e->value.function.esym = target->n.sym;
6144 e->value.function.isym = NULL;
6145 e->symtree = target;
6146 e->ts = target->n.sym->ts;
6147 e->expr_type = EXPR_FUNCTION;
6149 /* Resolution is not necessary if this is a class subroutine; this
6150 function only has to identify the specific proc. Resolution of
6151 the call will be done next in resolve_typebound_call. */
6152 return gfc_resolve_expr (e);
6157 /* Resolve a typebound function, or 'method'. First separate all
6158 the non-CLASS references by calling resolve_compcall directly. */
6161 resolve_typebound_function (gfc_expr* e)
6163 gfc_symbol *declared;
6175 /* Deal with typebound operators for CLASS objects. */
6176 expr = e->value.compcall.base_object;
6177 overridable = !e->value.compcall.tbp->non_overridable;
6178 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
6180 /* If the base_object is not a variable, the corresponding actual
6181 argument expression must be stored in e->base_expression so
6182 that the corresponding tree temporary can be used as the base
6183 object in gfc_conv_procedure_call. */
6184 if (expr->expr_type != EXPR_VARIABLE)
6186 gfc_actual_arglist *args;
6188 for (args= e->value.function.actual; args; args = args->next)
6190 if (expr == args->expr)
6195 /* Since the typebound operators are generic, we have to ensure
6196 that any delays in resolution are corrected and that the vtab
6199 declared = ts.u.derived;
6200 c = gfc_find_component (declared, "_vptr", true, true);
6201 if (c->ts.u.derived == NULL)
6202 c->ts.u.derived = gfc_find_derived_vtab (declared);
6204 if (resolve_compcall (e, &name) == FAILURE)
6207 /* Use the generic name if it is there. */
6208 name = name ? name : e->value.function.esym->name;
6209 e->symtree = expr->symtree;
6210 e->ref = gfc_copy_ref (expr->ref);
6211 get_declared_from_expr (&class_ref, NULL, e, false);
6213 /* Trim away the extraneous references that emerge from nested
6214 use of interface.c (extend_expr). */
6215 if (class_ref && class_ref->next)
6217 gfc_free_ref_list (class_ref->next);
6218 class_ref->next = NULL;
6220 else if (e->ref && !class_ref)
6222 gfc_free_ref_list (e->ref);
6226 gfc_add_vptr_component (e);
6227 gfc_add_component_ref (e, name);
6228 e->value.function.esym = NULL;
6229 if (expr->expr_type != EXPR_VARIABLE)
6230 e->base_expr = expr;
6235 return resolve_compcall (e, NULL);
6237 if (resolve_ref (e) == FAILURE)
6240 /* Get the CLASS declared type. */
6241 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
6243 /* Weed out cases of the ultimate component being a derived type. */
6244 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6245 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6247 gfc_free_ref_list (new_ref);
6248 return resolve_compcall (e, NULL);
6251 c = gfc_find_component (declared, "_data", true, true);
6252 declared = c->ts.u.derived;
6254 /* Treat the call as if it is a typebound procedure, in order to roll
6255 out the correct name for the specific function. */
6256 if (resolve_compcall (e, &name) == FAILURE)
6258 gfc_free_ref_list (new_ref);
6265 /* Convert the expression to a procedure pointer component call. */
6266 e->value.function.esym = NULL;
6272 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6273 gfc_add_vptr_component (e);
6274 gfc_add_component_ref (e, name);
6276 /* Recover the typespec for the expression. This is really only
6277 necessary for generic procedures, where the additional call
6278 to gfc_add_component_ref seems to throw the collection of the
6279 correct typespec. */
6286 /* Resolve a typebound subroutine, or 'method'. First separate all
6287 the non-CLASS references by calling resolve_typebound_call
6291 resolve_typebound_subroutine (gfc_code *code)
6293 gfc_symbol *declared;
6303 st = code->expr1->symtree;
6305 /* Deal with typebound operators for CLASS objects. */
6306 expr = code->expr1->value.compcall.base_object;
6307 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6308 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6310 /* If the base_object is not a variable, the corresponding actual
6311 argument expression must be stored in e->base_expression so
6312 that the corresponding tree temporary can be used as the base
6313 object in gfc_conv_procedure_call. */
6314 if (expr->expr_type != EXPR_VARIABLE)
6316 gfc_actual_arglist *args;
6318 args= code->expr1->value.function.actual;
6319 for (; args; args = args->next)
6320 if (expr == args->expr)
6324 /* Since the typebound operators are generic, we have to ensure
6325 that any delays in resolution are corrected and that the vtab
6327 declared = expr->ts.u.derived;
6328 c = gfc_find_component (declared, "_vptr", true, true);
6329 if (c->ts.u.derived == NULL)
6330 c->ts.u.derived = gfc_find_derived_vtab (declared);
6332 if (resolve_typebound_call (code, &name) == FAILURE)
6335 /* Use the generic name if it is there. */
6336 name = name ? name : code->expr1->value.function.esym->name;
6337 code->expr1->symtree = expr->symtree;
6338 code->expr1->ref = gfc_copy_ref (expr->ref);
6340 /* Trim away the extraneous references that emerge from nested
6341 use of interface.c (extend_expr). */
6342 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6343 if (class_ref && class_ref->next)
6345 gfc_free_ref_list (class_ref->next);
6346 class_ref->next = NULL;
6348 else if (code->expr1->ref && !class_ref)
6350 gfc_free_ref_list (code->expr1->ref);
6351 code->expr1->ref = NULL;
6354 /* Now use the procedure in the vtable. */
6355 gfc_add_vptr_component (code->expr1);
6356 gfc_add_component_ref (code->expr1, name);
6357 code->expr1->value.function.esym = NULL;
6358 if (expr->expr_type != EXPR_VARIABLE)
6359 code->expr1->base_expr = expr;
6364 return resolve_typebound_call (code, NULL);
6366 if (resolve_ref (code->expr1) == FAILURE)
6369 /* Get the CLASS declared type. */
6370 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6372 /* Weed out cases of the ultimate component being a derived type. */
6373 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6374 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6376 gfc_free_ref_list (new_ref);
6377 return resolve_typebound_call (code, NULL);
6380 if (resolve_typebound_call (code, &name) == FAILURE)
6382 gfc_free_ref_list (new_ref);
6385 ts = code->expr1->ts;
6389 /* Convert the expression to a procedure pointer component call. */
6390 code->expr1->value.function.esym = NULL;
6391 code->expr1->symtree = st;
6394 code->expr1->ref = new_ref;
6396 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6397 gfc_add_vptr_component (code->expr1);
6398 gfc_add_component_ref (code->expr1, name);
6400 /* Recover the typespec for the expression. This is really only
6401 necessary for generic procedures, where the additional call
6402 to gfc_add_component_ref seems to throw the collection of the
6403 correct typespec. */
6404 code->expr1->ts = ts;
6411 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6414 resolve_ppc_call (gfc_code* c)
6416 gfc_component *comp;
6418 comp = gfc_get_proc_ptr_comp (c->expr1);
6419 gcc_assert (comp != NULL);
6421 c->resolved_sym = c->expr1->symtree->n.sym;
6422 c->expr1->expr_type = EXPR_VARIABLE;
6424 if (!comp->attr.subroutine)
6425 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6427 if (resolve_ref (c->expr1) == FAILURE)
6430 if (update_ppc_arglist (c->expr1) == FAILURE)
6433 c->ext.actual = c->expr1->value.compcall.actual;
6435 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6436 !(comp->ts.interface && comp->ts.interface->formal)) == FAILURE)
6439 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6445 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6448 resolve_expr_ppc (gfc_expr* e)
6450 gfc_component *comp;
6452 comp = gfc_get_proc_ptr_comp (e);
6453 gcc_assert (comp != NULL);
6455 /* Convert to EXPR_FUNCTION. */
6456 e->expr_type = EXPR_FUNCTION;
6457 e->value.function.isym = NULL;
6458 e->value.function.actual = e->value.compcall.actual;
6460 if (comp->as != NULL)
6461 e->rank = comp->as->rank;
6463 if (!comp->attr.function)
6464 gfc_add_function (&comp->attr, comp->name, &e->where);
6466 if (resolve_ref (e) == FAILURE)
6469 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6470 !(comp->ts.interface && comp->ts.interface->formal)) == FAILURE)
6473 if (update_ppc_arglist (e) == FAILURE)
6476 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6483 gfc_is_expandable_expr (gfc_expr *e)
6485 gfc_constructor *con;
6487 if (e->expr_type == EXPR_ARRAY)
6489 /* Traverse the constructor looking for variables that are flavor
6490 parameter. Parameters must be expanded since they are fully used at
6492 con = gfc_constructor_first (e->value.constructor);
6493 for (; con; con = gfc_constructor_next (con))
6495 if (con->expr->expr_type == EXPR_VARIABLE
6496 && con->expr->symtree
6497 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6498 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6500 if (con->expr->expr_type == EXPR_ARRAY
6501 && gfc_is_expandable_expr (con->expr))
6509 /* Resolve an expression. That is, make sure that types of operands agree
6510 with their operators, intrinsic operators are converted to function calls
6511 for overloaded types and unresolved function references are resolved. */
6514 gfc_resolve_expr (gfc_expr *e)
6517 bool inquiry_save, actual_arg_save, first_actual_arg_save;
6522 /* inquiry_argument only applies to variables. */
6523 inquiry_save = inquiry_argument;
6524 actual_arg_save = actual_arg;
6525 first_actual_arg_save = first_actual_arg;
6527 if (e->expr_type != EXPR_VARIABLE)
6529 inquiry_argument = false;
6531 first_actual_arg = false;
6534 switch (e->expr_type)
6537 t = resolve_operator (e);
6543 if (check_host_association (e))
6544 t = resolve_function (e);
6547 t = resolve_variable (e);
6549 expression_rank (e);
6552 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6553 && e->ref->type != REF_SUBSTRING)
6554 gfc_resolve_substring_charlen (e);
6559 t = resolve_typebound_function (e);
6562 case EXPR_SUBSTRING:
6563 t = resolve_ref (e);
6572 t = resolve_expr_ppc (e);
6577 if (resolve_ref (e) == FAILURE)
6580 t = gfc_resolve_array_constructor (e);
6581 /* Also try to expand a constructor. */
6584 expression_rank (e);
6585 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6586 gfc_expand_constructor (e, false);
6589 /* This provides the opportunity for the length of constructors with
6590 character valued function elements to propagate the string length
6591 to the expression. */
6592 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6594 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6595 here rather then add a duplicate test for it above. */
6596 gfc_expand_constructor (e, false);
6597 t = gfc_resolve_character_array_constructor (e);
6602 case EXPR_STRUCTURE:
6603 t = resolve_ref (e);
6607 t = resolve_structure_cons (e, 0);
6611 t = gfc_simplify_expr (e, 0);
6615 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6618 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6621 inquiry_argument = inquiry_save;
6622 actual_arg = actual_arg_save;
6623 first_actual_arg = first_actual_arg_save;
6629 /* Resolve an expression from an iterator. They must be scalar and have
6630 INTEGER or (optionally) REAL type. */
6633 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6634 const char *name_msgid)
6636 if (gfc_resolve_expr (expr) == FAILURE)
6639 if (expr->rank != 0)
6641 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6645 if (expr->ts.type != BT_INTEGER)
6647 if (expr->ts.type == BT_REAL)
6650 return gfc_notify_std (GFC_STD_F95_DEL,
6651 "%s at %L must be integer",
6652 _(name_msgid), &expr->where);
6655 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6662 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6670 /* Resolve the expressions in an iterator structure. If REAL_OK is
6671 false allow only INTEGER type iterators, otherwise allow REAL types.
6672 Set own_scope to true for ac-implied-do and data-implied-do as those
6673 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6676 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
6678 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6682 if (gfc_check_vardef_context (iter->var, false, false, own_scope,
6683 _("iterator variable"))
6687 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6688 "Start expression in DO loop") == FAILURE)
6691 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6692 "End expression in DO loop") == FAILURE)
6695 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6696 "Step expression in DO loop") == FAILURE)
6699 if (iter->step->expr_type == EXPR_CONSTANT)
6701 if ((iter->step->ts.type == BT_INTEGER
6702 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6703 || (iter->step->ts.type == BT_REAL
6704 && mpfr_sgn (iter->step->value.real) == 0))
6706 gfc_error ("Step expression in DO loop at %L cannot be zero",
6707 &iter->step->where);
6712 /* Convert start, end, and step to the same type as var. */
6713 if (iter->start->ts.kind != iter->var->ts.kind
6714 || iter->start->ts.type != iter->var->ts.type)
6715 gfc_convert_type (iter->start, &iter->var->ts, 2);
6717 if (iter->end->ts.kind != iter->var->ts.kind
6718 || iter->end->ts.type != iter->var->ts.type)
6719 gfc_convert_type (iter->end, &iter->var->ts, 2);
6721 if (iter->step->ts.kind != iter->var->ts.kind
6722 || iter->step->ts.type != iter->var->ts.type)
6723 gfc_convert_type (iter->step, &iter->var->ts, 2);
6725 if (iter->start->expr_type == EXPR_CONSTANT
6726 && iter->end->expr_type == EXPR_CONSTANT
6727 && iter->step->expr_type == EXPR_CONSTANT)
6730 if (iter->start->ts.type == BT_INTEGER)
6732 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6733 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6737 sgn = mpfr_sgn (iter->step->value.real);
6738 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6740 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6741 gfc_warning ("DO loop at %L will be executed zero times",
6742 &iter->step->where);
6749 /* Traversal function for find_forall_index. f == 2 signals that
6750 that variable itself is not to be checked - only the references. */
6753 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6755 if (expr->expr_type != EXPR_VARIABLE)
6758 /* A scalar assignment */
6759 if (!expr->ref || *f == 1)
6761 if (expr->symtree->n.sym == sym)
6773 /* Check whether the FORALL index appears in the expression or not.
6774 Returns SUCCESS if SYM is found in EXPR. */
6777 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6779 if (gfc_traverse_expr (expr, sym, forall_index, f))
6786 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6787 to be a scalar INTEGER variable. The subscripts and stride are scalar
6788 INTEGERs, and if stride is a constant it must be nonzero.
6789 Furthermore "A subscript or stride in a forall-triplet-spec shall
6790 not contain a reference to any index-name in the
6791 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6794 resolve_forall_iterators (gfc_forall_iterator *it)
6796 gfc_forall_iterator *iter, *iter2;
6798 for (iter = it; iter; iter = iter->next)
6800 if (gfc_resolve_expr (iter->var) == SUCCESS
6801 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6802 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6805 if (gfc_resolve_expr (iter->start) == SUCCESS
6806 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6807 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6808 &iter->start->where);
6809 if (iter->var->ts.kind != iter->start->ts.kind)
6810 gfc_convert_type (iter->start, &iter->var->ts, 1);
6812 if (gfc_resolve_expr (iter->end) == SUCCESS
6813 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6814 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6816 if (iter->var->ts.kind != iter->end->ts.kind)
6817 gfc_convert_type (iter->end, &iter->var->ts, 1);
6819 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6821 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6822 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6823 &iter->stride->where, "INTEGER");
6825 if (iter->stride->expr_type == EXPR_CONSTANT
6826 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6827 gfc_error ("FORALL stride expression at %L cannot be zero",
6828 &iter->stride->where);
6830 if (iter->var->ts.kind != iter->stride->ts.kind)
6831 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6834 for (iter = it; iter; iter = iter->next)
6835 for (iter2 = iter; iter2; iter2 = iter2->next)
6837 if (find_forall_index (iter2->start,
6838 iter->var->symtree->n.sym, 0) == SUCCESS
6839 || find_forall_index (iter2->end,
6840 iter->var->symtree->n.sym, 0) == SUCCESS
6841 || find_forall_index (iter2->stride,
6842 iter->var->symtree->n.sym, 0) == SUCCESS)
6843 gfc_error ("FORALL index '%s' may not appear in triplet "
6844 "specification at %L", iter->var->symtree->name,
6845 &iter2->start->where);
6850 /* Given a pointer to a symbol that is a derived type, see if it's
6851 inaccessible, i.e. if it's defined in another module and the components are
6852 PRIVATE. The search is recursive if necessary. Returns zero if no
6853 inaccessible components are found, nonzero otherwise. */
6856 derived_inaccessible (gfc_symbol *sym)
6860 if (sym->attr.use_assoc && sym->attr.private_comp)
6863 for (c = sym->components; c; c = c->next)
6865 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6873 /* Resolve the argument of a deallocate expression. The expression must be
6874 a pointer or a full array. */
6877 resolve_deallocate_expr (gfc_expr *e)
6879 symbol_attribute attr;
6880 int allocatable, pointer;
6886 if (gfc_resolve_expr (e) == FAILURE)
6889 if (e->expr_type != EXPR_VARIABLE)
6892 sym = e->symtree->n.sym;
6893 unlimited = UNLIMITED_POLY(sym);
6895 if (sym->ts.type == BT_CLASS)
6897 allocatable = CLASS_DATA (sym)->attr.allocatable;
6898 pointer = CLASS_DATA (sym)->attr.class_pointer;
6902 allocatable = sym->attr.allocatable;
6903 pointer = sym->attr.pointer;
6905 for (ref = e->ref; ref; ref = ref->next)
6910 if (ref->u.ar.type != AR_FULL
6911 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6912 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6917 c = ref->u.c.component;
6918 if (c->ts.type == BT_CLASS)
6920 allocatable = CLASS_DATA (c)->attr.allocatable;
6921 pointer = CLASS_DATA (c)->attr.class_pointer;
6925 allocatable = c->attr.allocatable;
6926 pointer = c->attr.pointer;
6936 attr = gfc_expr_attr (e);
6938 if (allocatable == 0 && attr.pointer == 0 && !unlimited)
6941 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6947 if (gfc_is_coindexed (e))
6949 gfc_error ("Coindexed allocatable object at %L", &e->where);
6954 && gfc_check_vardef_context (e, true, true, false, _("DEALLOCATE object"))
6957 if (gfc_check_vardef_context (e, false, true, false, _("DEALLOCATE object"))
6965 /* Returns true if the expression e contains a reference to the symbol sym. */
6967 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6969 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6976 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6978 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6982 /* Given the expression node e for an allocatable/pointer of derived type to be
6983 allocated, get the expression node to be initialized afterwards (needed for
6984 derived types with default initializers, and derived types with allocatable
6985 components that need nullification.) */
6988 gfc_expr_to_initialize (gfc_expr *e)
6994 result = gfc_copy_expr (e);
6996 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6997 for (ref = result->ref; ref; ref = ref->next)
6998 if (ref->type == REF_ARRAY && ref->next == NULL)
7000 ref->u.ar.type = AR_FULL;
7002 for (i = 0; i < ref->u.ar.dimen; i++)
7003 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
7008 gfc_free_shape (&result->shape, result->rank);
7010 /* Recalculate rank, shape, etc. */
7011 gfc_resolve_expr (result);
7016 /* If the last ref of an expression is an array ref, return a copy of the
7017 expression with that one removed. Otherwise, a copy of the original
7018 expression. This is used for allocate-expressions and pointer assignment
7019 LHS, where there may be an array specification that needs to be stripped
7020 off when using gfc_check_vardef_context. */
7023 remove_last_array_ref (gfc_expr* e)
7028 e2 = gfc_copy_expr (e);
7029 for (r = &e2->ref; *r; r = &(*r)->next)
7030 if ((*r)->type == REF_ARRAY && !(*r)->next)
7032 gfc_free_ref_list (*r);
7041 /* Used in resolve_allocate_expr to check that a allocation-object and
7042 a source-expr are conformable. This does not catch all possible
7043 cases; in particular a runtime checking is needed. */
7046 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
7049 for (tail = e2->ref; tail && tail->next; tail = tail->next);
7051 /* First compare rank. */
7052 if (tail && e1->rank != tail->u.ar.as->rank)
7054 gfc_error ("Source-expr at %L must be scalar or have the "
7055 "same rank as the allocate-object at %L",
7056 &e1->where, &e2->where);
7067 for (i = 0; i < e1->rank; i++)
7069 if (tail->u.ar.end[i])
7071 mpz_set (s, tail->u.ar.end[i]->value.integer);
7072 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
7073 mpz_add_ui (s, s, 1);
7077 mpz_set (s, tail->u.ar.start[i]->value.integer);
7080 if (mpz_cmp (e1->shape[i], s) != 0)
7082 gfc_error ("Source-expr at %L and allocate-object at %L must "
7083 "have the same shape", &e1->where, &e2->where);
7096 /* Resolve the expression in an ALLOCATE statement, doing the additional
7097 checks to see whether the expression is OK or not. The expression must
7098 have a trailing array reference that gives the size of the array. */
7101 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
7103 int i, pointer, allocatable, dimension, is_abstract;
7107 symbol_attribute attr;
7108 gfc_ref *ref, *ref2;
7111 gfc_symbol *sym = NULL;
7116 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7117 checking of coarrays. */
7118 for (ref = e->ref; ref; ref = ref->next)
7119 if (ref->next == NULL)
7122 if (ref && ref->type == REF_ARRAY)
7123 ref->u.ar.in_allocate = true;
7125 if (gfc_resolve_expr (e) == FAILURE)
7128 /* Make sure the expression is allocatable or a pointer. If it is
7129 pointer, the next-to-last reference must be a pointer. */
7133 sym = e->symtree->n.sym;
7135 /* Check whether ultimate component is abstract and CLASS. */
7138 /* Is the allocate-object unlimited polymorphic? */
7139 unlimited = UNLIMITED_POLY(e);
7141 if (e->expr_type != EXPR_VARIABLE)
7144 attr = gfc_expr_attr (e);
7145 pointer = attr.pointer;
7146 dimension = attr.dimension;
7147 codimension = attr.codimension;
7151 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
7153 allocatable = CLASS_DATA (sym)->attr.allocatable;
7154 pointer = CLASS_DATA (sym)->attr.class_pointer;
7155 dimension = CLASS_DATA (sym)->attr.dimension;
7156 codimension = CLASS_DATA (sym)->attr.codimension;
7157 is_abstract = CLASS_DATA (sym)->attr.abstract;
7161 allocatable = sym->attr.allocatable;
7162 pointer = sym->attr.pointer;
7163 dimension = sym->attr.dimension;
7164 codimension = sym->attr.codimension;
7169 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
7174 if (ref->u.ar.codimen > 0)
7177 for (n = ref->u.ar.dimen;
7178 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
7179 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
7186 if (ref->next != NULL)
7194 gfc_error ("Coindexed allocatable object at %L",
7199 c = ref->u.c.component;
7200 if (c->ts.type == BT_CLASS)
7202 allocatable = CLASS_DATA (c)->attr.allocatable;
7203 pointer = CLASS_DATA (c)->attr.class_pointer;
7204 dimension = CLASS_DATA (c)->attr.dimension;
7205 codimension = CLASS_DATA (c)->attr.codimension;
7206 is_abstract = CLASS_DATA (c)->attr.abstract;
7210 allocatable = c->attr.allocatable;
7211 pointer = c->attr.pointer;
7212 dimension = c->attr.dimension;
7213 codimension = c->attr.codimension;
7214 is_abstract = c->attr.abstract;
7226 /* Check for F08:C628. */
7227 if (allocatable == 0 && pointer == 0 && !unlimited)
7229 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7234 /* Some checks for the SOURCE tag. */
7237 /* Check F03:C631. */
7238 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
7240 gfc_error ("Type of entity at %L is type incompatible with "
7241 "source-expr at %L", &e->where, &code->expr3->where);
7245 /* Check F03:C632 and restriction following Note 6.18. */
7246 if (code->expr3->rank > 0 && !unlimited
7247 && conformable_arrays (code->expr3, e) == FAILURE)
7250 /* Check F03:C633. */
7251 if (code->expr3->ts.kind != e->ts.kind && !unlimited)
7253 gfc_error ("The allocate-object at %L and the source-expr at %L "
7254 "shall have the same kind type parameter",
7255 &e->where, &code->expr3->where);
7259 /* Check F2008, C642. */
7260 if (code->expr3->ts.type == BT_DERIVED
7261 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
7262 || (code->expr3->ts.u.derived->from_intmod
7263 == INTMOD_ISO_FORTRAN_ENV
7264 && code->expr3->ts.u.derived->intmod_sym_id
7265 == ISOFORTRAN_LOCK_TYPE)))
7267 gfc_error ("The source-expr at %L shall neither be of type "
7268 "LOCK_TYPE nor have a LOCK_TYPE component if "
7269 "allocate-object at %L is a coarray",
7270 &code->expr3->where, &e->where);
7275 /* Check F08:C629. */
7276 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
7279 gcc_assert (e->ts.type == BT_CLASS);
7280 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7281 "type-spec or source-expr", sym->name, &e->where);
7285 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
7287 int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7288 code->ext.alloc.ts.u.cl->length);
7289 if (cmp == 1 || cmp == -1 || cmp == -3)
7291 gfc_error ("Allocating %s at %L with type-spec requires the same "
7292 "character-length parameter as in the declaration",
7293 sym->name, &e->where);
7298 /* In the variable definition context checks, gfc_expr_attr is used
7299 on the expression. This is fooled by the array specification
7300 present in e, thus we have to eliminate that one temporarily. */
7301 e2 = remove_last_array_ref (e);
7303 if (t == SUCCESS && pointer)
7304 t = gfc_check_vardef_context (e2, true, true, false, _("ALLOCATE object"));
7306 t = gfc_check_vardef_context (e2, false, true, false, _("ALLOCATE object"));
7311 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7312 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7314 /* For class arrays, the initialization with SOURCE is done
7315 using _copy and trans_call. It is convenient to exploit that
7316 when the allocated type is different from the declared type but
7317 no SOURCE exists by setting expr3. */
7318 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7320 else if (!code->expr3)
7322 /* Set up default initializer if needed. */
7326 if (code->ext.alloc.ts.type == BT_DERIVED)
7327 ts = code->ext.alloc.ts;
7331 if (ts.type == BT_CLASS)
7332 ts = ts.u.derived->components->ts;
7334 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
7336 gfc_code *init_st = gfc_get_code ();
7337 init_st->loc = code->loc;
7338 init_st->op = EXEC_INIT_ASSIGN;
7339 init_st->expr1 = gfc_expr_to_initialize (e);
7340 init_st->expr2 = init_e;
7341 init_st->next = code->next;
7342 code->next = init_st;
7345 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7347 /* Default initialization via MOLD (non-polymorphic). */
7348 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7349 gfc_resolve_expr (rhs);
7350 gfc_free_expr (code->expr3);
7354 if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
7356 /* Make sure the vtab symbol is present when
7357 the module variables are generated. */
7358 gfc_typespec ts = e->ts;
7360 ts = code->expr3->ts;
7361 else if (code->ext.alloc.ts.type == BT_DERIVED)
7362 ts = code->ext.alloc.ts;
7364 gfc_find_derived_vtab (ts.u.derived);
7367 e = gfc_expr_to_initialize (e);
7369 else if (unlimited && !UNLIMITED_POLY (code->expr3))
7371 /* Again, make sure the vtab symbol is present when
7372 the module variables are generated. */
7373 gfc_typespec *ts = NULL;
7375 ts = &code->expr3->ts;
7377 ts = &code->ext.alloc.ts;
7381 if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
7382 gfc_find_derived_vtab (ts->u.derived);
7384 gfc_find_intrinsic_vtab (ts);
7387 e = gfc_expr_to_initialize (e);
7390 if (dimension == 0 && codimension == 0)
7393 /* Make sure the last reference node is an array specification. */
7395 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7396 || (dimension && ref2->u.ar.dimen == 0))
7398 gfc_error ("Array specification required in ALLOCATE statement "
7399 "at %L", &e->where);
7403 /* Make sure that the array section reference makes sense in the
7404 context of an ALLOCATE specification. */
7409 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7410 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7412 gfc_error ("Coarray specification required in ALLOCATE statement "
7413 "at %L", &e->where);
7417 for (i = 0; i < ar->dimen; i++)
7419 if (ref2->u.ar.type == AR_ELEMENT)
7422 switch (ar->dimen_type[i])
7428 if (ar->start[i] != NULL
7429 && ar->end[i] != NULL
7430 && ar->stride[i] == NULL)
7433 /* Fall Through... */
7438 case DIMEN_THIS_IMAGE:
7439 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7445 for (a = code->ext.alloc.list; a; a = a->next)
7447 sym = a->expr->symtree->n.sym;
7449 /* TODO - check derived type components. */
7450 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7453 if ((ar->start[i] != NULL
7454 && gfc_find_sym_in_expr (sym, ar->start[i]))
7455 || (ar->end[i] != NULL
7456 && gfc_find_sym_in_expr (sym, ar->end[i])))
7458 gfc_error ("'%s' must not appear in the array specification at "
7459 "%L in the same ALLOCATE statement where it is "
7460 "itself allocated", sym->name, &ar->where);
7466 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7468 if (ar->dimen_type[i] == DIMEN_ELEMENT
7469 || ar->dimen_type[i] == DIMEN_RANGE)
7471 if (i == (ar->dimen + ar->codimen - 1))
7473 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7474 "statement at %L", &e->where);
7480 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7481 && ar->stride[i] == NULL)
7484 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7497 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7499 gfc_expr *stat, *errmsg, *pe, *qe;
7500 gfc_alloc *a, *p, *q;
7503 errmsg = code->expr2;
7505 /* Check the stat variable. */
7508 gfc_check_vardef_context (stat, false, false, false, _("STAT variable"));
7510 if ((stat->ts.type != BT_INTEGER
7511 && !(stat->ref && (stat->ref->type == REF_ARRAY
7512 || stat->ref->type == REF_COMPONENT)))
7514 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7515 "variable", &stat->where);
7517 for (p = code->ext.alloc.list; p; p = p->next)
7518 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7520 gfc_ref *ref1, *ref2;
7523 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7524 ref1 = ref1->next, ref2 = ref2->next)
7526 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7528 if (ref1->u.c.component->name != ref2->u.c.component->name)
7537 gfc_error ("Stat-variable at %L shall not be %sd within "
7538 "the same %s statement", &stat->where, fcn, fcn);
7544 /* Check the errmsg variable. */
7548 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7551 gfc_check_vardef_context (errmsg, false, false, false,
7552 _("ERRMSG variable"));
7554 if ((errmsg->ts.type != BT_CHARACTER
7556 && (errmsg->ref->type == REF_ARRAY
7557 || errmsg->ref->type == REF_COMPONENT)))
7558 || errmsg->rank > 0 )
7559 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7560 "variable", &errmsg->where);
7562 for (p = code->ext.alloc.list; p; p = p->next)
7563 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7565 gfc_ref *ref1, *ref2;
7568 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7569 ref1 = ref1->next, ref2 = ref2->next)
7571 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7573 if (ref1->u.c.component->name != ref2->u.c.component->name)
7582 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7583 "the same %s statement", &errmsg->where, fcn, fcn);
7589 /* Check that an allocate-object appears only once in the statement. */
7591 for (p = code->ext.alloc.list; p; p = p->next)
7594 for (q = p->next; q; q = q->next)
7597 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7599 /* This is a potential collision. */
7600 gfc_ref *pr = pe->ref;
7601 gfc_ref *qr = qe->ref;
7603 /* Follow the references until
7604 a) They start to differ, in which case there is no error;
7605 you can deallocate a%b and a%c in a single statement
7606 b) Both of them stop, which is an error
7607 c) One of them stops, which is also an error. */
7610 if (pr == NULL && qr == NULL)
7612 gfc_error ("Allocate-object at %L also appears at %L",
7613 &pe->where, &qe->where);
7616 else if (pr != NULL && qr == NULL)
7618 gfc_error ("Allocate-object at %L is subobject of"
7619 " object at %L", &pe->where, &qe->where);
7622 else if (pr == NULL && qr != NULL)
7624 gfc_error ("Allocate-object at %L is subobject of"
7625 " object at %L", &qe->where, &pe->where);
7628 /* Here, pr != NULL && qr != NULL */
7629 gcc_assert(pr->type == qr->type);
7630 if (pr->type == REF_ARRAY)
7632 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7634 gcc_assert (qr->type == REF_ARRAY);
7636 if (pr->next && qr->next)
7639 gfc_array_ref *par = &(pr->u.ar);
7640 gfc_array_ref *qar = &(qr->u.ar);
7642 for (i=0; i<par->dimen; i++)
7644 if ((par->start[i] != NULL
7645 || qar->start[i] != NULL)
7646 && gfc_dep_compare_expr (par->start[i],
7647 qar->start[i]) != 0)
7654 if (pr->u.c.component->name != qr->u.c.component->name)
7667 if (strcmp (fcn, "ALLOCATE") == 0)
7669 for (a = code->ext.alloc.list; a; a = a->next)
7670 resolve_allocate_expr (a->expr, code);
7674 for (a = code->ext.alloc.list; a; a = a->next)
7675 resolve_deallocate_expr (a->expr);
7680 /************ SELECT CASE resolution subroutines ************/
7682 /* Callback function for our mergesort variant. Determines interval
7683 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7684 op1 > op2. Assumes we're not dealing with the default case.
7685 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7686 There are nine situations to check. */
7689 compare_cases (const gfc_case *op1, const gfc_case *op2)
7693 if (op1->low == NULL) /* op1 = (:L) */
7695 /* op2 = (:N), so overlap. */
7697 /* op2 = (M:) or (M:N), L < M */
7698 if (op2->low != NULL
7699 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7702 else if (op1->high == NULL) /* op1 = (K:) */
7704 /* op2 = (M:), so overlap. */
7706 /* op2 = (:N) or (M:N), K > N */
7707 if (op2->high != NULL
7708 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7711 else /* op1 = (K:L) */
7713 if (op2->low == NULL) /* op2 = (:N), K > N */
7714 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7716 else if (op2->high == NULL) /* op2 = (M:), L < M */
7717 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7719 else /* op2 = (M:N) */
7723 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7726 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7735 /* Merge-sort a double linked case list, detecting overlap in the
7736 process. LIST is the head of the double linked case list before it
7737 is sorted. Returns the head of the sorted list if we don't see any
7738 overlap, or NULL otherwise. */
7741 check_case_overlap (gfc_case *list)
7743 gfc_case *p, *q, *e, *tail;
7744 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7746 /* If the passed list was empty, return immediately. */
7753 /* Loop unconditionally. The only exit from this loop is a return
7754 statement, when we've finished sorting the case list. */
7761 /* Count the number of merges we do in this pass. */
7764 /* Loop while there exists a merge to be done. */
7769 /* Count this merge. */
7772 /* Cut the list in two pieces by stepping INSIZE places
7773 forward in the list, starting from P. */
7776 for (i = 0; i < insize; i++)
7785 /* Now we have two lists. Merge them! */
7786 while (psize > 0 || (qsize > 0 && q != NULL))
7788 /* See from which the next case to merge comes from. */
7791 /* P is empty so the next case must come from Q. */
7796 else if (qsize == 0 || q == NULL)
7805 cmp = compare_cases (p, q);
7808 /* The whole case range for P is less than the
7816 /* The whole case range for Q is greater than
7817 the case range for P. */
7824 /* The cases overlap, or they are the same
7825 element in the list. Either way, we must
7826 issue an error and get the next case from P. */
7827 /* FIXME: Sort P and Q by line number. */
7828 gfc_error ("CASE label at %L overlaps with CASE "
7829 "label at %L", &p->where, &q->where);
7837 /* Add the next element to the merged list. */
7846 /* P has now stepped INSIZE places along, and so has Q. So
7847 they're the same. */
7852 /* If we have done only one merge or none at all, we've
7853 finished sorting the cases. */
7862 /* Otherwise repeat, merging lists twice the size. */
7868 /* Check to see if an expression is suitable for use in a CASE statement.
7869 Makes sure that all case expressions are scalar constants of the same
7870 type. Return FAILURE if anything is wrong. */
7873 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7875 if (e == NULL) return SUCCESS;
7877 if (e->ts.type != case_expr->ts.type)
7879 gfc_error ("Expression in CASE statement at %L must be of type %s",
7880 &e->where, gfc_basic_typename (case_expr->ts.type));
7884 /* C805 (R808) For a given case-construct, each case-value shall be of
7885 the same type as case-expr. For character type, length differences
7886 are allowed, but the kind type parameters shall be the same. */
7888 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7890 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7891 &e->where, case_expr->ts.kind);
7895 /* Convert the case value kind to that of case expression kind,
7898 if (e->ts.kind != case_expr->ts.kind)
7899 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7903 gfc_error ("Expression in CASE statement at %L must be scalar",
7912 /* Given a completely parsed select statement, we:
7914 - Validate all expressions and code within the SELECT.
7915 - Make sure that the selection expression is not of the wrong type.
7916 - Make sure that no case ranges overlap.
7917 - Eliminate unreachable cases and unreachable code resulting from
7918 removing case labels.
7920 The standard does allow unreachable cases, e.g. CASE (5:3). But
7921 they are a hassle for code generation, and to prevent that, we just
7922 cut them out here. This is not necessary for overlapping cases
7923 because they are illegal and we never even try to generate code.
7925 We have the additional caveat that a SELECT construct could have
7926 been a computed GOTO in the source code. Fortunately we can fairly
7927 easily work around that here: The case_expr for a "real" SELECT CASE
7928 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7929 we have to do is make sure that the case_expr is a scalar integer
7933 resolve_select (gfc_code *code, bool select_type)
7936 gfc_expr *case_expr;
7937 gfc_case *cp, *default_case, *tail, *head;
7938 int seen_unreachable;
7944 if (code->expr1 == NULL)
7946 /* This was actually a computed GOTO statement. */
7947 case_expr = code->expr2;
7948 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7949 gfc_error ("Selection expression in computed GOTO statement "
7950 "at %L must be a scalar integer expression",
7953 /* Further checking is not necessary because this SELECT was built
7954 by the compiler, so it should always be OK. Just move the
7955 case_expr from expr2 to expr so that we can handle computed
7956 GOTOs as normal SELECTs from here on. */
7957 code->expr1 = code->expr2;
7962 case_expr = code->expr1;
7963 type = case_expr->ts.type;
7966 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7968 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7969 &case_expr->where, gfc_typename (&case_expr->ts));
7971 /* Punt. Going on here just produce more garbage error messages. */
7976 if (!select_type && case_expr->rank != 0)
7978 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7979 "expression", &case_expr->where);
7985 /* Raise a warning if an INTEGER case value exceeds the range of
7986 the case-expr. Later, all expressions will be promoted to the
7987 largest kind of all case-labels. */
7989 if (type == BT_INTEGER)
7990 for (body = code->block; body; body = body->block)
7991 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7994 && gfc_check_integer_range (cp->low->value.integer,
7995 case_expr->ts.kind) != ARITH_OK)
7996 gfc_warning ("Expression in CASE statement at %L is "
7997 "not in the range of %s", &cp->low->where,
7998 gfc_typename (&case_expr->ts));
8001 && cp->low != cp->high
8002 && gfc_check_integer_range (cp->high->value.integer,
8003 case_expr->ts.kind) != ARITH_OK)
8004 gfc_warning ("Expression in CASE statement at %L is "
8005 "not in the range of %s", &cp->high->where,
8006 gfc_typename (&case_expr->ts));
8009 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8010 of the SELECT CASE expression and its CASE values. Walk the lists
8011 of case values, and if we find a mismatch, promote case_expr to
8012 the appropriate kind. */
8014 if (type == BT_LOGICAL || type == BT_INTEGER)
8016 for (body = code->block; body; body = body->block)
8018 /* Walk the case label list. */
8019 for (cp = body->ext.block.case_list; cp; cp = cp->next)
8021 /* Intercept the DEFAULT case. It does not have a kind. */
8022 if (cp->low == NULL && cp->high == NULL)
8025 /* Unreachable case ranges are discarded, so ignore. */
8026 if (cp->low != NULL && cp->high != NULL
8027 && cp->low != cp->high
8028 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
8032 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
8033 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
8035 if (cp->high != NULL
8036 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
8037 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
8042 /* Assume there is no DEFAULT case. */
8043 default_case = NULL;
8048 for (body = code->block; body; body = body->block)
8050 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8052 seen_unreachable = 0;
8054 /* Walk the case label list, making sure that all case labels
8056 for (cp = body->ext.block.case_list; cp; cp = cp->next)
8058 /* Count the number of cases in the whole construct. */
8061 /* Intercept the DEFAULT case. */
8062 if (cp->low == NULL && cp->high == NULL)
8064 if (default_case != NULL)
8066 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8067 "by a second DEFAULT CASE at %L",
8068 &default_case->where, &cp->where);
8079 /* Deal with single value cases and case ranges. Errors are
8080 issued from the validation function. */
8081 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
8082 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
8088 if (type == BT_LOGICAL
8089 && ((cp->low == NULL || cp->high == NULL)
8090 || cp->low != cp->high))
8092 gfc_error ("Logical range in CASE statement at %L is not "
8093 "allowed", &cp->low->where);
8098 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
8101 value = cp->low->value.logical == 0 ? 2 : 1;
8102 if (value & seen_logical)
8104 gfc_error ("Constant logical value in CASE statement "
8105 "is repeated at %L",
8110 seen_logical |= value;
8113 if (cp->low != NULL && cp->high != NULL
8114 && cp->low != cp->high
8115 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
8117 if (gfc_option.warn_surprising)
8118 gfc_warning ("Range specification at %L can never "
8119 "be matched", &cp->where);
8121 cp->unreachable = 1;
8122 seen_unreachable = 1;
8126 /* If the case range can be matched, it can also overlap with
8127 other cases. To make sure it does not, we put it in a
8128 double linked list here. We sort that with a merge sort
8129 later on to detect any overlapping cases. */
8133 head->right = head->left = NULL;
8138 tail->right->left = tail;
8145 /* It there was a failure in the previous case label, give up
8146 for this case label list. Continue with the next block. */
8150 /* See if any case labels that are unreachable have been seen.
8151 If so, we eliminate them. This is a bit of a kludge because
8152 the case lists for a single case statement (label) is a
8153 single forward linked lists. */
8154 if (seen_unreachable)
8156 /* Advance until the first case in the list is reachable. */
8157 while (body->ext.block.case_list != NULL
8158 && body->ext.block.case_list->unreachable)
8160 gfc_case *n = body->ext.block.case_list;
8161 body->ext.block.case_list = body->ext.block.case_list->next;
8163 gfc_free_case_list (n);
8166 /* Strip all other unreachable cases. */
8167 if (body->ext.block.case_list)
8169 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
8171 if (cp->next->unreachable)
8173 gfc_case *n = cp->next;
8174 cp->next = cp->next->next;
8176 gfc_free_case_list (n);
8183 /* See if there were overlapping cases. If the check returns NULL,
8184 there was overlap. In that case we don't do anything. If head
8185 is non-NULL, we prepend the DEFAULT case. The sorted list can
8186 then used during code generation for SELECT CASE constructs with
8187 a case expression of a CHARACTER type. */
8190 head = check_case_overlap (head);
8192 /* Prepend the default_case if it is there. */
8193 if (head != NULL && default_case)
8195 default_case->left = NULL;
8196 default_case->right = head;
8197 head->left = default_case;
8201 /* Eliminate dead blocks that may be the result if we've seen
8202 unreachable case labels for a block. */
8203 for (body = code; body && body->block; body = body->block)
8205 if (body->block->ext.block.case_list == NULL)
8207 /* Cut the unreachable block from the code chain. */
8208 gfc_code *c = body->block;
8209 body->block = c->block;
8211 /* Kill the dead block, but not the blocks below it. */
8213 gfc_free_statements (c);
8217 /* More than two cases is legal but insane for logical selects.
8218 Issue a warning for it. */
8219 if (gfc_option.warn_surprising && type == BT_LOGICAL
8221 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
8226 /* Check if a derived type is extensible. */
8229 gfc_type_is_extensible (gfc_symbol *sym)
8231 return !(sym->attr.is_bind_c || sym->attr.sequence
8232 || (sym->attr.is_class
8233 && sym->components->ts.u.derived->attr.unlimited_polymorphic));
8237 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8238 correct as well as possibly the array-spec. */
8241 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
8245 gcc_assert (sym->assoc);
8246 gcc_assert (sym->attr.flavor == FL_VARIABLE);
8248 /* If this is for SELECT TYPE, the target may not yet be set. In that
8249 case, return. Resolution will be called later manually again when
8251 target = sym->assoc->target;
8254 gcc_assert (!sym->assoc->dangling);
8256 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
8259 /* For variable targets, we get some attributes from the target. */
8260 if (target->expr_type == EXPR_VARIABLE)
8264 gcc_assert (target->symtree);
8265 tsym = target->symtree->n.sym;
8267 sym->attr.asynchronous = tsym->attr.asynchronous;
8268 sym->attr.volatile_ = tsym->attr.volatile_;
8270 sym->attr.target = tsym->attr.target
8271 || gfc_expr_attr (target).pointer;
8274 /* Get type if this was not already set. Note that it can be
8275 some other type than the target in case this is a SELECT TYPE
8276 selector! So we must not update when the type is already there. */
8277 if (sym->ts.type == BT_UNKNOWN)
8278 sym->ts = target->ts;
8279 gcc_assert (sym->ts.type != BT_UNKNOWN);
8281 /* See if this is a valid association-to-variable. */
8282 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
8283 && !gfc_has_vector_subscript (target));
8285 /* Finally resolve if this is an array or not. */
8286 if (sym->attr.dimension && target->rank == 0)
8288 gfc_error ("Associate-name '%s' at %L is used as array",
8289 sym->name, &sym->declared_at);
8290 sym->attr.dimension = 0;
8294 /* We cannot deal with class selectors that need temporaries. */
8295 if (target->ts.type == BT_CLASS
8296 && gfc_ref_needs_temporary_p (target->ref))
8298 gfc_error ("CLASS selector at %L needs a temporary which is not "
8299 "yet implemented", &target->where);
8303 if (target->ts.type != BT_CLASS && target->rank > 0)
8304 sym->attr.dimension = 1;
8305 else if (target->ts.type == BT_CLASS)
8306 gfc_fix_class_refs (target);
8308 /* The associate-name will have a correct type by now. Make absolutely
8309 sure that it has not picked up a dimension attribute. */
8310 if (sym->ts.type == BT_CLASS)
8311 sym->attr.dimension = 0;
8313 if (sym->attr.dimension)
8315 sym->as = gfc_get_array_spec ();
8316 sym->as->rank = target->rank;
8317 sym->as->type = AS_DEFERRED;
8319 /* Target must not be coindexed, thus the associate-variable
8321 sym->as->corank = 0;
8324 /* Mark this as an associate variable. */
8325 sym->attr.associate_var = 1;
8327 /* If the target is a good class object, so is the associate variable. */
8328 if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
8329 sym->attr.class_ok = 1;
8333 /* Resolve a SELECT TYPE statement. */
8336 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
8338 gfc_symbol *selector_type;
8339 gfc_code *body, *new_st, *if_st, *tail;
8340 gfc_code *class_is = NULL, *default_case = NULL;
8343 char name[GFC_MAX_SYMBOL_LEN];
8348 ns = code->ext.block.ns;
8351 /* Check for F03:C813. */
8352 if (code->expr1->ts.type != BT_CLASS
8353 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8355 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8356 "at %L", &code->loc);
8360 if (!code->expr1->symtree->n.sym->attr.class_ok)
8365 if (code->expr1->symtree->n.sym->attr.untyped)
8366 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8367 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8369 /* F2008: C803 The selector expression must not be coindexed. */
8370 if (gfc_is_coindexed (code->expr2))
8372 gfc_error ("Selector at %L must not be coindexed",
8373 &code->expr2->where);
8380 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8382 if (gfc_is_coindexed (code->expr1))
8384 gfc_error ("Selector at %L must not be coindexed",
8385 &code->expr1->where);
8390 /* Loop over TYPE IS / CLASS IS cases. */
8391 for (body = code->block; body; body = body->block)
8393 c = body->ext.block.case_list;
8395 /* Check F03:C815. */
8396 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8397 && !selector_type->attr.unlimited_polymorphic
8398 && !gfc_type_is_extensible (c->ts.u.derived))
8400 gfc_error ("Derived type '%s' at %L must be extensible",
8401 c->ts.u.derived->name, &c->where);
8406 /* Check F03:C816. */
8407 if (c->ts.type != BT_UNKNOWN && !selector_type->attr.unlimited_polymorphic
8408 && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
8409 || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
8411 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8412 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8413 c->ts.u.derived->name, &c->where, selector_type->name);
8415 gfc_error ("Unexpected intrinsic type '%s' at %L",
8416 gfc_basic_typename (c->ts.type), &c->where);
8421 /* Check F03:C814. */
8422 if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length != NULL)
8424 gfc_error ("The type-spec at %L shall specify that each length "
8425 "type parameter is assumed", &c->where);
8430 /* Intercept the DEFAULT case. */
8431 if (c->ts.type == BT_UNKNOWN)
8433 /* Check F03:C818. */
8436 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8437 "by a second DEFAULT CASE at %L",
8438 &default_case->ext.block.case_list->where, &c->where);
8443 default_case = body;
8450 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8451 target if present. If there are any EXIT statements referring to the
8452 SELECT TYPE construct, this is no problem because the gfc_code
8453 reference stays the same and EXIT is equally possible from the BLOCK
8454 it is changed to. */
8455 code->op = EXEC_BLOCK;
8458 gfc_association_list* assoc;
8460 assoc = gfc_get_association_list ();
8461 assoc->st = code->expr1->symtree;
8462 assoc->target = gfc_copy_expr (code->expr2);
8463 assoc->target->where = code->expr2->where;
8464 /* assoc->variable will be set by resolve_assoc_var. */
8466 code->ext.block.assoc = assoc;
8467 code->expr1->symtree->n.sym->assoc = assoc;
8469 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8472 code->ext.block.assoc = NULL;
8474 /* Add EXEC_SELECT to switch on type. */
8475 new_st = gfc_get_code ();
8476 new_st->op = code->op;
8477 new_st->expr1 = code->expr1;
8478 new_st->expr2 = code->expr2;
8479 new_st->block = code->block;
8480 code->expr1 = code->expr2 = NULL;
8485 ns->code->next = new_st;
8487 code->op = EXEC_SELECT;
8489 gfc_add_vptr_component (code->expr1);
8490 gfc_add_hash_component (code->expr1);
8492 /* Loop over TYPE IS / CLASS IS cases. */
8493 for (body = code->block; body; body = body->block)
8495 c = body->ext.block.case_list;
8497 if (c->ts.type == BT_DERIVED)
8498 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8499 c->ts.u.derived->hash_value);
8500 else if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
8505 ivtab = gfc_find_intrinsic_vtab (&c->ts);
8506 gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
8507 e = CLASS_DATA (ivtab)->initializer;
8508 c->low = c->high = gfc_copy_expr (e);
8511 else if (c->ts.type == BT_UNKNOWN)
8514 /* Associate temporary to selector. This should only be done
8515 when this case is actually true, so build a new ASSOCIATE
8516 that does precisely this here (instead of using the
8519 if (c->ts.type == BT_CLASS)
8520 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8521 else if (c->ts.type == BT_DERIVED)
8522 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8523 else if (c->ts.type == BT_CHARACTER)
8525 if (c->ts.u.cl && c->ts.u.cl->length
8526 && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8527 charlen = mpz_get_si (c->ts.u.cl->length->value.integer);
8528 sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (c->ts.type),
8529 charlen, c->ts.kind);
8532 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
8535 st = gfc_find_symtree (ns->sym_root, name);
8536 gcc_assert (st->n.sym->assoc);
8537 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8538 st->n.sym->assoc->target->where = code->expr1->where;
8539 if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
8540 gfc_add_data_component (st->n.sym->assoc->target);
8542 new_st = gfc_get_code ();
8543 new_st->op = EXEC_BLOCK;
8544 new_st->ext.block.ns = gfc_build_block_ns (ns);
8545 new_st->ext.block.ns->code = body->next;
8546 body->next = new_st;
8548 /* Chain in the new list only if it is marked as dangling. Otherwise
8549 there is a CASE label overlap and this is already used. Just ignore,
8550 the error is diagnosed elsewhere. */
8551 if (st->n.sym->assoc->dangling)
8553 new_st->ext.block.assoc = st->n.sym->assoc;
8554 st->n.sym->assoc->dangling = 0;
8557 resolve_assoc_var (st->n.sym, false);
8560 /* Take out CLASS IS cases for separate treatment. */
8562 while (body && body->block)
8564 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8566 /* Add to class_is list. */
8567 if (class_is == NULL)
8569 class_is = body->block;
8574 for (tail = class_is; tail->block; tail = tail->block) ;
8575 tail->block = body->block;
8578 /* Remove from EXEC_SELECT list. */
8579 body->block = body->block->block;
8592 /* Add a default case to hold the CLASS IS cases. */
8593 for (tail = code; tail->block; tail = tail->block) ;
8594 tail->block = gfc_get_code ();
8596 tail->op = EXEC_SELECT_TYPE;
8597 tail->ext.block.case_list = gfc_get_case ();
8598 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8600 default_case = tail;
8603 /* More than one CLASS IS block? */
8604 if (class_is->block)
8608 /* Sort CLASS IS blocks by extension level. */
8612 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8615 /* F03:C817 (check for doubles). */
8616 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8617 == c2->ext.block.case_list->ts.u.derived->hash_value)
8619 gfc_error ("Double CLASS IS block in SELECT TYPE "
8621 &c2->ext.block.case_list->where);
8624 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8625 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8628 (*c1)->block = c2->block;
8638 /* Generate IF chain. */
8639 if_st = gfc_get_code ();
8640 if_st->op = EXEC_IF;
8642 for (body = class_is; body; body = body->block)
8644 new_st->block = gfc_get_code ();
8645 new_st = new_st->block;
8646 new_st->op = EXEC_IF;
8647 /* Set up IF condition: Call _gfortran_is_extension_of. */
8648 new_st->expr1 = gfc_get_expr ();
8649 new_st->expr1->expr_type = EXPR_FUNCTION;
8650 new_st->expr1->ts.type = BT_LOGICAL;
8651 new_st->expr1->ts.kind = 4;
8652 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8653 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8654 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8655 /* Set up arguments. */
8656 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8657 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8658 new_st->expr1->value.function.actual->expr->where = code->loc;
8659 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8660 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8661 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8662 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8663 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8664 new_st->next = body->next;
8666 if (default_case->next)
8668 new_st->block = gfc_get_code ();
8669 new_st = new_st->block;
8670 new_st->op = EXEC_IF;
8671 new_st->next = default_case->next;
8674 /* Replace CLASS DEFAULT code by the IF chain. */
8675 default_case->next = if_st;
8678 /* Resolve the internal code. This can not be done earlier because
8679 it requires that the sym->assoc of selectors is set already. */
8680 gfc_current_ns = ns;
8681 gfc_resolve_blocks (code->block, gfc_current_ns);
8682 gfc_current_ns = old_ns;
8684 resolve_select (code, true);
8688 /* Resolve a transfer statement. This is making sure that:
8689 -- a derived type being transferred has only non-pointer components
8690 -- a derived type being transferred doesn't have private components, unless
8691 it's being transferred from the module where the type was defined
8692 -- we're not trying to transfer a whole assumed size array. */
8695 resolve_transfer (gfc_code *code)
8704 while (exp != NULL && exp->expr_type == EXPR_OP
8705 && exp->value.op.op == INTRINSIC_PARENTHESES)
8706 exp = exp->value.op.op1;
8708 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8710 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8711 "MOLD=", &exp->where);
8715 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8716 && exp->expr_type != EXPR_FUNCTION))
8719 /* If we are reading, the variable will be changed. Note that
8720 code->ext.dt may be NULL if the TRANSFER is related to
8721 an INQUIRE statement -- but in this case, we are not reading, either. */
8722 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8723 && gfc_check_vardef_context (exp, false, false, false, _("item in READ"))
8727 sym = exp->symtree->n.sym;
8730 /* Go to actual component transferred. */
8731 for (ref = exp->ref; ref; ref = ref->next)
8732 if (ref->type == REF_COMPONENT)
8733 ts = &ref->u.c.component->ts;
8735 if (ts->type == BT_CLASS)
8737 /* FIXME: Test for defined input/output. */
8738 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8739 "it is processed by a defined input/output procedure",
8744 if (ts->type == BT_DERIVED)
8746 /* Check that transferred derived type doesn't contain POINTER
8748 if (ts->u.derived->attr.pointer_comp)
8750 gfc_error ("Data transfer element at %L cannot have POINTER "
8751 "components unless it is processed by a defined "
8752 "input/output procedure", &code->loc);
8757 if (ts->u.derived->attr.proc_pointer_comp)
8759 gfc_error ("Data transfer element at %L cannot have "
8760 "procedure pointer components", &code->loc);
8764 if (ts->u.derived->attr.alloc_comp)
8766 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8767 "components unless it is processed by a defined "
8768 "input/output procedure", &code->loc);
8772 if (derived_inaccessible (ts->u.derived))
8774 gfc_error ("Data transfer element at %L cannot have "
8775 "PRIVATE components",&code->loc);
8780 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8781 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8783 gfc_error ("Data transfer element at %L cannot be a full reference to "
8784 "an assumed-size array", &code->loc);
8790 /*********** Toplevel code resolution subroutines ***********/
8792 /* Find the set of labels that are reachable from this block. We also
8793 record the last statement in each block. */
8796 find_reachable_labels (gfc_code *block)
8803 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8805 /* Collect labels in this block. We don't keep those corresponding
8806 to END {IF|SELECT}, these are checked in resolve_branch by going
8807 up through the code_stack. */
8808 for (c = block; c; c = c->next)
8810 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8811 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8814 /* Merge with labels from parent block. */
8817 gcc_assert (cs_base->prev->reachable_labels);
8818 bitmap_ior_into (cs_base->reachable_labels,
8819 cs_base->prev->reachable_labels);
8825 resolve_lock_unlock (gfc_code *code)
8827 if (code->expr1->ts.type != BT_DERIVED
8828 || code->expr1->expr_type != EXPR_VARIABLE
8829 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8830 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8831 || code->expr1->rank != 0
8832 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8833 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8834 &code->expr1->where);
8838 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8839 || code->expr2->expr_type != EXPR_VARIABLE))
8840 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8841 &code->expr2->where);
8844 && gfc_check_vardef_context (code->expr2, false, false, false,
8845 _("STAT variable")) == FAILURE)
8850 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8851 || code->expr3->expr_type != EXPR_VARIABLE))
8852 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8853 &code->expr3->where);
8856 && gfc_check_vardef_context (code->expr3, false, false, false,
8857 _("ERRMSG variable")) == FAILURE)
8860 /* Check ACQUIRED_LOCK. */
8862 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8863 || code->expr4->expr_type != EXPR_VARIABLE))
8864 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8865 "variable", &code->expr4->where);
8868 && gfc_check_vardef_context (code->expr4, false, false, false,
8869 _("ACQUIRED_LOCK variable")) == FAILURE)
8875 resolve_sync (gfc_code *code)
8877 /* Check imageset. The * case matches expr1 == NULL. */
8880 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8881 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8882 "INTEGER expression", &code->expr1->where);
8883 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8884 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8885 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8886 &code->expr1->where);
8887 else if (code->expr1->expr_type == EXPR_ARRAY
8888 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8890 gfc_constructor *cons;
8891 cons = gfc_constructor_first (code->expr1->value.constructor);
8892 for (; cons; cons = gfc_constructor_next (cons))
8893 if (cons->expr->expr_type == EXPR_CONSTANT
8894 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8895 gfc_error ("Imageset argument at %L must between 1 and "
8896 "num_images()", &cons->expr->where);
8902 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8903 || code->expr2->expr_type != EXPR_VARIABLE))
8904 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8905 &code->expr2->where);
8909 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8910 || code->expr3->expr_type != EXPR_VARIABLE))
8911 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8912 &code->expr3->where);
8916 /* Given a branch to a label, see if the branch is conforming.
8917 The code node describes where the branch is located. */
8920 resolve_branch (gfc_st_label *label, gfc_code *code)
8927 /* Step one: is this a valid branching target? */
8929 if (label->defined == ST_LABEL_UNKNOWN)
8931 gfc_error ("Label %d referenced at %L is never defined", label->value,
8936 if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
8938 gfc_error ("Statement at %L is not a valid branch target statement "
8939 "for the branch statement at %L", &label->where, &code->loc);
8943 /* Step two: make sure this branch is not a branch to itself ;-) */
8945 if (code->here == label)
8947 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8951 /* Step three: See if the label is in the same block as the
8952 branching statement. The hard work has been done by setting up
8953 the bitmap reachable_labels. */
8955 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8957 /* Check now whether there is a CRITICAL construct; if so, check
8958 whether the label is still visible outside of the CRITICAL block,
8959 which is invalid. */
8960 for (stack = cs_base; stack; stack = stack->prev)
8962 if (stack->current->op == EXEC_CRITICAL
8963 && bitmap_bit_p (stack->reachable_labels, label->value))
8964 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8965 "label at %L", &code->loc, &label->where);
8966 else if (stack->current->op == EXEC_DO_CONCURRENT
8967 && bitmap_bit_p (stack->reachable_labels, label->value))
8968 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8969 "for label at %L", &code->loc, &label->where);
8975 /* Step four: If we haven't found the label in the bitmap, it may
8976 still be the label of the END of the enclosing block, in which
8977 case we find it by going up the code_stack. */
8979 for (stack = cs_base; stack; stack = stack->prev)
8981 if (stack->current->next && stack->current->next->here == label)
8983 if (stack->current->op == EXEC_CRITICAL)
8985 /* Note: A label at END CRITICAL does not leave the CRITICAL
8986 construct as END CRITICAL is still part of it. */
8987 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8988 " at %L", &code->loc, &label->where);
8991 else if (stack->current->op == EXEC_DO_CONCURRENT)
8993 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8994 "label at %L", &code->loc, &label->where);
9001 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
9005 /* The label is not in an enclosing block, so illegal. This was
9006 allowed in Fortran 66, so we allow it as extension. No
9007 further checks are necessary in this case. */
9008 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
9009 "as the GOTO statement at %L", &label->where,
9015 /* Check whether EXPR1 has the same shape as EXPR2. */
9018 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
9020 mpz_t shape[GFC_MAX_DIMENSIONS];
9021 mpz_t shape2[GFC_MAX_DIMENSIONS];
9022 gfc_try result = FAILURE;
9025 /* Compare the rank. */
9026 if (expr1->rank != expr2->rank)
9029 /* Compare the size of each dimension. */
9030 for (i=0; i<expr1->rank; i++)
9032 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
9035 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
9038 if (mpz_cmp (shape[i], shape2[i]))
9042 /* When either of the two expression is an assumed size array, we
9043 ignore the comparison of dimension sizes. */
9048 gfc_clear_shape (shape, i);
9049 gfc_clear_shape (shape2, i);
9054 /* Check whether a WHERE assignment target or a WHERE mask expression
9055 has the same shape as the outmost WHERE mask expression. */
9058 resolve_where (gfc_code *code, gfc_expr *mask)
9064 cblock = code->block;
9066 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9067 In case of nested WHERE, only the outmost one is stored. */
9068 if (mask == NULL) /* outmost WHERE */
9070 else /* inner WHERE */
9077 /* Check if the mask-expr has a consistent shape with the
9078 outmost WHERE mask-expr. */
9079 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
9080 gfc_error ("WHERE mask at %L has inconsistent shape",
9081 &cblock->expr1->where);
9084 /* the assignment statement of a WHERE statement, or the first
9085 statement in where-body-construct of a WHERE construct */
9086 cnext = cblock->next;
9091 /* WHERE assignment statement */
9094 /* Check shape consistent for WHERE assignment target. */
9095 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
9096 gfc_error ("WHERE assignment target at %L has "
9097 "inconsistent shape", &cnext->expr1->where);
9101 case EXEC_ASSIGN_CALL:
9102 resolve_call (cnext);
9103 if (!cnext->resolved_sym->attr.elemental)
9104 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9105 &cnext->ext.actual->expr->where);
9108 /* WHERE or WHERE construct is part of a where-body-construct */
9110 resolve_where (cnext, e);
9114 gfc_error ("Unsupported statement inside WHERE at %L",
9117 /* the next statement within the same where-body-construct */
9118 cnext = cnext->next;
9120 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9121 cblock = cblock->block;
9126 /* Resolve assignment in FORALL construct.
9127 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9128 FORALL index variables. */
9131 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
9135 for (n = 0; n < nvar; n++)
9137 gfc_symbol *forall_index;
9139 forall_index = var_expr[n]->symtree->n.sym;
9141 /* Check whether the assignment target is one of the FORALL index
9143 if ((code->expr1->expr_type == EXPR_VARIABLE)
9144 && (code->expr1->symtree->n.sym == forall_index))
9145 gfc_error ("Assignment to a FORALL index variable at %L",
9146 &code->expr1->where);
9149 /* If one of the FORALL index variables doesn't appear in the
9150 assignment variable, then there could be a many-to-one
9151 assignment. Emit a warning rather than an error because the
9152 mask could be resolving this problem. */
9153 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
9154 gfc_warning ("The FORALL with index '%s' is not used on the "
9155 "left side of the assignment at %L and so might "
9156 "cause multiple assignment to this object",
9157 var_expr[n]->symtree->name, &code->expr1->where);
9163 /* Resolve WHERE statement in FORALL construct. */
9166 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
9167 gfc_expr **var_expr)
9172 cblock = code->block;
9175 /* the assignment statement of a WHERE statement, or the first
9176 statement in where-body-construct of a WHERE construct */
9177 cnext = cblock->next;
9182 /* WHERE assignment statement */
9184 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
9187 /* WHERE operator assignment statement */
9188 case EXEC_ASSIGN_CALL:
9189 resolve_call (cnext);
9190 if (!cnext->resolved_sym->attr.elemental)
9191 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9192 &cnext->ext.actual->expr->where);
9195 /* WHERE or WHERE construct is part of a where-body-construct */
9197 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
9201 gfc_error ("Unsupported statement inside WHERE at %L",
9204 /* the next statement within the same where-body-construct */
9205 cnext = cnext->next;
9207 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9208 cblock = cblock->block;
9213 /* Traverse the FORALL body to check whether the following errors exist:
9214 1. For assignment, check if a many-to-one assignment happens.
9215 2. For WHERE statement, check the WHERE body to see if there is any
9216 many-to-one assignment. */
9219 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
9223 c = code->block->next;
9229 case EXEC_POINTER_ASSIGN:
9230 gfc_resolve_assign_in_forall (c, nvar, var_expr);
9233 case EXEC_ASSIGN_CALL:
9237 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9238 there is no need to handle it here. */
9242 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
9247 /* The next statement in the FORALL body. */
9253 /* Counts the number of iterators needed inside a forall construct, including
9254 nested forall constructs. This is used to allocate the needed memory
9255 in gfc_resolve_forall. */
9258 gfc_count_forall_iterators (gfc_code *code)
9260 int max_iters, sub_iters, current_iters;
9261 gfc_forall_iterator *fa;
9263 gcc_assert(code->op == EXEC_FORALL);
9267 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
9270 code = code->block->next;
9274 if (code->op == EXEC_FORALL)
9276 sub_iters = gfc_count_forall_iterators (code);
9277 if (sub_iters > max_iters)
9278 max_iters = sub_iters;
9283 return current_iters + max_iters;
9287 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9288 gfc_resolve_forall_body to resolve the FORALL body. */
9291 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
9293 static gfc_expr **var_expr;
9294 static int total_var = 0;
9295 static int nvar = 0;
9297 gfc_forall_iterator *fa;
9302 /* Start to resolve a FORALL construct */
9303 if (forall_save == 0)
9305 /* Count the total number of FORALL index in the nested FORALL
9306 construct in order to allocate the VAR_EXPR with proper size. */
9307 total_var = gfc_count_forall_iterators (code);
9309 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9310 var_expr = XCNEWVEC (gfc_expr *, total_var);
9313 /* The information about FORALL iterator, including FORALL index start, end
9314 and stride. The FORALL index can not appear in start, end or stride. */
9315 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
9317 /* Check if any outer FORALL index name is the same as the current
9319 for (i = 0; i < nvar; i++)
9321 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
9323 gfc_error ("An outer FORALL construct already has an index "
9324 "with this name %L", &fa->var->where);
9328 /* Record the current FORALL index. */
9329 var_expr[nvar] = gfc_copy_expr (fa->var);
9333 /* No memory leak. */
9334 gcc_assert (nvar <= total_var);
9337 /* Resolve the FORALL body. */
9338 gfc_resolve_forall_body (code, nvar, var_expr);
9340 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9341 gfc_resolve_blocks (code->block, ns);
9345 /* Free only the VAR_EXPRs allocated in this frame. */
9346 for (i = nvar; i < tmp; i++)
9347 gfc_free_expr (var_expr[i]);
9351 /* We are in the outermost FORALL construct. */
9352 gcc_assert (forall_save == 0);
9354 /* VAR_EXPR is not needed any more. */
9361 /* Resolve a BLOCK construct statement. */
9364 resolve_block_construct (gfc_code* code)
9366 /* Resolve the BLOCK's namespace. */
9367 gfc_resolve (code->ext.block.ns);
9369 /* For an ASSOCIATE block, the associations (and their targets) are already
9370 resolved during resolve_symbol. */
9374 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9377 static void resolve_code (gfc_code *, gfc_namespace *);
9380 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
9384 for (; b; b = b->block)
9386 t = gfc_resolve_expr (b->expr1);
9387 if (gfc_resolve_expr (b->expr2) == FAILURE)
9393 if (t == SUCCESS && b->expr1 != NULL
9394 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
9395 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9402 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
9403 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9408 resolve_branch (b->label1, b);
9412 resolve_block_construct (b);
9416 case EXEC_SELECT_TYPE:
9420 case EXEC_DO_CONCURRENT:
9428 case EXEC_OMP_ATOMIC:
9429 case EXEC_OMP_CRITICAL:
9431 case EXEC_OMP_MASTER:
9432 case EXEC_OMP_ORDERED:
9433 case EXEC_OMP_PARALLEL:
9434 case EXEC_OMP_PARALLEL_DO:
9435 case EXEC_OMP_PARALLEL_SECTIONS:
9436 case EXEC_OMP_PARALLEL_WORKSHARE:
9437 case EXEC_OMP_SECTIONS:
9438 case EXEC_OMP_SINGLE:
9440 case EXEC_OMP_TASKWAIT:
9441 case EXEC_OMP_TASKYIELD:
9442 case EXEC_OMP_WORKSHARE:
9446 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9449 resolve_code (b->next, ns);
9454 /* Does everything to resolve an ordinary assignment. Returns true
9455 if this is an interface assignment. */
9457 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9467 if (gfc_extend_assign (code, ns) == SUCCESS)
9471 if (code->op == EXEC_ASSIGN_CALL)
9473 lhs = code->ext.actual->expr;
9474 rhsptr = &code->ext.actual->next->expr;
9478 gfc_actual_arglist* args;
9479 gfc_typebound_proc* tbp;
9481 gcc_assert (code->op == EXEC_COMPCALL);
9483 args = code->expr1->value.compcall.actual;
9485 rhsptr = &args->next->expr;
9487 tbp = code->expr1->value.compcall.tbp;
9488 gcc_assert (!tbp->is_generic);
9491 /* Make a temporary rhs when there is a default initializer
9492 and rhs is the same symbol as the lhs. */
9493 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9494 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9495 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9496 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9497 *rhsptr = gfc_get_parentheses (*rhsptr);
9506 && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
9507 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9508 &code->loc) == FAILURE)
9511 /* Handle the case of a BOZ literal on the RHS. */
9512 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9515 if (gfc_option.warn_surprising)
9516 gfc_warning ("BOZ literal at %L is bitwise transferred "
9517 "non-integer symbol '%s'", &code->loc,
9518 lhs->symtree->n.sym->name);
9520 if (!gfc_convert_boz (rhs, &lhs->ts))
9522 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9524 if (rc == ARITH_UNDERFLOW)
9525 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9526 ". This check can be disabled with the option "
9527 "-fno-range-check", &rhs->where);
9528 else if (rc == ARITH_OVERFLOW)
9529 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9530 ". This check can be disabled with the option "
9531 "-fno-range-check", &rhs->where);
9532 else if (rc == ARITH_NAN)
9533 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9534 ". This check can be disabled with the option "
9535 "-fno-range-check", &rhs->where);
9540 if (lhs->ts.type == BT_CHARACTER
9541 && gfc_option.warn_character_truncation)
9543 if (lhs->ts.u.cl != NULL
9544 && lhs->ts.u.cl->length != NULL
9545 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9546 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9548 if (rhs->expr_type == EXPR_CONSTANT)
9549 rlen = rhs->value.character.length;
9551 else if (rhs->ts.u.cl != NULL
9552 && rhs->ts.u.cl->length != NULL
9553 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9554 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9556 if (rlen && llen && rlen > llen)
9557 gfc_warning_now ("CHARACTER expression will be truncated "
9558 "in assignment (%d/%d) at %L",
9559 llen, rlen, &code->loc);
9562 /* Ensure that a vector index expression for the lvalue is evaluated
9563 to a temporary if the lvalue symbol is referenced in it. */
9566 for (ref = lhs->ref; ref; ref= ref->next)
9567 if (ref->type == REF_ARRAY)
9569 for (n = 0; n < ref->u.ar.dimen; n++)
9570 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9571 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9572 ref->u.ar.start[n]))
9574 = gfc_get_parentheses (ref->u.ar.start[n]);
9578 if (gfc_pure (NULL))
9580 if (lhs->ts.type == BT_DERIVED
9581 && lhs->expr_type == EXPR_VARIABLE
9582 && lhs->ts.u.derived->attr.pointer_comp
9583 && rhs->expr_type == EXPR_VARIABLE
9584 && (gfc_impure_variable (rhs->symtree->n.sym)
9585 || gfc_is_coindexed (rhs)))
9588 if (gfc_is_coindexed (rhs))
9589 gfc_error ("Coindexed expression at %L is assigned to "
9590 "a derived type variable with a POINTER "
9591 "component in a PURE procedure",
9594 gfc_error ("The impure variable at %L is assigned to "
9595 "a derived type variable with a POINTER "
9596 "component in a PURE procedure (12.6)",
9601 /* Fortran 2008, C1283. */
9602 if (gfc_is_coindexed (lhs))
9604 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9605 "procedure", &rhs->where);
9610 if (gfc_implicit_pure (NULL))
9612 if (lhs->expr_type == EXPR_VARIABLE
9613 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9614 && lhs->symtree->n.sym->ns != gfc_current_ns)
9615 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9617 if (lhs->ts.type == BT_DERIVED
9618 && lhs->expr_type == EXPR_VARIABLE
9619 && lhs->ts.u.derived->attr.pointer_comp
9620 && rhs->expr_type == EXPR_VARIABLE
9621 && (gfc_impure_variable (rhs->symtree->n.sym)
9622 || gfc_is_coindexed (rhs)))
9623 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9625 /* Fortran 2008, C1283. */
9626 if (gfc_is_coindexed (lhs))
9627 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9631 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9632 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9633 if (lhs->ts.type == BT_CLASS)
9635 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9636 "%L - check that there is a matching specific subroutine "
9637 "for '=' operator", &lhs->where);
9641 /* F2008, Section 7.2.1.2. */
9642 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9644 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9645 "component in assignment at %L", &lhs->where);
9649 gfc_check_assign (lhs, rhs, 1);
9654 /* Add a component reference onto an expression. */
9657 add_comp_ref (gfc_expr *e, gfc_component *c)
9662 ref = &((*ref)->next);
9663 *ref = gfc_get_ref ();
9664 (*ref)->type = REF_COMPONENT;
9665 (*ref)->u.c.sym = e->ts.u.derived;
9666 (*ref)->u.c.component = c;
9669 /* Add a full array ref, as necessary. */
9672 gfc_add_full_array_ref (e, c->as);
9673 e->rank = c->as->rank;
9678 /* Build an assignment. Keep the argument 'op' for future use, so that
9679 pointer assignments can be made. */
9682 build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
9683 gfc_component *comp1, gfc_component *comp2, locus loc)
9685 gfc_code *this_code;
9687 this_code = gfc_get_code ();
9689 this_code->next = NULL;
9690 this_code->expr1 = gfc_copy_expr (expr1);
9691 this_code->expr2 = gfc_copy_expr (expr2);
9692 this_code->loc = loc;
9695 add_comp_ref (this_code->expr1, comp1);
9696 add_comp_ref (this_code->expr2, comp2);
9703 /* Makes a temporary variable expression based on the characteristics of
9704 a given variable expression. */
9707 get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
9709 static int serial = 0;
9710 char name[GFC_MAX_SYMBOL_LEN];
9713 gfc_array_ref *aref;
9716 sprintf (name, "DA@%d", serial++);
9717 gfc_get_sym_tree (name, ns, &tmp, false);
9718 gfc_add_type (tmp->n.sym, &e->ts, NULL);
9724 /* This function could be expanded to support other expression type
9725 but this is not needed here. */
9726 gcc_assert (e->expr_type == EXPR_VARIABLE);
9728 /* Obtain the arrayspec for the temporary. */
9731 aref = gfc_find_array_ref (e);
9732 if (e->expr_type == EXPR_VARIABLE
9733 && e->symtree->n.sym->as == aref->as)
9737 for (ref = e->ref; ref; ref = ref->next)
9738 if (ref->type == REF_COMPONENT
9739 && ref->u.c.component->as == aref->as)
9747 /* Add the attributes and the arrayspec to the temporary. */
9748 tmp->n.sym->attr = gfc_expr_attr (e);
9749 tmp->n.sym->attr.function = 0;
9750 tmp->n.sym->attr.result = 0;
9751 tmp->n.sym->attr.flavor = FL_VARIABLE;
9755 tmp->n.sym->as = gfc_copy_array_spec (as);
9758 if (as->type == AS_DEFERRED)
9759 tmp->n.sym->attr.allocatable = 1;
9762 tmp->n.sym->attr.dimension = 0;
9764 gfc_set_sym_referenced (tmp->n.sym);
9765 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
9766 gfc_commit_symbol (tmp->n.sym);
9767 e = gfc_lval_expr_from_sym (tmp->n.sym);
9769 /* Should the lhs be a section, use its array ref for the
9770 temporary expression. */
9771 if (aref && aref->type != AR_FULL)
9773 gfc_free_ref_list (e->ref);
9774 e->ref = gfc_copy_ref (ref);
9780 /* Add one line of code to the code chain, making sure that 'head' and
9781 'tail' are appropriately updated. */
9784 add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
9786 gcc_assert (this_code);
9788 *head = *tail = *this_code;
9790 *tail = gfc_append_code (*tail, *this_code);
9795 /* Counts the potential number of part array references that would
9796 result from resolution of typebound defined assignments. */
9799 nonscalar_typebound_assign (gfc_symbol *derived, int depth)
9802 int c_depth = 0, t_depth;
9804 for (c= derived->components; c; c = c->next)
9806 if ((c->ts.type != BT_DERIVED
9808 || c->attr.allocatable
9809 || c->attr.proc_pointer_comp
9810 || c->attr.class_pointer
9811 || c->attr.proc_pointer)
9812 && !c->attr.defined_assign_comp)
9815 if (c->as && c_depth == 0)
9818 if (c->ts.u.derived->attr.defined_assign_comp)
9819 t_depth = nonscalar_typebound_assign (c->ts.u.derived,
9824 c_depth = t_depth > c_depth ? t_depth : c_depth;
9826 return depth + c_depth;
9830 /* Implement 7.2.1.3 of the F08 standard:
9831 "An intrinsic assignment where the variable is of derived type is
9832 performed as if each component of the variable were assigned from the
9833 corresponding component of expr using pointer assignment (7.2.2) for
9834 each pointer component, defined assignment for each nonpointer
9835 nonallocatable component of a type that has a type-bound defined
9836 assignment consistent with the component, intrinsic assignment for
9837 each other nonpointer nonallocatable component, ..."
9839 The pointer assignments are taken care of by the intrinsic
9840 assignment of the structure itself. This function recursively adds
9841 defined assignments where required. The recursion is accomplished
9842 by calling resolve_code.
9844 When the lhs in a defined assignment has intent INOUT, we need a
9845 temporary for the lhs. In pseudo-code:
9847 ! Only call function lhs once.
9848 if (lhs is not a constant or an variable)
9851 ! Do the intrinsic assignment
9853 ! Now do the defined assignments
9854 do over components with typebound defined assignment [%cmp]
9855 #if one component's assignment procedure is INOUT
9857 #if expr2 non-variable
9863 t1%cmp {defined=} expr2%cmp
9869 expr1%cmp {defined=} expr2%cmp
9873 /* The temporary assignments have to be put on top of the additional
9874 code to avoid the result being changed by the intrinsic assignment.
9876 static int component_assignment_level = 0;
9877 static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
9880 generate_component_assignments (gfc_code **code, gfc_namespace *ns)
9882 gfc_component *comp1, *comp2;
9883 gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
9885 int error_count, depth;
9887 gfc_get_errors (NULL, &error_count);
9889 /* Filter out continuing processing after an error. */
9891 || (*code)->expr1->ts.type != BT_DERIVED
9892 || (*code)->expr2->ts.type != BT_DERIVED)
9895 /* TODO: Handle more than one part array reference in assignments. */
9896 depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
9897 (*code)->expr1->rank ? 1 : 0);
9900 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9901 "done because multiple part array references would "
9902 "occur in intermediate expressions.", &(*code)->loc);
9906 component_assignment_level++;
9908 /* Create a temporary so that functions get called only once. */
9909 if ((*code)->expr2->expr_type != EXPR_VARIABLE
9910 && (*code)->expr2->expr_type != EXPR_CONSTANT)
9914 /* Assign the rhs to the temporary. */
9915 tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
9916 this_code = build_assignment (EXEC_ASSIGN,
9917 tmp_expr, (*code)->expr2,
9918 NULL, NULL, (*code)->loc);
9919 /* Add the code and substitute the rhs expression. */
9920 add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
9921 gfc_free_expr ((*code)->expr2);
9922 (*code)->expr2 = tmp_expr;
9925 /* Do the intrinsic assignment. This is not needed if the lhs is one
9926 of the temporaries generated here, since the intrinsic assignment
9927 to the final result already does this. */
9928 if ((*code)->expr1->symtree->n.sym->name[2] != '@')
9930 this_code = build_assignment (EXEC_ASSIGN,
9931 (*code)->expr1, (*code)->expr2,
9932 NULL, NULL, (*code)->loc);
9933 add_code_to_chain (&this_code, &head, &tail);
9936 comp1 = (*code)->expr1->ts.u.derived->components;
9937 comp2 = (*code)->expr2->ts.u.derived->components;
9940 for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
9944 /* The intrinsic assignment does the right thing for pointers
9945 of all kinds and allocatable components. */
9946 if (comp1->ts.type != BT_DERIVED
9947 || comp1->attr.pointer
9948 || comp1->attr.allocatable
9949 || comp1->attr.proc_pointer_comp
9950 || comp1->attr.class_pointer
9951 || comp1->attr.proc_pointer)
9954 /* Make an assigment for this component. */
9955 this_code = build_assignment (EXEC_ASSIGN,
9956 (*code)->expr1, (*code)->expr2,
9957 comp1, comp2, (*code)->loc);
9959 /* Convert the assignment if there is a defined assignment for
9960 this type. Otherwise, using the call from resolve_code,
9961 recurse into its components. */
9962 resolve_code (this_code, ns);
9964 if (this_code->op == EXEC_ASSIGN_CALL)
9966 gfc_formal_arglist *dummy_args;
9968 /* Check that there is a typebound defined assignment. If not,
9969 then this must be a module defined assignment. We cannot
9970 use the defined_assign_comp attribute here because it must
9971 be this derived type that has the defined assignment and not
9973 if (!(comp1->ts.u.derived->f2k_derived
9974 && comp1->ts.u.derived->f2k_derived
9975 ->tb_op[INTRINSIC_ASSIGN]))
9977 gfc_free_statements (this_code);
9982 /* If the first argument of the subroutine has intent INOUT
9983 a temporary must be generated and used instead. */
9984 rsym = this_code->resolved_sym;
9985 dummy_args = gfc_sym_get_dummy_args (rsym);
9987 && dummy_args->sym->attr.intent == INTENT_INOUT)
9989 gfc_code *temp_code;
9992 /* Build the temporary required for the assignment and put
9993 it at the head of the generated code. */
9996 t1 = get_temp_from_expr ((*code)->expr1, ns);
9997 temp_code = build_assignment (EXEC_ASSIGN,
9999 NULL, NULL, (*code)->loc);
10001 /* For allocatable LHS, check whether it is allocated. Note
10002 that allocatable components with defined assignment are
10003 not yet support. See PR 57696. */
10004 if ((*code)->expr1->symtree->n.sym->attr.allocatable)
10008 gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
10009 block = gfc_get_code ();
10010 block->op = EXEC_IF;
10011 block->block = gfc_get_code ();
10012 block->block->op = EXEC_IF;
10013 block->block->expr1
10014 = gfc_build_intrinsic_call (ns,
10015 GFC_ISYM_ALLOCATED, "allocated",
10016 (*code)->loc, 1, e);
10017 block->block->next = temp_code;
10020 add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
10023 /* Replace the first actual arg with the component of the
10025 gfc_free_expr (this_code->ext.actual->expr);
10026 this_code->ext.actual->expr = gfc_copy_expr (t1);
10027 add_comp_ref (this_code->ext.actual->expr, comp1);
10029 /* If the LHS variable is allocatable and wasn't allocated and
10030 the temporary is allocatable, pointer assign the address of
10031 the freshly allocated LHS to the temporary. */
10032 if ((*code)->expr1->symtree->n.sym->attr.allocatable
10033 && gfc_expr_attr ((*code)->expr1).allocatable)
10038 cond = gfc_get_expr ();
10039 cond->ts.type = BT_LOGICAL;
10040 cond->ts.kind = gfc_default_logical_kind;
10041 cond->expr_type = EXPR_OP;
10042 cond->where = (*code)->loc;
10043 cond->value.op.op = INTRINSIC_NOT;
10044 cond->value.op.op1 = gfc_build_intrinsic_call (ns,
10045 GFC_ISYM_ALLOCATED, "allocated",
10046 (*code)->loc, 1, gfc_copy_expr (t1));
10047 block = gfc_get_code ();
10048 block->op = EXEC_IF;
10049 block->block = gfc_get_code ();
10050 block->block->op = EXEC_IF;
10051 block->block->expr1 = cond;
10052 block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
10053 t1, (*code)->expr1,
10054 NULL, NULL, (*code)->loc);
10055 add_code_to_chain (&block, &head, &tail);
10059 else if (this_code->op == EXEC_ASSIGN && !this_code->next)
10061 /* Don't add intrinsic assignments since they are already
10062 effected by the intrinsic assignment of the structure. */
10063 gfc_free_statements (this_code);
10068 add_code_to_chain (&this_code, &head, &tail);
10072 /* Transfer the value to the final result. */
10073 this_code = build_assignment (EXEC_ASSIGN,
10074 (*code)->expr1, t1,
10075 comp1, comp2, (*code)->loc);
10076 add_code_to_chain (&this_code, &head, &tail);
10080 /* Put the temporary assignments at the top of the generated code. */
10081 if (tmp_head && component_assignment_level == 1)
10083 gfc_append_code (tmp_head, head);
10085 tmp_head = tmp_tail = NULL;
10088 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10089 // not accidentally deallocated. Hence, nullify t1.
10090 if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
10091 && gfc_expr_attr ((*code)->expr1).allocatable)
10097 e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
10098 cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
10099 (*code)->loc, 2, gfc_copy_expr (t1), e);
10100 block = gfc_get_code ();
10101 block->op = EXEC_IF;
10102 block->block = gfc_get_code ();
10103 block->block->op = EXEC_IF;
10104 block->block->expr1 = cond;
10105 block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
10106 t1, gfc_get_null_expr (&(*code)->loc),
10107 NULL, NULL, (*code)->loc);
10108 gfc_append_code (tail, block);
10112 /* Now attach the remaining code chain to the input code. Step on
10113 to the end of the new code since resolution is complete. */
10114 gcc_assert ((*code)->op == EXEC_ASSIGN);
10115 tail->next = (*code)->next;
10116 /* Overwrite 'code' because this would place the intrinsic assignment
10117 before the temporary for the lhs is created. */
10118 gfc_free_expr ((*code)->expr1);
10119 gfc_free_expr ((*code)->expr2);
10125 component_assignment_level--;
10129 /* Given a block of code, recursively resolve everything pointed to by this
10133 resolve_code (gfc_code *code, gfc_namespace *ns)
10135 int omp_workshare_save;
10136 int forall_save, do_concurrent_save;
10140 frame.prev = cs_base;
10144 find_reachable_labels (code);
10146 for (; code; code = code->next)
10148 frame.current = code;
10149 forall_save = forall_flag;
10150 do_concurrent_save = do_concurrent_flag;
10152 if (code->op == EXEC_FORALL)
10155 gfc_resolve_forall (code, ns, forall_save);
10158 else if (code->block)
10160 omp_workshare_save = -1;
10163 case EXEC_OMP_PARALLEL_WORKSHARE:
10164 omp_workshare_save = omp_workshare_flag;
10165 omp_workshare_flag = 1;
10166 gfc_resolve_omp_parallel_blocks (code, ns);
10168 case EXEC_OMP_PARALLEL:
10169 case EXEC_OMP_PARALLEL_DO:
10170 case EXEC_OMP_PARALLEL_SECTIONS:
10171 case EXEC_OMP_TASK:
10172 omp_workshare_save = omp_workshare_flag;
10173 omp_workshare_flag = 0;
10174 gfc_resolve_omp_parallel_blocks (code, ns);
10177 gfc_resolve_omp_do_blocks (code, ns);
10179 case EXEC_SELECT_TYPE:
10180 /* Blocks are handled in resolve_select_type because we have
10181 to transform the SELECT TYPE into ASSOCIATE first. */
10183 case EXEC_DO_CONCURRENT:
10184 do_concurrent_flag = 1;
10185 gfc_resolve_blocks (code->block, ns);
10186 do_concurrent_flag = 2;
10188 case EXEC_OMP_WORKSHARE:
10189 omp_workshare_save = omp_workshare_flag;
10190 omp_workshare_flag = 1;
10193 gfc_resolve_blocks (code->block, ns);
10197 if (omp_workshare_save != -1)
10198 omp_workshare_flag = omp_workshare_save;
10202 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
10203 t = gfc_resolve_expr (code->expr1);
10204 forall_flag = forall_save;
10205 do_concurrent_flag = do_concurrent_save;
10207 if (gfc_resolve_expr (code->expr2) == FAILURE)
10210 if (code->op == EXEC_ALLOCATE
10211 && gfc_resolve_expr (code->expr3) == FAILURE)
10217 case EXEC_END_BLOCK:
10218 case EXEC_END_NESTED_BLOCK:
10222 case EXEC_ERROR_STOP:
10224 case EXEC_CONTINUE:
10226 case EXEC_ASSIGN_CALL:
10227 case EXEC_CRITICAL:
10230 case EXEC_SYNC_ALL:
10231 case EXEC_SYNC_IMAGES:
10232 case EXEC_SYNC_MEMORY:
10233 resolve_sync (code);
10238 resolve_lock_unlock (code);
10242 /* Keep track of which entry we are up to. */
10243 current_entry_id = code->ext.entry->id;
10247 resolve_where (code, NULL);
10251 if (code->expr1 != NULL)
10253 if (code->expr1->ts.type != BT_INTEGER)
10254 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10255 "INTEGER variable", &code->expr1->where);
10256 else if (code->expr1->symtree->n.sym->attr.assign != 1)
10257 gfc_error ("Variable '%s' has not been assigned a target "
10258 "label at %L", code->expr1->symtree->n.sym->name,
10259 &code->expr1->where);
10262 resolve_branch (code->label1, code);
10266 if (code->expr1 != NULL
10267 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
10268 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10269 "INTEGER return specifier", &code->expr1->where);
10272 case EXEC_INIT_ASSIGN:
10273 case EXEC_END_PROCEDURE:
10280 if (gfc_check_vardef_context (code->expr1, false, false, false,
10281 _("assignment")) == FAILURE)
10284 if (resolve_ordinary_assign (code, ns))
10286 if (code->op == EXEC_COMPCALL)
10292 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10293 if (code->expr1->ts.type == BT_DERIVED
10294 && code->expr1->ts.u.derived->attr.defined_assign_comp)
10295 generate_component_assignments (&code, ns);
10299 case EXEC_LABEL_ASSIGN:
10300 if (code->label1->defined == ST_LABEL_UNKNOWN)
10301 gfc_error ("Label %d referenced at %L is never defined",
10302 code->label1->value, &code->label1->where);
10304 && (code->expr1->expr_type != EXPR_VARIABLE
10305 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
10306 || code->expr1->symtree->n.sym->ts.kind
10307 != gfc_default_integer_kind
10308 || code->expr1->symtree->n.sym->as != NULL))
10309 gfc_error ("ASSIGN statement at %L requires a scalar "
10310 "default INTEGER variable", &code->expr1->where);
10313 case EXEC_POINTER_ASSIGN:
10320 /* This is both a variable definition and pointer assignment
10321 context, so check both of them. For rank remapping, a final
10322 array ref may be present on the LHS and fool gfc_expr_attr
10323 used in gfc_check_vardef_context. Remove it. */
10324 e = remove_last_array_ref (code->expr1);
10325 t = gfc_check_vardef_context (e, true, false, false,
10326 _("pointer assignment"));
10328 t = gfc_check_vardef_context (e, false, false, false,
10329 _("pointer assignment"));
10334 gfc_check_pointer_assign (code->expr1, code->expr2);
10338 case EXEC_ARITHMETIC_IF:
10340 && code->expr1->ts.type != BT_INTEGER
10341 && code->expr1->ts.type != BT_REAL)
10342 gfc_error ("Arithmetic IF statement at %L requires a numeric "
10343 "expression", &code->expr1->where);
10345 resolve_branch (code->label1, code);
10346 resolve_branch (code->label2, code);
10347 resolve_branch (code->label3, code);
10351 if (t == SUCCESS && code->expr1 != NULL
10352 && (code->expr1->ts.type != BT_LOGICAL
10353 || code->expr1->rank != 0))
10354 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10355 &code->expr1->where);
10360 resolve_call (code);
10363 case EXEC_COMPCALL:
10365 resolve_typebound_subroutine (code);
10368 case EXEC_CALL_PPC:
10369 resolve_ppc_call (code);
10373 /* Select is complicated. Also, a SELECT construct could be
10374 a transformed computed GOTO. */
10375 resolve_select (code, false);
10378 case EXEC_SELECT_TYPE:
10379 resolve_select_type (code, ns);
10383 resolve_block_construct (code);
10387 if (code->ext.iterator != NULL)
10389 gfc_iterator *iter = code->ext.iterator;
10390 if (gfc_resolve_iterator (iter, true, false) != FAILURE)
10391 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
10395 case EXEC_DO_WHILE:
10396 if (code->expr1 == NULL)
10397 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
10399 && (code->expr1->rank != 0
10400 || code->expr1->ts.type != BT_LOGICAL))
10401 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10402 "a scalar LOGICAL expression", &code->expr1->where);
10405 case EXEC_ALLOCATE:
10407 resolve_allocate_deallocate (code, "ALLOCATE");
10411 case EXEC_DEALLOCATE:
10413 resolve_allocate_deallocate (code, "DEALLOCATE");
10418 if (gfc_resolve_open (code->ext.open) == FAILURE)
10421 resolve_branch (code->ext.open->err, code);
10425 if (gfc_resolve_close (code->ext.close) == FAILURE)
10428 resolve_branch (code->ext.close->err, code);
10431 case EXEC_BACKSPACE:
10435 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
10438 resolve_branch (code->ext.filepos->err, code);
10442 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
10445 resolve_branch (code->ext.inquire->err, code);
10448 case EXEC_IOLENGTH:
10449 gcc_assert (code->ext.inquire != NULL);
10450 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
10453 resolve_branch (code->ext.inquire->err, code);
10457 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
10460 resolve_branch (code->ext.wait->err, code);
10461 resolve_branch (code->ext.wait->end, code);
10462 resolve_branch (code->ext.wait->eor, code);
10467 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
10470 resolve_branch (code->ext.dt->err, code);
10471 resolve_branch (code->ext.dt->end, code);
10472 resolve_branch (code->ext.dt->eor, code);
10475 case EXEC_TRANSFER:
10476 resolve_transfer (code);
10479 case EXEC_DO_CONCURRENT:
10481 resolve_forall_iterators (code->ext.forall_iterator);
10483 if (code->expr1 != NULL
10484 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
10485 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10486 "expression", &code->expr1->where);
10489 case EXEC_OMP_ATOMIC:
10490 case EXEC_OMP_BARRIER:
10491 case EXEC_OMP_CRITICAL:
10492 case EXEC_OMP_FLUSH:
10494 case EXEC_OMP_MASTER:
10495 case EXEC_OMP_ORDERED:
10496 case EXEC_OMP_SECTIONS:
10497 case EXEC_OMP_SINGLE:
10498 case EXEC_OMP_TASKWAIT:
10499 case EXEC_OMP_TASKYIELD:
10500 case EXEC_OMP_WORKSHARE:
10501 gfc_resolve_omp_directive (code, ns);
10504 case EXEC_OMP_PARALLEL:
10505 case EXEC_OMP_PARALLEL_DO:
10506 case EXEC_OMP_PARALLEL_SECTIONS:
10507 case EXEC_OMP_PARALLEL_WORKSHARE:
10508 case EXEC_OMP_TASK:
10509 omp_workshare_save = omp_workshare_flag;
10510 omp_workshare_flag = 0;
10511 gfc_resolve_omp_directive (code, ns);
10512 omp_workshare_flag = omp_workshare_save;
10516 gfc_internal_error ("resolve_code(): Bad statement code");
10520 cs_base = frame.prev;
10524 /* Resolve initial values and make sure they are compatible with
10528 resolve_values (gfc_symbol *sym)
10532 if (sym->value == NULL)
10535 if (sym->value->expr_type == EXPR_STRUCTURE)
10536 t= resolve_structure_cons (sym->value, 1);
10538 t = gfc_resolve_expr (sym->value);
10543 gfc_check_assign_symbol (sym, NULL, sym->value);
10547 /* Verify the binding labels for common blocks that are BIND(C). The label
10548 for a BIND(C) common block must be identical in all scoping units in which
10549 the common block is declared. Further, the binding label can not collide
10550 with any other global entity in the program. */
10553 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
10555 if (comm_block_tree->n.common->is_bind_c == 1)
10557 gfc_gsymbol *binding_label_gsym;
10558 gfc_gsymbol *comm_name_gsym;
10559 const char * bind_label = comm_block_tree->n.common->binding_label
10560 ? comm_block_tree->n.common->binding_label : "";
10562 /* See if a global symbol exists by the common block's name. It may
10563 be NULL if the common block is use-associated. */
10564 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
10565 comm_block_tree->n.common->name);
10566 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
10567 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
10568 "with the global entity '%s' at %L",
10570 comm_block_tree->n.common->name,
10571 &(comm_block_tree->n.common->where),
10572 comm_name_gsym->name, &(comm_name_gsym->where));
10573 else if (comm_name_gsym != NULL
10574 && strcmp (comm_name_gsym->name,
10575 comm_block_tree->n.common->name) == 0)
10577 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
10579 if (comm_name_gsym->binding_label == NULL)
10580 /* No binding label for common block stored yet; save this one. */
10581 comm_name_gsym->binding_label = bind_label;
10582 else if (strcmp (comm_name_gsym->binding_label, bind_label) != 0)
10584 /* Common block names match but binding labels do not. */
10585 gfc_error ("Binding label '%s' for common block '%s' at %L "
10586 "does not match the binding label '%s' for common "
10587 "block '%s' at %L",
10589 comm_block_tree->n.common->name,
10590 &(comm_block_tree->n.common->where),
10591 comm_name_gsym->binding_label,
10592 comm_name_gsym->name,
10593 &(comm_name_gsym->where));
10598 /* There is no binding label (NAME="") so we have nothing further to
10599 check and nothing to add as a global symbol for the label. */
10600 if (!comm_block_tree->n.common->binding_label)
10603 binding_label_gsym =
10604 gfc_find_gsymbol (gfc_gsym_root,
10605 comm_block_tree->n.common->binding_label);
10606 if (binding_label_gsym == NULL)
10608 /* Need to make a global symbol for the binding label to prevent
10609 it from colliding with another. */
10610 binding_label_gsym =
10611 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
10612 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
10613 binding_label_gsym->type = GSYM_COMMON;
10617 /* If comm_name_gsym is NULL, the name common block is use
10618 associated and the name could be colliding. */
10619 if (binding_label_gsym->type != GSYM_COMMON)
10620 gfc_error ("Binding label '%s' for common block '%s' at %L "
10621 "collides with the global entity '%s' at %L",
10622 comm_block_tree->n.common->binding_label,
10623 comm_block_tree->n.common->name,
10624 &(comm_block_tree->n.common->where),
10625 binding_label_gsym->name,
10626 &(binding_label_gsym->where));
10627 else if (comm_name_gsym != NULL
10628 && (strcmp (binding_label_gsym->name,
10629 comm_name_gsym->binding_label) != 0)
10630 && (strcmp (binding_label_gsym->sym_name,
10631 comm_name_gsym->name) != 0))
10632 gfc_error ("Binding label '%s' for common block '%s' at %L "
10633 "collides with global entity '%s' at %L",
10634 binding_label_gsym->name, binding_label_gsym->sym_name,
10635 &(comm_block_tree->n.common->where),
10636 comm_name_gsym->name, &(comm_name_gsym->where));
10644 /* Verify any BIND(C) derived types in the namespace so we can report errors
10645 for them once, rather than for each variable declared of that type. */
10648 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
10650 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
10651 && derived_sym->attr.is_bind_c == 1)
10652 verify_bind_c_derived_type (derived_sym);
10658 /* Verify that any binding labels used in a given namespace do not collide
10659 with the names or binding labels of any global symbols. */
10662 gfc_verify_binding_labels (gfc_symbol *sym)
10666 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
10667 && sym->attr.flavor != FL_DERIVED && sym->binding_label)
10669 gfc_gsymbol *bind_c_sym;
10671 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
10672 if (bind_c_sym != NULL
10673 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
10675 if (sym->attr.if_source == IFSRC_DECL
10676 && (bind_c_sym->type != GSYM_SUBROUTINE
10677 && bind_c_sym->type != GSYM_FUNCTION)
10678 && ((sym->attr.contained == 1
10679 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
10680 || (sym->attr.use_assoc == 1
10681 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
10683 /* Make sure global procedures don't collide with anything. */
10684 gfc_error ("Binding label '%s' at %L collides with the global "
10685 "entity '%s' at %L", sym->binding_label,
10686 &(sym->declared_at), bind_c_sym->name,
10687 &(bind_c_sym->where));
10690 else if (sym->attr.contained == 0
10691 && (sym->attr.if_source == IFSRC_IFBODY
10692 && sym->attr.flavor == FL_PROCEDURE)
10693 && (bind_c_sym->sym_name != NULL
10694 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
10696 /* Make sure procedures in interface bodies don't collide. */
10697 gfc_error ("Binding label '%s' in interface body at %L collides "
10698 "with the global entity '%s' at %L",
10699 sym->binding_label,
10700 &(sym->declared_at), bind_c_sym->name,
10701 &(bind_c_sym->where));
10704 else if (sym->attr.contained == 0
10705 && sym->attr.if_source == IFSRC_UNKNOWN)
10706 if ((sym->attr.use_assoc && bind_c_sym->mod_name
10707 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
10708 || sym->attr.use_assoc == 0)
10710 gfc_error ("Binding label '%s' at %L collides with global "
10711 "entity '%s' at %L", sym->binding_label,
10712 &(sym->declared_at), bind_c_sym->name,
10713 &(bind_c_sym->where));
10717 if (has_error != 0)
10718 /* Clear the binding label to prevent checking multiple times. */
10719 sym->binding_label = NULL;
10721 else if (bind_c_sym == NULL)
10723 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
10724 bind_c_sym->where = sym->declared_at;
10725 bind_c_sym->sym_name = sym->name;
10727 if (sym->attr.use_assoc == 1)
10728 bind_c_sym->mod_name = sym->module;
10730 if (sym->ns->proc_name != NULL)
10731 bind_c_sym->mod_name = sym->ns->proc_name->name;
10733 if (sym->attr.contained == 0)
10735 if (sym->attr.subroutine)
10736 bind_c_sym->type = GSYM_SUBROUTINE;
10737 else if (sym->attr.function)
10738 bind_c_sym->type = GSYM_FUNCTION;
10746 /* Resolve an index expression. */
10749 resolve_index_expr (gfc_expr *e)
10751 if (gfc_resolve_expr (e) == FAILURE)
10754 if (gfc_simplify_expr (e, 0) == FAILURE)
10757 if (gfc_specification_expr (e) == FAILURE)
10764 /* Resolve a charlen structure. */
10767 resolve_charlen (gfc_charlen *cl)
10770 bool saved_specification_expr;
10776 saved_specification_expr = specification_expr;
10777 specification_expr = true;
10779 if (cl->length_from_typespec)
10781 if (gfc_resolve_expr (cl->length) == FAILURE)
10783 specification_expr = saved_specification_expr;
10787 if (gfc_simplify_expr (cl->length, 0) == FAILURE)
10789 specification_expr = saved_specification_expr;
10796 if (resolve_index_expr (cl->length) == FAILURE)
10798 specification_expr = saved_specification_expr;
10803 /* "If the character length parameter value evaluates to a negative
10804 value, the length of character entities declared is zero." */
10805 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
10807 if (gfc_option.warn_surprising)
10808 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10809 " the length has been set to zero",
10810 &cl->length->where, i);
10811 gfc_replace_expr (cl->length,
10812 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
10815 /* Check that the character length is not too large. */
10816 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
10817 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
10818 && cl->length->ts.type == BT_INTEGER
10819 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
10821 gfc_error ("String length at %L is too large", &cl->length->where);
10822 specification_expr = saved_specification_expr;
10826 specification_expr = saved_specification_expr;
10831 /* Test for non-constant shape arrays. */
10834 is_non_constant_shape_array (gfc_symbol *sym)
10840 not_constant = false;
10841 if (sym->as != NULL)
10843 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10844 has not been simplified; parameter array references. Do the
10845 simplification now. */
10846 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
10848 e = sym->as->lower[i];
10849 if (e && (resolve_index_expr (e) == FAILURE
10850 || !gfc_is_constant_expr (e)))
10851 not_constant = true;
10852 e = sym->as->upper[i];
10853 if (e && (resolve_index_expr (e) == FAILURE
10854 || !gfc_is_constant_expr (e)))
10855 not_constant = true;
10858 return not_constant;
10861 /* Given a symbol and an initialization expression, add code to initialize
10862 the symbol to the function entry. */
10864 build_init_assign (gfc_symbol *sym, gfc_expr *init)
10868 gfc_namespace *ns = sym->ns;
10870 /* Search for the function namespace if this is a contained
10871 function without an explicit result. */
10872 if (sym->attr.function && sym == sym->result
10873 && sym->name != sym->ns->proc_name->name)
10875 ns = ns->contained;
10876 for (;ns; ns = ns->sibling)
10877 if (strcmp (ns->proc_name->name, sym->name) == 0)
10883 gfc_free_expr (init);
10887 /* Build an l-value expression for the result. */
10888 lval = gfc_lval_expr_from_sym (sym);
10890 /* Add the code at scope entry. */
10891 init_st = gfc_get_code ();
10892 init_st->next = ns->code;
10893 ns->code = init_st;
10895 /* Assign the default initializer to the l-value. */
10896 init_st->loc = sym->declared_at;
10897 init_st->op = EXEC_INIT_ASSIGN;
10898 init_st->expr1 = lval;
10899 init_st->expr2 = init;
10902 /* Assign the default initializer to a derived type variable or result. */
10905 apply_default_init (gfc_symbol *sym)
10907 gfc_expr *init = NULL;
10909 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10912 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
10913 init = gfc_default_initializer (&sym->ts);
10915 if (init == NULL && sym->ts.type != BT_CLASS)
10918 build_init_assign (sym, init);
10919 sym->attr.referenced = 1;
10922 /* Build an initializer for a local integer, real, complex, logical, or
10923 character variable, based on the command line flags finit-local-zero,
10924 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10925 null if the symbol should not have a default initialization. */
10927 build_default_init_expr (gfc_symbol *sym)
10930 gfc_expr *init_expr;
10933 /* These symbols should never have a default initialization. */
10934 if (sym->attr.allocatable
10935 || sym->attr.external
10937 || sym->attr.pointer
10938 || sym->attr.in_equivalence
10939 || sym->attr.in_common
10942 || sym->attr.cray_pointee
10943 || sym->attr.cray_pointer
10947 /* Now we'll try to build an initializer expression. */
10948 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
10949 &sym->declared_at);
10951 /* We will only initialize integers, reals, complex, logicals, and
10952 characters, and only if the corresponding command-line flags
10953 were set. Otherwise, we free init_expr and return null. */
10954 switch (sym->ts.type)
10957 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
10958 mpz_set_si (init_expr->value.integer,
10959 gfc_option.flag_init_integer_value);
10962 gfc_free_expr (init_expr);
10968 switch (gfc_option.flag_init_real)
10970 case GFC_INIT_REAL_SNAN:
10971 init_expr->is_snan = 1;
10972 /* Fall through. */
10973 case GFC_INIT_REAL_NAN:
10974 mpfr_set_nan (init_expr->value.real);
10977 case GFC_INIT_REAL_INF:
10978 mpfr_set_inf (init_expr->value.real, 1);
10981 case GFC_INIT_REAL_NEG_INF:
10982 mpfr_set_inf (init_expr->value.real, -1);
10985 case GFC_INIT_REAL_ZERO:
10986 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
10990 gfc_free_expr (init_expr);
10997 switch (gfc_option.flag_init_real)
10999 case GFC_INIT_REAL_SNAN:
11000 init_expr->is_snan = 1;
11001 /* Fall through. */
11002 case GFC_INIT_REAL_NAN:
11003 mpfr_set_nan (mpc_realref (init_expr->value.complex));
11004 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
11007 case GFC_INIT_REAL_INF:
11008 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
11009 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
11012 case GFC_INIT_REAL_NEG_INF:
11013 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
11014 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
11017 case GFC_INIT_REAL_ZERO:
11018 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
11022 gfc_free_expr (init_expr);
11029 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
11030 init_expr->value.logical = 0;
11031 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
11032 init_expr->value.logical = 1;
11035 gfc_free_expr (init_expr);
11041 /* For characters, the length must be constant in order to
11042 create a default initializer. */
11043 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
11044 && sym->ts.u.cl->length
11045 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11047 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
11048 init_expr->value.character.length = char_len;
11049 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
11050 for (i = 0; i < char_len; i++)
11051 init_expr->value.character.string[i]
11052 = (unsigned char) gfc_option.flag_init_character_value;
11056 gfc_free_expr (init_expr);
11059 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
11060 && sym->ts.u.cl->length)
11062 gfc_actual_arglist *arg;
11063 init_expr = gfc_get_expr ();
11064 init_expr->where = sym->declared_at;
11065 init_expr->ts = sym->ts;
11066 init_expr->expr_type = EXPR_FUNCTION;
11067 init_expr->value.function.isym =
11068 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
11069 init_expr->value.function.name = "repeat";
11070 arg = gfc_get_actual_arglist ();
11071 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
11073 arg->expr->value.character.string[0]
11074 = gfc_option.flag_init_character_value;
11075 arg->next = gfc_get_actual_arglist ();
11076 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
11077 init_expr->value.function.actual = arg;
11082 gfc_free_expr (init_expr);
11088 /* Add an initialization expression to a local variable. */
11090 apply_default_init_local (gfc_symbol *sym)
11092 gfc_expr *init = NULL;
11094 /* The symbol should be a variable or a function return value. */
11095 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
11096 || (sym->attr.function && sym->result != sym))
11099 /* Try to build the initializer expression. If we can't initialize
11100 this symbol, then init will be NULL. */
11101 init = build_default_init_expr (sym);
11105 /* For saved variables, we don't want to add an initializer at function
11106 entry, so we just add a static initializer. Note that automatic variables
11107 are stack allocated even with -fno-automatic; we have also to exclude
11108 result variable, which are also nonstatic. */
11109 if (sym->attr.save || sym->ns->save_all
11110 || (gfc_option.flag_max_stack_var_size == 0 && !sym->attr.result
11111 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
11113 /* Don't clobber an existing initializer! */
11114 gcc_assert (sym->value == NULL);
11119 build_init_assign (sym, init);
11123 /* Resolution of common features of flavors variable and procedure. */
11126 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
11128 gfc_array_spec *as;
11130 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
11131 as = CLASS_DATA (sym)->as;
11135 /* Constraints on deferred shape variable. */
11136 if (as == NULL || as->type != AS_DEFERRED)
11138 bool pointer, allocatable, dimension;
11140 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
11142 pointer = CLASS_DATA (sym)->attr.class_pointer;
11143 allocatable = CLASS_DATA (sym)->attr.allocatable;
11144 dimension = CLASS_DATA (sym)->attr.dimension;
11148 pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
11149 allocatable = sym->attr.allocatable;
11150 dimension = sym->attr.dimension;
11155 if (dimension && as->type != AS_ASSUMED_RANK)
11157 gfc_error ("Allocatable array '%s' at %L must have a deferred "
11158 "shape or assumed rank", sym->name, &sym->declared_at);
11161 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object "
11162 "'%s' at %L may not be ALLOCATABLE",
11163 sym->name, &sym->declared_at) == FAILURE)
11167 if (pointer && dimension && as->type != AS_ASSUMED_RANK)
11169 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
11170 "assumed rank", sym->name, &sym->declared_at);
11176 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
11177 && sym->ts.type != BT_CLASS && !sym->assoc)
11179 gfc_error ("Array '%s' at %L cannot have a deferred shape",
11180 sym->name, &sym->declared_at);
11185 /* Constraints on polymorphic variables. */
11186 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
11189 if (sym->attr.class_ok
11190 && !sym->attr.select_type_temporary
11191 && !UNLIMITED_POLY(sym)
11192 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
11194 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
11195 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
11196 &sym->declared_at);
11201 /* Assume that use associated symbols were checked in the module ns.
11202 Class-variables that are associate-names are also something special
11203 and excepted from the test. */
11204 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
11206 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
11207 "or pointer", sym->name, &sym->declared_at);
11216 /* Additional checks for symbols with flavor variable and derived
11217 type. To be called from resolve_fl_variable. */
11220 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
11222 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
11224 /* Check to see if a derived type is blocked from being host
11225 associated by the presence of another class I symbol in the same
11226 namespace. 14.6.1.3 of the standard and the discussion on
11227 comp.lang.fortran. */
11228 if (sym->ns != sym->ts.u.derived->ns
11229 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
11232 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
11233 if (s && s->attr.generic)
11234 s = gfc_find_dt_in_generic (s);
11235 if (s && s->attr.flavor != FL_DERIVED)
11237 gfc_error ("The type '%s' cannot be host associated at %L "
11238 "because it is blocked by an incompatible object "
11239 "of the same name declared at %L",
11240 sym->ts.u.derived->name, &sym->declared_at,
11246 /* 4th constraint in section 11.3: "If an object of a type for which
11247 component-initialization is specified (R429) appears in the
11248 specification-part of a module and does not have the ALLOCATABLE
11249 or POINTER attribute, the object shall have the SAVE attribute."
11251 The check for initializers is performed with
11252 gfc_has_default_initializer because gfc_default_initializer generates
11253 a hidden default for allocatable components. */
11254 if (!(sym->value || no_init_flag) && sym->ns->proc_name
11255 && sym->ns->proc_name->attr.flavor == FL_MODULE
11256 && !sym->ns->save_all && !sym->attr.save
11257 && !sym->attr.pointer && !sym->attr.allocatable
11258 && gfc_has_default_initializer (sym->ts.u.derived)
11259 && gfc_notify_std (GFC_STD_F2008, "Implied SAVE for "
11260 "module variable '%s' at %L, needed due to "
11261 "the default initialization", sym->name,
11262 &sym->declared_at) == FAILURE)
11265 /* Assign default initializer. */
11266 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
11267 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
11269 sym->value = gfc_default_initializer (&sym->ts);
11276 /* Resolve symbols with flavor variable. */
11279 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
11281 int no_init_flag, automatic_flag;
11283 const char *auto_save_msg;
11284 bool saved_specification_expr;
11286 auto_save_msg = "Automatic object '%s' at %L cannot have the "
11289 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
11292 /* Set this flag to check that variables are parameters of all entries.
11293 This check is effected by the call to gfc_resolve_expr through
11294 is_non_constant_shape_array. */
11295 saved_specification_expr = specification_expr;
11296 specification_expr = true;
11298 if (sym->ns->proc_name
11299 && (sym->ns->proc_name->attr.flavor == FL_MODULE
11300 || sym->ns->proc_name->attr.is_main_program)
11301 && !sym->attr.use_assoc
11302 && !sym->attr.allocatable
11303 && !sym->attr.pointer
11304 && is_non_constant_shape_array (sym))
11306 /* The shape of a main program or module array needs to be
11308 gfc_error ("The module or main program array '%s' at %L must "
11309 "have constant shape", sym->name, &sym->declared_at);
11310 specification_expr = saved_specification_expr;
11314 /* Constraints on deferred type parameter. */
11315 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
11317 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
11318 "requires either the pointer or allocatable attribute",
11319 sym->name, &sym->declared_at);
11320 specification_expr = saved_specification_expr;
11324 if (sym->ts.type == BT_CHARACTER)
11326 /* Make sure that character string variables with assumed length are
11327 dummy arguments. */
11328 e = sym->ts.u.cl->length;
11329 if (e == NULL && !sym->attr.dummy && !sym->attr.result
11330 && !sym->ts.deferred && !sym->attr.select_type_temporary)
11332 gfc_error ("Entity with assumed character length at %L must be a "
11333 "dummy argument or a PARAMETER", &sym->declared_at);
11334 specification_expr = saved_specification_expr;
11338 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
11340 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
11341 specification_expr = saved_specification_expr;
11345 if (!gfc_is_constant_expr (e)
11346 && !(e->expr_type == EXPR_VARIABLE
11347 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
11349 if (!sym->attr.use_assoc && sym->ns->proc_name
11350 && (sym->ns->proc_name->attr.flavor == FL_MODULE
11351 || sym->ns->proc_name->attr.is_main_program))
11353 gfc_error ("'%s' at %L must have constant character length "
11354 "in this context", sym->name, &sym->declared_at);
11355 specification_expr = saved_specification_expr;
11358 if (sym->attr.in_common)
11360 gfc_error ("COMMON variable '%s' at %L must have constant "
11361 "character length", sym->name, &sym->declared_at);
11362 specification_expr = saved_specification_expr;
11368 if (sym->value == NULL && sym->attr.referenced)
11369 apply_default_init_local (sym); /* Try to apply a default initialization. */
11371 /* Determine if the symbol may not have an initializer. */
11372 no_init_flag = automatic_flag = 0;
11373 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
11374 || sym->attr.intrinsic || sym->attr.result)
11376 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
11377 && is_non_constant_shape_array (sym))
11379 no_init_flag = automatic_flag = 1;
11381 /* Also, they must not have the SAVE attribute.
11382 SAVE_IMPLICIT is checked below. */
11383 if (sym->as && sym->attr.codimension)
11385 int corank = sym->as->corank;
11386 sym->as->corank = 0;
11387 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
11388 sym->as->corank = corank;
11390 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
11392 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
11393 specification_expr = saved_specification_expr;
11398 /* Ensure that any initializer is simplified. */
11400 gfc_simplify_expr (sym->value, 1);
11402 /* Reject illegal initializers. */
11403 if (!sym->mark && sym->value)
11405 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
11406 && CLASS_DATA (sym)->attr.allocatable))
11407 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
11408 sym->name, &sym->declared_at);
11409 else if (sym->attr.external)
11410 gfc_error ("External '%s' at %L cannot have an initializer",
11411 sym->name, &sym->declared_at);
11412 else if (sym->attr.dummy
11413 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
11414 gfc_error ("Dummy '%s' at %L cannot have an initializer",
11415 sym->name, &sym->declared_at);
11416 else if (sym->attr.intrinsic)
11417 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
11418 sym->name, &sym->declared_at);
11419 else if (sym->attr.result)
11420 gfc_error ("Function result '%s' at %L cannot have an initializer",
11421 sym->name, &sym->declared_at);
11422 else if (automatic_flag)
11423 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
11424 sym->name, &sym->declared_at);
11426 goto no_init_error;
11427 specification_expr = saved_specification_expr;
11432 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
11434 gfc_try res = resolve_fl_variable_derived (sym, no_init_flag);
11435 specification_expr = saved_specification_expr;
11439 specification_expr = saved_specification_expr;
11444 /* Resolve a procedure. */
11447 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
11449 gfc_formal_arglist *arg;
11451 if (sym->attr.function
11452 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
11455 if (sym->ts.type == BT_CHARACTER)
11457 gfc_charlen *cl = sym->ts.u.cl;
11459 if (cl && cl->length && gfc_is_constant_expr (cl->length)
11460 && resolve_charlen (cl) == FAILURE)
11463 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11464 && sym->attr.proc == PROC_ST_FUNCTION)
11466 gfc_error ("Character-valued statement function '%s' at %L must "
11467 "have constant length", sym->name, &sym->declared_at);
11472 /* Ensure that derived type for are not of a private type. Internal
11473 module procedures are excluded by 2.2.3.3 - i.e., they are not
11474 externally accessible and can access all the objects accessible in
11476 if (!(sym->ns->parent
11477 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
11478 && gfc_check_symbol_access (sym))
11480 gfc_interface *iface;
11482 for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
11485 && arg->sym->ts.type == BT_DERIVED
11486 && !arg->sym->ts.u.derived->attr.use_assoc
11487 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
11488 && gfc_notify_std (GFC_STD_F2003, "'%s' is of a "
11489 "PRIVATE type and cannot be a dummy argument"
11490 " of '%s', which is PUBLIC at %L",
11491 arg->sym->name, sym->name, &sym->declared_at)
11494 /* Stop this message from recurring. */
11495 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
11500 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11501 PRIVATE to the containing module. */
11502 for (iface = sym->generic; iface; iface = iface->next)
11504 for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
11507 && arg->sym->ts.type == BT_DERIVED
11508 && !arg->sym->ts.u.derived->attr.use_assoc
11509 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
11510 && gfc_notify_std (GFC_STD_F2003, "Procedure "
11511 "'%s' in PUBLIC interface '%s' at %L "
11512 "takes dummy arguments of '%s' which is "
11513 "PRIVATE", iface->sym->name, sym->name,
11514 &iface->sym->declared_at,
11515 gfc_typename (&arg->sym->ts)) == FAILURE)
11517 /* Stop this message from recurring. */
11518 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
11524 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11525 PRIVATE to the containing module. */
11526 for (iface = sym->generic; iface; iface = iface->next)
11528 for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
11531 && arg->sym->ts.type == BT_DERIVED
11532 && !arg->sym->ts.u.derived->attr.use_assoc
11533 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
11534 && gfc_notify_std (GFC_STD_F2003, "Procedure "
11535 "'%s' in PUBLIC interface '%s' at %L "
11536 "takes dummy arguments of '%s' which is "
11537 "PRIVATE", iface->sym->name, sym->name,
11538 &iface->sym->declared_at,
11539 gfc_typename (&arg->sym->ts)) == FAILURE)
11541 /* Stop this message from recurring. */
11542 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
11549 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
11550 && !sym->attr.proc_pointer)
11552 gfc_error ("Function '%s' at %L cannot have an initializer",
11553 sym->name, &sym->declared_at);
11557 /* An external symbol may not have an initializer because it is taken to be
11558 a procedure. Exception: Procedure Pointers. */
11559 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
11561 gfc_error ("External object '%s' at %L may not have an initializer",
11562 sym->name, &sym->declared_at);
11566 /* An elemental function is required to return a scalar 12.7.1 */
11567 if (sym->attr.elemental && sym->attr.function && sym->as)
11569 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
11570 "result", sym->name, &sym->declared_at);
11571 /* Reset so that the error only occurs once. */
11572 sym->attr.elemental = 0;
11576 if (sym->attr.proc == PROC_ST_FUNCTION
11577 && (sym->attr.allocatable || sym->attr.pointer))
11579 gfc_error ("Statement function '%s' at %L may not have pointer or "
11580 "allocatable attribute", sym->name, &sym->declared_at);
11584 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11585 char-len-param shall not be array-valued, pointer-valued, recursive
11586 or pure. ....snip... A character value of * may only be used in the
11587 following ways: (i) Dummy arg of procedure - dummy associates with
11588 actual length; (ii) To declare a named constant; or (iii) External
11589 function - but length must be declared in calling scoping unit. */
11590 if (sym->attr.function
11591 && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
11592 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
11594 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
11595 || (sym->attr.recursive) || (sym->attr.pure))
11597 if (sym->as && sym->as->rank)
11598 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11599 "array-valued", sym->name, &sym->declared_at);
11601 if (sym->attr.pointer)
11602 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11603 "pointer-valued", sym->name, &sym->declared_at);
11605 if (sym->attr.pure)
11606 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11607 "pure", sym->name, &sym->declared_at);
11609 if (sym->attr.recursive)
11610 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11611 "recursive", sym->name, &sym->declared_at);
11616 /* Appendix B.2 of the standard. Contained functions give an
11617 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11618 character length is an F2003 feature. */
11619 if (!sym->attr.contained
11620 && gfc_current_form != FORM_FIXED
11621 && !sym->ts.deferred)
11622 gfc_notify_std (GFC_STD_F95_OBS,
11623 "CHARACTER(*) function '%s' at %L",
11624 sym->name, &sym->declared_at);
11627 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
11629 gfc_formal_arglist *curr_arg;
11630 int has_non_interop_arg = 0;
11632 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11633 sym->common_block) == FAILURE)
11635 /* Clear these to prevent looking at them again if there was an
11637 sym->attr.is_bind_c = 0;
11638 sym->attr.is_c_interop = 0;
11639 sym->ts.is_c_interop = 0;
11643 /* So far, no errors have been found. */
11644 sym->attr.is_c_interop = 1;
11645 sym->ts.is_c_interop = 1;
11648 curr_arg = gfc_sym_get_dummy_args (sym);
11649 while (curr_arg != NULL)
11651 /* Skip implicitly typed dummy args here. */
11652 if (curr_arg->sym->attr.implicit_type == 0)
11653 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
11654 /* If something is found to fail, record the fact so we
11655 can mark the symbol for the procedure as not being
11656 BIND(C) to try and prevent multiple errors being
11658 has_non_interop_arg = 1;
11660 curr_arg = curr_arg->next;
11663 /* See if any of the arguments were not interoperable and if so, clear
11664 the procedure symbol to prevent duplicate error messages. */
11665 if (has_non_interop_arg != 0)
11667 sym->attr.is_c_interop = 0;
11668 sym->ts.is_c_interop = 0;
11669 sym->attr.is_bind_c = 0;
11673 if (!sym->attr.proc_pointer)
11675 if (sym->attr.save == SAVE_EXPLICIT)
11677 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11678 "in '%s' at %L", sym->name, &sym->declared_at);
11681 if (sym->attr.intent)
11683 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11684 "in '%s' at %L", sym->name, &sym->declared_at);
11687 if (sym->attr.subroutine && sym->attr.result)
11689 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11690 "in '%s' at %L", sym->name, &sym->declared_at);
11693 if (sym->attr.external && sym->attr.function
11694 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
11695 || sym->attr.contained))
11697 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11698 "in '%s' at %L", sym->name, &sym->declared_at);
11701 if (strcmp ("ppr@", sym->name) == 0)
11703 gfc_error ("Procedure pointer result '%s' at %L "
11704 "is missing the pointer attribute",
11705 sym->ns->proc_name->name, &sym->declared_at);
11714 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11715 been defined and we now know their defined arguments, check that they fulfill
11716 the requirements of the standard for procedures used as finalizers. */
11719 gfc_resolve_finalizers (gfc_symbol* derived)
11721 gfc_finalizer* list;
11722 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
11723 gfc_try result = SUCCESS;
11724 bool seen_scalar = false;
11726 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
11729 /* Walk over the list of finalizer-procedures, check them, and if any one
11730 does not fit in with the standard's definition, print an error and remove
11731 it from the list. */
11732 prev_link = &derived->f2k_derived->finalizers;
11733 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
11735 gfc_formal_arglist *dummy_args;
11740 /* Skip this finalizer if we already resolved it. */
11741 if (list->proc_tree)
11743 prev_link = &(list->next);
11747 /* Check this exists and is a SUBROUTINE. */
11748 if (!list->proc_sym->attr.subroutine)
11750 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11751 list->proc_sym->name, &list->where);
11755 /* We should have exactly one argument. */
11756 dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
11757 if (!dummy_args || dummy_args->next)
11759 gfc_error ("FINAL procedure at %L must have exactly one argument",
11763 arg = dummy_args->sym;
11765 /* This argument must be of our type. */
11766 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
11768 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11769 &arg->declared_at, derived->name);
11773 /* It must neither be a pointer nor allocatable nor optional. */
11774 if (arg->attr.pointer)
11776 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11777 &arg->declared_at);
11780 if (arg->attr.allocatable)
11782 gfc_error ("Argument of FINAL procedure at %L must not be"
11783 " ALLOCATABLE", &arg->declared_at);
11786 if (arg->attr.optional)
11788 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11789 &arg->declared_at);
11793 /* It must not be INTENT(OUT). */
11794 if (arg->attr.intent == INTENT_OUT)
11796 gfc_error ("Argument of FINAL procedure at %L must not be"
11797 " INTENT(OUT)", &arg->declared_at);
11801 /* Warn if the procedure is non-scalar and not assumed shape. */
11802 if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0
11803 && arg->as->type != AS_ASSUMED_SHAPE)
11804 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11805 " shape argument", &arg->declared_at);
11807 /* Check that it does not match in kind and rank with a FINAL procedure
11808 defined earlier. To really loop over the *earlier* declarations,
11809 we need to walk the tail of the list as new ones were pushed at the
11811 /* TODO: Handle kind parameters once they are implemented. */
11812 my_rank = (arg->as ? arg->as->rank : 0);
11813 for (i = list->next; i; i = i->next)
11815 gfc_formal_arglist *dummy_args;
11817 /* Argument list might be empty; that is an error signalled earlier,
11818 but we nevertheless continued resolving. */
11819 dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
11822 gfc_symbol* i_arg = dummy_args->sym;
11823 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
11824 if (i_rank == my_rank)
11826 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11827 " rank (%d) as '%s'",
11828 list->proc_sym->name, &list->where, my_rank,
11829 i->proc_sym->name);
11835 /* Is this the/a scalar finalizer procedure? */
11836 if (!arg->as || arg->as->rank == 0)
11837 seen_scalar = true;
11839 /* Find the symtree for this procedure. */
11840 gcc_assert (!list->proc_tree);
11841 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
11843 prev_link = &list->next;
11846 /* Remove wrong nodes immediately from the list so we don't risk any
11847 troubles in the future when they might fail later expectations. */
11851 *prev_link = list->next;
11852 gfc_free_finalizer (i);
11855 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11856 were nodes in the list, must have been for arrays. It is surely a good
11857 idea to have a scalar version there if there's something to finalize. */
11858 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
11859 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11860 " defined at %L, suggest also scalar one",
11861 derived->name, &derived->declared_at);
11863 /* TODO: Remove this error when finalization is finished. */
11864 gfc_error ("Finalization at %L is not yet implemented",
11865 &derived->declared_at);
11867 gfc_find_derived_vtab (derived);
11872 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11875 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
11876 const char* generic_name, locus where)
11878 gfc_symbol *sym1, *sym2;
11879 const char *pass1, *pass2;
11881 gcc_assert (t1->specific && t2->specific);
11882 gcc_assert (!t1->specific->is_generic);
11883 gcc_assert (!t2->specific->is_generic);
11884 gcc_assert (t1->is_operator == t2->is_operator);
11886 sym1 = t1->specific->u.specific->n.sym;
11887 sym2 = t2->specific->u.specific->n.sym;
11892 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11893 if (sym1->attr.subroutine != sym2->attr.subroutine
11894 || sym1->attr.function != sym2->attr.function)
11896 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11897 " GENERIC '%s' at %L",
11898 sym1->name, sym2->name, generic_name, &where);
11902 /* Compare the interfaces. */
11903 if (t1->specific->nopass)
11905 else if (t1->specific->pass_arg)
11906 pass1 = t1->specific->pass_arg;
11908 pass1 = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym)->sym->name;
11909 if (t2->specific->nopass)
11911 else if (t2->specific->pass_arg)
11912 pass2 = t2->specific->pass_arg;
11914 pass2 = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym)->sym->name;
11915 if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
11916 NULL, 0, pass1, pass2))
11918 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11919 sym1->name, sym2->name, generic_name, &where);
11927 /* Worker function for resolving a generic procedure binding; this is used to
11928 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11930 The difference between those cases is finding possible inherited bindings
11931 that are overridden, as one has to look for them in tb_sym_root,
11932 tb_uop_root or tb_op, respectively. Thus the caller must already find
11933 the super-type and set p->overridden correctly. */
11936 resolve_tb_generic_targets (gfc_symbol* super_type,
11937 gfc_typebound_proc* p, const char* name)
11939 gfc_tbp_generic* target;
11940 gfc_symtree* first_target;
11941 gfc_symtree* inherited;
11943 gcc_assert (p && p->is_generic);
11945 /* Try to find the specific bindings for the symtrees in our target-list. */
11946 gcc_assert (p->u.generic);
11947 for (target = p->u.generic; target; target = target->next)
11948 if (!target->specific)
11950 gfc_typebound_proc* overridden_tbp;
11951 gfc_tbp_generic* g;
11952 const char* target_name;
11954 target_name = target->specific_st->name;
11956 /* Defined for this type directly. */
11957 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
11959 target->specific = target->specific_st->n.tb;
11960 goto specific_found;
11963 /* Look for an inherited specific binding. */
11966 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11971 gcc_assert (inherited->n.tb);
11972 target->specific = inherited->n.tb;
11973 goto specific_found;
11977 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11978 " at %L", target_name, name, &p->where);
11981 /* Once we've found the specific binding, check it is not ambiguous with
11982 other specifics already found or inherited for the same GENERIC. */
11984 gcc_assert (target->specific);
11986 /* This must really be a specific binding! */
11987 if (target->specific->is_generic)
11989 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11990 " '%s' is GENERIC, too", name, &p->where, target_name);
11994 /* Check those already resolved on this type directly. */
11995 for (g = p->u.generic; g; g = g->next)
11996 if (g != target && g->specific
11997 && check_generic_tbp_ambiguity (target, g, name, p->where)
12001 /* Check for ambiguity with inherited specific targets. */
12002 for (overridden_tbp = p->overridden; overridden_tbp;
12003 overridden_tbp = overridden_tbp->overridden)
12004 if (overridden_tbp->is_generic)
12006 for (g = overridden_tbp->u.generic; g; g = g->next)
12008 gcc_assert (g->specific);
12009 if (check_generic_tbp_ambiguity (target, g,
12010 name, p->where) == FAILURE)
12016 /* If we attempt to "overwrite" a specific binding, this is an error. */
12017 if (p->overridden && !p->overridden->is_generic)
12019 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
12020 " the same name", name, &p->where);
12024 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
12025 all must have the same attributes here. */
12026 first_target = p->u.generic->specific->u.specific;
12027 gcc_assert (first_target);
12028 p->subroutine = first_target->n.sym->attr.subroutine;
12029 p->function = first_target->n.sym->attr.function;
12035 /* Resolve a GENERIC procedure binding for a derived type. */
12038 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
12040 gfc_symbol* super_type;
12042 /* Find the overridden binding if any. */
12043 st->n.tb->overridden = NULL;
12044 super_type = gfc_get_derived_super_type (derived);
12047 gfc_symtree* overridden;
12048 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
12051 if (overridden && overridden->n.tb)
12052 st->n.tb->overridden = overridden->n.tb;
12055 /* Resolve using worker function. */
12056 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
12060 /* Retrieve the target-procedure of an operator binding and do some checks in
12061 common for intrinsic and user-defined type-bound operators. */
12064 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
12066 gfc_symbol* target_proc;
12068 gcc_assert (target->specific && !target->specific->is_generic);
12069 target_proc = target->specific->u.specific->n.sym;
12070 gcc_assert (target_proc);
12072 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12073 if (target->specific->nopass)
12075 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
12079 return target_proc;
12083 /* Resolve a type-bound intrinsic operator. */
12086 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
12087 gfc_typebound_proc* p)
12089 gfc_symbol* super_type;
12090 gfc_tbp_generic* target;
12092 /* If there's already an error here, do nothing (but don't fail again). */
12096 /* Operators should always be GENERIC bindings. */
12097 gcc_assert (p->is_generic);
12099 /* Look for an overridden binding. */
12100 super_type = gfc_get_derived_super_type (derived);
12101 if (super_type && super_type->f2k_derived)
12102 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
12105 p->overridden = NULL;
12107 /* Resolve general GENERIC properties using worker function. */
12108 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
12111 /* Check the targets to be procedures of correct interface. */
12112 for (target = p->u.generic; target; target = target->next)
12114 gfc_symbol* target_proc;
12116 target_proc = get_checked_tb_operator_target (target, p->where);
12120 if (!gfc_check_operator_interface (target_proc, op, p->where))
12123 /* Add target to non-typebound operator list. */
12124 if (!target->specific->deferred && !derived->attr.use_assoc
12125 && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
12127 gfc_interface *head, *intr;
12128 if (gfc_check_new_interface (derived->ns->op[op], target_proc,
12129 p->where) == FAILURE)
12131 head = derived->ns->op[op];
12132 intr = gfc_get_interface ();
12133 intr->sym = target_proc;
12134 intr->where = p->where;
12136 derived->ns->op[op] = intr;
12148 /* Resolve a type-bound user operator (tree-walker callback). */
12150 static gfc_symbol* resolve_bindings_derived;
12151 static gfc_try resolve_bindings_result;
12153 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
12156 resolve_typebound_user_op (gfc_symtree* stree)
12158 gfc_symbol* super_type;
12159 gfc_tbp_generic* target;
12161 gcc_assert (stree && stree->n.tb);
12163 if (stree->n.tb->error)
12166 /* Operators should always be GENERIC bindings. */
12167 gcc_assert (stree->n.tb->is_generic);
12169 /* Find overridden procedure, if any. */
12170 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
12171 if (super_type && super_type->f2k_derived)
12173 gfc_symtree* overridden;
12174 overridden = gfc_find_typebound_user_op (super_type, NULL,
12175 stree->name, true, NULL);
12177 if (overridden && overridden->n.tb)
12178 stree->n.tb->overridden = overridden->n.tb;
12181 stree->n.tb->overridden = NULL;
12183 /* Resolve basically using worker function. */
12184 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
12188 /* Check the targets to be functions of correct interface. */
12189 for (target = stree->n.tb->u.generic; target; target = target->next)
12191 gfc_symbol* target_proc;
12193 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
12197 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
12204 resolve_bindings_result = FAILURE;
12205 stree->n.tb->error = 1;
12209 /* Resolve the type-bound procedures for a derived type. */
12212 resolve_typebound_procedure (gfc_symtree* stree)
12216 gfc_symbol* me_arg;
12217 gfc_symbol* super_type;
12218 gfc_component* comp;
12220 gcc_assert (stree);
12222 /* Undefined specific symbol from GENERIC target definition. */
12226 if (stree->n.tb->error)
12229 /* If this is a GENERIC binding, use that routine. */
12230 if (stree->n.tb->is_generic)
12232 if (resolve_typebound_generic (resolve_bindings_derived, stree)
12238 /* Get the target-procedure to check it. */
12239 gcc_assert (!stree->n.tb->is_generic);
12240 gcc_assert (stree->n.tb->u.specific);
12241 proc = stree->n.tb->u.specific->n.sym;
12242 where = stree->n.tb->where;
12244 /* Default access should already be resolved from the parser. */
12245 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
12247 if (stree->n.tb->deferred)
12249 if (check_proc_interface (proc, &where) == FAILURE)
12254 /* Check for F08:C465. */
12255 if ((!proc->attr.subroutine && !proc->attr.function)
12256 || (proc->attr.proc != PROC_MODULE
12257 && proc->attr.if_source != IFSRC_IFBODY)
12258 || proc->attr.abstract)
12260 gfc_error ("'%s' must be a module procedure or an external procedure with"
12261 " an explicit interface at %L", proc->name, &where);
12266 stree->n.tb->subroutine = proc->attr.subroutine;
12267 stree->n.tb->function = proc->attr.function;
12269 /* Find the super-type of the current derived type. We could do this once and
12270 store in a global if speed is needed, but as long as not I believe this is
12271 more readable and clearer. */
12272 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
12274 /* If PASS, resolve and check arguments if not already resolved / loaded
12275 from a .mod file. */
12276 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
12278 gfc_formal_arglist *dummy_args;
12280 dummy_args = gfc_sym_get_dummy_args (proc);
12281 if (stree->n.tb->pass_arg)
12283 gfc_formal_arglist *i;
12285 /* If an explicit passing argument name is given, walk the arg-list
12286 and look for it. */
12289 stree->n.tb->pass_arg_num = 1;
12290 for (i = dummy_args; i; i = i->next)
12292 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
12297 ++stree->n.tb->pass_arg_num;
12302 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
12304 proc->name, stree->n.tb->pass_arg, &where,
12305 stree->n.tb->pass_arg);
12311 /* Otherwise, take the first one; there should in fact be at least
12313 stree->n.tb->pass_arg_num = 1;
12316 gfc_error ("Procedure '%s' with PASS at %L must have at"
12317 " least one argument", proc->name, &where);
12320 me_arg = dummy_args->sym;
12323 /* Now check that the argument-type matches and the passed-object
12324 dummy argument is generally fine. */
12326 gcc_assert (me_arg);
12328 if (me_arg->ts.type != BT_CLASS)
12330 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12331 " at %L", proc->name, &where);
12335 if (CLASS_DATA (me_arg)->ts.u.derived
12336 != resolve_bindings_derived)
12338 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12339 " the derived-type '%s'", me_arg->name, proc->name,
12340 me_arg->name, &where, resolve_bindings_derived->name);
12344 gcc_assert (me_arg->ts.type == BT_CLASS);
12345 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
12347 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
12348 " scalar", proc->name, &where);
12351 if (CLASS_DATA (me_arg)->attr.allocatable)
12353 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
12354 " be ALLOCATABLE", proc->name, &where);
12357 if (CLASS_DATA (me_arg)->attr.class_pointer)
12359 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
12360 " be POINTER", proc->name, &where);
12365 /* If we are extending some type, check that we don't override a procedure
12366 flagged NON_OVERRIDABLE. */
12367 stree->n.tb->overridden = NULL;
12370 gfc_symtree* overridden;
12371 overridden = gfc_find_typebound_proc (super_type, NULL,
12372 stree->name, true, NULL);
12376 if (overridden->n.tb)
12377 stree->n.tb->overridden = overridden->n.tb;
12379 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
12384 /* See if there's a name collision with a component directly in this type. */
12385 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
12386 if (!strcmp (comp->name, stree->name))
12388 gfc_error ("Procedure '%s' at %L has the same name as a component of"
12390 stree->name, &where, resolve_bindings_derived->name);
12394 /* Try to find a name collision with an inherited component. */
12395 if (super_type && gfc_find_component (super_type, stree->name, true, true))
12397 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
12398 " component of '%s'",
12399 stree->name, &where, resolve_bindings_derived->name);
12403 stree->n.tb->error = 0;
12407 resolve_bindings_result = FAILURE;
12408 stree->n.tb->error = 1;
12413 resolve_typebound_procedures (gfc_symbol* derived)
12416 gfc_symbol* super_type;
12418 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
12421 super_type = gfc_get_derived_super_type (derived);
12423 resolve_symbol (super_type);
12425 resolve_bindings_derived = derived;
12426 resolve_bindings_result = SUCCESS;
12428 /* Make sure the vtab has been generated. */
12429 gfc_find_derived_vtab (derived);
12431 if (derived->f2k_derived->tb_sym_root)
12432 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
12433 &resolve_typebound_procedure);
12435 if (derived->f2k_derived->tb_uop_root)
12436 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
12437 &resolve_typebound_user_op);
12439 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
12441 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
12442 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
12444 resolve_bindings_result = FAILURE;
12447 return resolve_bindings_result;
12451 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12452 to give all identical derived types the same backend_decl. */
12454 add_dt_to_dt_list (gfc_symbol *derived)
12456 gfc_dt_list *dt_list;
12458 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
12459 if (derived == dt_list->derived)
12462 dt_list = gfc_get_dt_list ();
12463 dt_list->next = gfc_derived_types;
12464 dt_list->derived = derived;
12465 gfc_derived_types = dt_list;
12469 /* Ensure that a derived-type is really not abstract, meaning that every
12470 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12473 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
12478 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
12480 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
12483 if (st->n.tb && st->n.tb->deferred)
12485 gfc_symtree* overriding;
12486 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
12489 gcc_assert (overriding->n.tb);
12490 if (overriding->n.tb->deferred)
12492 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
12493 " '%s' is DEFERRED and not overridden",
12494 sub->name, &sub->declared_at, st->name);
12503 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
12505 /* The algorithm used here is to recursively travel up the ancestry of sub
12506 and for each ancestor-type, check all bindings. If any of them is
12507 DEFERRED, look it up starting from sub and see if the found (overriding)
12508 binding is not DEFERRED.
12509 This is not the most efficient way to do this, but it should be ok and is
12510 clearer than something sophisticated. */
12512 gcc_assert (ancestor && !sub->attr.abstract);
12514 if (!ancestor->attr.abstract)
12517 /* Walk bindings of this ancestor. */
12518 if (ancestor->f2k_derived)
12521 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
12526 /* Find next ancestor type and recurse on it. */
12527 ancestor = gfc_get_derived_super_type (ancestor);
12529 return ensure_not_abstract (sub, ancestor);
12535 /* This check for typebound defined assignments is done recursively
12536 since the order in which derived types are resolved is not always in
12537 order of the declarations. */
12540 check_defined_assignments (gfc_symbol *derived)
12544 for (c = derived->components; c; c = c->next)
12546 if (c->ts.type != BT_DERIVED
12548 || c->attr.allocatable
12549 || c->attr.proc_pointer_comp
12550 || c->attr.class_pointer
12551 || c->attr.proc_pointer)
12554 if (c->ts.u.derived->attr.defined_assign_comp
12555 || (c->ts.u.derived->f2k_derived
12556 && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
12558 derived->attr.defined_assign_comp = 1;
12562 check_defined_assignments (c->ts.u.derived);
12563 if (c->ts.u.derived->attr.defined_assign_comp)
12565 derived->attr.defined_assign_comp = 1;
12572 /* Resolve the components of a derived type. This does not have to wait until
12573 resolution stage, but can be done as soon as the dt declaration has been
12577 resolve_fl_derived0 (gfc_symbol *sym)
12579 gfc_symbol* super_type;
12582 if (sym->attr.unlimited_polymorphic)
12585 super_type = gfc_get_derived_super_type (sym);
12588 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
12590 gfc_error ("As extending type '%s' at %L has a coarray component, "
12591 "parent type '%s' shall also have one", sym->name,
12592 &sym->declared_at, super_type->name);
12596 /* Ensure the extended type gets resolved before we do. */
12597 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
12600 /* An ABSTRACT type must be extensible. */
12601 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
12603 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
12604 sym->name, &sym->declared_at);
12608 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
12611 for ( ; c != NULL; c = c->next)
12613 if (c->attr.artificial)
12616 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
12617 if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function)
12619 gfc_error ("Deferred-length character component '%s' at %L is not "
12620 "yet supported", c->name, &c->loc);
12625 if ((!sym->attr.is_class || c != sym->components)
12626 && c->attr.codimension
12627 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
12629 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12630 "deferred shape", c->name, &c->loc);
12635 if (c->attr.codimension && c->ts.type == BT_DERIVED
12636 && c->ts.u.derived->ts.is_iso_c)
12638 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12639 "shall not be a coarray", c->name, &c->loc);
12644 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
12645 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
12646 || c->attr.allocatable))
12648 gfc_error ("Component '%s' at %L with coarray component "
12649 "shall be a nonpointer, nonallocatable scalar",
12655 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
12657 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12658 "is not an array pointer", c->name, &c->loc);
12662 if (c->attr.proc_pointer && c->ts.interface)
12664 gfc_symbol *ifc = c->ts.interface;
12666 if (!sym->attr.vtype
12667 && check_proc_interface (ifc, &c->loc) == FAILURE)
12670 if (ifc->attr.if_source || ifc->attr.intrinsic)
12672 /* Resolve interface and copy attributes. */
12673 if (ifc->formal && !ifc->formal_ns)
12674 resolve_symbol (ifc);
12675 if (ifc->attr.intrinsic)
12676 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
12680 c->ts = ifc->result->ts;
12681 c->attr.allocatable = ifc->result->attr.allocatable;
12682 c->attr.pointer = ifc->result->attr.pointer;
12683 c->attr.dimension = ifc->result->attr.dimension;
12684 c->as = gfc_copy_array_spec (ifc->result->as);
12685 c->attr.class_ok = ifc->result->attr.class_ok;
12690 c->attr.allocatable = ifc->attr.allocatable;
12691 c->attr.pointer = ifc->attr.pointer;
12692 c->attr.dimension = ifc->attr.dimension;
12693 c->as = gfc_copy_array_spec (ifc->as);
12694 c->attr.class_ok = ifc->attr.class_ok;
12696 c->ts.interface = ifc;
12697 c->attr.function = ifc->attr.function;
12698 c->attr.subroutine = ifc->attr.subroutine;
12700 c->attr.pure = ifc->attr.pure;
12701 c->attr.elemental = ifc->attr.elemental;
12702 c->attr.recursive = ifc->attr.recursive;
12703 c->attr.always_explicit = ifc->attr.always_explicit;
12704 c->attr.ext_attr |= ifc->attr.ext_attr;
12705 /* Copy char length. */
12706 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
12708 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
12709 if (cl->length && !cl->resolved
12710 && gfc_resolve_expr (cl->length) == FAILURE)
12716 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
12718 /* Since PPCs are not implicitly typed, a PPC without an explicit
12719 interface must be a subroutine. */
12720 gfc_add_subroutine (&c->attr, c->name, &c->loc);
12723 /* Procedure pointer components: Check PASS arg. */
12724 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
12725 && !sym->attr.vtype)
12727 gfc_symbol* me_arg;
12729 if (c->tb->pass_arg)
12731 gfc_formal_arglist* i;
12733 /* If an explicit passing argument name is given, walk the arg-list
12734 and look for it. */
12737 c->tb->pass_arg_num = 1;
12738 for (i = c->ts.interface->formal; i; i = i->next)
12740 if (!strcmp (i->sym->name, c->tb->pass_arg))
12745 c->tb->pass_arg_num++;
12750 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12751 "at %L has no argument '%s'", c->name,
12752 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
12759 /* Otherwise, take the first one; there should in fact be at least
12761 c->tb->pass_arg_num = 1;
12762 if (!c->ts.interface->formal)
12764 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12765 "must have at least one argument",
12770 me_arg = c->ts.interface->formal->sym;
12773 /* Now check that the argument-type matches. */
12774 gcc_assert (me_arg);
12775 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
12776 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
12777 || (me_arg->ts.type == BT_CLASS
12778 && CLASS_DATA (me_arg)->ts.u.derived != sym))
12780 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12781 " the derived type '%s'", me_arg->name, c->name,
12782 me_arg->name, &c->loc, sym->name);
12787 /* Check for C453. */
12788 if (me_arg->attr.dimension)
12790 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12791 "must be scalar", me_arg->name, c->name, me_arg->name,
12797 if (me_arg->attr.pointer)
12799 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12800 "may not have the POINTER attribute", me_arg->name,
12801 c->name, me_arg->name, &c->loc);
12806 if (me_arg->attr.allocatable)
12808 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12809 "may not be ALLOCATABLE", me_arg->name, c->name,
12810 me_arg->name, &c->loc);
12815 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
12816 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12817 " at %L", c->name, &c->loc);
12821 /* Check type-spec if this is not the parent-type component. */
12822 if (((sym->attr.is_class
12823 && (!sym->components->ts.u.derived->attr.extension
12824 || c != sym->components->ts.u.derived->components))
12825 || (!sym->attr.is_class
12826 && (!sym->attr.extension || c != sym->components)))
12827 && !sym->attr.vtype
12828 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
12831 /* If this type is an extension, set the accessibility of the parent
12834 && ((sym->attr.is_class
12835 && c == sym->components->ts.u.derived->components)
12836 || (!sym->attr.is_class && c == sym->components))
12837 && strcmp (super_type->name, c->name) == 0)
12838 c->attr.access = super_type->attr.access;
12840 /* If this type is an extension, see if this component has the same name
12841 as an inherited type-bound procedure. */
12842 if (super_type && !sym->attr.is_class
12843 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
12845 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12846 " inherited type-bound procedure",
12847 c->name, sym->name, &c->loc);
12851 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
12852 && !c->ts.deferred)
12854 if (c->ts.u.cl->length == NULL
12855 || (resolve_charlen (c->ts.u.cl) == FAILURE)
12856 || !gfc_is_constant_expr (c->ts.u.cl->length))
12858 gfc_error ("Character length of component '%s' needs to "
12859 "be a constant specification expression at %L",
12861 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
12866 if (c->ts.type == BT_CHARACTER && c->ts.deferred
12867 && !c->attr.pointer && !c->attr.allocatable)
12869 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12870 "length must be a POINTER or ALLOCATABLE",
12871 c->name, sym->name, &c->loc);
12875 if (c->ts.type == BT_DERIVED
12876 && sym->component_access != ACCESS_PRIVATE
12877 && gfc_check_symbol_access (sym)
12878 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
12879 && !c->ts.u.derived->attr.use_assoc
12880 && !gfc_check_symbol_access (c->ts.u.derived)
12881 && gfc_notify_std (GFC_STD_F2003, "the component '%s' "
12882 "is a PRIVATE type and cannot be a component of "
12883 "'%s', which is PUBLIC at %L", c->name,
12884 sym->name, &sym->declared_at) == FAILURE)
12887 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
12889 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12890 "type %s", c->name, &c->loc, sym->name);
12894 if (sym->attr.sequence)
12896 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
12898 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12899 "not have the SEQUENCE attribute",
12900 c->ts.u.derived->name, &sym->declared_at);
12905 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
12906 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
12907 else if (c->ts.type == BT_CLASS && c->attr.class_ok
12908 && CLASS_DATA (c)->ts.u.derived->attr.generic)
12909 CLASS_DATA (c)->ts.u.derived
12910 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
12912 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
12913 && c->attr.pointer && c->ts.u.derived->components == NULL
12914 && !c->ts.u.derived->attr.zero_comp)
12916 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12917 "that has not been declared", c->name, sym->name,
12922 if (c->ts.type == BT_CLASS && c->attr.class_ok
12923 && CLASS_DATA (c)->attr.class_pointer
12924 && CLASS_DATA (c)->ts.u.derived->components == NULL
12925 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
12926 && !UNLIMITED_POLY (c))
12928 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12929 "that has not been declared", c->name, sym->name,
12935 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
12936 && (!c->attr.class_ok
12937 || !(CLASS_DATA (c)->attr.class_pointer
12938 || CLASS_DATA (c)->attr.allocatable)))
12940 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12941 "or pointer", c->name, &c->loc);
12942 /* Prevent a recurrence of the error. */
12943 c->ts.type = BT_UNKNOWN;
12947 /* Ensure that all the derived type components are put on the
12948 derived type list; even in formal namespaces, where derived type
12949 pointer components might not have been declared. */
12950 if (c->ts.type == BT_DERIVED
12952 && c->ts.u.derived->components
12954 && sym != c->ts.u.derived)
12955 add_dt_to_dt_list (c->ts.u.derived);
12957 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
12958 || c->attr.proc_pointer
12959 || c->attr.allocatable)) == FAILURE)
12962 if (c->initializer && !sym->attr.vtype
12963 && gfc_check_assign_symbol (sym, c, c->initializer) == FAILURE)
12967 check_defined_assignments (sym);
12969 if (!sym->attr.defined_assign_comp && super_type)
12970 sym->attr.defined_assign_comp
12971 = super_type->attr.defined_assign_comp;
12973 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12974 all DEFERRED bindings are overridden. */
12975 if (super_type && super_type->attr.abstract && !sym->attr.abstract
12976 && !sym->attr.is_class
12977 && ensure_not_abstract (sym, super_type) == FAILURE)
12980 /* Add derived type to the derived type list. */
12981 add_dt_to_dt_list (sym);
12983 /* Check if the type is finalizable. This is done in order to ensure that the
12984 finalization wrapper is generated early enough. */
12985 gfc_is_finalizable (sym, NULL);
12991 /* The following procedure does the full resolution of a derived type,
12992 including resolution of all type-bound procedures (if present). In contrast
12993 to 'resolve_fl_derived0' this can only be done after the module has been
12994 parsed completely. */
12997 resolve_fl_derived (gfc_symbol *sym)
12999 gfc_symbol *gen_dt = NULL;
13001 if (sym->attr.unlimited_polymorphic)
13004 if (!sym->attr.is_class)
13005 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
13006 if (gen_dt && gen_dt->generic && gen_dt->generic->next
13007 && (!gen_dt->generic->sym->attr.use_assoc
13008 || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
13009 && gfc_notify_std (GFC_STD_F2003, "Generic name '%s' of "
13010 "function '%s' at %L being the same name as derived "
13011 "type at %L", sym->name,
13012 gen_dt->generic->sym == sym
13013 ? gen_dt->generic->next->sym->name
13014 : gen_dt->generic->sym->name,
13015 gen_dt->generic->sym == sym
13016 ? &gen_dt->generic->next->sym->declared_at
13017 : &gen_dt->generic->sym->declared_at,
13018 &sym->declared_at) == FAILURE)
13021 /* Resolve the finalizer procedures. */
13022 if (gfc_resolve_finalizers (sym) == FAILURE)
13025 if (sym->attr.is_class && sym->ts.u.derived == NULL)
13027 /* Fix up incomplete CLASS symbols. */
13028 gfc_component *data = gfc_find_component (sym, "_data", true, true);
13029 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
13031 /* Nothing more to do for unlimited polymorphic entities. */
13032 if (data->ts.u.derived->attr.unlimited_polymorphic)
13034 else if (vptr->ts.u.derived == NULL)
13036 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
13038 vptr->ts.u.derived = vtab->ts.u.derived;
13042 if (resolve_fl_derived0 (sym) == FAILURE)
13045 /* Resolve the type-bound procedures. */
13046 if (resolve_typebound_procedures (sym) == FAILURE)
13054 resolve_fl_namelist (gfc_symbol *sym)
13059 for (nl = sym->namelist; nl; nl = nl->next)
13061 /* Check again, the check in match only works if NAMELIST comes
13063 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
13065 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
13066 "allowed", nl->sym->name, sym->name, &sym->declared_at);
13070 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
13071 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array "
13072 "object '%s' with assumed shape in namelist "
13073 "'%s' at %L", nl->sym->name, sym->name,
13074 &sym->declared_at) == FAILURE)
13077 if (is_non_constant_shape_array (nl->sym)
13078 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array "
13079 "object '%s' with nonconstant shape in namelist "
13080 "'%s' at %L", nl->sym->name, sym->name,
13081 &sym->declared_at) == FAILURE)
13084 if (nl->sym->ts.type == BT_CHARACTER
13085 && (nl->sym->ts.u.cl->length == NULL
13086 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
13087 && gfc_notify_std (GFC_STD_F2003, "NAMELIST object "
13088 "'%s' with nonconstant character length in "
13089 "namelist '%s' at %L", nl->sym->name, sym->name,
13090 &sym->declared_at) == FAILURE)
13093 /* FIXME: Once UDDTIO is implemented, the following can be
13095 if (nl->sym->ts.type == BT_CLASS)
13097 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
13098 "polymorphic and requires a defined input/output "
13099 "procedure", nl->sym->name, sym->name, &sym->declared_at);
13103 if (nl->sym->ts.type == BT_DERIVED
13104 && (nl->sym->ts.u.derived->attr.alloc_comp
13105 || nl->sym->ts.u.derived->attr.pointer_comp))
13107 if (gfc_notify_std (GFC_STD_F2003, "NAMELIST object "
13108 "'%s' in namelist '%s' at %L with ALLOCATABLE "
13109 "or POINTER components", nl->sym->name,
13110 sym->name, &sym->declared_at) == FAILURE)
13113 /* FIXME: Once UDDTIO is implemented, the following can be
13115 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
13116 "ALLOCATABLE or POINTER components and thus requires "
13117 "a defined input/output procedure", nl->sym->name,
13118 sym->name, &sym->declared_at);
13123 /* Reject PRIVATE objects in a PUBLIC namelist. */
13124 if (gfc_check_symbol_access (sym))
13126 for (nl = sym->namelist; nl; nl = nl->next)
13128 if (!nl->sym->attr.use_assoc
13129 && !is_sym_host_assoc (nl->sym, sym->ns)
13130 && !gfc_check_symbol_access (nl->sym))
13132 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
13133 "cannot be member of PUBLIC namelist '%s' at %L",
13134 nl->sym->name, sym->name, &sym->declared_at);
13138 /* Types with private components that came here by USE-association. */
13139 if (nl->sym->ts.type == BT_DERIVED
13140 && derived_inaccessible (nl->sym->ts.u.derived))
13142 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
13143 "components and cannot be member of namelist '%s' at %L",
13144 nl->sym->name, sym->name, &sym->declared_at);
13148 /* Types with private components that are defined in the same module. */
13149 if (nl->sym->ts.type == BT_DERIVED
13150 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
13151 && nl->sym->ts.u.derived->attr.private_comp)
13153 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
13154 "cannot be a member of PUBLIC namelist '%s' at %L",
13155 nl->sym->name, sym->name, &sym->declared_at);
13162 /* 14.1.2 A module or internal procedure represent local entities
13163 of the same type as a namelist member and so are not allowed. */
13164 for (nl = sym->namelist; nl; nl = nl->next)
13166 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
13169 if (nl->sym->attr.function && nl->sym == nl->sym->result)
13170 if ((nl->sym == sym->ns->proc_name)
13172 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
13177 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
13178 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
13180 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13181 "attribute in '%s' at %L", nlsym->name,
13182 &sym->declared_at);
13192 resolve_fl_parameter (gfc_symbol *sym)
13194 /* A parameter array's shape needs to be constant. */
13195 if (sym->as != NULL
13196 && (sym->as->type == AS_DEFERRED
13197 || is_non_constant_shape_array (sym)))
13199 gfc_error ("Parameter array '%s' at %L cannot be automatic "
13200 "or of deferred shape", sym->name, &sym->declared_at);
13204 /* Make sure a parameter that has been implicitly typed still
13205 matches the implicit type, since PARAMETER statements can precede
13206 IMPLICIT statements. */
13207 if (sym->attr.implicit_type
13208 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
13211 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
13212 "later IMPLICIT type", sym->name, &sym->declared_at);
13216 /* Make sure the types of derived parameters are consistent. This
13217 type checking is deferred until resolution because the type may
13218 refer to a derived type from the host. */
13219 if (sym->ts.type == BT_DERIVED
13220 && !gfc_compare_types (&sym->ts, &sym->value->ts))
13222 gfc_error ("Incompatible derived type in PARAMETER at %L",
13223 &sym->value->where);
13230 /* Do anything necessary to resolve a symbol. Right now, we just
13231 assume that an otherwise unknown symbol is a variable. This sort
13232 of thing commonly happens for symbols in module. */
13235 resolve_symbol (gfc_symbol *sym)
13237 int check_constant, mp_flag;
13238 gfc_symtree *symtree;
13239 gfc_symtree *this_symtree;
13242 symbol_attribute class_attr;
13243 gfc_array_spec *as;
13244 bool saved_specification_expr;
13250 if (sym->attr.artificial)
13253 if (sym->attr.unlimited_polymorphic)
13256 if (sym->attr.flavor == FL_UNKNOWN
13257 || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
13258 && !sym->attr.generic && !sym->attr.external
13259 && sym->attr.if_source == IFSRC_UNKNOWN))
13262 /* If we find that a flavorless symbol is an interface in one of the
13263 parent namespaces, find its symtree in this namespace, free the
13264 symbol and set the symtree to point to the interface symbol. */
13265 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
13267 symtree = gfc_find_symtree (ns->sym_root, sym->name);
13268 if (symtree && (symtree->n.sym->generic ||
13269 (symtree->n.sym->attr.flavor == FL_PROCEDURE
13270 && sym->ns->construct_entities)))
13272 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
13274 gfc_release_symbol (sym);
13275 symtree->n.sym->refs++;
13276 this_symtree->n.sym = symtree->n.sym;
13281 /* Otherwise give it a flavor according to such attributes as
13283 if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
13284 && sym->attr.intrinsic == 0)
13285 sym->attr.flavor = FL_VARIABLE;
13286 else if (sym->attr.flavor == FL_UNKNOWN)
13288 sym->attr.flavor = FL_PROCEDURE;
13289 if (sym->attr.dimension)
13290 sym->attr.function = 1;
13294 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
13295 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
13297 if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
13298 && resolve_procedure_interface (sym) == FAILURE)
13301 if (sym->attr.is_protected && !sym->attr.proc_pointer
13302 && (sym->attr.procedure || sym->attr.external))
13304 if (sym->attr.external)
13305 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13306 "at %L", &sym->declared_at);
13308 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13309 "at %L", &sym->declared_at);
13314 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
13317 /* Symbols that are module procedures with results (functions) have
13318 the types and array specification copied for type checking in
13319 procedures that call them, as well as for saving to a module
13320 file. These symbols can't stand the scrutiny that their results
13322 mp_flag = (sym->result != NULL && sym->result != sym);
13324 /* Make sure that the intrinsic is consistent with its internal
13325 representation. This needs to be done before assigning a default
13326 type to avoid spurious warnings. */
13327 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
13328 && gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
13331 /* Resolve associate names. */
13333 resolve_assoc_var (sym, true);
13335 /* Assign default type to symbols that need one and don't have one. */
13336 if (sym->ts.type == BT_UNKNOWN)
13338 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
13340 gfc_set_default_type (sym, 1, NULL);
13343 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
13344 && !sym->attr.function && !sym->attr.subroutine
13345 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
13346 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
13348 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
13350 /* The specific case of an external procedure should emit an error
13351 in the case that there is no implicit type. */
13353 gfc_set_default_type (sym, sym->attr.external, NULL);
13356 /* Result may be in another namespace. */
13357 resolve_symbol (sym->result);
13359 if (!sym->result->attr.proc_pointer)
13361 sym->ts = sym->result->ts;
13362 sym->as = gfc_copy_array_spec (sym->result->as);
13363 sym->attr.dimension = sym->result->attr.dimension;
13364 sym->attr.pointer = sym->result->attr.pointer;
13365 sym->attr.allocatable = sym->result->attr.allocatable;
13366 sym->attr.contiguous = sym->result->attr.contiguous;
13371 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
13373 bool saved_specification_expr = specification_expr;
13374 specification_expr = true;
13375 gfc_resolve_array_spec (sym->result->as, false);
13376 specification_expr = saved_specification_expr;
13379 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
13381 as = CLASS_DATA (sym)->as;
13382 class_attr = CLASS_DATA (sym)->attr;
13383 class_attr.pointer = class_attr.class_pointer;
13387 class_attr = sym->attr;
13392 if (sym->attr.contiguous
13393 && (!class_attr.dimension
13394 || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
13395 && !class_attr.pointer)))
13397 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
13398 "array pointer or an assumed-shape or assumed-rank array",
13399 sym->name, &sym->declared_at);
13403 /* Assumed size arrays and assumed shape arrays must be dummy
13404 arguments. Array-spec's of implied-shape should have been resolved to
13405 AS_EXPLICIT already. */
13409 gcc_assert (as->type != AS_IMPLIED_SHAPE);
13410 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
13411 || as->type == AS_ASSUMED_SHAPE)
13412 && !sym->attr.dummy && !sym->attr.select_type_temporary)
13414 if (as->type == AS_ASSUMED_SIZE)
13415 gfc_error ("Assumed size array at %L must be a dummy argument",
13416 &sym->declared_at);
13418 gfc_error ("Assumed shape array at %L must be a dummy argument",
13419 &sym->declared_at);
13422 /* TS 29113, C535a. */
13423 if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
13424 && !sym->attr.select_type_temporary)
13426 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13427 &sym->declared_at);
13430 if (as->type == AS_ASSUMED_RANK
13431 && (sym->attr.codimension || sym->attr.value))
13433 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13434 "CODIMENSION attribute", &sym->declared_at);
13439 /* Make sure symbols with known intent or optional are really dummy
13440 variable. Because of ENTRY statement, this has to be deferred
13441 until resolution time. */
13443 if (!sym->attr.dummy
13444 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
13446 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
13450 if (sym->attr.value && !sym->attr.dummy)
13452 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
13453 "it is not a dummy argument", sym->name, &sym->declared_at);
13457 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
13459 gfc_charlen *cl = sym->ts.u.cl;
13460 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
13462 gfc_error ("Character dummy variable '%s' at %L with VALUE "
13463 "attribute must have constant length",
13464 sym->name, &sym->declared_at);
13468 if (sym->ts.is_c_interop
13469 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
13471 gfc_error ("C interoperable character dummy variable '%s' at %L "
13472 "with VALUE attribute must have length one",
13473 sym->name, &sym->declared_at);
13478 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
13479 && sym->ts.u.derived->attr.generic)
13481 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
13482 if (!sym->ts.u.derived)
13484 gfc_error ("The derived type '%s' at %L is of type '%s', "
13485 "which has not been defined", sym->name,
13486 &sym->declared_at, sym->ts.u.derived->name);
13487 sym->ts.type = BT_UNKNOWN;
13492 if (sym->ts.type == BT_ASSUMED)
13494 /* TS 29113, C407a. */
13495 if (!sym->attr.dummy)
13497 gfc_error ("Assumed type of variable %s at %L is only permitted "
13498 "for dummy variables", sym->name, &sym->declared_at);
13501 if (sym->attr.allocatable || sym->attr.codimension
13502 || sym->attr.pointer || sym->attr.value)
13504 gfc_error ("Assumed-type variable %s at %L may not have the "
13505 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13506 sym->name, &sym->declared_at);
13509 if (sym->attr.intent == INTENT_OUT)
13511 gfc_error ("Assumed-type variable %s at %L may not have the "
13512 "INTENT(OUT) attribute",
13513 sym->name, &sym->declared_at);
13516 if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
13518 gfc_error ("Assumed-type variable %s at %L shall not be an "
13519 "explicit-shape array", sym->name, &sym->declared_at);
13524 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13525 do this for something that was implicitly typed because that is handled
13526 in gfc_set_default_type. Handle dummy arguments and procedure
13527 definitions separately. Also, anything that is use associated is not
13528 handled here but instead is handled in the module it is declared in.
13529 Finally, derived type definitions are allowed to be BIND(C) since that
13530 only implies that they're interoperable, and they are checked fully for
13531 interoperability when a variable is declared of that type. */
13532 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
13533 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
13534 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
13536 gfc_try t = SUCCESS;
13538 /* First, make sure the variable is declared at the
13539 module-level scope (J3/04-007, Section 15.3). */
13540 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
13541 sym->attr.in_common == 0)
13543 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
13544 "is neither a COMMON block nor declared at the "
13545 "module level scope", sym->name, &(sym->declared_at));
13548 else if (sym->common_head != NULL)
13550 t = verify_com_block_vars_c_interop (sym->common_head);
13554 /* If type() declaration, we need to verify that the components
13555 of the given type are all C interoperable, etc. */
13556 if (sym->ts.type == BT_DERIVED &&
13557 sym->ts.u.derived->attr.is_c_interop != 1)
13559 /* Make sure the user marked the derived type as BIND(C). If
13560 not, call the verify routine. This could print an error
13561 for the derived type more than once if multiple variables
13562 of that type are declared. */
13563 if (sym->ts.u.derived->attr.is_bind_c != 1)
13564 verify_bind_c_derived_type (sym->ts.u.derived);
13568 /* Verify the variable itself as C interoperable if it
13569 is BIND(C). It is not possible for this to succeed if
13570 the verify_bind_c_derived_type failed, so don't have to handle
13571 any error returned by verify_bind_c_derived_type. */
13572 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
13573 sym->common_block);
13578 /* clear the is_bind_c flag to prevent reporting errors more than
13579 once if something failed. */
13580 sym->attr.is_bind_c = 0;
13585 /* If a derived type symbol has reached this point, without its
13586 type being declared, we have an error. Notice that most
13587 conditions that produce undefined derived types have already
13588 been dealt with. However, the likes of:
13589 implicit type(t) (t) ..... call foo (t) will get us here if
13590 the type is not declared in the scope of the implicit
13591 statement. Change the type to BT_UNKNOWN, both because it is so
13592 and to prevent an ICE. */
13593 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
13594 && sym->ts.u.derived->components == NULL
13595 && !sym->ts.u.derived->attr.zero_comp)
13597 gfc_error ("The derived type '%s' at %L is of type '%s', "
13598 "which has not been defined", sym->name,
13599 &sym->declared_at, sym->ts.u.derived->name);
13600 sym->ts.type = BT_UNKNOWN;
13604 /* Make sure that the derived type has been resolved and that the
13605 derived type is visible in the symbol's namespace, if it is a
13606 module function and is not PRIVATE. */
13607 if (sym->ts.type == BT_DERIVED
13608 && sym->ts.u.derived->attr.use_assoc
13609 && sym->ns->proc_name
13610 && sym->ns->proc_name->attr.flavor == FL_MODULE
13611 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
13614 /* Unless the derived-type declaration is use associated, Fortran 95
13615 does not allow public entries of private derived types.
13616 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13617 161 in 95-006r3. */
13618 if (sym->ts.type == BT_DERIVED
13619 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
13620 && !sym->ts.u.derived->attr.use_assoc
13621 && gfc_check_symbol_access (sym)
13622 && !gfc_check_symbol_access (sym->ts.u.derived)
13623 && gfc_notify_std (GFC_STD_F2003, "PUBLIC %s '%s' at %L "
13624 "of PRIVATE derived type '%s'",
13625 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
13626 : "variable", sym->name, &sym->declared_at,
13627 sym->ts.u.derived->name) == FAILURE)
13630 /* F2008, C1302. */
13631 if (sym->ts.type == BT_DERIVED
13632 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
13633 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
13634 || sym->ts.u.derived->attr.lock_comp)
13635 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
13637 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13638 "type LOCK_TYPE must be a coarray", sym->name,
13639 &sym->declared_at);
13643 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13644 default initialization is defined (5.1.2.4.4). */
13645 if (sym->ts.type == BT_DERIVED
13647 && sym->attr.intent == INTENT_OUT
13649 && sym->as->type == AS_ASSUMED_SIZE)
13651 for (c = sym->ts.u.derived->components; c; c = c->next)
13653 if (c->initializer)
13655 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13656 "ASSUMED SIZE and so cannot have a default initializer",
13657 sym->name, &sym->declared_at);
13664 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
13665 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
13667 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13668 "INTENT(OUT)", sym->name, &sym->declared_at);
13673 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
13674 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
13675 && CLASS_DATA (sym)->attr.coarray_comp))
13676 || class_attr.codimension)
13677 && (sym->attr.result || sym->result == sym))
13679 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13680 "a coarray component", sym->name, &sym->declared_at);
13685 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
13686 && sym->ts.u.derived->ts.is_iso_c)
13688 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13689 "shall not be a coarray", sym->name, &sym->declared_at);
13694 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
13695 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
13696 && CLASS_DATA (sym)->attr.coarray_comp))
13697 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
13698 || class_attr.allocatable))
13700 gfc_error ("Variable '%s' at %L with coarray component "
13701 "shall be a nonpointer, nonallocatable scalar",
13702 sym->name, &sym->declared_at);
13706 /* F2008, C526. The function-result case was handled above. */
13707 if (class_attr.codimension
13708 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
13709 || sym->attr.select_type_temporary
13710 || sym->ns->save_all
13711 || sym->ns->proc_name->attr.flavor == FL_MODULE
13712 || sym->ns->proc_name->attr.is_main_program
13713 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
13715 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13716 "nor a dummy argument", sym->name, &sym->declared_at);
13720 else if (class_attr.codimension && !sym->attr.select_type_temporary
13721 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
13723 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13724 "deferred shape", sym->name, &sym->declared_at);
13727 else if (class_attr.codimension && class_attr.allocatable && as
13728 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
13730 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13731 "deferred shape", sym->name, &sym->declared_at);
13736 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
13737 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
13738 && CLASS_DATA (sym)->attr.coarray_comp))
13739 || (class_attr.codimension && class_attr.allocatable))
13740 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
13742 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13743 "allocatable coarray or have coarray components",
13744 sym->name, &sym->declared_at);
13748 if (class_attr.codimension && sym->attr.dummy
13749 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
13751 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13752 "procedure '%s'", sym->name, &sym->declared_at,
13753 sym->ns->proc_name->name);
13757 if (sym->ts.type == BT_LOGICAL
13758 && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
13759 || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
13760 && sym->ns->proc_name->attr.is_bind_c)))
13763 for (i = 0; gfc_logical_kinds[i].kind; i++)
13764 if (gfc_logical_kinds[i].kind == sym->ts.kind)
13766 if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
13767 && gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument '%s' at %L "
13768 "with non-C_Bool kind in BIND(C) procedure '%s'",
13769 sym->name, &sym->declared_at,
13770 sym->ns->proc_name->name) == FAILURE)
13772 else if (!gfc_logical_kinds[i].c_bool
13773 && gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable '%s' at"
13774 " %L with non-C_Bool kind in BIND(C) "
13775 "procedure '%s'", sym->name,
13777 sym->attr.function ? sym->name
13778 : sym->ns->proc_name->name)
13783 switch (sym->attr.flavor)
13786 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
13791 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
13796 if (resolve_fl_namelist (sym) == FAILURE)
13801 if (resolve_fl_parameter (sym) == FAILURE)
13809 /* Resolve array specifier. Check as well some constraints
13810 on COMMON blocks. */
13812 check_constant = sym->attr.in_common && !sym->attr.pointer;
13814 /* Set the formal_arg_flag so that check_conflict will not throw
13815 an error for host associated variables in the specification
13816 expression for an array_valued function. */
13817 if (sym->attr.function && sym->as)
13818 formal_arg_flag = 1;
13820 saved_specification_expr = specification_expr;
13821 specification_expr = true;
13822 gfc_resolve_array_spec (sym->as, check_constant);
13823 specification_expr = saved_specification_expr;
13825 formal_arg_flag = 0;
13827 /* Resolve formal namespaces. */
13828 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
13829 && !sym->attr.contained && !sym->attr.intrinsic)
13830 gfc_resolve (sym->formal_ns);
13832 /* Make sure the formal namespace is present. */
13833 if (sym->formal && !sym->formal_ns)
13835 gfc_formal_arglist *formal = sym->formal;
13836 while (formal && !formal->sym)
13837 formal = formal->next;
13841 sym->formal_ns = formal->sym->ns;
13842 if (sym->ns != formal->sym->ns)
13843 sym->formal_ns->refs++;
13847 /* Check threadprivate restrictions. */
13848 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
13849 && (!sym->attr.in_common
13850 && sym->module == NULL
13851 && (sym->ns->proc_name == NULL
13852 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
13853 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
13855 /* If we have come this far we can apply default-initializers, as
13856 described in 14.7.5, to those variables that have not already
13857 been assigned one. */
13858 if (sym->ts.type == BT_DERIVED
13860 && !sym->attr.allocatable
13861 && !sym->attr.alloc_comp)
13863 symbol_attribute *a = &sym->attr;
13865 if ((!a->save && !a->dummy && !a->pointer
13866 && !a->in_common && !a->use_assoc
13867 && (a->referenced || a->result)
13868 && !(a->function && sym != sym->result))
13869 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
13870 apply_default_init (sym);
13873 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
13874 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
13875 && !CLASS_DATA (sym)->attr.class_pointer
13876 && !CLASS_DATA (sym)->attr.allocatable)
13877 apply_default_init (sym);
13879 /* If this symbol has a type-spec, check it. */
13880 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
13881 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
13882 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
13888 /************* Resolve DATA statements *************/
13892 gfc_data_value *vnode;
13898 /* Advance the values structure to point to the next value in the data list. */
13901 next_data_value (void)
13903 while (mpz_cmp_ui (values.left, 0) == 0)
13906 if (values.vnode->next == NULL)
13909 values.vnode = values.vnode->next;
13910 mpz_set (values.left, values.vnode->repeat);
13918 check_data_variable (gfc_data_variable *var, locus *where)
13924 ar_type mark = AR_UNKNOWN;
13926 mpz_t section_index[GFC_MAX_DIMENSIONS];
13932 if (gfc_resolve_expr (var->expr) == FAILURE)
13936 mpz_init_set_si (offset, 0);
13939 if (e->expr_type != EXPR_VARIABLE)
13940 gfc_internal_error ("check_data_variable(): Bad expression");
13942 sym = e->symtree->n.sym;
13944 if (sym->ns->is_block_data && !sym->attr.in_common)
13946 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13947 sym->name, &sym->declared_at);
13950 if (e->ref == NULL && sym->as)
13952 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13953 " declaration", sym->name, where);
13957 has_pointer = sym->attr.pointer;
13959 if (gfc_is_coindexed (e))
13961 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
13966 for (ref = e->ref; ref; ref = ref->next)
13968 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
13972 && ref->type == REF_ARRAY
13973 && ref->u.ar.type != AR_FULL)
13975 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13976 "be a full array", sym->name, where);
13981 if (e->rank == 0 || has_pointer)
13983 mpz_init_set_ui (size, 1);
13990 /* Find the array section reference. */
13991 for (ref = e->ref; ref; ref = ref->next)
13993 if (ref->type != REF_ARRAY)
13995 if (ref->u.ar.type == AR_ELEMENT)
14001 /* Set marks according to the reference pattern. */
14002 switch (ref->u.ar.type)
14010 /* Get the start position of array section. */
14011 gfc_get_section_index (ar, section_index, &offset);
14016 gcc_unreachable ();
14019 if (gfc_array_size (e, &size) == FAILURE)
14021 gfc_error ("Nonconstant array section at %L in DATA statement",
14023 mpz_clear (offset);
14030 while (mpz_cmp_ui (size, 0) > 0)
14032 if (next_data_value () == FAILURE)
14034 gfc_error ("DATA statement at %L has more variables than values",
14040 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
14044 /* If we have more than one element left in the repeat count,
14045 and we have more than one element left in the target variable,
14046 then create a range assignment. */
14047 /* FIXME: Only done for full arrays for now, since array sections
14049 if (mark == AR_FULL && ref && ref->next == NULL
14050 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
14054 if (mpz_cmp (size, values.left) >= 0)
14056 mpz_init_set (range, values.left);
14057 mpz_sub (size, size, values.left);
14058 mpz_set_ui (values.left, 0);
14062 mpz_init_set (range, size);
14063 mpz_sub (values.left, values.left, size);
14064 mpz_set_ui (size, 0);
14067 t = gfc_assign_data_value (var->expr, values.vnode->expr,
14070 mpz_add (offset, offset, range);
14077 /* Assign initial value to symbol. */
14080 mpz_sub_ui (values.left, values.left, 1);
14081 mpz_sub_ui (size, size, 1);
14083 t = gfc_assign_data_value (var->expr, values.vnode->expr,
14088 if (mark == AR_FULL)
14089 mpz_add_ui (offset, offset, 1);
14091 /* Modify the array section indexes and recalculate the offset
14092 for next element. */
14093 else if (mark == AR_SECTION)
14094 gfc_advance_section (section_index, ar, &offset);
14098 if (mark == AR_SECTION)
14100 for (i = 0; i < ar->dimen; i++)
14101 mpz_clear (section_index[i]);
14105 mpz_clear (offset);
14111 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
14113 /* Iterate over a list of elements in a DATA statement. */
14116 traverse_data_list (gfc_data_variable *var, locus *where)
14119 iterator_stack frame;
14120 gfc_expr *e, *start, *end, *step;
14121 gfc_try retval = SUCCESS;
14123 mpz_init (frame.value);
14126 start = gfc_copy_expr (var->iter.start);
14127 end = gfc_copy_expr (var->iter.end);
14128 step = gfc_copy_expr (var->iter.step);
14130 if (gfc_simplify_expr (start, 1) == FAILURE
14131 || start->expr_type != EXPR_CONSTANT)
14133 gfc_error ("start of implied-do loop at %L could not be "
14134 "simplified to a constant value", &start->where);
14138 if (gfc_simplify_expr (end, 1) == FAILURE
14139 || end->expr_type != EXPR_CONSTANT)
14141 gfc_error ("end of implied-do loop at %L could not be "
14142 "simplified to a constant value", &start->where);
14146 if (gfc_simplify_expr (step, 1) == FAILURE
14147 || step->expr_type != EXPR_CONSTANT)
14149 gfc_error ("step of implied-do loop at %L could not be "
14150 "simplified to a constant value", &start->where);
14155 mpz_set (trip, end->value.integer);
14156 mpz_sub (trip, trip, start->value.integer);
14157 mpz_add (trip, trip, step->value.integer);
14159 mpz_div (trip, trip, step->value.integer);
14161 mpz_set (frame.value, start->value.integer);
14163 frame.prev = iter_stack;
14164 frame.variable = var->iter.var->symtree;
14165 iter_stack = &frame;
14167 while (mpz_cmp_ui (trip, 0) > 0)
14169 if (traverse_data_var (var->list, where) == FAILURE)
14175 e = gfc_copy_expr (var->expr);
14176 if (gfc_simplify_expr (e, 1) == FAILURE)
14183 mpz_add (frame.value, frame.value, step->value.integer);
14185 mpz_sub_ui (trip, trip, 1);
14189 mpz_clear (frame.value);
14192 gfc_free_expr (start);
14193 gfc_free_expr (end);
14194 gfc_free_expr (step);
14196 iter_stack = frame.prev;
14201 /* Type resolve variables in the variable list of a DATA statement. */
14204 traverse_data_var (gfc_data_variable *var, locus *where)
14208 for (; var; var = var->next)
14210 if (var->expr == NULL)
14211 t = traverse_data_list (var, where);
14213 t = check_data_variable (var, where);
14223 /* Resolve the expressions and iterators associated with a data statement.
14224 This is separate from the assignment checking because data lists should
14225 only be resolved once. */
14228 resolve_data_variables (gfc_data_variable *d)
14230 for (; d; d = d->next)
14232 if (d->list == NULL)
14234 if (gfc_resolve_expr (d->expr) == FAILURE)
14239 if (gfc_resolve_iterator (&d->iter, false, true) == FAILURE)
14242 if (resolve_data_variables (d->list) == FAILURE)
14251 /* Resolve a single DATA statement. We implement this by storing a pointer to
14252 the value list into static variables, and then recursively traversing the
14253 variables list, expanding iterators and such. */
14256 resolve_data (gfc_data *d)
14259 if (resolve_data_variables (d->var) == FAILURE)
14262 values.vnode = d->value;
14263 if (d->value == NULL)
14264 mpz_set_ui (values.left, 0);
14266 mpz_set (values.left, d->value->repeat);
14268 if (traverse_data_var (d->var, &d->where) == FAILURE)
14271 /* At this point, we better not have any values left. */
14273 if (next_data_value () == SUCCESS)
14274 gfc_error ("DATA statement at %L has more values than variables",
14279 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14280 accessed by host or use association, is a dummy argument to a pure function,
14281 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14282 is storage associated with any such variable, shall not be used in the
14283 following contexts: (clients of this function). */
14285 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14286 procedure. Returns zero if assignment is OK, nonzero if there is a
14289 gfc_impure_variable (gfc_symbol *sym)
14294 if (sym->attr.use_assoc || sym->attr.in_common)
14297 /* Check if the symbol's ns is inside the pure procedure. */
14298 for (ns = gfc_current_ns; ns; ns = ns->parent)
14302 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
14306 proc = sym->ns->proc_name;
14307 if (sym->attr.dummy
14308 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
14309 || proc->attr.function))
14312 /* TODO: Sort out what can be storage associated, if anything, and include
14313 it here. In principle equivalences should be scanned but it does not
14314 seem to be possible to storage associate an impure variable this way. */
14319 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14320 current namespace is inside a pure procedure. */
14323 gfc_pure (gfc_symbol *sym)
14325 symbol_attribute attr;
14330 /* Check if the current namespace or one of its parents
14331 belongs to a pure procedure. */
14332 for (ns = gfc_current_ns; ns; ns = ns->parent)
14334 sym = ns->proc_name;
14338 if (attr.flavor == FL_PROCEDURE && attr.pure)
14346 return attr.flavor == FL_PROCEDURE && attr.pure;
14350 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14351 checks if the current namespace is implicitly pure. Note that this
14352 function returns false for a PURE procedure. */
14355 gfc_implicit_pure (gfc_symbol *sym)
14361 /* Check if the current procedure is implicit_pure. Walk up
14362 the procedure list until we find a procedure. */
14363 for (ns = gfc_current_ns; ns; ns = ns->parent)
14365 sym = ns->proc_name;
14369 if (sym->attr.flavor == FL_PROCEDURE)
14374 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
14375 && !sym->attr.pure;
14379 /* Test whether the current procedure is elemental or not. */
14382 gfc_elemental (gfc_symbol *sym)
14384 symbol_attribute attr;
14387 sym = gfc_current_ns->proc_name;
14392 return attr.flavor == FL_PROCEDURE && attr.elemental;
14396 /* Warn about unused labels. */
14399 warn_unused_fortran_label (gfc_st_label *label)
14404 warn_unused_fortran_label (label->left);
14406 if (label->defined == ST_LABEL_UNKNOWN)
14409 switch (label->referenced)
14411 case ST_LABEL_UNKNOWN:
14412 gfc_warning ("Label %d at %L defined but not used", label->value,
14416 case ST_LABEL_BAD_TARGET:
14417 gfc_warning ("Label %d at %L defined but cannot be used",
14418 label->value, &label->where);
14425 warn_unused_fortran_label (label->right);
14429 /* Returns the sequence type of a symbol or sequence. */
14432 sequence_type (gfc_typespec ts)
14441 if (ts.u.derived->components == NULL)
14442 return SEQ_NONDEFAULT;
14444 result = sequence_type (ts.u.derived->components->ts);
14445 for (c = ts.u.derived->components->next; c; c = c->next)
14446 if (sequence_type (c->ts) != result)
14452 if (ts.kind != gfc_default_character_kind)
14453 return SEQ_NONDEFAULT;
14455 return SEQ_CHARACTER;
14458 if (ts.kind != gfc_default_integer_kind)
14459 return SEQ_NONDEFAULT;
14461 return SEQ_NUMERIC;
14464 if (!(ts.kind == gfc_default_real_kind
14465 || ts.kind == gfc_default_double_kind))
14466 return SEQ_NONDEFAULT;
14468 return SEQ_NUMERIC;
14471 if (ts.kind != gfc_default_complex_kind)
14472 return SEQ_NONDEFAULT;
14474 return SEQ_NUMERIC;
14477 if (ts.kind != gfc_default_logical_kind)
14478 return SEQ_NONDEFAULT;
14480 return SEQ_NUMERIC;
14483 return SEQ_NONDEFAULT;
14488 /* Resolve derived type EQUIVALENCE object. */
14491 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
14493 gfc_component *c = derived->components;
14498 /* Shall not be an object of nonsequence derived type. */
14499 if (!derived->attr.sequence)
14501 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
14502 "attribute to be an EQUIVALENCE object", sym->name,
14507 /* Shall not have allocatable components. */
14508 if (derived->attr.alloc_comp)
14510 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
14511 "components to be an EQUIVALENCE object",sym->name,
14516 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
14518 gfc_error ("Derived type variable '%s' at %L with default "
14519 "initialization cannot be in EQUIVALENCE with a variable "
14520 "in COMMON", sym->name, &e->where);
14524 for (; c ; c = c->next)
14526 if (c->ts.type == BT_DERIVED
14527 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
14530 /* Shall not be an object of sequence derived type containing a pointer
14531 in the structure. */
14532 if (c->attr.pointer)
14534 gfc_error ("Derived type variable '%s' at %L with pointer "
14535 "component(s) cannot be an EQUIVALENCE object",
14536 sym->name, &e->where);
14544 /* Resolve equivalence object.
14545 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14546 an allocatable array, an object of nonsequence derived type, an object of
14547 sequence derived type containing a pointer at any level of component
14548 selection, an automatic object, a function name, an entry name, a result
14549 name, a named constant, a structure component, or a subobject of any of
14550 the preceding objects. A substring shall not have length zero. A
14551 derived type shall not have components with default initialization nor
14552 shall two objects of an equivalence group be initialized.
14553 Either all or none of the objects shall have an protected attribute.
14554 The simple constraints are done in symbol.c(check_conflict) and the rest
14555 are implemented here. */
14558 resolve_equivalence (gfc_equiv *eq)
14561 gfc_symbol *first_sym;
14564 locus *last_where = NULL;
14565 seq_type eq_type, last_eq_type;
14566 gfc_typespec *last_ts;
14567 int object, cnt_protected;
14570 last_ts = &eq->expr->symtree->n.sym->ts;
14572 first_sym = eq->expr->symtree->n.sym;
14576 for (object = 1; eq; eq = eq->eq, object++)
14580 e->ts = e->symtree->n.sym->ts;
14581 /* match_varspec might not know yet if it is seeing
14582 array reference or substring reference, as it doesn't
14584 if (e->ref && e->ref->type == REF_ARRAY)
14586 gfc_ref *ref = e->ref;
14587 sym = e->symtree->n.sym;
14589 if (sym->attr.dimension)
14591 ref->u.ar.as = sym->as;
14595 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14596 if (e->ts.type == BT_CHARACTER
14598 && ref->type == REF_ARRAY
14599 && ref->u.ar.dimen == 1
14600 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
14601 && ref->u.ar.stride[0] == NULL)
14603 gfc_expr *start = ref->u.ar.start[0];
14604 gfc_expr *end = ref->u.ar.end[0];
14607 /* Optimize away the (:) reference. */
14608 if (start == NULL && end == NULL)
14611 e->ref = ref->next;
14613 e->ref->next = ref->next;
14618 ref->type = REF_SUBSTRING;
14620 start = gfc_get_int_expr (gfc_default_integer_kind,
14622 ref->u.ss.start = start;
14623 if (end == NULL && e->ts.u.cl)
14624 end = gfc_copy_expr (e->ts.u.cl->length);
14625 ref->u.ss.end = end;
14626 ref->u.ss.length = e->ts.u.cl;
14633 /* Any further ref is an error. */
14636 gcc_assert (ref->type == REF_ARRAY);
14637 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14643 if (gfc_resolve_expr (e) == FAILURE)
14646 sym = e->symtree->n.sym;
14648 if (sym->attr.is_protected)
14650 if (cnt_protected > 0 && cnt_protected != object)
14652 gfc_error ("Either all or none of the objects in the "
14653 "EQUIVALENCE set at %L shall have the "
14654 "PROTECTED attribute",
14659 /* Shall not equivalence common block variables in a PURE procedure. */
14660 if (sym->ns->proc_name
14661 && sym->ns->proc_name->attr.pure
14662 && sym->attr.in_common)
14664 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14665 "object in the pure procedure '%s'",
14666 sym->name, &e->where, sym->ns->proc_name->name);
14670 /* Shall not be a named constant. */
14671 if (e->expr_type == EXPR_CONSTANT)
14673 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14674 "object", sym->name, &e->where);
14678 if (e->ts.type == BT_DERIVED
14679 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
14682 /* Check that the types correspond correctly:
14684 A numeric sequence structure may be equivalenced to another sequence
14685 structure, an object of default integer type, default real type, double
14686 precision real type, default logical type such that components of the
14687 structure ultimately only become associated to objects of the same
14688 kind. A character sequence structure may be equivalenced to an object
14689 of default character kind or another character sequence structure.
14690 Other objects may be equivalenced only to objects of the same type and
14691 kind parameters. */
14693 /* Identical types are unconditionally OK. */
14694 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
14695 goto identical_types;
14697 last_eq_type = sequence_type (*last_ts);
14698 eq_type = sequence_type (sym->ts);
14700 /* Since the pair of objects is not of the same type, mixed or
14701 non-default sequences can be rejected. */
14703 msg = "Sequence %s with mixed components in EQUIVALENCE "
14704 "statement at %L with different type objects";
14706 && last_eq_type == SEQ_MIXED
14707 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
14709 || (eq_type == SEQ_MIXED
14710 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
14711 &e->where) == FAILURE))
14714 msg = "Non-default type object or sequence %s in EQUIVALENCE "
14715 "statement at %L with objects of different type";
14717 && last_eq_type == SEQ_NONDEFAULT
14718 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
14719 last_where) == FAILURE)
14720 || (eq_type == SEQ_NONDEFAULT
14721 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
14722 &e->where) == FAILURE))
14725 msg ="Non-CHARACTER object '%s' in default CHARACTER "
14726 "EQUIVALENCE statement at %L";
14727 if (last_eq_type == SEQ_CHARACTER
14728 && eq_type != SEQ_CHARACTER
14729 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
14730 &e->where) == FAILURE)
14733 msg ="Non-NUMERIC object '%s' in default NUMERIC "
14734 "EQUIVALENCE statement at %L";
14735 if (last_eq_type == SEQ_NUMERIC
14736 && eq_type != SEQ_NUMERIC
14737 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
14738 &e->where) == FAILURE)
14743 last_where = &e->where;
14748 /* Shall not be an automatic array. */
14749 if (e->ref->type == REF_ARRAY
14750 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
14752 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14753 "an EQUIVALENCE object", sym->name, &e->where);
14760 /* Shall not be a structure component. */
14761 if (r->type == REF_COMPONENT)
14763 gfc_error ("Structure component '%s' at %L cannot be an "
14764 "EQUIVALENCE object",
14765 r->u.c.component->name, &e->where);
14769 /* A substring shall not have length zero. */
14770 if (r->type == REF_SUBSTRING)
14772 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
14774 gfc_error ("Substring at %L has length zero",
14775 &r->u.ss.start->where);
14785 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14788 resolve_fntype (gfc_namespace *ns)
14790 gfc_entry_list *el;
14793 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
14796 /* If there are any entries, ns->proc_name is the entry master
14797 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14799 sym = ns->entries->sym;
14801 sym = ns->proc_name;
14802 if (sym->result == sym
14803 && sym->ts.type == BT_UNKNOWN
14804 && gfc_set_default_type (sym, 0, NULL) == FAILURE
14805 && !sym->attr.untyped)
14807 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14808 sym->name, &sym->declared_at);
14809 sym->attr.untyped = 1;
14812 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
14813 && !sym->attr.contained
14814 && !gfc_check_symbol_access (sym->ts.u.derived)
14815 && gfc_check_symbol_access (sym))
14817 gfc_notify_std (GFC_STD_F2003, "PUBLIC function '%s' at "
14818 "%L of PRIVATE type '%s'", sym->name,
14819 &sym->declared_at, sym->ts.u.derived->name);
14823 for (el = ns->entries->next; el; el = el->next)
14825 if (el->sym->result == el->sym
14826 && el->sym->ts.type == BT_UNKNOWN
14827 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
14828 && !el->sym->attr.untyped)
14830 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14831 el->sym->name, &el->sym->declared_at);
14832 el->sym->attr.untyped = 1;
14838 /* 12.3.2.1.1 Defined operators. */
14841 check_uop_procedure (gfc_symbol *sym, locus where)
14843 gfc_formal_arglist *formal;
14845 if (!sym->attr.function)
14847 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14848 sym->name, &where);
14852 if (sym->ts.type == BT_CHARACTER
14853 && !(sym->ts.u.cl && sym->ts.u.cl->length)
14854 && !(sym->result && sym->result->ts.u.cl
14855 && sym->result->ts.u.cl->length))
14857 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14858 "character length", sym->name, &where);
14862 formal = gfc_sym_get_dummy_args (sym);
14863 if (!formal || !formal->sym)
14865 gfc_error ("User operator procedure '%s' at %L must have at least "
14866 "one argument", sym->name, &where);
14870 if (formal->sym->attr.intent != INTENT_IN)
14872 gfc_error ("First argument of operator interface at %L must be "
14873 "INTENT(IN)", &where);
14877 if (formal->sym->attr.optional)
14879 gfc_error ("First argument of operator interface at %L cannot be "
14880 "optional", &where);
14884 formal = formal->next;
14885 if (!formal || !formal->sym)
14888 if (formal->sym->attr.intent != INTENT_IN)
14890 gfc_error ("Second argument of operator interface at %L must be "
14891 "INTENT(IN)", &where);
14895 if (formal->sym->attr.optional)
14897 gfc_error ("Second argument of operator interface at %L cannot be "
14898 "optional", &where);
14904 gfc_error ("Operator interface at %L must have, at most, two "
14905 "arguments", &where);
14913 gfc_resolve_uops (gfc_symtree *symtree)
14915 gfc_interface *itr;
14917 if (symtree == NULL)
14920 gfc_resolve_uops (symtree->left);
14921 gfc_resolve_uops (symtree->right);
14923 for (itr = symtree->n.uop->op; itr; itr = itr->next)
14924 check_uop_procedure (itr->sym, itr->sym->declared_at);
14928 /* Examine all of the expressions associated with a program unit,
14929 assign types to all intermediate expressions, make sure that all
14930 assignments are to compatible types and figure out which names
14931 refer to which functions or subroutines. It doesn't check code
14932 block, which is handled by resolve_code. */
14935 resolve_types (gfc_namespace *ns)
14941 gfc_namespace* old_ns = gfc_current_ns;
14943 /* Check that all IMPLICIT types are ok. */
14944 if (!ns->seen_implicit_none)
14947 for (letter = 0; letter != GFC_LETTERS; ++letter)
14948 if (ns->set_flag[letter]
14949 && resolve_typespec_used (&ns->default_type[letter],
14950 &ns->implicit_loc[letter],
14955 gfc_current_ns = ns;
14957 resolve_entries (ns);
14959 resolve_common_vars (ns->blank_common.head, false);
14960 resolve_common_blocks (ns->common_root);
14962 resolve_contained_functions (ns);
14964 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
14965 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
14966 resolve_formal_arglist (ns->proc_name);
14968 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
14970 for (cl = ns->cl_list; cl; cl = cl->next)
14971 resolve_charlen (cl);
14973 gfc_traverse_ns (ns, resolve_symbol);
14975 resolve_fntype (ns);
14977 for (n = ns->contained; n; n = n->sibling)
14979 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
14980 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14981 "also be PURE", n->proc_name->name,
14982 &n->proc_name->declared_at);
14988 do_concurrent_flag = 0;
14989 gfc_check_interfaces (ns);
14991 gfc_traverse_ns (ns, resolve_values);
14997 for (d = ns->data; d; d = d->next)
15001 gfc_traverse_ns (ns, gfc_formalize_init_value);
15003 gfc_traverse_ns (ns, gfc_verify_binding_labels);
15005 if (ns->common_root != NULL)
15006 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
15008 for (eq = ns->equiv; eq; eq = eq->next)
15009 resolve_equivalence (eq);
15011 /* Warn about unused labels. */
15012 if (warn_unused_label)
15013 warn_unused_fortran_label (ns->st_labels);
15015 gfc_resolve_uops (ns->uop_root);
15017 gfc_current_ns = old_ns;
15021 /* Call resolve_code recursively. */
15024 resolve_codes (gfc_namespace *ns)
15027 bitmap_obstack old_obstack;
15029 if (ns->resolved == 1)
15032 for (n = ns->contained; n; n = n->sibling)
15035 gfc_current_ns = ns;
15037 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
15038 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
15041 /* Set to an out of range value. */
15042 current_entry_id = -1;
15044 old_obstack = labels_obstack;
15045 bitmap_obstack_initialize (&labels_obstack);
15047 resolve_code (ns->code, ns);
15049 bitmap_obstack_release (&labels_obstack);
15050 labels_obstack = old_obstack;
15054 /* This function is called after a complete program unit has been compiled.
15055 Its purpose is to examine all of the expressions associated with a program
15056 unit, assign types to all intermediate expressions, make sure that all
15057 assignments are to compatible types and figure out which names refer to
15058 which functions or subroutines. */
15061 gfc_resolve (gfc_namespace *ns)
15063 gfc_namespace *old_ns;
15064 code_stack *old_cs_base;
15070 old_ns = gfc_current_ns;
15071 old_cs_base = cs_base;
15073 resolve_types (ns);
15074 component_assignment_level = 0;
15075 resolve_codes (ns);
15077 gfc_current_ns = old_ns;
15078 cs_base = old_cs_base;
15081 gfc_run_passes (ns);