1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
29 #include "arith.h" /* For gfc_compare_expr(). */
30 #include "dependency.h"
32 #include "target-memory.h" /* for gfc_simplify_transfer */
33 #include "constructor.h"
35 /* Types used in equivalence statements. */
39 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
43 /* Stack to keep track of the nesting of blocks as we move through the
44 code. See resolve_branch() and resolve_code(). */
46 typedef struct code_stack
48 struct gfc_code
*head
, *current
;
49 struct code_stack
*prev
;
51 /* This bitmap keeps track of the targets valid for a branch from
52 inside this block except for END {IF|SELECT}s of enclosing
54 bitmap reachable_labels
;
58 static code_stack
*cs_base
= NULL
;
61 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
63 static int forall_flag
;
64 static int do_concurrent_flag
;
66 static bool assumed_type_expr_allowed
= false;
68 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
70 static int omp_workshare_flag
;
72 /* Nonzero if we are processing a formal arglist. The corresponding function
73 resets the flag each time that it is read. */
74 static int formal_arg_flag
= 0;
76 /* True if we are resolving a specification expression. */
77 static int specification_expr
= 0;
79 /* The id of the last entry seen. */
80 static int current_entry_id
;
82 /* We use bitmaps to determine if a branch target is valid. */
83 static bitmap_obstack labels_obstack
;
85 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
86 static bool inquiry_argument
= false;
89 gfc_is_formal_arg (void)
91 return formal_arg_flag
;
94 /* Is the symbol host associated? */
96 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
98 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
107 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
108 an ABSTRACT derived-type. If where is not NULL, an error message with that
109 locus is printed, optionally using name. */
112 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
114 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
119 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
120 name
, where
, ts
->u
.derived
->name
);
122 gfc_error ("ABSTRACT type '%s' used at %L",
123 ts
->u
.derived
->name
, where
);
133 static void resolve_symbol (gfc_symbol
*sym
);
134 static gfc_try
resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
);
137 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
140 resolve_procedure_interface (gfc_symbol
*sym
)
142 if (sym
->ts
.interface
== sym
)
144 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
145 sym
->name
, &sym
->declared_at
);
148 if (sym
->ts
.interface
->attr
.procedure
)
150 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
151 "in a later PROCEDURE statement", sym
->ts
.interface
->name
,
152 sym
->name
, &sym
->declared_at
);
156 /* Get the attributes from the interface (now resolved). */
157 if (sym
->ts
.interface
->attr
.if_source
|| sym
->ts
.interface
->attr
.intrinsic
)
159 gfc_symbol
*ifc
= sym
->ts
.interface
;
160 resolve_symbol (ifc
);
162 if (ifc
->attr
.intrinsic
)
163 resolve_intrinsic (ifc
, &ifc
->declared_at
);
167 sym
->ts
= ifc
->result
->ts
;
172 sym
->ts
.interface
= ifc
;
173 sym
->attr
.function
= ifc
->attr
.function
;
174 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
175 gfc_copy_formal_args (sym
, ifc
);
177 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
178 sym
->attr
.pointer
= ifc
->attr
.pointer
;
179 sym
->attr
.pure
= ifc
->attr
.pure
;
180 sym
->attr
.elemental
= ifc
->attr
.elemental
;
181 sym
->attr
.dimension
= ifc
->attr
.dimension
;
182 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
183 sym
->attr
.recursive
= ifc
->attr
.recursive
;
184 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
185 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
186 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
187 /* Copy array spec. */
188 sym
->as
= gfc_copy_array_spec (ifc
->as
);
192 for (i
= 0; i
< sym
->as
->rank
; i
++)
194 gfc_expr_replace_symbols (sym
->as
->lower
[i
], sym
);
195 gfc_expr_replace_symbols (sym
->as
->upper
[i
], sym
);
198 /* Copy char length. */
199 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
201 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
202 gfc_expr_replace_symbols (sym
->ts
.u
.cl
->length
, sym
);
203 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
204 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
208 else if (sym
->ts
.interface
->name
[0] != '\0')
210 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
211 sym
->ts
.interface
->name
, sym
->name
, &sym
->declared_at
);
219 /* Resolve types of formal argument lists. These have to be done early so that
220 the formal argument lists of module procedures can be copied to the
221 containing module before the individual procedures are resolved
222 individually. We also resolve argument lists of procedures in interface
223 blocks because they are self-contained scoping units.
225 Since a dummy argument cannot be a non-dummy procedure, the only
226 resort left for untyped names are the IMPLICIT types. */
229 resolve_formal_arglist (gfc_symbol
*proc
)
231 gfc_formal_arglist
*f
;
235 if (proc
->result
!= NULL
)
240 if (gfc_elemental (proc
)
241 || sym
->attr
.pointer
|| sym
->attr
.allocatable
242 || (sym
->as
&& sym
->as
->rank
> 0))
244 proc
->attr
.always_explicit
= 1;
245 sym
->attr
.always_explicit
= 1;
250 for (f
= proc
->formal
; f
; f
= f
->next
)
256 /* Alternate return placeholder. */
257 if (gfc_elemental (proc
))
258 gfc_error ("Alternate return specifier in elemental subroutine "
259 "'%s' at %L is not allowed", proc
->name
,
261 if (proc
->attr
.function
)
262 gfc_error ("Alternate return specifier in function "
263 "'%s' at %L is not allowed", proc
->name
,
267 else if (sym
->attr
.procedure
&& sym
->ts
.interface
268 && sym
->attr
.if_source
!= IFSRC_DECL
)
269 resolve_procedure_interface (sym
);
271 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
272 resolve_formal_arglist (sym
);
274 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
276 if (sym
->attr
.flavor
== FL_UNKNOWN
)
277 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
281 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
282 && (!sym
->attr
.function
|| sym
->result
== sym
))
283 gfc_set_default_type (sym
, 1, sym
->ns
);
286 gfc_resolve_array_spec (sym
->as
, 0);
288 /* We can't tell if an array with dimension (:) is assumed or deferred
289 shape until we know if it has the pointer or allocatable attributes.
291 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
292 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
)
293 && sym
->attr
.flavor
!= FL_PROCEDURE
)
295 sym
->as
->type
= AS_ASSUMED_SHAPE
;
296 for (i
= 0; i
< sym
->as
->rank
; i
++)
297 sym
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
301 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
302 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
303 || sym
->attr
.optional
)
305 proc
->attr
.always_explicit
= 1;
307 proc
->result
->attr
.always_explicit
= 1;
310 /* If the flavor is unknown at this point, it has to be a variable.
311 A procedure specification would have already set the type. */
313 if (sym
->attr
.flavor
== FL_UNKNOWN
)
314 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
318 if (sym
->attr
.flavor
== FL_PROCEDURE
)
323 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
324 "also be PURE", sym
->name
, &sym
->declared_at
);
328 else if (!sym
->attr
.pointer
)
330 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
333 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s'"
334 " of pure function '%s' at %L with VALUE "
335 "attribute but without INTENT(IN)",
336 sym
->name
, proc
->name
, &sym
->declared_at
);
338 gfc_error ("Argument '%s' of pure function '%s' at %L must "
339 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
343 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
346 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s'"
347 " of pure subroutine '%s' at %L with VALUE "
348 "attribute but without INTENT", sym
->name
,
349 proc
->name
, &sym
->declared_at
);
351 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
352 "must have its INTENT specified or have the "
353 "VALUE attribute", sym
->name
, proc
->name
,
359 if (proc
->attr
.implicit_pure
)
361 if (sym
->attr
.flavor
== FL_PROCEDURE
)
364 proc
->attr
.implicit_pure
= 0;
366 else if (!sym
->attr
.pointer
)
368 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
369 proc
->attr
.implicit_pure
= 0;
371 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
372 proc
->attr
.implicit_pure
= 0;
376 if (gfc_elemental (proc
))
379 if (sym
->attr
.codimension
380 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
381 && CLASS_DATA (sym
)->attr
.codimension
))
383 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
384 "procedure", sym
->name
, &sym
->declared_at
);
388 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
389 && CLASS_DATA (sym
)->as
))
391 gfc_error ("Argument '%s' of elemental procedure at %L must "
392 "be scalar", sym
->name
, &sym
->declared_at
);
396 if (sym
->attr
.allocatable
397 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
398 && CLASS_DATA (sym
)->attr
.allocatable
))
400 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
401 "have the ALLOCATABLE attribute", sym
->name
,
406 if (sym
->attr
.pointer
407 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
408 && CLASS_DATA (sym
)->attr
.class_pointer
))
410 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
411 "have the POINTER attribute", sym
->name
,
416 if (sym
->attr
.flavor
== FL_PROCEDURE
)
418 gfc_error ("Dummy procedure '%s' not allowed in elemental "
419 "procedure '%s' at %L", sym
->name
, proc
->name
,
424 if (sym
->attr
.intent
== INTENT_UNKNOWN
)
426 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
427 "have its INTENT specified", sym
->name
, proc
->name
,
433 /* Each dummy shall be specified to be scalar. */
434 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
438 gfc_error ("Argument '%s' of statement function at %L must "
439 "be scalar", sym
->name
, &sym
->declared_at
);
443 if (sym
->ts
.type
== BT_CHARACTER
)
445 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
446 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
448 gfc_error ("Character-valued argument '%s' of statement "
449 "function at %L must have constant length",
450 sym
->name
, &sym
->declared_at
);
460 /* Work function called when searching for symbols that have argument lists
461 associated with them. */
464 find_arglists (gfc_symbol
*sym
)
466 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
467 || sym
->attr
.flavor
== FL_DERIVED
)
470 resolve_formal_arglist (sym
);
474 /* Given a namespace, resolve all formal argument lists within the namespace.
478 resolve_formal_arglists (gfc_namespace
*ns
)
483 gfc_traverse_ns (ns
, find_arglists
);
488 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
492 /* If this namespace is not a function or an entry master function,
494 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
495 || sym
->attr
.entry_master
)
498 /* Try to find out of what the return type is. */
499 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
501 t
= gfc_set_default_type (sym
->result
, 0, ns
);
503 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
505 if (sym
->result
== sym
)
506 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
507 sym
->name
, &sym
->declared_at
);
508 else if (!sym
->result
->attr
.proc_pointer
)
509 gfc_error ("Result '%s' of contained function '%s' at %L has "
510 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
511 &sym
->result
->declared_at
);
512 sym
->result
->attr
.untyped
= 1;
516 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
517 type, lists the only ways a character length value of * can be used:
518 dummy arguments of procedures, named constants, and function results
519 in external functions. Internal function results and results of module
520 procedures are not on this list, ergo, not permitted. */
522 if (sym
->result
->ts
.type
== BT_CHARACTER
)
524 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
525 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
527 /* See if this is a module-procedure and adapt error message
530 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
531 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
533 gfc_error ("Character-valued %s '%s' at %L must not be"
535 module_proc
? _("module procedure")
536 : _("internal function"),
537 sym
->name
, &sym
->declared_at
);
543 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
544 introduce duplicates. */
547 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
549 gfc_formal_arglist
*f
, *new_arglist
;
552 for (; new_args
!= NULL
; new_args
= new_args
->next
)
554 new_sym
= new_args
->sym
;
555 /* See if this arg is already in the formal argument list. */
556 for (f
= proc
->formal
; f
; f
= f
->next
)
558 if (new_sym
== f
->sym
)
565 /* Add a new argument. Argument order is not important. */
566 new_arglist
= gfc_get_formal_arglist ();
567 new_arglist
->sym
= new_sym
;
568 new_arglist
->next
= proc
->formal
;
569 proc
->formal
= new_arglist
;
574 /* Flag the arguments that are not present in all entries. */
577 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
579 gfc_formal_arglist
*f
, *head
;
582 for (f
= proc
->formal
; f
; f
= f
->next
)
587 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
589 if (new_args
->sym
== f
->sym
)
596 f
->sym
->attr
.not_always_present
= 1;
601 /* Resolve alternate entry points. If a symbol has multiple entry points we
602 create a new master symbol for the main routine, and turn the existing
603 symbol into an entry point. */
606 resolve_entries (gfc_namespace
*ns
)
608 gfc_namespace
*old_ns
;
612 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
613 static int master_count
= 0;
615 if (ns
->proc_name
== NULL
)
618 /* No need to do anything if this procedure doesn't have alternate entry
623 /* We may already have resolved alternate entry points. */
624 if (ns
->proc_name
->attr
.entry_master
)
627 /* If this isn't a procedure something has gone horribly wrong. */
628 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
630 /* Remember the current namespace. */
631 old_ns
= gfc_current_ns
;
635 /* Add the main entry point to the list of entry points. */
636 el
= gfc_get_entry_list ();
637 el
->sym
= ns
->proc_name
;
639 el
->next
= ns
->entries
;
641 ns
->proc_name
->attr
.entry
= 1;
643 /* If it is a module function, it needs to be in the right namespace
644 so that gfc_get_fake_result_decl can gather up the results. The
645 need for this arose in get_proc_name, where these beasts were
646 left in their own namespace, to keep prior references linked to
647 the entry declaration.*/
648 if (ns
->proc_name
->attr
.function
649 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
652 /* Do the same for entries where the master is not a module
653 procedure. These are retained in the module namespace because
654 of the module procedure declaration. */
655 for (el
= el
->next
; el
; el
= el
->next
)
656 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
657 && el
->sym
->attr
.mod_proc
)
661 /* Add an entry statement for it. */
668 /* Create a new symbol for the master function. */
669 /* Give the internal function a unique name (within this file).
670 Also include the function name so the user has some hope of figuring
671 out what is going on. */
672 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
673 master_count
++, ns
->proc_name
->name
);
674 gfc_get_ha_symbol (name
, &proc
);
675 gcc_assert (proc
!= NULL
);
677 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
678 if (ns
->proc_name
->attr
.subroutine
)
679 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
683 gfc_typespec
*ts
, *fts
;
684 gfc_array_spec
*as
, *fas
;
685 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
687 fas
= ns
->entries
->sym
->as
;
688 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
689 fts
= &ns
->entries
->sym
->result
->ts
;
690 if (fts
->type
== BT_UNKNOWN
)
691 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
692 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
694 ts
= &el
->sym
->result
->ts
;
696 as
= as
? as
: el
->sym
->result
->as
;
697 if (ts
->type
== BT_UNKNOWN
)
698 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
700 if (! gfc_compare_types (ts
, fts
)
701 || (el
->sym
->result
->attr
.dimension
702 != ns
->entries
->sym
->result
->attr
.dimension
)
703 || (el
->sym
->result
->attr
.pointer
704 != ns
->entries
->sym
->result
->attr
.pointer
))
706 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
707 && gfc_compare_array_spec (as
, fas
) == 0)
708 gfc_error ("Function %s at %L has entries with mismatched "
709 "array specifications", ns
->entries
->sym
->name
,
710 &ns
->entries
->sym
->declared_at
);
711 /* The characteristics need to match and thus both need to have
712 the same string length, i.e. both len=*, or both len=4.
713 Having both len=<variable> is also possible, but difficult to
714 check at compile time. */
715 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
716 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
717 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
719 && ts
->u
.cl
->length
->expr_type
720 != fts
->u
.cl
->length
->expr_type
)
722 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
723 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
724 fts
->u
.cl
->length
->value
.integer
) != 0)))
725 gfc_notify_std (GFC_STD_GNU
, "Extension: Function %s at %L with "
726 "entries returning variables of different "
727 "string lengths", ns
->entries
->sym
->name
,
728 &ns
->entries
->sym
->declared_at
);
733 sym
= ns
->entries
->sym
->result
;
734 /* All result types the same. */
736 if (sym
->attr
.dimension
)
737 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
738 if (sym
->attr
.pointer
)
739 gfc_add_pointer (&proc
->attr
, NULL
);
743 /* Otherwise the result will be passed through a union by
745 proc
->attr
.mixed_entry_master
= 1;
746 for (el
= ns
->entries
; el
; el
= el
->next
)
748 sym
= el
->sym
->result
;
749 if (sym
->attr
.dimension
)
751 if (el
== ns
->entries
)
752 gfc_error ("FUNCTION result %s can't be an array in "
753 "FUNCTION %s at %L", sym
->name
,
754 ns
->entries
->sym
->name
, &sym
->declared_at
);
756 gfc_error ("ENTRY result %s can't be an array in "
757 "FUNCTION %s at %L", sym
->name
,
758 ns
->entries
->sym
->name
, &sym
->declared_at
);
760 else if (sym
->attr
.pointer
)
762 if (el
== ns
->entries
)
763 gfc_error ("FUNCTION result %s can't be a POINTER in "
764 "FUNCTION %s at %L", sym
->name
,
765 ns
->entries
->sym
->name
, &sym
->declared_at
);
767 gfc_error ("ENTRY result %s can't be a POINTER in "
768 "FUNCTION %s at %L", sym
->name
,
769 ns
->entries
->sym
->name
, &sym
->declared_at
);
774 if (ts
->type
== BT_UNKNOWN
)
775 ts
= gfc_get_default_type (sym
->name
, NULL
);
779 if (ts
->kind
== gfc_default_integer_kind
)
783 if (ts
->kind
== gfc_default_real_kind
784 || ts
->kind
== gfc_default_double_kind
)
788 if (ts
->kind
== gfc_default_complex_kind
)
792 if (ts
->kind
== gfc_default_logical_kind
)
796 /* We will issue error elsewhere. */
804 if (el
== ns
->entries
)
805 gfc_error ("FUNCTION result %s can't be of type %s "
806 "in FUNCTION %s at %L", sym
->name
,
807 gfc_typename (ts
), ns
->entries
->sym
->name
,
810 gfc_error ("ENTRY result %s can't be of type %s "
811 "in FUNCTION %s at %L", sym
->name
,
812 gfc_typename (ts
), ns
->entries
->sym
->name
,
819 proc
->attr
.access
= ACCESS_PRIVATE
;
820 proc
->attr
.entry_master
= 1;
822 /* Merge all the entry point arguments. */
823 for (el
= ns
->entries
; el
; el
= el
->next
)
824 merge_argument_lists (proc
, el
->sym
->formal
);
826 /* Check the master formal arguments for any that are not
827 present in all entry points. */
828 for (el
= ns
->entries
; el
; el
= el
->next
)
829 check_argument_lists (proc
, el
->sym
->formal
);
831 /* Use the master function for the function body. */
832 ns
->proc_name
= proc
;
834 /* Finalize the new symbols. */
835 gfc_commit_symbols ();
837 /* Restore the original namespace. */
838 gfc_current_ns
= old_ns
;
842 /* Resolve common variables. */
844 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
846 gfc_symbol
*csym
= sym
;
848 for (; csym
; csym
= csym
->common_next
)
850 if (csym
->value
|| csym
->attr
.data
)
852 if (!csym
->ns
->is_block_data
)
853 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
854 "but only in BLOCK DATA initialization is "
855 "allowed", csym
->name
, &csym
->declared_at
);
856 else if (!named_common
)
857 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
858 "in a blank COMMON but initialization is only "
859 "allowed in named common blocks", csym
->name
,
863 if (csym
->ts
.type
!= BT_DERIVED
)
866 if (!(csym
->ts
.u
.derived
->attr
.sequence
867 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
868 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
869 "has neither the SEQUENCE nor the BIND(C) "
870 "attribute", csym
->name
, &csym
->declared_at
);
871 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
872 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
873 "has an ultimate component that is "
874 "allocatable", csym
->name
, &csym
->declared_at
);
875 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
876 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
877 "may not have default initializer", csym
->name
,
880 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
881 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
885 /* Resolve common blocks. */
887 resolve_common_blocks (gfc_symtree
*common_root
)
891 if (common_root
== NULL
)
894 if (common_root
->left
)
895 resolve_common_blocks (common_root
->left
);
896 if (common_root
->right
)
897 resolve_common_blocks (common_root
->right
);
899 resolve_common_vars (common_root
->n
.common
->head
, true);
901 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
905 if (sym
->attr
.flavor
== FL_PARAMETER
)
906 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
907 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
909 if (sym
->attr
.external
)
910 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
911 sym
->name
, &common_root
->n
.common
->where
);
913 if (sym
->attr
.intrinsic
)
914 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
915 sym
->name
, &common_root
->n
.common
->where
);
916 else if (sym
->attr
.result
917 || gfc_is_function_return_value (sym
, gfc_current_ns
))
918 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
919 "that is also a function result", sym
->name
,
920 &common_root
->n
.common
->where
);
921 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
922 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
923 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
924 "that is also a global procedure", sym
->name
,
925 &common_root
->n
.common
->where
);
929 /* Resolve contained function types. Because contained functions can call one
930 another, they have to be worked out before any of the contained procedures
933 The good news is that if a function doesn't already have a type, the only
934 way it can get one is through an IMPLICIT type or a RESULT variable, because
935 by definition contained functions are contained namespace they're contained
936 in, not in a sibling or parent namespace. */
939 resolve_contained_functions (gfc_namespace
*ns
)
941 gfc_namespace
*child
;
944 resolve_formal_arglists (ns
);
946 for (child
= ns
->contained
; child
; child
= child
->sibling
)
948 /* Resolve alternate entry points first. */
949 resolve_entries (child
);
951 /* Then check function return types. */
952 resolve_contained_fntype (child
->proc_name
, child
);
953 for (el
= child
->entries
; el
; el
= el
->next
)
954 resolve_contained_fntype (el
->sym
, child
);
959 static gfc_try
resolve_fl_derived0 (gfc_symbol
*sym
);
962 /* Resolve all of the elements of a structure constructor and make sure that
963 the types are correct. The 'init' flag indicates that the given
964 constructor is an initializer. */
967 resolve_structure_cons (gfc_expr
*expr
, int init
)
969 gfc_constructor
*cons
;
976 if (expr
->ts
.type
== BT_DERIVED
)
977 resolve_fl_derived0 (expr
->ts
.u
.derived
);
979 cons
= gfc_constructor_first (expr
->value
.constructor
);
981 /* See if the user is trying to invoke a structure constructor for one of
982 the iso_c_binding derived types. */
983 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
984 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
985 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
987 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
988 expr
->ts
.u
.derived
->name
, &(expr
->where
));
992 /* Return if structure constructor is c_null_(fun)prt. */
993 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
994 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
995 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
998 /* A constructor may have references if it is the result of substituting a
999 parameter variable. In this case we just pull out the component we
1002 comp
= expr
->ref
->u
.c
.sym
->components
;
1004 comp
= expr
->ts
.u
.derived
->components
;
1006 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1013 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
1019 rank
= comp
->as
? comp
->as
->rank
: 0;
1020 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1021 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1023 gfc_error ("The rank of the element in the structure "
1024 "constructor at %L does not match that of the "
1025 "component (%d/%d)", &cons
->expr
->where
,
1026 cons
->expr
->rank
, rank
);
1030 /* If we don't have the right type, try to convert it. */
1032 if (!comp
->attr
.proc_pointer
&&
1033 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1036 if (strcmp (comp
->name
, "_extends") == 0)
1038 /* Can afford to be brutal with the _extends initializer.
1039 The derived type can get lost because it is PRIVATE
1040 but it is not usage constrained by the standard. */
1041 cons
->expr
->ts
= comp
->ts
;
1044 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1045 gfc_error ("The element in the structure constructor at %L, "
1046 "for pointer component '%s', is %s but should be %s",
1047 &cons
->expr
->where
, comp
->name
,
1048 gfc_basic_typename (cons
->expr
->ts
.type
),
1049 gfc_basic_typename (comp
->ts
.type
));
1051 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1054 /* For strings, the length of the constructor should be the same as
1055 the one of the structure, ensure this if the lengths are known at
1056 compile time and when we are dealing with PARAMETER or structure
1058 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1059 && comp
->ts
.u
.cl
->length
1060 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1061 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1062 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1063 && cons
->expr
->rank
!= 0
1064 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1065 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1067 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1068 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1070 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1071 to make use of the gfc_resolve_character_array_constructor
1072 machinery. The expression is later simplified away to
1073 an array of string literals. */
1074 gfc_expr
*para
= cons
->expr
;
1075 cons
->expr
= gfc_get_expr ();
1076 cons
->expr
->ts
= para
->ts
;
1077 cons
->expr
->where
= para
->where
;
1078 cons
->expr
->expr_type
= EXPR_ARRAY
;
1079 cons
->expr
->rank
= para
->rank
;
1080 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1081 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1082 para
, &cons
->expr
->where
);
1084 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1087 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1088 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1090 gfc_charlen
*cl
, *cl2
;
1093 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1095 if (cl
== cons
->expr
->ts
.u
.cl
)
1103 cl2
->next
= cl
->next
;
1105 gfc_free_expr (cl
->length
);
1109 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1110 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1111 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1112 gfc_resolve_character_array_constructor (cons
->expr
);
1116 if (cons
->expr
->expr_type
== EXPR_NULL
1117 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1118 || comp
->attr
.proc_pointer
1119 || (comp
->ts
.type
== BT_CLASS
1120 && (CLASS_DATA (comp
)->attr
.class_pointer
1121 || CLASS_DATA (comp
)->attr
.allocatable
))))
1124 gfc_error ("The NULL in the structure constructor at %L is "
1125 "being applied to component '%s', which is neither "
1126 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1130 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1132 /* Check procedure pointer interface. */
1133 gfc_symbol
*s2
= NULL
;
1138 if (gfc_is_proc_ptr_comp (cons
->expr
, &c2
))
1140 s2
= c2
->ts
.interface
;
1143 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1145 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1146 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1148 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1150 s2
= cons
->expr
->symtree
->n
.sym
;
1151 name
= cons
->expr
->symtree
->n
.sym
->name
;
1154 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1157 gfc_error ("Interface mismatch for procedure-pointer component "
1158 "'%s' in structure constructor at %L: %s",
1159 comp
->name
, &cons
->expr
->where
, err
);
1164 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1165 || cons
->expr
->expr_type
== EXPR_NULL
)
1168 a
= gfc_expr_attr (cons
->expr
);
1170 if (!a
.pointer
&& !a
.target
)
1173 gfc_error ("The element in the structure constructor at %L, "
1174 "for pointer component '%s' should be a POINTER or "
1175 "a TARGET", &cons
->expr
->where
, comp
->name
);
1180 /* F08:C461. Additional checks for pointer initialization. */
1184 gfc_error ("Pointer initialization target at %L "
1185 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1190 gfc_error ("Pointer initialization target at %L "
1191 "must have the SAVE attribute", &cons
->expr
->where
);
1195 /* F2003, C1272 (3). */
1196 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1197 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1198 || gfc_is_coindexed (cons
->expr
)))
1201 gfc_error ("Invalid expression in the structure constructor for "
1202 "pointer component '%s' at %L in PURE procedure",
1203 comp
->name
, &cons
->expr
->where
);
1206 if (gfc_implicit_pure (NULL
)
1207 && cons
->expr
->expr_type
== EXPR_VARIABLE
1208 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1209 || gfc_is_coindexed (cons
->expr
)))
1210 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1218 /****************** Expression name resolution ******************/
1220 /* Returns 0 if a symbol was not declared with a type or
1221 attribute declaration statement, nonzero otherwise. */
1224 was_declared (gfc_symbol
*sym
)
1230 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1233 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1234 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1235 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1236 || a
.asynchronous
|| a
.codimension
)
1243 /* Determine if a symbol is generic or not. */
1246 generic_sym (gfc_symbol
*sym
)
1250 if (sym
->attr
.generic
||
1251 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1254 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1257 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1264 return generic_sym (s
);
1271 /* Determine if a symbol is specific or not. */
1274 specific_sym (gfc_symbol
*sym
)
1278 if (sym
->attr
.if_source
== IFSRC_IFBODY
1279 || sym
->attr
.proc
== PROC_MODULE
1280 || sym
->attr
.proc
== PROC_INTERNAL
1281 || sym
->attr
.proc
== PROC_ST_FUNCTION
1282 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1283 || sym
->attr
.external
)
1286 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1289 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1291 return (s
== NULL
) ? 0 : specific_sym (s
);
1295 /* Figure out if the procedure is specific, generic or unknown. */
1298 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1302 procedure_kind (gfc_symbol
*sym
)
1304 if (generic_sym (sym
))
1305 return PTYPE_GENERIC
;
1307 if (specific_sym (sym
))
1308 return PTYPE_SPECIFIC
;
1310 return PTYPE_UNKNOWN
;
1313 /* Check references to assumed size arrays. The flag need_full_assumed_size
1314 is nonzero when matching actual arguments. */
1316 static int need_full_assumed_size
= 0;
1319 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1321 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1324 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1325 What should it be? */
1326 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1327 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1328 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1330 gfc_error ("The upper bound in the last dimension must "
1331 "appear in the reference to the assumed size "
1332 "array '%s' at %L", sym
->name
, &e
->where
);
1339 /* Look for bad assumed size array references in argument expressions
1340 of elemental and array valued intrinsic procedures. Since this is
1341 called from procedure resolution functions, it only recurses at
1345 resolve_assumed_size_actual (gfc_expr
*e
)
1350 switch (e
->expr_type
)
1353 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1358 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1359 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1370 /* Check a generic procedure, passed as an actual argument, to see if
1371 there is a matching specific name. If none, it is an error, and if
1372 more than one, the reference is ambiguous. */
1374 count_specific_procs (gfc_expr
*e
)
1381 sym
= e
->symtree
->n
.sym
;
1383 for (p
= sym
->generic
; p
; p
= p
->next
)
1384 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1386 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1392 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1396 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1397 "argument at %L", sym
->name
, &e
->where
);
1403 /* See if a call to sym could possibly be a not allowed RECURSION because of
1404 a missing RECURSIVE declaration. This means that either sym is the current
1405 context itself, or sym is the parent of a contained procedure calling its
1406 non-RECURSIVE containing procedure.
1407 This also works if sym is an ENTRY. */
1410 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1412 gfc_symbol
* proc_sym
;
1413 gfc_symbol
* context_proc
;
1414 gfc_namespace
* real_context
;
1416 if (sym
->attr
.flavor
== FL_PROGRAM
1417 || sym
->attr
.flavor
== FL_DERIVED
)
1420 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1422 /* If we've got an ENTRY, find real procedure. */
1423 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1424 proc_sym
= sym
->ns
->entries
->sym
;
1428 /* If sym is RECURSIVE, all is well of course. */
1429 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1432 /* Find the context procedure's "real" symbol if it has entries.
1433 We look for a procedure symbol, so recurse on the parents if we don't
1434 find one (like in case of a BLOCK construct). */
1435 for (real_context
= context
; ; real_context
= real_context
->parent
)
1437 /* We should find something, eventually! */
1438 gcc_assert (real_context
);
1440 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1441 : real_context
->proc_name
);
1443 /* In some special cases, there may not be a proc_name, like for this
1445 real(bad_kind()) function foo () ...
1446 when checking the call to bad_kind ().
1447 In these cases, we simply return here and assume that the
1452 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1456 /* A call from sym's body to itself is recursion, of course. */
1457 if (context_proc
== proc_sym
)
1460 /* The same is true if context is a contained procedure and sym the
1462 if (context_proc
->attr
.contained
)
1464 gfc_symbol
* parent_proc
;
1466 gcc_assert (context
->parent
);
1467 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1468 : context
->parent
->proc_name
);
1470 if (parent_proc
== proc_sym
)
1478 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1479 its typespec and formal argument list. */
1482 resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1484 gfc_intrinsic_sym
* isym
= NULL
;
1490 /* Already resolved. */
1491 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1494 /* We already know this one is an intrinsic, so we don't call
1495 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1496 gfc_find_subroutine directly to check whether it is a function or
1499 if (sym
->intmod_sym_id
)
1500 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1501 else if (!sym
->attr
.subroutine
)
1502 isym
= gfc_find_function (sym
->name
);
1506 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1507 && !sym
->attr
.implicit_type
)
1508 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1509 " ignored", sym
->name
, &sym
->declared_at
);
1511 if (!sym
->attr
.function
&&
1512 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1517 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1519 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1521 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1522 " specifier", sym
->name
, &sym
->declared_at
);
1526 if (!sym
->attr
.subroutine
&&
1527 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1532 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1537 gfc_copy_formal_args_intr (sym
, isym
);
1539 /* Check it is actually available in the standard settings. */
1540 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1543 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1544 " available in the current standard settings but %s. Use"
1545 " an appropriate -std=* option or enable -fall-intrinsics"
1546 " in order to use it.",
1547 sym
->name
, &sym
->declared_at
, symstd
);
1555 /* Resolve a procedure expression, like passing it to a called procedure or as
1556 RHS for a procedure pointer assignment. */
1559 resolve_procedure_expression (gfc_expr
* expr
)
1563 if (expr
->expr_type
!= EXPR_VARIABLE
)
1565 gcc_assert (expr
->symtree
);
1567 sym
= expr
->symtree
->n
.sym
;
1569 if (sym
->attr
.intrinsic
)
1570 resolve_intrinsic (sym
, &expr
->where
);
1572 if (sym
->attr
.flavor
!= FL_PROCEDURE
1573 || (sym
->attr
.function
&& sym
->result
== sym
))
1576 /* A non-RECURSIVE procedure that is used as procedure expression within its
1577 own body is in danger of being called recursively. */
1578 if (is_illegal_recursion (sym
, gfc_current_ns
))
1579 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1580 " itself recursively. Declare it RECURSIVE or use"
1581 " -frecursive", sym
->name
, &expr
->where
);
1587 /* Resolve an actual argument list. Most of the time, this is just
1588 resolving the expressions in the list.
1589 The exception is that we sometimes have to decide whether arguments
1590 that look like procedure arguments are really simple variable
1594 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1595 bool no_formal_args
)
1598 gfc_symtree
*parent_st
;
1600 int save_need_full_assumed_size
;
1602 assumed_type_expr_allowed
= true;
1604 for (; arg
; arg
= arg
->next
)
1609 /* Check the label is a valid branching target. */
1612 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1614 gfc_error ("Label %d referenced at %L is never defined",
1615 arg
->label
->value
, &arg
->label
->where
);
1622 if (e
->expr_type
== EXPR_VARIABLE
1623 && e
->symtree
->n
.sym
->attr
.generic
1625 && count_specific_procs (e
) != 1)
1628 if (e
->ts
.type
!= BT_PROCEDURE
)
1630 save_need_full_assumed_size
= need_full_assumed_size
;
1631 if (e
->expr_type
!= EXPR_VARIABLE
)
1632 need_full_assumed_size
= 0;
1633 if (gfc_resolve_expr (e
) != SUCCESS
)
1635 need_full_assumed_size
= save_need_full_assumed_size
;
1639 /* See if the expression node should really be a variable reference. */
1641 sym
= e
->symtree
->n
.sym
;
1643 if (sym
->attr
.flavor
== FL_PROCEDURE
1644 || sym
->attr
.intrinsic
1645 || sym
->attr
.external
)
1649 /* If a procedure is not already determined to be something else
1650 check if it is intrinsic. */
1651 if (!sym
->attr
.intrinsic
1652 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1653 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1654 && gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1655 sym
->attr
.intrinsic
= 1;
1657 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1659 gfc_error ("Statement function '%s' at %L is not allowed as an "
1660 "actual argument", sym
->name
, &e
->where
);
1663 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1664 sym
->attr
.subroutine
);
1665 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1667 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1668 "actual argument", sym
->name
, &e
->where
);
1671 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1672 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1674 if (gfc_notify_std (GFC_STD_F2008
,
1675 "Fortran 2008: Internal procedure '%s' is"
1676 " used as actual argument at %L",
1677 sym
->name
, &e
->where
) == FAILURE
)
1681 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1683 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1684 "allowed as an actual argument at %L", sym
->name
,
1688 /* Check if a generic interface has a specific procedure
1689 with the same name before emitting an error. */
1690 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1693 /* Just in case a specific was found for the expression. */
1694 sym
= e
->symtree
->n
.sym
;
1696 /* If the symbol is the function that names the current (or
1697 parent) scope, then we really have a variable reference. */
1699 if (gfc_is_function_return_value (sym
, sym
->ns
))
1702 /* If all else fails, see if we have a specific intrinsic. */
1703 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1705 gfc_intrinsic_sym
*isym
;
1707 isym
= gfc_find_function (sym
->name
);
1708 if (isym
== NULL
|| !isym
->specific
)
1710 gfc_error ("Unable to find a specific INTRINSIC procedure "
1711 "for the reference '%s' at %L", sym
->name
,
1716 sym
->attr
.intrinsic
= 1;
1717 sym
->attr
.function
= 1;
1720 if (gfc_resolve_expr (e
) == FAILURE
)
1725 /* See if the name is a module procedure in a parent unit. */
1727 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1730 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1732 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1736 if (parent_st
== NULL
)
1739 sym
= parent_st
->n
.sym
;
1740 e
->symtree
= parent_st
; /* Point to the right thing. */
1742 if (sym
->attr
.flavor
== FL_PROCEDURE
1743 || sym
->attr
.intrinsic
1744 || sym
->attr
.external
)
1746 if (gfc_resolve_expr (e
) == FAILURE
)
1752 e
->expr_type
= EXPR_VARIABLE
;
1754 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1755 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1756 && CLASS_DATA (sym
)->as
))
1758 e
->rank
= sym
->ts
.type
== BT_CLASS
1759 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1760 e
->ref
= gfc_get_ref ();
1761 e
->ref
->type
= REF_ARRAY
;
1762 e
->ref
->u
.ar
.type
= AR_FULL
;
1763 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1764 ? CLASS_DATA (sym
)->as
: sym
->as
;
1767 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1768 primary.c (match_actual_arg). If above code determines that it
1769 is a variable instead, it needs to be resolved as it was not
1770 done at the beginning of this function. */
1771 save_need_full_assumed_size
= need_full_assumed_size
;
1772 if (e
->expr_type
!= EXPR_VARIABLE
)
1773 need_full_assumed_size
= 0;
1774 if (gfc_resolve_expr (e
) != SUCCESS
)
1776 need_full_assumed_size
= save_need_full_assumed_size
;
1779 /* Check argument list functions %VAL, %LOC and %REF. There is
1780 nothing to do for %REF. */
1781 if (arg
->name
&& arg
->name
[0] == '%')
1783 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1785 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1787 gfc_error ("By-value argument at %L is not of numeric "
1794 gfc_error ("By-value argument at %L cannot be an array or "
1795 "an array section", &e
->where
);
1799 /* Intrinsics are still PROC_UNKNOWN here. However,
1800 since same file external procedures are not resolvable
1801 in gfortran, it is a good deal easier to leave them to
1803 if (ptype
!= PROC_UNKNOWN
1804 && ptype
!= PROC_DUMMY
1805 && ptype
!= PROC_EXTERNAL
1806 && ptype
!= PROC_MODULE
)
1808 gfc_error ("By-value argument at %L is not allowed "
1809 "in this context", &e
->where
);
1814 /* Statement functions have already been excluded above. */
1815 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1816 && e
->ts
.type
== BT_PROCEDURE
)
1818 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1820 gfc_error ("Passing internal procedure at %L by location "
1821 "not allowed", &e
->where
);
1827 /* Fortran 2008, C1237. */
1828 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1829 && gfc_has_ultimate_pointer (e
))
1831 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1832 "component", &e
->where
);
1836 assumed_type_expr_allowed
= false;
1842 /* Do the checks of the actual argument list that are specific to elemental
1843 procedures. If called with c == NULL, we have a function, otherwise if
1844 expr == NULL, we have a subroutine. */
1847 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1849 gfc_actual_arglist
*arg0
;
1850 gfc_actual_arglist
*arg
;
1851 gfc_symbol
*esym
= NULL
;
1852 gfc_intrinsic_sym
*isym
= NULL
;
1854 gfc_intrinsic_arg
*iformal
= NULL
;
1855 gfc_formal_arglist
*eformal
= NULL
;
1856 bool formal_optional
= false;
1857 bool set_by_optional
= false;
1861 /* Is this an elemental procedure? */
1862 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1864 if (expr
->value
.function
.esym
!= NULL
1865 && expr
->value
.function
.esym
->attr
.elemental
)
1867 arg0
= expr
->value
.function
.actual
;
1868 esym
= expr
->value
.function
.esym
;
1870 else if (expr
->value
.function
.isym
!= NULL
1871 && expr
->value
.function
.isym
->elemental
)
1873 arg0
= expr
->value
.function
.actual
;
1874 isym
= expr
->value
.function
.isym
;
1879 else if (c
&& c
->ext
.actual
!= NULL
)
1881 arg0
= c
->ext
.actual
;
1883 if (c
->resolved_sym
)
1884 esym
= c
->resolved_sym
;
1886 esym
= c
->symtree
->n
.sym
;
1889 if (!esym
->attr
.elemental
)
1895 /* The rank of an elemental is the rank of its array argument(s). */
1896 for (arg
= arg0
; arg
; arg
= arg
->next
)
1898 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1900 rank
= arg
->expr
->rank
;
1901 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1902 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1903 set_by_optional
= true;
1905 /* Function specific; set the result rank and shape. */
1909 if (!expr
->shape
&& arg
->expr
->shape
)
1911 expr
->shape
= gfc_get_shape (rank
);
1912 for (i
= 0; i
< rank
; i
++)
1913 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1920 /* If it is an array, it shall not be supplied as an actual argument
1921 to an elemental procedure unless an array of the same rank is supplied
1922 as an actual argument corresponding to a nonoptional dummy argument of
1923 that elemental procedure(12.4.1.5). */
1924 formal_optional
= false;
1926 iformal
= isym
->formal
;
1928 eformal
= esym
->formal
;
1930 for (arg
= arg0
; arg
; arg
= arg
->next
)
1934 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1935 formal_optional
= true;
1936 eformal
= eformal
->next
;
1938 else if (isym
&& iformal
)
1940 if (iformal
->optional
)
1941 formal_optional
= true;
1942 iformal
= iformal
->next
;
1945 formal_optional
= true;
1947 if (pedantic
&& arg
->expr
!= NULL
1948 && arg
->expr
->expr_type
== EXPR_VARIABLE
1949 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1952 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1953 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1955 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1956 "MISSING, it cannot be the actual argument of an "
1957 "ELEMENTAL procedure unless there is a non-optional "
1958 "argument with the same rank (12.4.1.5)",
1959 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1963 for (arg
= arg0
; arg
; arg
= arg
->next
)
1965 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1968 /* Being elemental, the last upper bound of an assumed size array
1969 argument must be present. */
1970 if (resolve_assumed_size_actual (arg
->expr
))
1973 /* Elemental procedure's array actual arguments must conform. */
1976 if (gfc_check_conformance (arg
->expr
, e
,
1977 "elemental procedure") == FAILURE
)
1984 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1985 is an array, the intent inout/out variable needs to be also an array. */
1986 if (rank
> 0 && esym
&& expr
== NULL
)
1987 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1988 arg
= arg
->next
, eformal
= eformal
->next
)
1989 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1990 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1991 && arg
->expr
&& arg
->expr
->rank
== 0)
1993 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1994 "ELEMENTAL subroutine '%s' is a scalar, but another "
1995 "actual argument is an array", &arg
->expr
->where
,
1996 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1997 : "INOUT", eformal
->sym
->name
, esym
->name
);
2004 /* This function does the checking of references to global procedures
2005 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2006 77 and 95 standards. It checks for a gsymbol for the name, making
2007 one if it does not already exist. If it already exists, then the
2008 reference being resolved must correspond to the type of gsymbol.
2009 Otherwise, the new symbol is equipped with the attributes of the
2010 reference. The corresponding code that is called in creating
2011 global entities is parse.c.
2013 In addition, for all but -std=legacy, the gsymbols are used to
2014 check the interfaces of external procedures from the same file.
2015 The namespace of the gsymbol is resolved and then, once this is
2016 done the interface is checked. */
2020 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2022 if (!gsym_ns
->proc_name
->attr
.recursive
)
2025 if (sym
->ns
== gsym_ns
)
2028 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2035 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2037 if (gsym_ns
->entries
)
2039 gfc_entry_list
*entry
= gsym_ns
->entries
;
2041 for (; entry
; entry
= entry
->next
)
2043 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2045 if (strcmp (gsym_ns
->proc_name
->name
,
2046 sym
->ns
->proc_name
->name
) == 0)
2050 && strcmp (gsym_ns
->proc_name
->name
,
2051 sym
->ns
->parent
->proc_name
->name
) == 0)
2060 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2061 gfc_actual_arglist
**actual
, int sub
)
2065 enum gfc_symbol_type type
;
2067 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2069 gsym
= gfc_get_gsymbol (sym
->name
);
2071 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2072 gfc_global_used (gsym
, where
);
2074 if (gfc_option
.flag_whole_file
2075 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2076 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2077 && gsym
->type
!= GSYM_UNKNOWN
2079 && gsym
->ns
->resolved
!= -1
2080 && gsym
->ns
->proc_name
2081 && not_in_recursive (sym
, gsym
->ns
)
2082 && not_entry_self_reference (sym
, gsym
->ns
))
2084 gfc_symbol
*def_sym
;
2086 /* Resolve the gsymbol namespace if needed. */
2087 if (!gsym
->ns
->resolved
)
2089 gfc_dt_list
*old_dt_list
;
2090 struct gfc_omp_saved_state old_omp_state
;
2092 /* Stash away derived types so that the backend_decls do not
2094 old_dt_list
= gfc_derived_types
;
2095 gfc_derived_types
= NULL
;
2096 /* And stash away openmp state. */
2097 gfc_omp_save_and_clear_state (&old_omp_state
);
2099 gfc_resolve (gsym
->ns
);
2101 /* Store the new derived types with the global namespace. */
2102 if (gfc_derived_types
)
2103 gsym
->ns
->derived_types
= gfc_derived_types
;
2105 /* Restore the derived types of this namespace. */
2106 gfc_derived_types
= old_dt_list
;
2107 /* And openmp state. */
2108 gfc_omp_restore_state (&old_omp_state
);
2111 /* Make sure that translation for the gsymbol occurs before
2112 the procedure currently being resolved. */
2113 ns
= gfc_global_ns_list
;
2114 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2116 if (ns
->sibling
== gsym
->ns
)
2118 ns
->sibling
= gsym
->ns
->sibling
;
2119 gsym
->ns
->sibling
= gfc_global_ns_list
;
2120 gfc_global_ns_list
= gsym
->ns
;
2125 def_sym
= gsym
->ns
->proc_name
;
2126 if (def_sym
->attr
.entry_master
)
2128 gfc_entry_list
*entry
;
2129 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2130 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2132 def_sym
= entry
->sym
;
2137 /* Differences in constant character lengths. */
2138 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2140 long int l1
= 0, l2
= 0;
2141 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2142 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2145 && cl1
->length
!= NULL
2146 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2147 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2150 && cl2
->length
!= NULL
2151 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2152 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2154 if (l1
&& l2
&& l1
!= l2
)
2155 gfc_error ("Character length mismatch in return type of "
2156 "function '%s' at %L (%ld/%ld)", sym
->name
,
2157 &sym
->declared_at
, l1
, l2
);
2160 /* Type mismatch of function return type and expected type. */
2161 if (sym
->attr
.function
2162 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2163 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2164 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2165 gfc_typename (&def_sym
->ts
));
2167 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2169 gfc_formal_arglist
*arg
= def_sym
->formal
;
2170 for ( ; arg
; arg
= arg
->next
)
2173 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2174 else if (arg
->sym
->attr
.allocatable
2175 || arg
->sym
->attr
.asynchronous
2176 || arg
->sym
->attr
.optional
2177 || arg
->sym
->attr
.pointer
2178 || arg
->sym
->attr
.target
2179 || arg
->sym
->attr
.value
2180 || arg
->sym
->attr
.volatile_
)
2182 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2183 "has an attribute that requires an explicit "
2184 "interface for this procedure", arg
->sym
->name
,
2185 sym
->name
, &sym
->declared_at
);
2188 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2189 else if (arg
->sym
&& arg
->sym
->as
2190 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2192 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2193 "argument '%s' must have an explicit interface",
2194 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2197 /* F2008, 12.4.2.2 (2c) */
2198 else if (arg
->sym
->attr
.codimension
)
2200 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2201 "'%s' must have an explicit interface",
2202 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2205 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2206 else if (false) /* TODO: is a parametrized derived type */
2208 gfc_error ("Procedure '%s' at %L with parametrized derived "
2209 "type argument '%s' must have an explicit "
2210 "interface", sym
->name
, &sym
->declared_at
,
2214 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2215 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2217 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2218 "argument '%s' must have an explicit interface",
2219 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2224 if (def_sym
->attr
.function
)
2226 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2227 if (def_sym
->as
&& def_sym
->as
->rank
2228 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2229 gfc_error ("The reference to function '%s' at %L either needs an "
2230 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2233 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2234 if ((def_sym
->result
->attr
.pointer
2235 || def_sym
->result
->attr
.allocatable
)
2236 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2237 || def_sym
->result
->attr
.pointer
2238 != sym
->result
->attr
.pointer
2239 || def_sym
->result
->attr
.allocatable
2240 != sym
->result
->attr
.allocatable
))
2241 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2242 "result must have an explicit interface", sym
->name
,
2245 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2246 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2247 && def_sym
->ts
.type
== BT_CHARACTER
&& def_sym
->ts
.u
.cl
->length
!= NULL
)
2249 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2251 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2252 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2254 gfc_error ("Nonconstant character-length function '%s' at %L "
2255 "must have an explicit interface", sym
->name
,
2261 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2262 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2264 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2265 "interface", sym
->name
, &sym
->declared_at
);
2268 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2269 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2271 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2272 "an explicit interface", sym
->name
, &sym
->declared_at
);
2275 if (gfc_option
.flag_whole_file
== 1
2276 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2277 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2278 gfc_errors_to_warnings (1);
2280 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2281 gfc_procedure_use (def_sym
, actual
, where
);
2283 gfc_errors_to_warnings (0);
2286 if (gsym
->type
== GSYM_UNKNOWN
)
2289 gsym
->where
= *where
;
2296 /************* Function resolution *************/
2298 /* Resolve a function call known to be generic.
2299 Section 14.1.2.4.1. */
2302 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2306 if (sym
->attr
.generic
)
2308 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2311 expr
->value
.function
.name
= s
->name
;
2312 expr
->value
.function
.esym
= s
;
2314 if (s
->ts
.type
!= BT_UNKNOWN
)
2316 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2317 expr
->ts
= s
->result
->ts
;
2320 expr
->rank
= s
->as
->rank
;
2321 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2322 expr
->rank
= s
->result
->as
->rank
;
2324 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2329 /* TODO: Need to search for elemental references in generic
2333 if (sym
->attr
.intrinsic
)
2334 return gfc_intrinsic_func_interface (expr
, 0);
2341 resolve_generic_f (gfc_expr
*expr
)
2345 gfc_interface
*intr
= NULL
;
2347 sym
= expr
->symtree
->n
.sym
;
2351 m
= resolve_generic_f0 (expr
, sym
);
2354 else if (m
== MATCH_ERROR
)
2359 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2360 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2363 if (sym
->ns
->parent
== NULL
)
2365 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2369 if (!generic_sym (sym
))
2373 /* Last ditch attempt. See if the reference is to an intrinsic
2374 that possesses a matching interface. 14.1.2.4 */
2375 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2377 gfc_error ("There is no specific function for the generic '%s' "
2378 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2384 if (gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
, NULL
,
2387 return resolve_structure_cons (expr
, 0);
2390 m
= gfc_intrinsic_func_interface (expr
, 0);
2395 gfc_error ("Generic function '%s' at %L is not consistent with a "
2396 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2403 /* Resolve a function call known to be specific. */
2406 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2410 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2412 if (sym
->attr
.dummy
)
2414 sym
->attr
.proc
= PROC_DUMMY
;
2418 sym
->attr
.proc
= PROC_EXTERNAL
;
2422 if (sym
->attr
.proc
== PROC_MODULE
2423 || sym
->attr
.proc
== PROC_ST_FUNCTION
2424 || sym
->attr
.proc
== PROC_INTERNAL
)
2427 if (sym
->attr
.intrinsic
)
2429 m
= gfc_intrinsic_func_interface (expr
, 1);
2433 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2434 "with an intrinsic", sym
->name
, &expr
->where
);
2442 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2445 expr
->ts
= sym
->result
->ts
;
2448 expr
->value
.function
.name
= sym
->name
;
2449 expr
->value
.function
.esym
= sym
;
2450 if (sym
->as
!= NULL
)
2451 expr
->rank
= sym
->as
->rank
;
2458 resolve_specific_f (gfc_expr
*expr
)
2463 sym
= expr
->symtree
->n
.sym
;
2467 m
= resolve_specific_f0 (sym
, expr
);
2470 if (m
== MATCH_ERROR
)
2473 if (sym
->ns
->parent
== NULL
)
2476 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2482 gfc_error ("Unable to resolve the specific function '%s' at %L",
2483 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2489 /* Resolve a procedure call not known to be generic nor specific. */
2492 resolve_unknown_f (gfc_expr
*expr
)
2497 sym
= expr
->symtree
->n
.sym
;
2499 if (sym
->attr
.dummy
)
2501 sym
->attr
.proc
= PROC_DUMMY
;
2502 expr
->value
.function
.name
= sym
->name
;
2506 /* See if we have an intrinsic function reference. */
2508 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2510 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2515 /* The reference is to an external name. */
2517 sym
->attr
.proc
= PROC_EXTERNAL
;
2518 expr
->value
.function
.name
= sym
->name
;
2519 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2521 if (sym
->as
!= NULL
)
2522 expr
->rank
= sym
->as
->rank
;
2524 /* Type of the expression is either the type of the symbol or the
2525 default type of the symbol. */
2528 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2530 if (sym
->ts
.type
!= BT_UNKNOWN
)
2534 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2536 if (ts
->type
== BT_UNKNOWN
)
2538 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2539 sym
->name
, &expr
->where
);
2550 /* Return true, if the symbol is an external procedure. */
2552 is_external_proc (gfc_symbol
*sym
)
2554 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2555 && !(sym
->attr
.intrinsic
2556 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
2557 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2558 && !sym
->attr
.proc_pointer
2559 && !sym
->attr
.use_assoc
2567 /* Figure out if a function reference is pure or not. Also set the name
2568 of the function for a potential error message. Return nonzero if the
2569 function is PURE, zero if not. */
2571 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2574 pure_function (gfc_expr
*e
, const char **name
)
2580 if (e
->symtree
!= NULL
2581 && e
->symtree
->n
.sym
!= NULL
2582 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2583 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2585 if (e
->value
.function
.esym
)
2587 pure
= gfc_pure (e
->value
.function
.esym
);
2588 *name
= e
->value
.function
.esym
->name
;
2590 else if (e
->value
.function
.isym
)
2592 pure
= e
->value
.function
.isym
->pure
2593 || e
->value
.function
.isym
->elemental
;
2594 *name
= e
->value
.function
.isym
->name
;
2598 /* Implicit functions are not pure. */
2600 *name
= e
->value
.function
.name
;
2608 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2609 int *f ATTRIBUTE_UNUSED
)
2613 /* Don't bother recursing into other statement functions
2614 since they will be checked individually for purity. */
2615 if (e
->expr_type
!= EXPR_FUNCTION
2617 || e
->symtree
->n
.sym
== sym
2618 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2621 return pure_function (e
, &name
) ? false : true;
2626 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2628 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2633 is_scalar_expr_ptr (gfc_expr
*expr
)
2635 gfc_try retval
= SUCCESS
;
2640 /* See if we have a gfc_ref, which means we have a substring, array
2641 reference, or a component. */
2642 if (expr
->ref
!= NULL
)
2645 while (ref
->next
!= NULL
)
2651 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2652 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2657 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2659 else if (ref
->u
.ar
.type
== AR_FULL
)
2661 /* The user can give a full array if the array is of size 1. */
2662 if (ref
->u
.ar
.as
!= NULL
2663 && ref
->u
.ar
.as
->rank
== 1
2664 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2665 && ref
->u
.ar
.as
->lower
[0] != NULL
2666 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2667 && ref
->u
.ar
.as
->upper
[0] != NULL
2668 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2670 /* If we have a character string, we need to check if
2671 its length is one. */
2672 if (expr
->ts
.type
== BT_CHARACTER
)
2674 if (expr
->ts
.u
.cl
== NULL
2675 || expr
->ts
.u
.cl
->length
== NULL
2676 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2682 /* We have constant lower and upper bounds. If the
2683 difference between is 1, it can be considered a
2685 FIXME: Use gfc_dep_compare_expr instead. */
2686 start
= (int) mpz_get_si
2687 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2688 end
= (int) mpz_get_si
2689 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2690 if (end
- start
+ 1 != 1)
2705 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2707 /* Character string. Make sure it's of length 1. */
2708 if (expr
->ts
.u
.cl
== NULL
2709 || expr
->ts
.u
.cl
->length
== NULL
2710 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2713 else if (expr
->rank
!= 0)
2720 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2721 and, in the case of c_associated, set the binding label based on
2725 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2726 gfc_symbol
**new_sym
)
2728 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2729 int optional_arg
= 0;
2730 gfc_try retval
= SUCCESS
;
2731 gfc_symbol
*args_sym
;
2732 gfc_typespec
*arg_ts
;
2733 symbol_attribute arg_attr
;
2735 if (args
->expr
->expr_type
== EXPR_CONSTANT
2736 || args
->expr
->expr_type
== EXPR_OP
2737 || args
->expr
->expr_type
== EXPR_NULL
)
2739 gfc_error ("Argument to '%s' at %L is not a variable",
2740 sym
->name
, &(args
->expr
->where
));
2744 args_sym
= args
->expr
->symtree
->n
.sym
;
2746 /* The typespec for the actual arg should be that stored in the expr
2747 and not necessarily that of the expr symbol (args_sym), because
2748 the actual expression could be a part-ref of the expr symbol. */
2749 arg_ts
= &(args
->expr
->ts
);
2750 arg_attr
= gfc_expr_attr (args
->expr
);
2752 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2754 /* If the user gave two args then they are providing something for
2755 the optional arg (the second cptr). Therefore, set the name and
2756 binding label to the c_associated for two cptrs. Otherwise,
2757 set c_associated to expect one cptr. */
2761 sprintf (name
, "%s_2", sym
->name
);
2767 sprintf (name
, "%s_1", sym
->name
);
2771 /* Get a new symbol for the version of c_associated that
2773 *new_sym
= get_iso_c_sym (sym
, name
, NULL
, optional_arg
);
2775 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2776 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2778 sprintf (name
, "%s", sym
->name
);
2780 /* Error check the call. */
2781 if (args
->next
!= NULL
)
2783 gfc_error_now ("More actual than formal arguments in '%s' "
2784 "call at %L", name
, &(args
->expr
->where
));
2787 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2792 /* Make sure we have either the target or pointer attribute. */
2793 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2795 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2796 "a TARGET or an associated pointer",
2798 sym
->name
, &(args
->expr
->where
));
2802 if (gfc_is_coindexed (args
->expr
))
2804 gfc_error_now ("Coindexed argument not permitted"
2805 " in '%s' call at %L", name
,
2806 &(args
->expr
->where
));
2810 /* Follow references to make sure there are no array
2812 seen_section
= false;
2814 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2816 if (ref
->type
== REF_ARRAY
)
2818 if (ref
->u
.ar
.type
== AR_SECTION
)
2819 seen_section
= true;
2821 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2824 for (r
= ref
->next
; r
; r
=r
->next
)
2825 if (r
->type
== REF_COMPONENT
)
2827 gfc_error_now ("Array section not permitted"
2828 " in '%s' call at %L", name
,
2829 &(args
->expr
->where
));
2837 if (seen_section
&& retval
== SUCCESS
)
2838 gfc_warning ("Array section in '%s' call at %L", name
,
2839 &(args
->expr
->where
));
2841 /* See if we have interoperable type and type param. */
2842 if (gfc_verify_c_interop (arg_ts
) == SUCCESS
2843 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2845 if (args_sym
->attr
.target
== 1)
2847 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2848 has the target attribute and is interoperable. */
2849 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2850 allocatable variable that has the TARGET attribute and
2851 is not an array of zero size. */
2852 if (args_sym
->attr
.allocatable
== 1)
2854 if (args_sym
->attr
.dimension
!= 0
2855 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2857 gfc_error_now ("Allocatable variable '%s' used as a "
2858 "parameter to '%s' at %L must not be "
2859 "an array of zero size",
2860 args_sym
->name
, sym
->name
,
2861 &(args
->expr
->where
));
2867 /* A non-allocatable target variable with C
2868 interoperable type and type parameters must be
2870 if (args_sym
&& args_sym
->attr
.dimension
)
2872 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2874 gfc_error ("Assumed-shape array '%s' at %L "
2875 "cannot be an argument to the "
2876 "procedure '%s' because "
2877 "it is not C interoperable",
2879 &(args
->expr
->where
), sym
->name
);
2882 else if (args_sym
->as
->type
== AS_DEFERRED
)
2884 gfc_error ("Deferred-shape array '%s' at %L "
2885 "cannot be an argument to the "
2886 "procedure '%s' because "
2887 "it is not C interoperable",
2889 &(args
->expr
->where
), sym
->name
);
2894 /* Make sure it's not a character string. Arrays of
2895 any type should be ok if the variable is of a C
2896 interoperable type. */
2897 if (arg_ts
->type
== BT_CHARACTER
)
2898 if (arg_ts
->u
.cl
!= NULL
2899 && (arg_ts
->u
.cl
->length
== NULL
2900 || arg_ts
->u
.cl
->length
->expr_type
2903 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2905 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2907 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2908 "at %L must have a length of 1",
2909 args_sym
->name
, sym
->name
,
2910 &(args
->expr
->where
));
2915 else if (arg_attr
.pointer
2916 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2918 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2920 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2921 "associated scalar POINTER", args_sym
->name
,
2922 sym
->name
, &(args
->expr
->where
));
2928 /* The parameter is not required to be C interoperable. If it
2929 is not C interoperable, it must be a nonpolymorphic scalar
2930 with no length type parameters. It still must have either
2931 the pointer or target attribute, and it can be
2932 allocatable (but must be allocated when c_loc is called). */
2933 if (args
->expr
->rank
!= 0
2934 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2936 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2937 "scalar", args_sym
->name
, sym
->name
,
2938 &(args
->expr
->where
));
2941 else if (arg_ts
->type
== BT_CHARACTER
2942 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2944 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2945 "%L must have a length of 1",
2946 args_sym
->name
, sym
->name
,
2947 &(args
->expr
->where
));
2950 else if (arg_ts
->type
== BT_CLASS
)
2952 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2953 "polymorphic", args_sym
->name
, sym
->name
,
2954 &(args
->expr
->where
));
2959 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2961 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2963 /* TODO: Update this error message to allow for procedure
2964 pointers once they are implemented. */
2965 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2967 args_sym
->name
, sym
->name
,
2968 &(args
->expr
->where
));
2971 else if (args_sym
->attr
.is_bind_c
!= 1)
2973 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2975 args_sym
->name
, sym
->name
,
2976 &(args
->expr
->where
));
2981 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2986 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2987 "iso_c_binding function: '%s'!\n", sym
->name
);
2994 /* Resolve a function call, which means resolving the arguments, then figuring
2995 out which entity the name refers to. */
2998 resolve_function (gfc_expr
*expr
)
3000 gfc_actual_arglist
*arg
;
3005 procedure_type p
= PROC_INTRINSIC
;
3006 bool no_formal_args
;
3010 sym
= expr
->symtree
->n
.sym
;
3012 /* If this is a procedure pointer component, it has already been resolved. */
3013 if (gfc_is_proc_ptr_comp (expr
, NULL
))
3016 if (sym
&& sym
->attr
.intrinsic
3017 && resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
3020 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3022 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
3026 /* If this ia a deferred TBP with an abstract interface (which may
3027 of course be referenced), expr->value.function.esym will be set. */
3028 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3030 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3031 sym
->name
, &expr
->where
);
3035 /* Switch off assumed size checking and do this again for certain kinds
3036 of procedure, once the procedure itself is resolved. */
3037 need_full_assumed_size
++;
3039 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3040 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3042 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3043 inquiry_argument
= true;
3044 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
3046 if (resolve_actual_arglist (expr
->value
.function
.actual
,
3047 p
, no_formal_args
) == FAILURE
)
3049 inquiry_argument
= false;
3053 inquiry_argument
= false;
3055 /* Need to setup the call to the correct c_associated, depending on
3056 the number of cptrs to user gives to compare. */
3057 if (sym
&& sym
->attr
.is_iso_c
== 1)
3059 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
3063 /* Get the symtree for the new symbol (resolved func).
3064 the old one will be freed later, when it's no longer used. */
3065 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3068 /* Resume assumed_size checking. */
3069 need_full_assumed_size
--;
3071 /* If the procedure is external, check for usage. */
3072 if (sym
&& is_external_proc (sym
))
3073 resolve_global_procedure (sym
, &expr
->where
,
3074 &expr
->value
.function
.actual
, 0);
3076 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3078 && sym
->ts
.u
.cl
->length
== NULL
3080 && !sym
->ts
.deferred
3081 && expr
->value
.function
.esym
== NULL
3082 && !sym
->attr
.contained
)
3084 /* Internal procedures are taken care of in resolve_contained_fntype. */
3085 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3086 "be used at %L since it is not a dummy argument",
3087 sym
->name
, &expr
->where
);
3091 /* See if function is already resolved. */
3093 if (expr
->value
.function
.name
!= NULL
)
3095 if (expr
->ts
.type
== BT_UNKNOWN
)
3101 /* Apply the rules of section 14.1.2. */
3103 switch (procedure_kind (sym
))
3106 t
= resolve_generic_f (expr
);
3109 case PTYPE_SPECIFIC
:
3110 t
= resolve_specific_f (expr
);
3114 t
= resolve_unknown_f (expr
);
3118 gfc_internal_error ("resolve_function(): bad function type");
3122 /* If the expression is still a function (it might have simplified),
3123 then we check to see if we are calling an elemental function. */
3125 if (expr
->expr_type
!= EXPR_FUNCTION
)
3128 temp
= need_full_assumed_size
;
3129 need_full_assumed_size
= 0;
3131 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3134 if (omp_workshare_flag
3135 && expr
->value
.function
.esym
3136 && ! gfc_elemental (expr
->value
.function
.esym
))
3138 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3139 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3144 #define GENERIC_ID expr->value.function.isym->id
3145 else if (expr
->value
.function
.actual
!= NULL
3146 && expr
->value
.function
.isym
!= NULL
3147 && GENERIC_ID
!= GFC_ISYM_LBOUND
3148 && GENERIC_ID
!= GFC_ISYM_LEN
3149 && GENERIC_ID
!= GFC_ISYM_LOC
3150 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3152 /* Array intrinsics must also have the last upper bound of an
3153 assumed size array argument. UBOUND and SIZE have to be
3154 excluded from the check if the second argument is anything
3157 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3159 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3160 && arg
->next
!= NULL
&& arg
->next
->expr
)
3162 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3165 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3168 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3173 if (arg
->expr
!= NULL
3174 && arg
->expr
->rank
> 0
3175 && resolve_assumed_size_actual (arg
->expr
))
3181 need_full_assumed_size
= temp
;
3184 if (!pure_function (expr
, &name
) && name
)
3188 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3189 "FORALL %s", name
, &expr
->where
,
3190 forall_flag
== 2 ? "mask" : "block");
3193 else if (do_concurrent_flag
)
3195 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3196 "DO CONCURRENT %s", name
, &expr
->where
,
3197 do_concurrent_flag
== 2 ? "mask" : "block");
3200 else if (gfc_pure (NULL
))
3202 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3203 "procedure within a PURE procedure", name
, &expr
->where
);
3207 if (gfc_implicit_pure (NULL
))
3208 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3211 /* Functions without the RECURSIVE attribution are not allowed to
3212 * call themselves. */
3213 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3216 esym
= expr
->value
.function
.esym
;
3218 if (is_illegal_recursion (esym
, gfc_current_ns
))
3220 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3221 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3222 " function '%s' is not RECURSIVE",
3223 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3225 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3226 " is not RECURSIVE", esym
->name
, &expr
->where
);
3232 /* Character lengths of use associated functions may contains references to
3233 symbols not referenced from the current program unit otherwise. Make sure
3234 those symbols are marked as referenced. */
3236 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3237 && expr
->value
.function
.esym
->attr
.use_assoc
)
3239 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3242 /* Make sure that the expression has a typespec that works. */
3243 if (expr
->ts
.type
== BT_UNKNOWN
)
3245 if (expr
->symtree
->n
.sym
->result
3246 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3247 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3248 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3255 /************* Subroutine resolution *************/
3258 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3264 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3265 sym
->name
, &c
->loc
);
3266 else if (do_concurrent_flag
)
3267 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3268 "PURE", sym
->name
, &c
->loc
);
3269 else if (gfc_pure (NULL
))
3270 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3273 if (gfc_implicit_pure (NULL
))
3274 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3279 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3283 if (sym
->attr
.generic
)
3285 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3288 c
->resolved_sym
= s
;
3289 pure_subroutine (c
, s
);
3293 /* TODO: Need to search for elemental references in generic interface. */
3296 if (sym
->attr
.intrinsic
)
3297 return gfc_intrinsic_sub_interface (c
, 0);
3304 resolve_generic_s (gfc_code
*c
)
3309 sym
= c
->symtree
->n
.sym
;
3313 m
= resolve_generic_s0 (c
, sym
);
3316 else if (m
== MATCH_ERROR
)
3320 if (sym
->ns
->parent
== NULL
)
3322 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3326 if (!generic_sym (sym
))
3330 /* Last ditch attempt. See if the reference is to an intrinsic
3331 that possesses a matching interface. 14.1.2.4 */
3332 sym
= c
->symtree
->n
.sym
;
3334 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3336 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3337 sym
->name
, &c
->loc
);
3341 m
= gfc_intrinsic_sub_interface (c
, 0);
3345 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3346 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3352 /* Set the name and binding label of the subroutine symbol in the call
3353 expression represented by 'c' to include the type and kind of the
3354 second parameter. This function is for resolving the appropriate
3355 version of c_f_pointer() and c_f_procpointer(). For example, a
3356 call to c_f_pointer() for a default integer pointer could have a
3357 name of c_f_pointer_i4. If no second arg exists, which is an error
3358 for these two functions, it defaults to the generic symbol's name
3359 and binding label. */
3362 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3363 char *name
, const char **binding_label
)
3365 gfc_expr
*arg
= NULL
;
3369 /* The second arg of c_f_pointer and c_f_procpointer determines
3370 the type and kind for the procedure name. */
3371 arg
= c
->ext
.actual
->next
->expr
;
3375 /* Set up the name to have the given symbol's name,
3376 plus the type and kind. */
3377 /* a derived type is marked with the type letter 'u' */
3378 if (arg
->ts
.type
== BT_DERIVED
)
3381 kind
= 0; /* set the kind as 0 for now */
3385 type
= gfc_type_letter (arg
->ts
.type
);
3386 kind
= arg
->ts
.kind
;
3389 if (arg
->ts
.type
== BT_CHARACTER
)
3390 /* Kind info for character strings not needed. */
3393 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3394 /* Set up the binding label as the given symbol's label plus
3395 the type and kind. */
3396 *binding_label
= gfc_get_string ("%s_%c%d", sym
->binding_label
, type
,
3401 /* If the second arg is missing, set the name and label as
3402 was, cause it should at least be found, and the missing
3403 arg error will be caught by compare_parameters(). */
3404 sprintf (name
, "%s", sym
->name
);
3405 *binding_label
= sym
->binding_label
;
3412 /* Resolve a generic version of the iso_c_binding procedure given
3413 (sym) to the specific one based on the type and kind of the
3414 argument(s). Currently, this function resolves c_f_pointer() and
3415 c_f_procpointer based on the type and kind of the second argument
3416 (FPTR). Other iso_c_binding procedures aren't specially handled.
3417 Upon successfully exiting, c->resolved_sym will hold the resolved
3418 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3422 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3424 gfc_symbol
*new_sym
;
3425 /* this is fine, since we know the names won't use the max */
3426 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3427 const char* binding_label
;
3428 /* default to success; will override if find error */
3429 match m
= MATCH_YES
;
3431 /* Make sure the actual arguments are in the necessary order (based on the
3432 formal args) before resolving. */
3433 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
3435 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3436 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3438 set_name_and_label (c
, sym
, name
, &binding_label
);
3440 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3442 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3444 /* Make sure we got a third arg if the second arg has non-zero
3445 rank. We must also check that the type and rank are
3446 correct since we short-circuit this check in
3447 gfc_procedure_use() (called above to sort actual args). */
3448 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
3450 if(c
->ext
.actual
->next
->next
== NULL
3451 || c
->ext
.actual
->next
->next
->expr
== NULL
)
3454 gfc_error ("Missing SHAPE parameter for call to %s "
3455 "at %L", sym
->name
, &(c
->loc
));
3457 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
3459 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
3462 gfc_error ("SHAPE parameter for call to %s at %L must "
3463 "be a rank 1 INTEGER array", sym
->name
,
3470 if (m
!= MATCH_ERROR
)
3472 /* the 1 means to add the optional arg to formal list */
3473 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3475 /* for error reporting, say it's declared where the original was */
3476 new_sym
->declared_at
= sym
->declared_at
;
3481 /* no differences for c_loc or c_funloc */
3485 /* set the resolved symbol */
3486 if (m
!= MATCH_ERROR
)
3487 c
->resolved_sym
= new_sym
;
3489 c
->resolved_sym
= sym
;
3495 /* Resolve a subroutine call known to be specific. */
3498 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3502 if(sym
->attr
.is_iso_c
)
3504 m
= gfc_iso_c_sub_interface (c
,sym
);
3508 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3510 if (sym
->attr
.dummy
)
3512 sym
->attr
.proc
= PROC_DUMMY
;
3516 sym
->attr
.proc
= PROC_EXTERNAL
;
3520 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3523 if (sym
->attr
.intrinsic
)
3525 m
= gfc_intrinsic_sub_interface (c
, 1);
3529 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3530 "with an intrinsic", sym
->name
, &c
->loc
);
3538 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3540 c
->resolved_sym
= sym
;
3541 pure_subroutine (c
, sym
);
3548 resolve_specific_s (gfc_code
*c
)
3553 sym
= c
->symtree
->n
.sym
;
3557 m
= resolve_specific_s0 (c
, sym
);
3560 if (m
== MATCH_ERROR
)
3563 if (sym
->ns
->parent
== NULL
)
3566 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3572 sym
= c
->symtree
->n
.sym
;
3573 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3574 sym
->name
, &c
->loc
);
3580 /* Resolve a subroutine call not known to be generic nor specific. */
3583 resolve_unknown_s (gfc_code
*c
)
3587 sym
= c
->symtree
->n
.sym
;
3589 if (sym
->attr
.dummy
)
3591 sym
->attr
.proc
= PROC_DUMMY
;
3595 /* See if we have an intrinsic function reference. */
3597 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3599 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3604 /* The reference is to an external name. */
3607 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3609 c
->resolved_sym
= sym
;
3611 pure_subroutine (c
, sym
);
3617 /* Resolve a subroutine call. Although it was tempting to use the same code
3618 for functions, subroutines and functions are stored differently and this
3619 makes things awkward. */
3622 resolve_call (gfc_code
*c
)
3625 procedure_type ptype
= PROC_INTRINSIC
;
3626 gfc_symbol
*csym
, *sym
;
3627 bool no_formal_args
;
3629 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3631 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3633 gfc_error ("'%s' at %L has a type, which is not consistent with "
3634 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3638 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3641 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3642 sym
= st
? st
->n
.sym
: NULL
;
3643 if (sym
&& csym
!= sym
3644 && sym
->ns
== gfc_current_ns
3645 && sym
->attr
.flavor
== FL_PROCEDURE
3646 && sym
->attr
.contained
)
3649 if (csym
->attr
.generic
)
3650 c
->symtree
->n
.sym
= sym
;
3653 csym
= c
->symtree
->n
.sym
;
3657 /* If this ia a deferred TBP with an abstract interface
3658 (which may of course be referenced), c->expr1 will be set. */
3659 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3661 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3662 csym
->name
, &c
->loc
);
3666 /* Subroutines without the RECURSIVE attribution are not allowed to
3667 * call themselves. */
3668 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3670 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3671 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3672 " subroutine '%s' is not RECURSIVE",
3673 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3675 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3676 " is not RECURSIVE", csym
->name
, &c
->loc
);
3681 /* Switch off assumed size checking and do this again for certain kinds
3682 of procedure, once the procedure itself is resolved. */
3683 need_full_assumed_size
++;
3686 ptype
= csym
->attr
.proc
;
3688 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3689 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3690 no_formal_args
) == FAILURE
)
3693 /* Resume assumed_size checking. */
3694 need_full_assumed_size
--;
3696 /* If external, check for usage. */
3697 if (csym
&& is_external_proc (csym
))
3698 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3701 if (c
->resolved_sym
== NULL
)
3703 c
->resolved_isym
= NULL
;
3704 switch (procedure_kind (csym
))
3707 t
= resolve_generic_s (c
);
3710 case PTYPE_SPECIFIC
:
3711 t
= resolve_specific_s (c
);
3715 t
= resolve_unknown_s (c
);
3719 gfc_internal_error ("resolve_subroutine(): bad function type");
3723 /* Some checks of elemental subroutine actual arguments. */
3724 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3731 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3732 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3733 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3734 if their shapes do not match. If either op1->shape or op2->shape is
3735 NULL, return SUCCESS. */
3738 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3745 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3747 for (i
= 0; i
< op1
->rank
; i
++)
3749 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3751 gfc_error ("Shapes for operands at %L and %L are not conformable",
3752 &op1
->where
, &op2
->where
);
3763 /* Resolve an operator expression node. This can involve replacing the
3764 operation with a user defined function call. */
3767 resolve_operator (gfc_expr
*e
)
3769 gfc_expr
*op1
, *op2
;
3771 bool dual_locus_error
;
3774 /* Resolve all subnodes-- give them types. */
3776 switch (e
->value
.op
.op
)
3779 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3782 /* Fall through... */
3785 case INTRINSIC_UPLUS
:
3786 case INTRINSIC_UMINUS
:
3787 case INTRINSIC_PARENTHESES
:
3788 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3793 /* Typecheck the new node. */
3795 op1
= e
->value
.op
.op1
;
3796 op2
= e
->value
.op
.op2
;
3797 dual_locus_error
= false;
3799 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3800 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3802 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3806 switch (e
->value
.op
.op
)
3808 case INTRINSIC_UPLUS
:
3809 case INTRINSIC_UMINUS
:
3810 if (op1
->ts
.type
== BT_INTEGER
3811 || op1
->ts
.type
== BT_REAL
3812 || op1
->ts
.type
== BT_COMPLEX
)
3818 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3819 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3822 case INTRINSIC_PLUS
:
3823 case INTRINSIC_MINUS
:
3824 case INTRINSIC_TIMES
:
3825 case INTRINSIC_DIVIDE
:
3826 case INTRINSIC_POWER
:
3827 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3829 gfc_type_convert_binary (e
, 1);
3834 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3835 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3836 gfc_typename (&op2
->ts
));
3839 case INTRINSIC_CONCAT
:
3840 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3841 && op1
->ts
.kind
== op2
->ts
.kind
)
3843 e
->ts
.type
= BT_CHARACTER
;
3844 e
->ts
.kind
= op1
->ts
.kind
;
3849 _("Operands of string concatenation operator at %%L are %s/%s"),
3850 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3856 case INTRINSIC_NEQV
:
3857 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3859 e
->ts
.type
= BT_LOGICAL
;
3860 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3861 if (op1
->ts
.kind
< e
->ts
.kind
)
3862 gfc_convert_type (op1
, &e
->ts
, 2);
3863 else if (op2
->ts
.kind
< e
->ts
.kind
)
3864 gfc_convert_type (op2
, &e
->ts
, 2);
3868 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3869 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3870 gfc_typename (&op2
->ts
));
3875 if (op1
->ts
.type
== BT_LOGICAL
)
3877 e
->ts
.type
= BT_LOGICAL
;
3878 e
->ts
.kind
= op1
->ts
.kind
;
3882 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3883 gfc_typename (&op1
->ts
));
3887 case INTRINSIC_GT_OS
:
3889 case INTRINSIC_GE_OS
:
3891 case INTRINSIC_LT_OS
:
3893 case INTRINSIC_LE_OS
:
3894 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3896 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3900 /* Fall through... */
3903 case INTRINSIC_EQ_OS
:
3905 case INTRINSIC_NE_OS
:
3906 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3907 && op1
->ts
.kind
== op2
->ts
.kind
)
3909 e
->ts
.type
= BT_LOGICAL
;
3910 e
->ts
.kind
= gfc_default_logical_kind
;
3914 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3916 gfc_type_convert_binary (e
, 1);
3918 e
->ts
.type
= BT_LOGICAL
;
3919 e
->ts
.kind
= gfc_default_logical_kind
;
3923 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3925 _("Logicals at %%L must be compared with %s instead of %s"),
3926 (e
->value
.op
.op
== INTRINSIC_EQ
3927 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3928 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3931 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3932 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3933 gfc_typename (&op2
->ts
));
3937 case INTRINSIC_USER
:
3938 if (e
->value
.op
.uop
->op
== NULL
)
3939 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3940 else if (op2
== NULL
)
3941 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3942 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3945 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3946 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3947 gfc_typename (&op2
->ts
));
3948 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3953 case INTRINSIC_PARENTHESES
:
3955 if (e
->ts
.type
== BT_CHARACTER
)
3956 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3960 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3963 /* Deal with arrayness of an operand through an operator. */
3967 switch (e
->value
.op
.op
)
3969 case INTRINSIC_PLUS
:
3970 case INTRINSIC_MINUS
:
3971 case INTRINSIC_TIMES
:
3972 case INTRINSIC_DIVIDE
:
3973 case INTRINSIC_POWER
:
3974 case INTRINSIC_CONCAT
:
3978 case INTRINSIC_NEQV
:
3980 case INTRINSIC_EQ_OS
:
3982 case INTRINSIC_NE_OS
:
3984 case INTRINSIC_GT_OS
:
3986 case INTRINSIC_GE_OS
:
3988 case INTRINSIC_LT_OS
:
3990 case INTRINSIC_LE_OS
:
3992 if (op1
->rank
== 0 && op2
->rank
== 0)
3995 if (op1
->rank
== 0 && op2
->rank
!= 0)
3997 e
->rank
= op2
->rank
;
3999 if (e
->shape
== NULL
)
4000 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4003 if (op1
->rank
!= 0 && op2
->rank
== 0)
4005 e
->rank
= op1
->rank
;
4007 if (e
->shape
== NULL
)
4008 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4011 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4013 if (op1
->rank
== op2
->rank
)
4015 e
->rank
= op1
->rank
;
4016 if (e
->shape
== NULL
)
4018 t
= compare_shapes (op1
, op2
);
4022 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4027 /* Allow higher level expressions to work. */
4030 /* Try user-defined operators, and otherwise throw an error. */
4031 dual_locus_error
= true;
4033 _("Inconsistent ranks for operator at %%L and %%L"));
4040 case INTRINSIC_PARENTHESES
:
4042 case INTRINSIC_UPLUS
:
4043 case INTRINSIC_UMINUS
:
4044 /* Simply copy arrayness attribute */
4045 e
->rank
= op1
->rank
;
4047 if (e
->shape
== NULL
)
4048 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4056 /* Attempt to simplify the expression. */
4059 t
= gfc_simplify_expr (e
, 0);
4060 /* Some calls do not succeed in simplification and return FAILURE
4061 even though there is no error; e.g. variable references to
4062 PARAMETER arrays. */
4063 if (!gfc_is_constant_expr (e
))
4071 match m
= gfc_extend_expr (e
);
4074 if (m
== MATCH_ERROR
)
4078 if (dual_locus_error
)
4079 gfc_error (msg
, &op1
->where
, &op2
->where
);
4081 gfc_error (msg
, &e
->where
);
4087 /************** Array resolution subroutines **************/
4090 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4093 /* Compare two integer expressions. */
4096 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4100 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4101 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4104 /* If either of the types isn't INTEGER, we must have
4105 raised an error earlier. */
4107 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4110 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4120 /* Compare an integer expression with an integer. */
4123 compare_bound_int (gfc_expr
*a
, int b
)
4127 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4130 if (a
->ts
.type
!= BT_INTEGER
)
4131 gfc_internal_error ("compare_bound_int(): Bad expression");
4133 i
= mpz_cmp_si (a
->value
.integer
, b
);
4143 /* Compare an integer expression with a mpz_t. */
4146 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4150 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4153 if (a
->ts
.type
!= BT_INTEGER
)
4154 gfc_internal_error ("compare_bound_int(): Bad expression");
4156 i
= mpz_cmp (a
->value
.integer
, b
);
4166 /* Compute the last value of a sequence given by a triplet.
4167 Return 0 if it wasn't able to compute the last value, or if the
4168 sequence if empty, and 1 otherwise. */
4171 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4172 gfc_expr
*stride
, mpz_t last
)
4176 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4177 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4178 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4181 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4182 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4185 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4187 if (compare_bound (start
, end
) == CMP_GT
)
4189 mpz_set (last
, end
->value
.integer
);
4193 if (compare_bound_int (stride
, 0) == CMP_GT
)
4195 /* Stride is positive */
4196 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4201 /* Stride is negative */
4202 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4207 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4208 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4209 mpz_sub (last
, end
->value
.integer
, rem
);
4216 /* Compare a single dimension of an array reference to the array
4220 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4224 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4226 gcc_assert (ar
->stride
[i
] == NULL
);
4227 /* This implies [*] as [*:] and [*:3] are not possible. */
4228 if (ar
->start
[i
] == NULL
)
4230 gcc_assert (ar
->end
[i
] == NULL
);
4235 /* Given start, end and stride values, calculate the minimum and
4236 maximum referenced indexes. */
4238 switch (ar
->dimen_type
[i
])
4241 case DIMEN_THIS_IMAGE
:
4246 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4249 gfc_warning ("Array reference at %L is out of bounds "
4250 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4251 mpz_get_si (ar
->start
[i
]->value
.integer
),
4252 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4254 gfc_warning ("Array reference at %L is out of bounds "
4255 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4256 mpz_get_si (ar
->start
[i
]->value
.integer
),
4257 mpz_get_si (as
->lower
[i
]->value
.integer
),
4261 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4264 gfc_warning ("Array reference at %L is out of bounds "
4265 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4266 mpz_get_si (ar
->start
[i
]->value
.integer
),
4267 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4269 gfc_warning ("Array reference at %L is out of bounds "
4270 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4271 mpz_get_si (ar
->start
[i
]->value
.integer
),
4272 mpz_get_si (as
->upper
[i
]->value
.integer
),
4281 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4282 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4284 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4286 /* Check for zero stride, which is not allowed. */
4287 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4289 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4293 /* if start == len || (stride > 0 && start < len)
4294 || (stride < 0 && start > len),
4295 then the array section contains at least one element. In this
4296 case, there is an out-of-bounds access if
4297 (start < lower || start > upper). */
4298 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4299 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4300 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4301 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4302 && comp_start_end
== CMP_GT
))
4304 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4306 gfc_warning ("Lower array reference at %L is out of bounds "
4307 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4308 mpz_get_si (AR_START
->value
.integer
),
4309 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4312 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4314 gfc_warning ("Lower array reference at %L is out of bounds "
4315 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4316 mpz_get_si (AR_START
->value
.integer
),
4317 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4322 /* If we can compute the highest index of the array section,
4323 then it also has to be between lower and upper. */
4324 mpz_init (last_value
);
4325 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4328 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4330 gfc_warning ("Upper array reference at %L is out of bounds "
4331 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4332 mpz_get_si (last_value
),
4333 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4334 mpz_clear (last_value
);
4337 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4339 gfc_warning ("Upper array reference at %L is out of bounds "
4340 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4341 mpz_get_si (last_value
),
4342 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4343 mpz_clear (last_value
);
4347 mpz_clear (last_value
);
4355 gfc_internal_error ("check_dimension(): Bad array reference");
4362 /* Compare an array reference with an array specification. */
4365 compare_spec_to_ref (gfc_array_ref
*ar
)
4372 /* TODO: Full array sections are only allowed as actual parameters. */
4373 if (as
->type
== AS_ASSUMED_SIZE
4374 && (/*ar->type == AR_FULL
4375 ||*/ (ar
->type
== AR_SECTION
4376 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4378 gfc_error ("Rightmost upper bound of assumed size array section "
4379 "not specified at %L", &ar
->where
);
4383 if (ar
->type
== AR_FULL
)
4386 if (as
->rank
!= ar
->dimen
)
4388 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4389 &ar
->where
, ar
->dimen
, as
->rank
);
4393 /* ar->codimen == 0 is a local array. */
4394 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4396 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4397 &ar
->where
, ar
->codimen
, as
->corank
);
4401 for (i
= 0; i
< as
->rank
; i
++)
4402 if (check_dimension (i
, ar
, as
) == FAILURE
)
4405 /* Local access has no coarray spec. */
4406 if (ar
->codimen
!= 0)
4407 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4409 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4410 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4412 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4413 i
+ 1 - as
->rank
, &ar
->where
);
4416 if (check_dimension (i
, ar
, as
) == FAILURE
)
4424 /* Resolve one part of an array index. */
4427 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4428 int force_index_integer_kind
)
4435 if (gfc_resolve_expr (index
) == FAILURE
)
4438 if (check_scalar
&& index
->rank
!= 0)
4440 gfc_error ("Array index at %L must be scalar", &index
->where
);
4444 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4446 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4447 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4451 if (index
->ts
.type
== BT_REAL
)
4452 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
4453 &index
->where
) == FAILURE
)
4456 if ((index
->ts
.kind
!= gfc_index_integer_kind
4457 && force_index_integer_kind
)
4458 || index
->ts
.type
!= BT_INTEGER
)
4461 ts
.type
= BT_INTEGER
;
4462 ts
.kind
= gfc_index_integer_kind
;
4464 gfc_convert_type_warn (index
, &ts
, 2, 0);
4470 /* Resolve one part of an array index. */
4473 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4475 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4478 /* Resolve a dim argument to an intrinsic function. */
4481 gfc_resolve_dim_arg (gfc_expr
*dim
)
4486 if (gfc_resolve_expr (dim
) == FAILURE
)
4491 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4496 if (dim
->ts
.type
!= BT_INTEGER
)
4498 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4502 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4507 ts
.type
= BT_INTEGER
;
4508 ts
.kind
= gfc_index_integer_kind
;
4510 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4516 /* Given an expression that contains array references, update those array
4517 references to point to the right array specifications. While this is
4518 filled in during matching, this information is difficult to save and load
4519 in a module, so we take care of it here.
4521 The idea here is that the original array reference comes from the
4522 base symbol. We traverse the list of reference structures, setting
4523 the stored reference to references. Component references can
4524 provide an additional array specification. */
4527 find_array_spec (gfc_expr
*e
)
4533 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4534 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4536 as
= e
->symtree
->n
.sym
->as
;
4538 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4543 gfc_internal_error ("find_array_spec(): Missing spec");
4550 c
= ref
->u
.c
.component
;
4551 if (c
->attr
.dimension
)
4554 gfc_internal_error ("find_array_spec(): unused as(1)");
4565 gfc_internal_error ("find_array_spec(): unused as(2)");
4569 /* Resolve an array reference. */
4572 resolve_array_ref (gfc_array_ref
*ar
)
4574 int i
, check_scalar
;
4577 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4579 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4581 /* Do not force gfc_index_integer_kind for the start. We can
4582 do fine with any integer kind. This avoids temporary arrays
4583 created for indexing with a vector. */
4584 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4586 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4588 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4593 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4597 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4601 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4602 if (e
->expr_type
== EXPR_VARIABLE
4603 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4604 ar
->start
[i
] = gfc_get_parentheses (e
);
4608 gfc_error ("Array index at %L is an array of rank %d",
4609 &ar
->c_where
[i
], e
->rank
);
4613 /* Fill in the upper bound, which may be lower than the
4614 specified one for something like a(2:10:5), which is
4615 identical to a(2:7:5). Only relevant for strides not equal
4616 to one. Don't try a division by zero. */
4617 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4618 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4619 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4620 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4624 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4626 if (ar
->end
[i
] == NULL
)
4629 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4631 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4633 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4634 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4636 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4647 if (ar
->type
== AR_FULL
)
4649 if (ar
->as
->rank
== 0)
4650 ar
->type
= AR_ELEMENT
;
4652 /* Make sure array is the same as array(:,:), this way
4653 we don't need to special case all the time. */
4654 ar
->dimen
= ar
->as
->rank
;
4655 for (i
= 0; i
< ar
->dimen
; i
++)
4657 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4659 gcc_assert (ar
->start
[i
] == NULL
);
4660 gcc_assert (ar
->end
[i
] == NULL
);
4661 gcc_assert (ar
->stride
[i
] == NULL
);
4665 /* If the reference type is unknown, figure out what kind it is. */
4667 if (ar
->type
== AR_UNKNOWN
)
4669 ar
->type
= AR_ELEMENT
;
4670 for (i
= 0; i
< ar
->dimen
; i
++)
4671 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4672 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4674 ar
->type
= AR_SECTION
;
4679 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4682 if (ar
->as
->corank
&& ar
->codimen
== 0)
4685 ar
->codimen
= ar
->as
->corank
;
4686 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4687 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4695 resolve_substring (gfc_ref
*ref
)
4697 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4699 if (ref
->u
.ss
.start
!= NULL
)
4701 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4704 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4706 gfc_error ("Substring start index at %L must be of type INTEGER",
4707 &ref
->u
.ss
.start
->where
);
4711 if (ref
->u
.ss
.start
->rank
!= 0)
4713 gfc_error ("Substring start index at %L must be scalar",
4714 &ref
->u
.ss
.start
->where
);
4718 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4719 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4720 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4722 gfc_error ("Substring start index at %L is less than one",
4723 &ref
->u
.ss
.start
->where
);
4728 if (ref
->u
.ss
.end
!= NULL
)
4730 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4733 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4735 gfc_error ("Substring end index at %L must be of type INTEGER",
4736 &ref
->u
.ss
.end
->where
);
4740 if (ref
->u
.ss
.end
->rank
!= 0)
4742 gfc_error ("Substring end index at %L must be scalar",
4743 &ref
->u
.ss
.end
->where
);
4747 if (ref
->u
.ss
.length
!= NULL
4748 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4749 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4750 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4752 gfc_error ("Substring end index at %L exceeds the string length",
4753 &ref
->u
.ss
.start
->where
);
4757 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4758 gfc_integer_kinds
[k
].huge
) == CMP_GT
4759 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4760 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4762 gfc_error ("Substring end index at %L is too large",
4763 &ref
->u
.ss
.end
->where
);
4772 /* This function supplies missing substring charlens. */
4775 gfc_resolve_substring_charlen (gfc_expr
*e
)
4778 gfc_expr
*start
, *end
;
4780 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4781 if (char_ref
->type
== REF_SUBSTRING
)
4787 gcc_assert (char_ref
->next
== NULL
);
4791 if (e
->ts
.u
.cl
->length
)
4792 gfc_free_expr (e
->ts
.u
.cl
->length
);
4793 else if (e
->expr_type
== EXPR_VARIABLE
4794 && e
->symtree
->n
.sym
->attr
.dummy
)
4798 e
->ts
.type
= BT_CHARACTER
;
4799 e
->ts
.kind
= gfc_default_character_kind
;
4802 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4804 if (char_ref
->u
.ss
.start
)
4805 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4807 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4809 if (char_ref
->u
.ss
.end
)
4810 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4811 else if (e
->expr_type
== EXPR_VARIABLE
)
4812 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4819 /* Length = (end - start +1). */
4820 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4821 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4822 gfc_get_int_expr (gfc_default_integer_kind
,
4825 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4826 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4828 /* Make sure that the length is simplified. */
4829 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4830 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4834 /* Resolve subtype references. */
4837 resolve_ref (gfc_expr
*expr
)
4839 int current_part_dimension
, n_components
, seen_part_dimension
;
4842 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4843 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4845 find_array_spec (expr
);
4849 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4853 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
4861 if (resolve_substring (ref
) == FAILURE
)
4866 /* Check constraints on part references. */
4868 current_part_dimension
= 0;
4869 seen_part_dimension
= 0;
4872 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4877 switch (ref
->u
.ar
.type
)
4880 /* Coarray scalar. */
4881 if (ref
->u
.ar
.as
->rank
== 0)
4883 current_part_dimension
= 0;
4888 current_part_dimension
= 1;
4892 current_part_dimension
= 0;
4896 gfc_internal_error ("resolve_ref(): Bad array reference");
4902 if (current_part_dimension
|| seen_part_dimension
)
4905 if (ref
->u
.c
.component
->attr
.pointer
4906 || ref
->u
.c
.component
->attr
.proc_pointer
4907 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4908 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4910 gfc_error ("Component to the right of a part reference "
4911 "with nonzero rank must not have the POINTER "
4912 "attribute at %L", &expr
->where
);
4915 else if (ref
->u
.c
.component
->attr
.allocatable
4916 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4917 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4920 gfc_error ("Component to the right of a part reference "
4921 "with nonzero rank must not have the ALLOCATABLE "
4922 "attribute at %L", &expr
->where
);
4934 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4935 || ref
->next
== NULL
)
4936 && current_part_dimension
4937 && seen_part_dimension
)
4939 gfc_error ("Two or more part references with nonzero rank must "
4940 "not be specified at %L", &expr
->where
);
4944 if (ref
->type
== REF_COMPONENT
)
4946 if (current_part_dimension
)
4947 seen_part_dimension
= 1;
4949 /* reset to make sure */
4950 current_part_dimension
= 0;
4958 /* Given an expression, determine its shape. This is easier than it sounds.
4959 Leaves the shape array NULL if it is not possible to determine the shape. */
4962 expression_shape (gfc_expr
*e
)
4964 mpz_t array
[GFC_MAX_DIMENSIONS
];
4967 if (e
->rank
== 0 || e
->shape
!= NULL
)
4970 for (i
= 0; i
< e
->rank
; i
++)
4971 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4974 e
->shape
= gfc_get_shape (e
->rank
);
4976 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4981 for (i
--; i
>= 0; i
--)
4982 mpz_clear (array
[i
]);
4986 /* Given a variable expression node, compute the rank of the expression by
4987 examining the base symbol and any reference structures it may have. */
4990 expression_rank (gfc_expr
*e
)
4995 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4996 could lead to serious confusion... */
4997 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5001 if (e
->expr_type
== EXPR_ARRAY
)
5003 /* Constructors can have a rank different from one via RESHAPE(). */
5005 if (e
->symtree
== NULL
)
5011 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5012 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5018 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5020 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5021 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5022 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5024 if (ref
->type
!= REF_ARRAY
)
5027 if (ref
->u
.ar
.type
== AR_FULL
)
5029 rank
= ref
->u
.ar
.as
->rank
;
5033 if (ref
->u
.ar
.type
== AR_SECTION
)
5035 /* Figure out the rank of the section. */
5037 gfc_internal_error ("expression_rank(): Two array specs");
5039 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5040 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5041 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5051 expression_shape (e
);
5055 /* Resolve a variable expression. */
5058 resolve_variable (gfc_expr
*e
)
5065 if (e
->symtree
== NULL
)
5067 sym
= e
->symtree
->n
.sym
;
5069 /* TS 29113, 407b. */
5070 if (e
->ts
.type
== BT_ASSUMED
&& !assumed_type_expr_allowed
)
5072 gfc_error ("Invalid expression with assumed-type variable %s at %L",
5073 sym
->name
, &e
->where
);
5077 /* TS 29113, 407b. */
5078 if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5079 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5080 && e
->ref
->next
== NULL
))
5082 gfc_error ("Assumed-type variable %s with designator at %L",
5083 sym
->name
, &e
->ref
->u
.ar
.where
);
5087 /* If this is an associate-name, it may be parsed with an array reference
5088 in error even though the target is scalar. Fail directly in this case.
5089 TODO Understand why class scalar expressions must be excluded. */
5090 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5092 if (sym
->ts
.type
== BT_CLASS
)
5093 gfc_fix_class_refs (e
);
5094 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5098 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5099 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5101 /* On the other hand, the parser may not have known this is an array;
5102 in this case, we have to add a FULL reference. */
5103 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5105 e
->ref
= gfc_get_ref ();
5106 e
->ref
->type
= REF_ARRAY
;
5107 e
->ref
->u
.ar
.type
= AR_FULL
;
5108 e
->ref
->u
.ar
.dimen
= 0;
5111 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
5114 if (sym
->attr
.flavor
== FL_PROCEDURE
5115 && (!sym
->attr
.function
5116 || (sym
->attr
.function
&& sym
->result
5117 && sym
->result
->attr
.proc_pointer
5118 && !sym
->result
->attr
.function
)))
5120 e
->ts
.type
= BT_PROCEDURE
;
5121 goto resolve_procedure
;
5124 if (sym
->ts
.type
!= BT_UNKNOWN
)
5125 gfc_variable_attr (e
, &e
->ts
);
5128 /* Must be a simple variable reference. */
5129 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5134 if (check_assumed_size_reference (sym
, e
))
5137 /* If a PRIVATE variable is used in the specification expression of the
5138 result variable, it might be accessed from outside the module and can
5139 thus not be TREE_PUBLIC() = 0.
5140 TODO: sym->attr.public_used only has to be set for the result variable's
5141 type-parameter expression and not for dummies or automatic variables.
5142 Additionally, it only has to be set if the function is either PUBLIC or
5143 used in a generic interface or TBP; unfortunately,
5144 proc_name->attr.public_used can get set at a later stage. */
5145 if (specification_expr
&& sym
->attr
.access
== ACCESS_PRIVATE
5146 && !sym
->attr
.function
&& !sym
->attr
.use_assoc
5147 && gfc_current_ns
->proc_name
&& gfc_current_ns
->proc_name
->attr
.function
)
5148 sym
->attr
.public_used
= 1;
5150 /* Deal with forward references to entries during resolve_code, to
5151 satisfy, at least partially, 12.5.2.5. */
5152 if (gfc_current_ns
->entries
5153 && current_entry_id
== sym
->entry_id
5156 && cs_base
->current
->op
!= EXEC_ENTRY
)
5158 gfc_entry_list
*entry
;
5159 gfc_formal_arglist
*formal
;
5163 /* If the symbol is a dummy... */
5164 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5166 entry
= gfc_current_ns
->entries
;
5169 /* ...test if the symbol is a parameter of previous entries. */
5170 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5171 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5173 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5177 /* If it has not been seen as a dummy, this is an error. */
5180 if (specification_expr
)
5181 gfc_error ("Variable '%s', used in a specification expression"
5182 ", is referenced at %L before the ENTRY statement "
5183 "in which it is a parameter",
5184 sym
->name
, &cs_base
->current
->loc
);
5186 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5187 "statement in which it is a parameter",
5188 sym
->name
, &cs_base
->current
->loc
);
5193 /* Now do the same check on the specification expressions. */
5194 specification_expr
= 1;
5195 if (sym
->ts
.type
== BT_CHARACTER
5196 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5200 for (n
= 0; n
< sym
->as
->rank
; n
++)
5202 specification_expr
= 1;
5203 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5205 specification_expr
= 1;
5206 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5209 specification_expr
= 0;
5212 /* Update the symbol's entry level. */
5213 sym
->entry_id
= current_entry_id
+ 1;
5216 /* If a symbol has been host_associated mark it. This is used latter,
5217 to identify if aliasing is possible via host association. */
5218 if (sym
->attr
.flavor
== FL_VARIABLE
5219 && gfc_current_ns
->parent
5220 && (gfc_current_ns
->parent
== sym
->ns
5221 || (gfc_current_ns
->parent
->parent
5222 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5223 sym
->attr
.host_assoc
= 1;
5226 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5229 /* F2008, C617 and C1229. */
5230 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5231 && gfc_is_coindexed (e
))
5233 gfc_ref
*ref
, *ref2
= NULL
;
5235 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5237 if (ref
->type
== REF_COMPONENT
)
5239 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5243 for ( ; ref
; ref
= ref
->next
)
5244 if (ref
->type
== REF_COMPONENT
)
5247 /* Expression itself is not coindexed object. */
5248 if (ref
&& e
->ts
.type
== BT_CLASS
)
5250 gfc_error ("Polymorphic subobject of coindexed object at %L",
5255 /* Expression itself is coindexed object. */
5259 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5260 for ( ; c
; c
= c
->next
)
5261 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5263 gfc_error ("Coindexed object with polymorphic allocatable "
5264 "subcomponent at %L", &e
->where
);
5275 /* Checks to see that the correct symbol has been host associated.
5276 The only situation where this arises is that in which a twice
5277 contained function is parsed after the host association is made.
5278 Therefore, on detecting this, change the symbol in the expression
5279 and convert the array reference into an actual arglist if the old
5280 symbol is a variable. */
5282 check_host_association (gfc_expr
*e
)
5284 gfc_symbol
*sym
, *old_sym
;
5288 gfc_actual_arglist
*arg
, *tail
= NULL
;
5289 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5291 /* If the expression is the result of substitution in
5292 interface.c(gfc_extend_expr) because there is no way in
5293 which the host association can be wrong. */
5294 if (e
->symtree
== NULL
5295 || e
->symtree
->n
.sym
== NULL
5296 || e
->user_operator
)
5299 old_sym
= e
->symtree
->n
.sym
;
5301 if (gfc_current_ns
->parent
5302 && old_sym
->ns
!= gfc_current_ns
)
5304 /* Use the 'USE' name so that renamed module symbols are
5305 correctly handled. */
5306 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5308 if (sym
&& old_sym
!= sym
5309 && sym
->ts
.type
== old_sym
->ts
.type
5310 && sym
->attr
.flavor
== FL_PROCEDURE
5311 && sym
->attr
.contained
)
5313 /* Clear the shape, since it might not be valid. */
5314 gfc_free_shape (&e
->shape
, e
->rank
);
5316 /* Give the expression the right symtree! */
5317 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5318 gcc_assert (st
!= NULL
);
5320 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5321 || e
->expr_type
== EXPR_FUNCTION
)
5323 /* Original was function so point to the new symbol, since
5324 the actual argument list is already attached to the
5326 e
->value
.function
.esym
= NULL
;
5331 /* Original was variable so convert array references into
5332 an actual arglist. This does not need any checking now
5333 since resolve_function will take care of it. */
5334 e
->value
.function
.actual
= NULL
;
5335 e
->expr_type
= EXPR_FUNCTION
;
5338 /* Ambiguity will not arise if the array reference is not
5339 the last reference. */
5340 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5341 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5344 gcc_assert (ref
->type
== REF_ARRAY
);
5346 /* Grab the start expressions from the array ref and
5347 copy them into actual arguments. */
5348 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5350 arg
= gfc_get_actual_arglist ();
5351 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5352 if (e
->value
.function
.actual
== NULL
)
5353 tail
= e
->value
.function
.actual
= arg
;
5361 /* Dump the reference list and set the rank. */
5362 gfc_free_ref_list (e
->ref
);
5364 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5367 gfc_resolve_expr (e
);
5371 /* This might have changed! */
5372 return e
->expr_type
== EXPR_FUNCTION
;
5377 gfc_resolve_character_operator (gfc_expr
*e
)
5379 gfc_expr
*op1
= e
->value
.op
.op1
;
5380 gfc_expr
*op2
= e
->value
.op
.op2
;
5381 gfc_expr
*e1
= NULL
;
5382 gfc_expr
*e2
= NULL
;
5384 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5386 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5387 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5388 else if (op1
->expr_type
== EXPR_CONSTANT
)
5389 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5390 op1
->value
.character
.length
);
5392 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5393 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5394 else if (op2
->expr_type
== EXPR_CONSTANT
)
5395 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5396 op2
->value
.character
.length
);
5398 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5403 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5404 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5405 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5406 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5407 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5413 /* Ensure that an character expression has a charlen and, if possible, a
5414 length expression. */
5417 fixup_charlen (gfc_expr
*e
)
5419 /* The cases fall through so that changes in expression type and the need
5420 for multiple fixes are picked up. In all circumstances, a charlen should
5421 be available for the middle end to hang a backend_decl on. */
5422 switch (e
->expr_type
)
5425 gfc_resolve_character_operator (e
);
5428 if (e
->expr_type
== EXPR_ARRAY
)
5429 gfc_resolve_character_array_constructor (e
);
5431 case EXPR_SUBSTRING
:
5432 if (!e
->ts
.u
.cl
&& e
->ref
)
5433 gfc_resolve_substring_charlen (e
);
5437 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5444 /* Update an actual argument to include the passed-object for type-bound
5445 procedures at the right position. */
5447 static gfc_actual_arglist
*
5448 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5451 gcc_assert (argpos
> 0);
5455 gfc_actual_arglist
* result
;
5457 result
= gfc_get_actual_arglist ();
5461 result
->name
= name
;
5467 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5469 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5474 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5477 extract_compcall_passed_object (gfc_expr
* e
)
5481 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5483 if (e
->value
.compcall
.base_object
)
5484 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5487 po
= gfc_get_expr ();
5488 po
->expr_type
= EXPR_VARIABLE
;
5489 po
->symtree
= e
->symtree
;
5490 po
->ref
= gfc_copy_ref (e
->ref
);
5491 po
->where
= e
->where
;
5494 if (gfc_resolve_expr (po
) == FAILURE
)
5501 /* Update the arglist of an EXPR_COMPCALL expression to include the
5505 update_compcall_arglist (gfc_expr
* e
)
5508 gfc_typebound_proc
* tbp
;
5510 tbp
= e
->value
.compcall
.tbp
;
5515 po
= extract_compcall_passed_object (e
);
5519 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5525 gcc_assert (tbp
->pass_arg_num
> 0);
5526 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5534 /* Extract the passed object from a PPC call (a copy of it). */
5537 extract_ppc_passed_object (gfc_expr
*e
)
5542 po
= gfc_get_expr ();
5543 po
->expr_type
= EXPR_VARIABLE
;
5544 po
->symtree
= e
->symtree
;
5545 po
->ref
= gfc_copy_ref (e
->ref
);
5546 po
->where
= e
->where
;
5548 /* Remove PPC reference. */
5550 while ((*ref
)->next
)
5551 ref
= &(*ref
)->next
;
5552 gfc_free_ref_list (*ref
);
5555 if (gfc_resolve_expr (po
) == FAILURE
)
5562 /* Update the actual arglist of a procedure pointer component to include the
5566 update_ppc_arglist (gfc_expr
* e
)
5570 gfc_typebound_proc
* tb
;
5572 if (!gfc_is_proc_ptr_comp (e
, &ppc
))
5579 else if (tb
->nopass
)
5582 po
= extract_ppc_passed_object (e
);
5589 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5594 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5596 gfc_error ("Base object for procedure-pointer component call at %L is of"
5597 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5601 gcc_assert (tb
->pass_arg_num
> 0);
5602 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5610 /* Check that the object a TBP is called on is valid, i.e. it must not be
5611 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5614 check_typebound_baseobject (gfc_expr
* e
)
5617 gfc_try return_value
= FAILURE
;
5619 base
= extract_compcall_passed_object (e
);
5623 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5626 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5628 gfc_error ("Base object for type-bound procedure call at %L is of"
5629 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5633 /* F08:C1230. If the procedure called is NOPASS,
5634 the base object must be scalar. */
5635 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
> 0)
5637 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5638 " be scalar", &e
->where
);
5642 return_value
= SUCCESS
;
5645 gfc_free_expr (base
);
5646 return return_value
;
5650 /* Resolve a call to a type-bound procedure, either function or subroutine,
5651 statically from the data in an EXPR_COMPCALL expression. The adapted
5652 arglist and the target-procedure symtree are returned. */
5655 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5656 gfc_actual_arglist
** actual
)
5658 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5659 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5661 /* Update the actual arglist for PASS. */
5662 if (update_compcall_arglist (e
) == FAILURE
)
5665 *actual
= e
->value
.compcall
.actual
;
5666 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5668 gfc_free_ref_list (e
->ref
);
5670 e
->value
.compcall
.actual
= NULL
;
5672 /* If we find a deferred typebound procedure, check for derived types
5673 that an overriding typebound procedure has not been missed. */
5674 if (e
->value
.compcall
.name
5675 && !e
->value
.compcall
.tbp
->non_overridable
5676 && e
->value
.compcall
.base_object
5677 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5680 gfc_symbol
*derived
;
5682 /* Use the derived type of the base_object. */
5683 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5686 /* If necessary, go through the inheritance chain. */
5687 while (!st
&& derived
)
5689 /* Look for the typebound procedure 'name'. */
5690 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5691 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5692 e
->value
.compcall
.name
);
5694 derived
= gfc_get_derived_super_type (derived
);
5697 /* Now find the specific name in the derived type namespace. */
5698 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5699 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5700 derived
->ns
, 1, &st
);
5708 /* Get the ultimate declared type from an expression. In addition,
5709 return the last class/derived type reference and the copy of the
5710 reference list. If check_types is set true, derived types are
5711 identified as well as class references. */
5713 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5714 gfc_expr
*e
, bool check_types
)
5716 gfc_symbol
*declared
;
5723 *new_ref
= gfc_copy_ref (e
->ref
);
5725 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5727 if (ref
->type
!= REF_COMPONENT
)
5730 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5731 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5732 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5734 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5740 if (declared
== NULL
)
5741 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5747 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5748 which of the specific bindings (if any) matches the arglist and transform
5749 the expression into a call of that binding. */
5752 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5754 gfc_typebound_proc
* genproc
;
5755 const char* genname
;
5757 gfc_symbol
*derived
;
5759 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5760 genname
= e
->value
.compcall
.name
;
5761 genproc
= e
->value
.compcall
.tbp
;
5763 if (!genproc
->is_generic
)
5766 /* Try the bindings on this type and in the inheritance hierarchy. */
5767 for (; genproc
; genproc
= genproc
->overridden
)
5771 gcc_assert (genproc
->is_generic
);
5772 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5775 gfc_actual_arglist
* args
;
5778 gcc_assert (g
->specific
);
5780 if (g
->specific
->error
)
5783 target
= g
->specific
->u
.specific
->n
.sym
;
5785 /* Get the right arglist by handling PASS/NOPASS. */
5786 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5787 if (!g
->specific
->nopass
)
5790 po
= extract_compcall_passed_object (e
);
5794 gcc_assert (g
->specific
->pass_arg_num
> 0);
5795 gcc_assert (!g
->specific
->error
);
5796 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5797 g
->specific
->pass_arg
);
5799 resolve_actual_arglist (args
, target
->attr
.proc
,
5800 is_external_proc (target
) && !target
->formal
);
5802 /* Check if this arglist matches the formal. */
5803 matches
= gfc_arglist_matches_symbol (&args
, target
);
5805 /* Clean up and break out of the loop if we've found it. */
5806 gfc_free_actual_arglist (args
);
5809 e
->value
.compcall
.tbp
= g
->specific
;
5810 genname
= g
->specific_st
->name
;
5811 /* Pass along the name for CLASS methods, where the vtab
5812 procedure pointer component has to be referenced. */
5820 /* Nothing matching found! */
5821 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5822 " '%s' at %L", genname
, &e
->where
);
5826 /* Make sure that we have the right specific instance for the name. */
5827 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5829 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5831 e
->value
.compcall
.tbp
= st
->n
.tb
;
5837 /* Resolve a call to a type-bound subroutine. */
5840 resolve_typebound_call (gfc_code
* c
, const char **name
)
5842 gfc_actual_arglist
* newactual
;
5843 gfc_symtree
* target
;
5845 /* Check that's really a SUBROUTINE. */
5846 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5848 gfc_error ("'%s' at %L should be a SUBROUTINE",
5849 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5853 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
5856 /* Pass along the name for CLASS methods, where the vtab
5857 procedure pointer component has to be referenced. */
5859 *name
= c
->expr1
->value
.compcall
.name
;
5861 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
5864 /* Transform into an ordinary EXEC_CALL for now. */
5866 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
5869 c
->ext
.actual
= newactual
;
5870 c
->symtree
= target
;
5871 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5873 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5875 gfc_free_expr (c
->expr1
);
5876 c
->expr1
= gfc_get_expr ();
5877 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5878 c
->expr1
->symtree
= target
;
5879 c
->expr1
->where
= c
->loc
;
5881 return resolve_call (c
);
5885 /* Resolve a component-call expression. */
5887 resolve_compcall (gfc_expr
* e
, const char **name
)
5889 gfc_actual_arglist
* newactual
;
5890 gfc_symtree
* target
;
5892 /* Check that's really a FUNCTION. */
5893 if (!e
->value
.compcall
.tbp
->function
)
5895 gfc_error ("'%s' at %L should be a FUNCTION",
5896 e
->value
.compcall
.name
, &e
->where
);
5900 /* These must not be assign-calls! */
5901 gcc_assert (!e
->value
.compcall
.assign
);
5903 if (check_typebound_baseobject (e
) == FAILURE
)
5906 /* Pass along the name for CLASS methods, where the vtab
5907 procedure pointer component has to be referenced. */
5909 *name
= e
->value
.compcall
.name
;
5911 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
5913 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5915 /* Take the rank from the function's symbol. */
5916 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5917 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5919 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5920 arglist to the TBP's binding target. */
5922 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
5925 e
->value
.function
.actual
= newactual
;
5926 e
->value
.function
.name
= NULL
;
5927 e
->value
.function
.esym
= target
->n
.sym
;
5928 e
->value
.function
.isym
= NULL
;
5929 e
->symtree
= target
;
5930 e
->ts
= target
->n
.sym
->ts
;
5931 e
->expr_type
= EXPR_FUNCTION
;
5933 /* Resolution is not necessary if this is a class subroutine; this
5934 function only has to identify the specific proc. Resolution of
5935 the call will be done next in resolve_typebound_call. */
5936 return gfc_resolve_expr (e
);
5941 /* Resolve a typebound function, or 'method'. First separate all
5942 the non-CLASS references by calling resolve_compcall directly. */
5945 resolve_typebound_function (gfc_expr
* e
)
5947 gfc_symbol
*declared
;
5959 /* Deal with typebound operators for CLASS objects. */
5960 expr
= e
->value
.compcall
.base_object
;
5961 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5962 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5964 /* If the base_object is not a variable, the corresponding actual
5965 argument expression must be stored in e->base_expression so
5966 that the corresponding tree temporary can be used as the base
5967 object in gfc_conv_procedure_call. */
5968 if (expr
->expr_type
!= EXPR_VARIABLE
)
5970 gfc_actual_arglist
*args
;
5972 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5974 if (expr
== args
->expr
)
5979 /* Since the typebound operators are generic, we have to ensure
5980 that any delays in resolution are corrected and that the vtab
5983 declared
= ts
.u
.derived
;
5984 c
= gfc_find_component (declared
, "_vptr", true, true);
5985 if (c
->ts
.u
.derived
== NULL
)
5986 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5988 if (resolve_compcall (e
, &name
) == FAILURE
)
5991 /* Use the generic name if it is there. */
5992 name
= name
? name
: e
->value
.function
.esym
->name
;
5993 e
->symtree
= expr
->symtree
;
5994 e
->ref
= gfc_copy_ref (expr
->ref
);
5995 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5997 /* Trim away the extraneous references that emerge from nested
5998 use of interface.c (extend_expr). */
5999 if (class_ref
&& class_ref
->next
)
6001 gfc_free_ref_list (class_ref
->next
);
6002 class_ref
->next
= NULL
;
6004 else if (e
->ref
&& !class_ref
)
6006 gfc_free_ref_list (e
->ref
);
6010 gfc_add_vptr_component (e
);
6011 gfc_add_component_ref (e
, name
);
6012 e
->value
.function
.esym
= NULL
;
6013 if (expr
->expr_type
!= EXPR_VARIABLE
)
6014 e
->base_expr
= expr
;
6019 return resolve_compcall (e
, NULL
);
6021 if (resolve_ref (e
) == FAILURE
)
6024 /* Get the CLASS declared type. */
6025 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6027 /* Weed out cases of the ultimate component being a derived type. */
6028 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6029 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6031 gfc_free_ref_list (new_ref
);
6032 return resolve_compcall (e
, NULL
);
6035 c
= gfc_find_component (declared
, "_data", true, true);
6036 declared
= c
->ts
.u
.derived
;
6038 /* Treat the call as if it is a typebound procedure, in order to roll
6039 out the correct name for the specific function. */
6040 if (resolve_compcall (e
, &name
) == FAILURE
)
6046 /* Convert the expression to a procedure pointer component call. */
6047 e
->value
.function
.esym
= NULL
;
6053 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6054 gfc_add_vptr_component (e
);
6055 gfc_add_component_ref (e
, name
);
6057 /* Recover the typespec for the expression. This is really only
6058 necessary for generic procedures, where the additional call
6059 to gfc_add_component_ref seems to throw the collection of the
6060 correct typespec. */
6067 /* Resolve a typebound subroutine, or 'method'. First separate all
6068 the non-CLASS references by calling resolve_typebound_call
6072 resolve_typebound_subroutine (gfc_code
*code
)
6074 gfc_symbol
*declared
;
6084 st
= code
->expr1
->symtree
;
6086 /* Deal with typebound operators for CLASS objects. */
6087 expr
= code
->expr1
->value
.compcall
.base_object
;
6088 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6089 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6091 /* If the base_object is not a variable, the corresponding actual
6092 argument expression must be stored in e->base_expression so
6093 that the corresponding tree temporary can be used as the base
6094 object in gfc_conv_procedure_call. */
6095 if (expr
->expr_type
!= EXPR_VARIABLE
)
6097 gfc_actual_arglist
*args
;
6099 args
= code
->expr1
->value
.function
.actual
;
6100 for (; args
; args
= args
->next
)
6101 if (expr
== args
->expr
)
6105 /* Since the typebound operators are generic, we have to ensure
6106 that any delays in resolution are corrected and that the vtab
6108 declared
= expr
->ts
.u
.derived
;
6109 c
= gfc_find_component (declared
, "_vptr", true, true);
6110 if (c
->ts
.u
.derived
== NULL
)
6111 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6113 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6116 /* Use the generic name if it is there. */
6117 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6118 code
->expr1
->symtree
= expr
->symtree
;
6119 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6121 /* Trim away the extraneous references that emerge from nested
6122 use of interface.c (extend_expr). */
6123 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6124 if (class_ref
&& class_ref
->next
)
6126 gfc_free_ref_list (class_ref
->next
);
6127 class_ref
->next
= NULL
;
6129 else if (code
->expr1
->ref
&& !class_ref
)
6131 gfc_free_ref_list (code
->expr1
->ref
);
6132 code
->expr1
->ref
= NULL
;
6135 /* Now use the procedure in the vtable. */
6136 gfc_add_vptr_component (code
->expr1
);
6137 gfc_add_component_ref (code
->expr1
, name
);
6138 code
->expr1
->value
.function
.esym
= NULL
;
6139 if (expr
->expr_type
!= EXPR_VARIABLE
)
6140 code
->expr1
->base_expr
= expr
;
6145 return resolve_typebound_call (code
, NULL
);
6147 if (resolve_ref (code
->expr1
) == FAILURE
)
6150 /* Get the CLASS declared type. */
6151 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6153 /* Weed out cases of the ultimate component being a derived type. */
6154 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6155 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6157 gfc_free_ref_list (new_ref
);
6158 return resolve_typebound_call (code
, NULL
);
6161 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6163 ts
= code
->expr1
->ts
;
6167 /* Convert the expression to a procedure pointer component call. */
6168 code
->expr1
->value
.function
.esym
= NULL
;
6169 code
->expr1
->symtree
= st
;
6172 code
->expr1
->ref
= new_ref
;
6174 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6175 gfc_add_vptr_component (code
->expr1
);
6176 gfc_add_component_ref (code
->expr1
, name
);
6178 /* Recover the typespec for the expression. This is really only
6179 necessary for generic procedures, where the additional call
6180 to gfc_add_component_ref seems to throw the collection of the
6181 correct typespec. */
6182 code
->expr1
->ts
= ts
;
6189 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6192 resolve_ppc_call (gfc_code
* c
)
6194 gfc_component
*comp
;
6197 b
= gfc_is_proc_ptr_comp (c
->expr1
, &comp
);
6200 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6201 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6203 if (!comp
->attr
.subroutine
)
6204 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6206 if (resolve_ref (c
->expr1
) == FAILURE
)
6209 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6212 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6214 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6215 comp
->formal
== NULL
) == FAILURE
)
6218 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6224 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6227 resolve_expr_ppc (gfc_expr
* e
)
6229 gfc_component
*comp
;
6232 b
= gfc_is_proc_ptr_comp (e
, &comp
);
6235 /* Convert to EXPR_FUNCTION. */
6236 e
->expr_type
= EXPR_FUNCTION
;
6237 e
->value
.function
.isym
= NULL
;
6238 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6240 if (comp
->as
!= NULL
)
6241 e
->rank
= comp
->as
->rank
;
6243 if (!comp
->attr
.function
)
6244 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6246 if (resolve_ref (e
) == FAILURE
)
6249 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6250 comp
->formal
== NULL
) == FAILURE
)
6253 if (update_ppc_arglist (e
) == FAILURE
)
6256 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6263 gfc_is_expandable_expr (gfc_expr
*e
)
6265 gfc_constructor
*con
;
6267 if (e
->expr_type
== EXPR_ARRAY
)
6269 /* Traverse the constructor looking for variables that are flavor
6270 parameter. Parameters must be expanded since they are fully used at
6272 con
= gfc_constructor_first (e
->value
.constructor
);
6273 for (; con
; con
= gfc_constructor_next (con
))
6275 if (con
->expr
->expr_type
== EXPR_VARIABLE
6276 && con
->expr
->symtree
6277 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6278 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6280 if (con
->expr
->expr_type
== EXPR_ARRAY
6281 && gfc_is_expandable_expr (con
->expr
))
6289 /* Resolve an expression. That is, make sure that types of operands agree
6290 with their operators, intrinsic operators are converted to function calls
6291 for overloaded types and unresolved function references are resolved. */
6294 gfc_resolve_expr (gfc_expr
*e
)
6302 /* inquiry_argument only applies to variables. */
6303 inquiry_save
= inquiry_argument
;
6304 if (e
->expr_type
!= EXPR_VARIABLE
)
6305 inquiry_argument
= false;
6307 switch (e
->expr_type
)
6310 t
= resolve_operator (e
);
6316 if (check_host_association (e
))
6317 t
= resolve_function (e
);
6320 t
= resolve_variable (e
);
6322 expression_rank (e
);
6325 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6326 && e
->ref
->type
!= REF_SUBSTRING
)
6327 gfc_resolve_substring_charlen (e
);
6332 t
= resolve_typebound_function (e
);
6335 case EXPR_SUBSTRING
:
6336 t
= resolve_ref (e
);
6345 t
= resolve_expr_ppc (e
);
6350 if (resolve_ref (e
) == FAILURE
)
6353 t
= gfc_resolve_array_constructor (e
);
6354 /* Also try to expand a constructor. */
6357 expression_rank (e
);
6358 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6359 gfc_expand_constructor (e
, false);
6362 /* This provides the opportunity for the length of constructors with
6363 character valued function elements to propagate the string length
6364 to the expression. */
6365 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6367 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6368 here rather then add a duplicate test for it above. */
6369 gfc_expand_constructor (e
, false);
6370 t
= gfc_resolve_character_array_constructor (e
);
6375 case EXPR_STRUCTURE
:
6376 t
= resolve_ref (e
);
6380 t
= resolve_structure_cons (e
, 0);
6384 t
= gfc_simplify_expr (e
, 0);
6388 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6391 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6394 inquiry_argument
= inquiry_save
;
6400 /* Resolve an expression from an iterator. They must be scalar and have
6401 INTEGER or (optionally) REAL type. */
6404 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6405 const char *name_msgid
)
6407 if (gfc_resolve_expr (expr
) == FAILURE
)
6410 if (expr
->rank
!= 0)
6412 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6416 if (expr
->ts
.type
!= BT_INTEGER
)
6418 if (expr
->ts
.type
== BT_REAL
)
6421 return gfc_notify_std (GFC_STD_F95_DEL
,
6422 "Deleted feature: %s at %L must be integer",
6423 _(name_msgid
), &expr
->where
);
6426 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6433 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6441 /* Resolve the expressions in an iterator structure. If REAL_OK is
6442 false allow only INTEGER type iterators, otherwise allow REAL types. */
6445 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6447 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6451 if (gfc_check_vardef_context (iter
->var
, false, false, _("iterator variable"))
6455 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6456 "Start expression in DO loop") == FAILURE
)
6459 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6460 "End expression in DO loop") == FAILURE
)
6463 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6464 "Step expression in DO loop") == FAILURE
)
6467 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6469 if ((iter
->step
->ts
.type
== BT_INTEGER
6470 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6471 || (iter
->step
->ts
.type
== BT_REAL
6472 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6474 gfc_error ("Step expression in DO loop at %L cannot be zero",
6475 &iter
->step
->where
);
6480 /* Convert start, end, and step to the same type as var. */
6481 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6482 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6483 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6485 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6486 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6487 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6489 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6490 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6491 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6493 if (iter
->start
->expr_type
== EXPR_CONSTANT
6494 && iter
->end
->expr_type
== EXPR_CONSTANT
6495 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6498 if (iter
->start
->ts
.type
== BT_INTEGER
)
6500 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6501 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6505 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6506 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6508 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6509 gfc_warning ("DO loop at %L will be executed zero times",
6510 &iter
->step
->where
);
6517 /* Traversal function for find_forall_index. f == 2 signals that
6518 that variable itself is not to be checked - only the references. */
6521 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6523 if (expr
->expr_type
!= EXPR_VARIABLE
)
6526 /* A scalar assignment */
6527 if (!expr
->ref
|| *f
== 1)
6529 if (expr
->symtree
->n
.sym
== sym
)
6541 /* Check whether the FORALL index appears in the expression or not.
6542 Returns SUCCESS if SYM is found in EXPR. */
6545 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6547 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6554 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6555 to be a scalar INTEGER variable. The subscripts and stride are scalar
6556 INTEGERs, and if stride is a constant it must be nonzero.
6557 Furthermore "A subscript or stride in a forall-triplet-spec shall
6558 not contain a reference to any index-name in the
6559 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6562 resolve_forall_iterators (gfc_forall_iterator
*it
)
6564 gfc_forall_iterator
*iter
, *iter2
;
6566 for (iter
= it
; iter
; iter
= iter
->next
)
6568 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6569 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6570 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6573 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6574 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6575 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6576 &iter
->start
->where
);
6577 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6578 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6580 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6581 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6582 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6584 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6585 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6587 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6589 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6590 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6591 &iter
->stride
->where
, "INTEGER");
6593 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6594 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6595 gfc_error ("FORALL stride expression at %L cannot be zero",
6596 &iter
->stride
->where
);
6598 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6599 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6602 for (iter
= it
; iter
; iter
= iter
->next
)
6603 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6605 if (find_forall_index (iter2
->start
,
6606 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6607 || find_forall_index (iter2
->end
,
6608 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6609 || find_forall_index (iter2
->stride
,
6610 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6611 gfc_error ("FORALL index '%s' may not appear in triplet "
6612 "specification at %L", iter
->var
->symtree
->name
,
6613 &iter2
->start
->where
);
6618 /* Given a pointer to a symbol that is a derived type, see if it's
6619 inaccessible, i.e. if it's defined in another module and the components are
6620 PRIVATE. The search is recursive if necessary. Returns zero if no
6621 inaccessible components are found, nonzero otherwise. */
6624 derived_inaccessible (gfc_symbol
*sym
)
6628 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6631 for (c
= sym
->components
; c
; c
= c
->next
)
6633 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6641 /* Resolve the argument of a deallocate expression. The expression must be
6642 a pointer or a full array. */
6645 resolve_deallocate_expr (gfc_expr
*e
)
6647 symbol_attribute attr
;
6648 int allocatable
, pointer
;
6653 if (gfc_resolve_expr (e
) == FAILURE
)
6656 if (e
->expr_type
!= EXPR_VARIABLE
)
6659 sym
= e
->symtree
->n
.sym
;
6661 if (sym
->ts
.type
== BT_CLASS
)
6663 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6664 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6668 allocatable
= sym
->attr
.allocatable
;
6669 pointer
= sym
->attr
.pointer
;
6671 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6676 if (ref
->u
.ar
.type
!= AR_FULL
6677 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6678 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6683 c
= ref
->u
.c
.component
;
6684 if (c
->ts
.type
== BT_CLASS
)
6686 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6687 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6691 allocatable
= c
->attr
.allocatable
;
6692 pointer
= c
->attr
.pointer
;
6702 attr
= gfc_expr_attr (e
);
6704 if (allocatable
== 0 && attr
.pointer
== 0)
6707 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6713 if (gfc_is_coindexed (e
))
6715 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6720 && gfc_check_vardef_context (e
, true, true, _("DEALLOCATE object"))
6723 if (gfc_check_vardef_context (e
, false, true, _("DEALLOCATE object"))
6731 /* Returns true if the expression e contains a reference to the symbol sym. */
6733 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6735 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6742 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6744 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6748 /* Given the expression node e for an allocatable/pointer of derived type to be
6749 allocated, get the expression node to be initialized afterwards (needed for
6750 derived types with default initializers, and derived types with allocatable
6751 components that need nullification.) */
6754 gfc_expr_to_initialize (gfc_expr
*e
)
6760 result
= gfc_copy_expr (e
);
6762 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6763 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6764 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6766 ref
->u
.ar
.type
= AR_FULL
;
6768 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6769 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6774 gfc_free_shape (&result
->shape
, result
->rank
);
6776 /* Recalculate rank, shape, etc. */
6777 gfc_resolve_expr (result
);
6782 /* If the last ref of an expression is an array ref, return a copy of the
6783 expression with that one removed. Otherwise, a copy of the original
6784 expression. This is used for allocate-expressions and pointer assignment
6785 LHS, where there may be an array specification that needs to be stripped
6786 off when using gfc_check_vardef_context. */
6789 remove_last_array_ref (gfc_expr
* e
)
6794 e2
= gfc_copy_expr (e
);
6795 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6796 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6798 gfc_free_ref_list (*r
);
6807 /* Used in resolve_allocate_expr to check that a allocation-object and
6808 a source-expr are conformable. This does not catch all possible
6809 cases; in particular a runtime checking is needed. */
6812 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6815 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6817 /* First compare rank. */
6818 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6820 gfc_error ("Source-expr at %L must be scalar or have the "
6821 "same rank as the allocate-object at %L",
6822 &e1
->where
, &e2
->where
);
6833 for (i
= 0; i
< e1
->rank
; i
++)
6835 if (tail
->u
.ar
.end
[i
])
6837 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6838 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6839 mpz_add_ui (s
, s
, 1);
6843 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6846 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6848 gfc_error ("Source-expr at %L and allocate-object at %L must "
6849 "have the same shape", &e1
->where
, &e2
->where
);
6862 /* Resolve the expression in an ALLOCATE statement, doing the additional
6863 checks to see whether the expression is OK or not. The expression must
6864 have a trailing array reference that gives the size of the array. */
6867 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6869 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6872 symbol_attribute attr
;
6873 gfc_ref
*ref
, *ref2
;
6876 gfc_symbol
*sym
= NULL
;
6881 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6882 checking of coarrays. */
6883 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6884 if (ref
->next
== NULL
)
6887 if (ref
&& ref
->type
== REF_ARRAY
)
6888 ref
->u
.ar
.in_allocate
= true;
6890 if (gfc_resolve_expr (e
) == FAILURE
)
6893 /* Make sure the expression is allocatable or a pointer. If it is
6894 pointer, the next-to-last reference must be a pointer. */
6898 sym
= e
->symtree
->n
.sym
;
6900 /* Check whether ultimate component is abstract and CLASS. */
6903 if (e
->expr_type
!= EXPR_VARIABLE
)
6906 attr
= gfc_expr_attr (e
);
6907 pointer
= attr
.pointer
;
6908 dimension
= attr
.dimension
;
6909 codimension
= attr
.codimension
;
6913 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6915 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6916 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6917 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6918 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6919 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6923 allocatable
= sym
->attr
.allocatable
;
6924 pointer
= sym
->attr
.pointer
;
6925 dimension
= sym
->attr
.dimension
;
6926 codimension
= sym
->attr
.codimension
;
6931 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6936 if (ref
->u
.ar
.codimen
> 0)
6939 for (n
= ref
->u
.ar
.dimen
;
6940 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6941 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6948 if (ref
->next
!= NULL
)
6956 gfc_error ("Coindexed allocatable object at %L",
6961 c
= ref
->u
.c
.component
;
6962 if (c
->ts
.type
== BT_CLASS
)
6964 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6965 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6966 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6967 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6968 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6972 allocatable
= c
->attr
.allocatable
;
6973 pointer
= c
->attr
.pointer
;
6974 dimension
= c
->attr
.dimension
;
6975 codimension
= c
->attr
.codimension
;
6976 is_abstract
= c
->attr
.abstract
;
6988 /* Check for F08:C628. */
6989 if (allocatable
== 0 && pointer
== 0)
6991 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6996 /* Some checks for the SOURCE tag. */
6999 /* Check F03:C631. */
7000 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7002 gfc_error ("Type of entity at %L is type incompatible with "
7003 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7007 /* Check F03:C632 and restriction following Note 6.18. */
7008 if (code
->expr3
->rank
> 0
7009 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
7012 /* Check F03:C633. */
7013 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
7015 gfc_error ("The allocate-object at %L and the source-expr at %L "
7016 "shall have the same kind type parameter",
7017 &e
->where
, &code
->expr3
->where
);
7021 /* Check F2008, C642. */
7022 if (code
->expr3
->ts
.type
== BT_DERIVED
7023 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7024 || (code
->expr3
->ts
.u
.derived
->from_intmod
7025 == INTMOD_ISO_FORTRAN_ENV
7026 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7027 == ISOFORTRAN_LOCK_TYPE
)))
7029 gfc_error ("The source-expr at %L shall neither be of type "
7030 "LOCK_TYPE nor have a LOCK_TYPE component if "
7031 "allocate-object at %L is a coarray",
7032 &code
->expr3
->where
, &e
->where
);
7037 /* Check F08:C629. */
7038 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7041 gcc_assert (e
->ts
.type
== BT_CLASS
);
7042 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7043 "type-spec or source-expr", sym
->name
, &e
->where
);
7047 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
7049 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7050 code
->ext
.alloc
.ts
.u
.cl
->length
);
7051 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7053 gfc_error ("Allocating %s at %L with type-spec requires the same "
7054 "character-length parameter as in the declaration",
7055 sym
->name
, &e
->where
);
7060 /* In the variable definition context checks, gfc_expr_attr is used
7061 on the expression. This is fooled by the array specification
7062 present in e, thus we have to eliminate that one temporarily. */
7063 e2
= remove_last_array_ref (e
);
7065 if (t
== SUCCESS
&& pointer
)
7066 t
= gfc_check_vardef_context (e2
, true, true, _("ALLOCATE object"));
7068 t
= gfc_check_vardef_context (e2
, false, true, _("ALLOCATE object"));
7073 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7074 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7076 /* For class arrays, the initialization with SOURCE is done
7077 using _copy and trans_call. It is convenient to exploit that
7078 when the allocated type is different from the declared type but
7079 no SOURCE exists by setting expr3. */
7080 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7082 else if (!code
->expr3
)
7084 /* Set up default initializer if needed. */
7088 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7089 ts
= code
->ext
.alloc
.ts
;
7093 if (ts
.type
== BT_CLASS
)
7094 ts
= ts
.u
.derived
->components
->ts
;
7096 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7098 gfc_code
*init_st
= gfc_get_code ();
7099 init_st
->loc
= code
->loc
;
7100 init_st
->op
= EXEC_INIT_ASSIGN
;
7101 init_st
->expr1
= gfc_expr_to_initialize (e
);
7102 init_st
->expr2
= init_e
;
7103 init_st
->next
= code
->next
;
7104 code
->next
= init_st
;
7107 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7109 /* Default initialization via MOLD (non-polymorphic). */
7110 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7111 gfc_resolve_expr (rhs
);
7112 gfc_free_expr (code
->expr3
);
7116 if (e
->ts
.type
== BT_CLASS
)
7118 /* Make sure the vtab symbol is present when
7119 the module variables are generated. */
7120 gfc_typespec ts
= e
->ts
;
7122 ts
= code
->expr3
->ts
;
7123 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7124 ts
= code
->ext
.alloc
.ts
;
7125 gfc_find_derived_vtab (ts
.u
.derived
);
7127 e
= gfc_expr_to_initialize (e
);
7130 if (dimension
== 0 && codimension
== 0)
7133 /* Make sure the last reference node is an array specification. */
7135 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7136 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7138 gfc_error ("Array specification required in ALLOCATE statement "
7139 "at %L", &e
->where
);
7143 /* Make sure that the array section reference makes sense in the
7144 context of an ALLOCATE specification. */
7149 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7150 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7152 gfc_error ("Coarray specification required in ALLOCATE statement "
7153 "at %L", &e
->where
);
7157 for (i
= 0; i
< ar
->dimen
; i
++)
7159 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7162 switch (ar
->dimen_type
[i
])
7168 if (ar
->start
[i
] != NULL
7169 && ar
->end
[i
] != NULL
7170 && ar
->stride
[i
] == NULL
)
7173 /* Fall Through... */
7178 case DIMEN_THIS_IMAGE
:
7179 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7185 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7187 sym
= a
->expr
->symtree
->n
.sym
;
7189 /* TODO - check derived type components. */
7190 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7193 if ((ar
->start
[i
] != NULL
7194 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7195 || (ar
->end
[i
] != NULL
7196 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7198 gfc_error ("'%s' must not appear in the array specification at "
7199 "%L in the same ALLOCATE statement where it is "
7200 "itself allocated", sym
->name
, &ar
->where
);
7206 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7208 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7209 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7211 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7213 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7214 "statement at %L", &e
->where
);
7220 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7221 && ar
->stride
[i
] == NULL
)
7224 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7237 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7239 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7240 gfc_alloc
*a
, *p
, *q
;
7243 errmsg
= code
->expr2
;
7245 /* Check the stat variable. */
7248 gfc_check_vardef_context (stat
, false, false, _("STAT variable"));
7250 if ((stat
->ts
.type
!= BT_INTEGER
7251 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7252 || stat
->ref
->type
== REF_COMPONENT
)))
7254 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7255 "variable", &stat
->where
);
7257 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7258 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7260 gfc_ref
*ref1
, *ref2
;
7263 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7264 ref1
= ref1
->next
, ref2
= ref2
->next
)
7266 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7268 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7277 gfc_error ("Stat-variable at %L shall not be %sd within "
7278 "the same %s statement", &stat
->where
, fcn
, fcn
);
7284 /* Check the errmsg variable. */
7288 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7291 gfc_check_vardef_context (errmsg
, false, false, _("ERRMSG variable"));
7293 if ((errmsg
->ts
.type
!= BT_CHARACTER
7295 && (errmsg
->ref
->type
== REF_ARRAY
7296 || errmsg
->ref
->type
== REF_COMPONENT
)))
7297 || errmsg
->rank
> 0 )
7298 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7299 "variable", &errmsg
->where
);
7301 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7302 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7304 gfc_ref
*ref1
, *ref2
;
7307 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7308 ref1
= ref1
->next
, ref2
= ref2
->next
)
7310 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7312 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7321 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7322 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7328 /* Check that an allocate-object appears only once in the statement.
7329 FIXME: Checking derived types is disabled. */
7330 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7333 for (q
= p
->next
; q
; q
= q
->next
)
7336 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7338 /* This is a potential collision. */
7339 gfc_ref
*pr
= pe
->ref
;
7340 gfc_ref
*qr
= qe
->ref
;
7342 /* Follow the references until
7343 a) They start to differ, in which case there is no error;
7344 you can deallocate a%b and a%c in a single statement
7345 b) Both of them stop, which is an error
7346 c) One of them stops, which is also an error. */
7349 if (pr
== NULL
&& qr
== NULL
)
7351 gfc_error ("Allocate-object at %L also appears at %L",
7352 &pe
->where
, &qe
->where
);
7355 else if (pr
!= NULL
&& qr
== NULL
)
7357 gfc_error ("Allocate-object at %L is subobject of"
7358 " object at %L", &pe
->where
, &qe
->where
);
7361 else if (pr
== NULL
&& qr
!= NULL
)
7363 gfc_error ("Allocate-object at %L is subobject of"
7364 " object at %L", &qe
->where
, &pe
->where
);
7367 /* Here, pr != NULL && qr != NULL */
7368 gcc_assert(pr
->type
== qr
->type
);
7369 if (pr
->type
== REF_ARRAY
)
7371 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7373 gcc_assert (qr
->type
== REF_ARRAY
);
7375 if (pr
->next
&& qr
->next
)
7377 gfc_array_ref
*par
= &(pr
->u
.ar
);
7378 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7379 if (gfc_dep_compare_expr (par
->start
[0],
7380 qar
->start
[0]) != 0)
7386 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7397 if (strcmp (fcn
, "ALLOCATE") == 0)
7399 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7400 resolve_allocate_expr (a
->expr
, code
);
7404 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7405 resolve_deallocate_expr (a
->expr
);
7410 /************ SELECT CASE resolution subroutines ************/
7412 /* Callback function for our mergesort variant. Determines interval
7413 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7414 op1 > op2. Assumes we're not dealing with the default case.
7415 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7416 There are nine situations to check. */
7419 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7423 if (op1
->low
== NULL
) /* op1 = (:L) */
7425 /* op2 = (:N), so overlap. */
7427 /* op2 = (M:) or (M:N), L < M */
7428 if (op2
->low
!= NULL
7429 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7432 else if (op1
->high
== NULL
) /* op1 = (K:) */
7434 /* op2 = (M:), so overlap. */
7436 /* op2 = (:N) or (M:N), K > N */
7437 if (op2
->high
!= NULL
7438 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7441 else /* op1 = (K:L) */
7443 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7444 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7446 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7447 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7449 else /* op2 = (M:N) */
7453 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7456 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7465 /* Merge-sort a double linked case list, detecting overlap in the
7466 process. LIST is the head of the double linked case list before it
7467 is sorted. Returns the head of the sorted list if we don't see any
7468 overlap, or NULL otherwise. */
7471 check_case_overlap (gfc_case
*list
)
7473 gfc_case
*p
, *q
, *e
, *tail
;
7474 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7476 /* If the passed list was empty, return immediately. */
7483 /* Loop unconditionally. The only exit from this loop is a return
7484 statement, when we've finished sorting the case list. */
7491 /* Count the number of merges we do in this pass. */
7494 /* Loop while there exists a merge to be done. */
7499 /* Count this merge. */
7502 /* Cut the list in two pieces by stepping INSIZE places
7503 forward in the list, starting from P. */
7506 for (i
= 0; i
< insize
; i
++)
7515 /* Now we have two lists. Merge them! */
7516 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7518 /* See from which the next case to merge comes from. */
7521 /* P is empty so the next case must come from Q. */
7526 else if (qsize
== 0 || q
== NULL
)
7535 cmp
= compare_cases (p
, q
);
7538 /* The whole case range for P is less than the
7546 /* The whole case range for Q is greater than
7547 the case range for P. */
7554 /* The cases overlap, or they are the same
7555 element in the list. Either way, we must
7556 issue an error and get the next case from P. */
7557 /* FIXME: Sort P and Q by line number. */
7558 gfc_error ("CASE label at %L overlaps with CASE "
7559 "label at %L", &p
->where
, &q
->where
);
7567 /* Add the next element to the merged list. */
7576 /* P has now stepped INSIZE places along, and so has Q. So
7577 they're the same. */
7582 /* If we have done only one merge or none at all, we've
7583 finished sorting the cases. */
7592 /* Otherwise repeat, merging lists twice the size. */
7598 /* Check to see if an expression is suitable for use in a CASE statement.
7599 Makes sure that all case expressions are scalar constants of the same
7600 type. Return FAILURE if anything is wrong. */
7603 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7605 if (e
== NULL
) return SUCCESS
;
7607 if (e
->ts
.type
!= case_expr
->ts
.type
)
7609 gfc_error ("Expression in CASE statement at %L must be of type %s",
7610 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7614 /* C805 (R808) For a given case-construct, each case-value shall be of
7615 the same type as case-expr. For character type, length differences
7616 are allowed, but the kind type parameters shall be the same. */
7618 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7620 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7621 &e
->where
, case_expr
->ts
.kind
);
7625 /* Convert the case value kind to that of case expression kind,
7628 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7629 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7633 gfc_error ("Expression in CASE statement at %L must be scalar",
7642 /* Given a completely parsed select statement, we:
7644 - Validate all expressions and code within the SELECT.
7645 - Make sure that the selection expression is not of the wrong type.
7646 - Make sure that no case ranges overlap.
7647 - Eliminate unreachable cases and unreachable code resulting from
7648 removing case labels.
7650 The standard does allow unreachable cases, e.g. CASE (5:3). But
7651 they are a hassle for code generation, and to prevent that, we just
7652 cut them out here. This is not necessary for overlapping cases
7653 because they are illegal and we never even try to generate code.
7655 We have the additional caveat that a SELECT construct could have
7656 been a computed GOTO in the source code. Fortunately we can fairly
7657 easily work around that here: The case_expr for a "real" SELECT CASE
7658 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7659 we have to do is make sure that the case_expr is a scalar integer
7663 resolve_select (gfc_code
*code
)
7666 gfc_expr
*case_expr
;
7667 gfc_case
*cp
, *default_case
, *tail
, *head
;
7668 int seen_unreachable
;
7674 if (code
->expr1
== NULL
)
7676 /* This was actually a computed GOTO statement. */
7677 case_expr
= code
->expr2
;
7678 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7679 gfc_error ("Selection expression in computed GOTO statement "
7680 "at %L must be a scalar integer expression",
7683 /* Further checking is not necessary because this SELECT was built
7684 by the compiler, so it should always be OK. Just move the
7685 case_expr from expr2 to expr so that we can handle computed
7686 GOTOs as normal SELECTs from here on. */
7687 code
->expr1
= code
->expr2
;
7692 case_expr
= code
->expr1
;
7694 type
= case_expr
->ts
.type
;
7695 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7697 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7698 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7700 /* Punt. Going on here just produce more garbage error messages. */
7704 /* Raise a warning if an INTEGER case value exceeds the range of
7705 the case-expr. Later, all expressions will be promoted to the
7706 largest kind of all case-labels. */
7708 if (type
== BT_INTEGER
)
7709 for (body
= code
->block
; body
; body
= body
->block
)
7710 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7713 && gfc_check_integer_range (cp
->low
->value
.integer
,
7714 case_expr
->ts
.kind
) != ARITH_OK
)
7715 gfc_warning ("Expression in CASE statement at %L is "
7716 "not in the range of %s", &cp
->low
->where
,
7717 gfc_typename (&case_expr
->ts
));
7720 && cp
->low
!= cp
->high
7721 && gfc_check_integer_range (cp
->high
->value
.integer
,
7722 case_expr
->ts
.kind
) != ARITH_OK
)
7723 gfc_warning ("Expression in CASE statement at %L is "
7724 "not in the range of %s", &cp
->high
->where
,
7725 gfc_typename (&case_expr
->ts
));
7728 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7729 of the SELECT CASE expression and its CASE values. Walk the lists
7730 of case values, and if we find a mismatch, promote case_expr to
7731 the appropriate kind. */
7733 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7735 for (body
= code
->block
; body
; body
= body
->block
)
7737 /* Walk the case label list. */
7738 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7740 /* Intercept the DEFAULT case. It does not have a kind. */
7741 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7744 /* Unreachable case ranges are discarded, so ignore. */
7745 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7746 && cp
->low
!= cp
->high
7747 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7751 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7752 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7754 if (cp
->high
!= NULL
7755 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7756 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7761 /* Assume there is no DEFAULT case. */
7762 default_case
= NULL
;
7767 for (body
= code
->block
; body
; body
= body
->block
)
7769 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7771 seen_unreachable
= 0;
7773 /* Walk the case label list, making sure that all case labels
7775 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7777 /* Count the number of cases in the whole construct. */
7780 /* Intercept the DEFAULT case. */
7781 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7783 if (default_case
!= NULL
)
7785 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7786 "by a second DEFAULT CASE at %L",
7787 &default_case
->where
, &cp
->where
);
7798 /* Deal with single value cases and case ranges. Errors are
7799 issued from the validation function. */
7800 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
7801 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
7807 if (type
== BT_LOGICAL
7808 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7809 || cp
->low
!= cp
->high
))
7811 gfc_error ("Logical range in CASE statement at %L is not "
7812 "allowed", &cp
->low
->where
);
7817 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7820 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7821 if (value
& seen_logical
)
7823 gfc_error ("Constant logical value in CASE statement "
7824 "is repeated at %L",
7829 seen_logical
|= value
;
7832 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7833 && cp
->low
!= cp
->high
7834 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7836 if (gfc_option
.warn_surprising
)
7837 gfc_warning ("Range specification at %L can never "
7838 "be matched", &cp
->where
);
7840 cp
->unreachable
= 1;
7841 seen_unreachable
= 1;
7845 /* If the case range can be matched, it can also overlap with
7846 other cases. To make sure it does not, we put it in a
7847 double linked list here. We sort that with a merge sort
7848 later on to detect any overlapping cases. */
7852 head
->right
= head
->left
= NULL
;
7857 tail
->right
->left
= tail
;
7864 /* It there was a failure in the previous case label, give up
7865 for this case label list. Continue with the next block. */
7869 /* See if any case labels that are unreachable have been seen.
7870 If so, we eliminate them. This is a bit of a kludge because
7871 the case lists for a single case statement (label) is a
7872 single forward linked lists. */
7873 if (seen_unreachable
)
7875 /* Advance until the first case in the list is reachable. */
7876 while (body
->ext
.block
.case_list
!= NULL
7877 && body
->ext
.block
.case_list
->unreachable
)
7879 gfc_case
*n
= body
->ext
.block
.case_list
;
7880 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7882 gfc_free_case_list (n
);
7885 /* Strip all other unreachable cases. */
7886 if (body
->ext
.block
.case_list
)
7888 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7890 if (cp
->next
->unreachable
)
7892 gfc_case
*n
= cp
->next
;
7893 cp
->next
= cp
->next
->next
;
7895 gfc_free_case_list (n
);
7902 /* See if there were overlapping cases. If the check returns NULL,
7903 there was overlap. In that case we don't do anything. If head
7904 is non-NULL, we prepend the DEFAULT case. The sorted list can
7905 then used during code generation for SELECT CASE constructs with
7906 a case expression of a CHARACTER type. */
7909 head
= check_case_overlap (head
);
7911 /* Prepend the default_case if it is there. */
7912 if (head
!= NULL
&& default_case
)
7914 default_case
->left
= NULL
;
7915 default_case
->right
= head
;
7916 head
->left
= default_case
;
7920 /* Eliminate dead blocks that may be the result if we've seen
7921 unreachable case labels for a block. */
7922 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7924 if (body
->block
->ext
.block
.case_list
== NULL
)
7926 /* Cut the unreachable block from the code chain. */
7927 gfc_code
*c
= body
->block
;
7928 body
->block
= c
->block
;
7930 /* Kill the dead block, but not the blocks below it. */
7932 gfc_free_statements (c
);
7936 /* More than two cases is legal but insane for logical selects.
7937 Issue a warning for it. */
7938 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7940 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7945 /* Check if a derived type is extensible. */
7948 gfc_type_is_extensible (gfc_symbol
*sym
)
7950 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
7954 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7955 correct as well as possibly the array-spec. */
7958 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7962 gcc_assert (sym
->assoc
);
7963 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7965 /* If this is for SELECT TYPE, the target may not yet be set. In that
7966 case, return. Resolution will be called later manually again when
7968 target
= sym
->assoc
->target
;
7971 gcc_assert (!sym
->assoc
->dangling
);
7973 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
7976 /* For variable targets, we get some attributes from the target. */
7977 if (target
->expr_type
== EXPR_VARIABLE
)
7981 gcc_assert (target
->symtree
);
7982 tsym
= target
->symtree
->n
.sym
;
7984 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7985 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7987 sym
->attr
.target
= tsym
->attr
.target
7988 || gfc_expr_attr (target
).pointer
;
7991 /* Get type if this was not already set. Note that it can be
7992 some other type than the target in case this is a SELECT TYPE
7993 selector! So we must not update when the type is already there. */
7994 if (sym
->ts
.type
== BT_UNKNOWN
)
7995 sym
->ts
= target
->ts
;
7996 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7998 /* See if this is a valid association-to-variable. */
7999 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8000 && !gfc_has_vector_subscript (target
));
8002 /* Finally resolve if this is an array or not. */
8003 if (sym
->attr
.dimension
&& target
->rank
== 0)
8005 gfc_error ("Associate-name '%s' at %L is used as array",
8006 sym
->name
, &sym
->declared_at
);
8007 sym
->attr
.dimension
= 0;
8011 /* We cannot deal with class selectors that need temporaries. */
8012 if (target
->ts
.type
== BT_CLASS
8013 && gfc_ref_needs_temporary_p (target
->ref
))
8015 gfc_error ("CLASS selector at %L needs a temporary which is not "
8016 "yet implemented", &target
->where
);
8020 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
8021 sym
->attr
.dimension
= 1;
8022 else if (target
->ts
.type
== BT_CLASS
)
8023 gfc_fix_class_refs (target
);
8025 /* The associate-name will have a correct type by now. Make absolutely
8026 sure that it has not picked up a dimension attribute. */
8027 if (sym
->ts
.type
== BT_CLASS
)
8028 sym
->attr
.dimension
= 0;
8030 if (sym
->attr
.dimension
)
8032 sym
->as
= gfc_get_array_spec ();
8033 sym
->as
->rank
= target
->rank
;
8034 sym
->as
->type
= AS_DEFERRED
;
8036 /* Target must not be coindexed, thus the associate-variable
8038 sym
->as
->corank
= 0;
8043 /* Resolve a SELECT TYPE statement. */
8046 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8048 gfc_symbol
*selector_type
;
8049 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8050 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8053 char name
[GFC_MAX_SYMBOL_LEN
];
8057 ns
= code
->ext
.block
.ns
;
8060 /* Check for F03:C813. */
8061 if (code
->expr1
->ts
.type
!= BT_CLASS
8062 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8064 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8065 "at %L", &code
->loc
);
8069 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8074 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8075 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8076 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8079 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8081 /* Loop over TYPE IS / CLASS IS cases. */
8082 for (body
= code
->block
; body
; body
= body
->block
)
8084 c
= body
->ext
.block
.case_list
;
8086 /* Check F03:C815. */
8087 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8088 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8090 gfc_error ("Derived type '%s' at %L must be extensible",
8091 c
->ts
.u
.derived
->name
, &c
->where
);
8096 /* Check F03:C816. */
8097 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8098 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
8100 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8101 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8106 /* Intercept the DEFAULT case. */
8107 if (c
->ts
.type
== BT_UNKNOWN
)
8109 /* Check F03:C818. */
8112 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8113 "by a second DEFAULT CASE at %L",
8114 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8119 default_case
= body
;
8126 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8127 target if present. If there are any EXIT statements referring to the
8128 SELECT TYPE construct, this is no problem because the gfc_code
8129 reference stays the same and EXIT is equally possible from the BLOCK
8130 it is changed to. */
8131 code
->op
= EXEC_BLOCK
;
8134 gfc_association_list
* assoc
;
8136 assoc
= gfc_get_association_list ();
8137 assoc
->st
= code
->expr1
->symtree
;
8138 assoc
->target
= gfc_copy_expr (code
->expr2
);
8139 assoc
->target
->where
= code
->expr2
->where
;
8140 /* assoc->variable will be set by resolve_assoc_var. */
8142 code
->ext
.block
.assoc
= assoc
;
8143 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8145 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8148 code
->ext
.block
.assoc
= NULL
;
8150 /* Add EXEC_SELECT to switch on type. */
8151 new_st
= gfc_get_code ();
8152 new_st
->op
= code
->op
;
8153 new_st
->expr1
= code
->expr1
;
8154 new_st
->expr2
= code
->expr2
;
8155 new_st
->block
= code
->block
;
8156 code
->expr1
= code
->expr2
= NULL
;
8161 ns
->code
->next
= new_st
;
8163 code
->op
= EXEC_SELECT
;
8164 gfc_add_vptr_component (code
->expr1
);
8165 gfc_add_hash_component (code
->expr1
);
8167 /* Loop over TYPE IS / CLASS IS cases. */
8168 for (body
= code
->block
; body
; body
= body
->block
)
8170 c
= body
->ext
.block
.case_list
;
8172 if (c
->ts
.type
== BT_DERIVED
)
8173 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8174 c
->ts
.u
.derived
->hash_value
);
8176 else if (c
->ts
.type
== BT_UNKNOWN
)
8179 /* Associate temporary to selector. This should only be done
8180 when this case is actually true, so build a new ASSOCIATE
8181 that does precisely this here (instead of using the
8184 if (c
->ts
.type
== BT_CLASS
)
8185 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8187 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8188 st
= gfc_find_symtree (ns
->sym_root
, name
);
8189 gcc_assert (st
->n
.sym
->assoc
);
8190 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8191 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8192 if (c
->ts
.type
== BT_DERIVED
)
8193 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8195 new_st
= gfc_get_code ();
8196 new_st
->op
= EXEC_BLOCK
;
8197 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8198 new_st
->ext
.block
.ns
->code
= body
->next
;
8199 body
->next
= new_st
;
8201 /* Chain in the new list only if it is marked as dangling. Otherwise
8202 there is a CASE label overlap and this is already used. Just ignore,
8203 the error is diagnosed elsewhere. */
8204 if (st
->n
.sym
->assoc
->dangling
)
8206 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8207 st
->n
.sym
->assoc
->dangling
= 0;
8210 resolve_assoc_var (st
->n
.sym
, false);
8213 /* Take out CLASS IS cases for separate treatment. */
8215 while (body
&& body
->block
)
8217 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8219 /* Add to class_is list. */
8220 if (class_is
== NULL
)
8222 class_is
= body
->block
;
8227 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8228 tail
->block
= body
->block
;
8231 /* Remove from EXEC_SELECT list. */
8232 body
->block
= body
->block
->block
;
8245 /* Add a default case to hold the CLASS IS cases. */
8246 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8247 tail
->block
= gfc_get_code ();
8249 tail
->op
= EXEC_SELECT_TYPE
;
8250 tail
->ext
.block
.case_list
= gfc_get_case ();
8251 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8253 default_case
= tail
;
8256 /* More than one CLASS IS block? */
8257 if (class_is
->block
)
8261 /* Sort CLASS IS blocks by extension level. */
8265 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8268 /* F03:C817 (check for doubles). */
8269 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8270 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8272 gfc_error ("Double CLASS IS block in SELECT TYPE "
8274 &c2
->ext
.block
.case_list
->where
);
8277 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8278 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8281 (*c1
)->block
= c2
->block
;
8291 /* Generate IF chain. */
8292 if_st
= gfc_get_code ();
8293 if_st
->op
= EXEC_IF
;
8295 for (body
= class_is
; body
; body
= body
->block
)
8297 new_st
->block
= gfc_get_code ();
8298 new_st
= new_st
->block
;
8299 new_st
->op
= EXEC_IF
;
8300 /* Set up IF condition: Call _gfortran_is_extension_of. */
8301 new_st
->expr1
= gfc_get_expr ();
8302 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8303 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8304 new_st
->expr1
->ts
.kind
= 4;
8305 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8306 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8307 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8308 /* Set up arguments. */
8309 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8310 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8311 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8312 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8313 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8314 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8315 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8316 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8317 new_st
->next
= body
->next
;
8319 if (default_case
->next
)
8321 new_st
->block
= gfc_get_code ();
8322 new_st
= new_st
->block
;
8323 new_st
->op
= EXEC_IF
;
8324 new_st
->next
= default_case
->next
;
8327 /* Replace CLASS DEFAULT code by the IF chain. */
8328 default_case
->next
= if_st
;
8331 /* Resolve the internal code. This can not be done earlier because
8332 it requires that the sym->assoc of selectors is set already. */
8333 gfc_current_ns
= ns
;
8334 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8335 gfc_current_ns
= old_ns
;
8337 resolve_select (code
);
8341 /* Resolve a transfer statement. This is making sure that:
8342 -- a derived type being transferred has only non-pointer components
8343 -- a derived type being transferred doesn't have private components, unless
8344 it's being transferred from the module where the type was defined
8345 -- we're not trying to transfer a whole assumed size array. */
8348 resolve_transfer (gfc_code
*code
)
8357 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8358 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8359 exp
= exp
->value
.op
.op1
;
8361 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8363 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8364 "MOLD=", &exp
->where
);
8368 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8369 && exp
->expr_type
!= EXPR_FUNCTION
))
8372 /* If we are reading, the variable will be changed. Note that
8373 code->ext.dt may be NULL if the TRANSFER is related to
8374 an INQUIRE statement -- but in this case, we are not reading, either. */
8375 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8376 && gfc_check_vardef_context (exp
, false, false, _("item in READ"))
8380 sym
= exp
->symtree
->n
.sym
;
8383 /* Go to actual component transferred. */
8384 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8385 if (ref
->type
== REF_COMPONENT
)
8386 ts
= &ref
->u
.c
.component
->ts
;
8388 if (ts
->type
== BT_CLASS
)
8390 /* FIXME: Test for defined input/output. */
8391 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8392 "it is processed by a defined input/output procedure",
8397 if (ts
->type
== BT_DERIVED
)
8399 /* Check that transferred derived type doesn't contain POINTER
8401 if (ts
->u
.derived
->attr
.pointer_comp
)
8403 gfc_error ("Data transfer element at %L cannot have POINTER "
8404 "components unless it is processed by a defined "
8405 "input/output procedure", &code
->loc
);
8410 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8412 gfc_error ("Data transfer element at %L cannot have "
8413 "procedure pointer components", &code
->loc
);
8417 if (ts
->u
.derived
->attr
.alloc_comp
)
8419 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8420 "components unless it is processed by a defined "
8421 "input/output procedure", &code
->loc
);
8425 if (derived_inaccessible (ts
->u
.derived
))
8427 gfc_error ("Data transfer element at %L cannot have "
8428 "PRIVATE components",&code
->loc
);
8433 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8434 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8436 gfc_error ("Data transfer element at %L cannot be a full reference to "
8437 "an assumed-size array", &code
->loc
);
8443 /*********** Toplevel code resolution subroutines ***********/
8445 /* Find the set of labels that are reachable from this block. We also
8446 record the last statement in each block. */
8449 find_reachable_labels (gfc_code
*block
)
8456 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8458 /* Collect labels in this block. We don't keep those corresponding
8459 to END {IF|SELECT}, these are checked in resolve_branch by going
8460 up through the code_stack. */
8461 for (c
= block
; c
; c
= c
->next
)
8463 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8464 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8467 /* Merge with labels from parent block. */
8470 gcc_assert (cs_base
->prev
->reachable_labels
);
8471 bitmap_ior_into (cs_base
->reachable_labels
,
8472 cs_base
->prev
->reachable_labels
);
8478 resolve_lock_unlock (gfc_code
*code
)
8480 if (code
->expr1
->ts
.type
!= BT_DERIVED
8481 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8482 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8483 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8484 || code
->expr1
->rank
!= 0
8485 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8486 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8487 &code
->expr1
->where
);
8491 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8492 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8493 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8494 &code
->expr2
->where
);
8497 && gfc_check_vardef_context (code
->expr2
, false, false,
8498 _("STAT variable")) == FAILURE
)
8503 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8504 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8505 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8506 &code
->expr3
->where
);
8509 && gfc_check_vardef_context (code
->expr3
, false, false,
8510 _("ERRMSG variable")) == FAILURE
)
8513 /* Check ACQUIRED_LOCK. */
8515 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8516 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8517 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8518 "variable", &code
->expr4
->where
);
8521 && gfc_check_vardef_context (code
->expr4
, false, false,
8522 _("ACQUIRED_LOCK variable")) == FAILURE
)
8528 resolve_sync (gfc_code
*code
)
8530 /* Check imageset. The * case matches expr1 == NULL. */
8533 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8534 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8535 "INTEGER expression", &code
->expr1
->where
);
8536 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8537 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8538 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8539 &code
->expr1
->where
);
8540 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8541 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8543 gfc_constructor
*cons
;
8544 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8545 for (; cons
; cons
= gfc_constructor_next (cons
))
8546 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8547 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8548 gfc_error ("Imageset argument at %L must between 1 and "
8549 "num_images()", &cons
->expr
->where
);
8555 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8556 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8557 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8558 &code
->expr2
->where
);
8562 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8563 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8564 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8565 &code
->expr3
->where
);
8569 /* Given a branch to a label, see if the branch is conforming.
8570 The code node describes where the branch is located. */
8573 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8580 /* Step one: is this a valid branching target? */
8582 if (label
->defined
== ST_LABEL_UNKNOWN
)
8584 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8589 if (label
->defined
!= ST_LABEL_TARGET
)
8591 gfc_error ("Statement at %L is not a valid branch target statement "
8592 "for the branch statement at %L", &label
->where
, &code
->loc
);
8596 /* Step two: make sure this branch is not a branch to itself ;-) */
8598 if (code
->here
== label
)
8600 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8604 /* Step three: See if the label is in the same block as the
8605 branching statement. The hard work has been done by setting up
8606 the bitmap reachable_labels. */
8608 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8610 /* Check now whether there is a CRITICAL construct; if so, check
8611 whether the label is still visible outside of the CRITICAL block,
8612 which is invalid. */
8613 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8615 if (stack
->current
->op
== EXEC_CRITICAL
8616 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8617 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8618 "label at %L", &code
->loc
, &label
->where
);
8619 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8620 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8621 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8622 "for label at %L", &code
->loc
, &label
->where
);
8628 /* Step four: If we haven't found the label in the bitmap, it may
8629 still be the label of the END of the enclosing block, in which
8630 case we find it by going up the code_stack. */
8632 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8634 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8636 if (stack
->current
->op
== EXEC_CRITICAL
)
8638 /* Note: A label at END CRITICAL does not leave the CRITICAL
8639 construct as END CRITICAL is still part of it. */
8640 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8641 " at %L", &code
->loc
, &label
->where
);
8644 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8646 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8647 "label at %L", &code
->loc
, &label
->where
);
8654 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8658 /* The label is not in an enclosing block, so illegal. This was
8659 allowed in Fortran 66, so we allow it as extension. No
8660 further checks are necessary in this case. */
8661 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8662 "as the GOTO statement at %L", &label
->where
,
8668 /* Check whether EXPR1 has the same shape as EXPR2. */
8671 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8673 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8674 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8675 gfc_try result
= FAILURE
;
8678 /* Compare the rank. */
8679 if (expr1
->rank
!= expr2
->rank
)
8682 /* Compare the size of each dimension. */
8683 for (i
=0; i
<expr1
->rank
; i
++)
8685 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8688 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8691 if (mpz_cmp (shape
[i
], shape2
[i
]))
8695 /* When either of the two expression is an assumed size array, we
8696 ignore the comparison of dimension sizes. */
8701 gfc_clear_shape (shape
, i
);
8702 gfc_clear_shape (shape2
, i
);
8707 /* Check whether a WHERE assignment target or a WHERE mask expression
8708 has the same shape as the outmost WHERE mask expression. */
8711 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8717 cblock
= code
->block
;
8719 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8720 In case of nested WHERE, only the outmost one is stored. */
8721 if (mask
== NULL
) /* outmost WHERE */
8723 else /* inner WHERE */
8730 /* Check if the mask-expr has a consistent shape with the
8731 outmost WHERE mask-expr. */
8732 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8733 gfc_error ("WHERE mask at %L has inconsistent shape",
8734 &cblock
->expr1
->where
);
8737 /* the assignment statement of a WHERE statement, or the first
8738 statement in where-body-construct of a WHERE construct */
8739 cnext
= cblock
->next
;
8744 /* WHERE assignment statement */
8747 /* Check shape consistent for WHERE assignment target. */
8748 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8749 gfc_error ("WHERE assignment target at %L has "
8750 "inconsistent shape", &cnext
->expr1
->where
);
8754 case EXEC_ASSIGN_CALL
:
8755 resolve_call (cnext
);
8756 if (!cnext
->resolved_sym
->attr
.elemental
)
8757 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8758 &cnext
->ext
.actual
->expr
->where
);
8761 /* WHERE or WHERE construct is part of a where-body-construct */
8763 resolve_where (cnext
, e
);
8767 gfc_error ("Unsupported statement inside WHERE at %L",
8770 /* the next statement within the same where-body-construct */
8771 cnext
= cnext
->next
;
8773 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8774 cblock
= cblock
->block
;
8779 /* Resolve assignment in FORALL construct.
8780 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8781 FORALL index variables. */
8784 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8788 for (n
= 0; n
< nvar
; n
++)
8790 gfc_symbol
*forall_index
;
8792 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8794 /* Check whether the assignment target is one of the FORALL index
8796 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8797 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8798 gfc_error ("Assignment to a FORALL index variable at %L",
8799 &code
->expr1
->where
);
8802 /* If one of the FORALL index variables doesn't appear in the
8803 assignment variable, then there could be a many-to-one
8804 assignment. Emit a warning rather than an error because the
8805 mask could be resolving this problem. */
8806 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
8807 gfc_warning ("The FORALL with index '%s' is not used on the "
8808 "left side of the assignment at %L and so might "
8809 "cause multiple assignment to this object",
8810 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8816 /* Resolve WHERE statement in FORALL construct. */
8819 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8820 gfc_expr
**var_expr
)
8825 cblock
= code
->block
;
8828 /* the assignment statement of a WHERE statement, or the first
8829 statement in where-body-construct of a WHERE construct */
8830 cnext
= cblock
->next
;
8835 /* WHERE assignment statement */
8837 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8840 /* WHERE operator assignment statement */
8841 case EXEC_ASSIGN_CALL
:
8842 resolve_call (cnext
);
8843 if (!cnext
->resolved_sym
->attr
.elemental
)
8844 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8845 &cnext
->ext
.actual
->expr
->where
);
8848 /* WHERE or WHERE construct is part of a where-body-construct */
8850 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8854 gfc_error ("Unsupported statement inside WHERE at %L",
8857 /* the next statement within the same where-body-construct */
8858 cnext
= cnext
->next
;
8860 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8861 cblock
= cblock
->block
;
8866 /* Traverse the FORALL body to check whether the following errors exist:
8867 1. For assignment, check if a many-to-one assignment happens.
8868 2. For WHERE statement, check the WHERE body to see if there is any
8869 many-to-one assignment. */
8872 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8876 c
= code
->block
->next
;
8882 case EXEC_POINTER_ASSIGN
:
8883 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8886 case EXEC_ASSIGN_CALL
:
8890 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8891 there is no need to handle it here. */
8895 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8900 /* The next statement in the FORALL body. */
8906 /* Counts the number of iterators needed inside a forall construct, including
8907 nested forall constructs. This is used to allocate the needed memory
8908 in gfc_resolve_forall. */
8911 gfc_count_forall_iterators (gfc_code
*code
)
8913 int max_iters
, sub_iters
, current_iters
;
8914 gfc_forall_iterator
*fa
;
8916 gcc_assert(code
->op
== EXEC_FORALL
);
8920 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8923 code
= code
->block
->next
;
8927 if (code
->op
== EXEC_FORALL
)
8929 sub_iters
= gfc_count_forall_iterators (code
);
8930 if (sub_iters
> max_iters
)
8931 max_iters
= sub_iters
;
8936 return current_iters
+ max_iters
;
8940 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8941 gfc_resolve_forall_body to resolve the FORALL body. */
8944 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8946 static gfc_expr
**var_expr
;
8947 static int total_var
= 0;
8948 static int nvar
= 0;
8950 gfc_forall_iterator
*fa
;
8955 /* Start to resolve a FORALL construct */
8956 if (forall_save
== 0)
8958 /* Count the total number of FORALL index in the nested FORALL
8959 construct in order to allocate the VAR_EXPR with proper size. */
8960 total_var
= gfc_count_forall_iterators (code
);
8962 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8963 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8966 /* The information about FORALL iterator, including FORALL index start, end
8967 and stride. The FORALL index can not appear in start, end or stride. */
8968 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8970 /* Check if any outer FORALL index name is the same as the current
8972 for (i
= 0; i
< nvar
; i
++)
8974 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8976 gfc_error ("An outer FORALL construct already has an index "
8977 "with this name %L", &fa
->var
->where
);
8981 /* Record the current FORALL index. */
8982 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8986 /* No memory leak. */
8987 gcc_assert (nvar
<= total_var
);
8990 /* Resolve the FORALL body. */
8991 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8993 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8994 gfc_resolve_blocks (code
->block
, ns
);
8998 /* Free only the VAR_EXPRs allocated in this frame. */
8999 for (i
= nvar
; i
< tmp
; i
++)
9000 gfc_free_expr (var_expr
[i
]);
9004 /* We are in the outermost FORALL construct. */
9005 gcc_assert (forall_save
== 0);
9007 /* VAR_EXPR is not needed any more. */
9014 /* Resolve a BLOCK construct statement. */
9017 resolve_block_construct (gfc_code
* code
)
9019 /* Resolve the BLOCK's namespace. */
9020 gfc_resolve (code
->ext
.block
.ns
);
9022 /* For an ASSOCIATE block, the associations (and their targets) are already
9023 resolved during resolve_symbol. */
9027 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9030 static void resolve_code (gfc_code
*, gfc_namespace
*);
9033 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9037 for (; b
; b
= b
->block
)
9039 t
= gfc_resolve_expr (b
->expr1
);
9040 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
9046 if (t
== SUCCESS
&& b
->expr1
!= NULL
9047 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9048 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9055 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9056 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9061 resolve_branch (b
->label1
, b
);
9065 resolve_block_construct (b
);
9069 case EXEC_SELECT_TYPE
:
9073 case EXEC_DO_CONCURRENT
:
9081 case EXEC_OMP_ATOMIC
:
9082 case EXEC_OMP_CRITICAL
:
9084 case EXEC_OMP_MASTER
:
9085 case EXEC_OMP_ORDERED
:
9086 case EXEC_OMP_PARALLEL
:
9087 case EXEC_OMP_PARALLEL_DO
:
9088 case EXEC_OMP_PARALLEL_SECTIONS
:
9089 case EXEC_OMP_PARALLEL_WORKSHARE
:
9090 case EXEC_OMP_SECTIONS
:
9091 case EXEC_OMP_SINGLE
:
9093 case EXEC_OMP_TASKWAIT
:
9094 case EXEC_OMP_TASKYIELD
:
9095 case EXEC_OMP_WORKSHARE
:
9099 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9102 resolve_code (b
->next
, ns
);
9107 /* Does everything to resolve an ordinary assignment. Returns true
9108 if this is an interface assignment. */
9110 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9120 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
9124 if (code
->op
== EXEC_ASSIGN_CALL
)
9126 lhs
= code
->ext
.actual
->expr
;
9127 rhsptr
= &code
->ext
.actual
->next
->expr
;
9131 gfc_actual_arglist
* args
;
9132 gfc_typebound_proc
* tbp
;
9134 gcc_assert (code
->op
== EXEC_COMPCALL
);
9136 args
= code
->expr1
->value
.compcall
.actual
;
9138 rhsptr
= &args
->next
->expr
;
9140 tbp
= code
->expr1
->value
.compcall
.tbp
;
9141 gcc_assert (!tbp
->is_generic
);
9144 /* Make a temporary rhs when there is a default initializer
9145 and rhs is the same symbol as the lhs. */
9146 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9147 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9148 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9149 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9150 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9159 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
9160 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9161 &code
->loc
) == FAILURE
)
9164 /* Handle the case of a BOZ literal on the RHS. */
9165 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9168 if (gfc_option
.warn_surprising
)
9169 gfc_warning ("BOZ literal at %L is bitwise transferred "
9170 "non-integer symbol '%s'", &code
->loc
,
9171 lhs
->symtree
->n
.sym
->name
);
9173 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9175 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9177 if (rc
== ARITH_UNDERFLOW
)
9178 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9179 ". This check can be disabled with the option "
9180 "-fno-range-check", &rhs
->where
);
9181 else if (rc
== ARITH_OVERFLOW
)
9182 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9183 ". This check can be disabled with the option "
9184 "-fno-range-check", &rhs
->where
);
9185 else if (rc
== ARITH_NAN
)
9186 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9187 ". This check can be disabled with the option "
9188 "-fno-range-check", &rhs
->where
);
9193 if (lhs
->ts
.type
== BT_CHARACTER
9194 && gfc_option
.warn_character_truncation
)
9196 if (lhs
->ts
.u
.cl
!= NULL
9197 && lhs
->ts
.u
.cl
->length
!= NULL
9198 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9199 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9201 if (rhs
->expr_type
== EXPR_CONSTANT
)
9202 rlen
= rhs
->value
.character
.length
;
9204 else if (rhs
->ts
.u
.cl
!= NULL
9205 && rhs
->ts
.u
.cl
->length
!= NULL
9206 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9207 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9209 if (rlen
&& llen
&& rlen
> llen
)
9210 gfc_warning_now ("CHARACTER expression will be truncated "
9211 "in assignment (%d/%d) at %L",
9212 llen
, rlen
, &code
->loc
);
9215 /* Ensure that a vector index expression for the lvalue is evaluated
9216 to a temporary if the lvalue symbol is referenced in it. */
9219 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9220 if (ref
->type
== REF_ARRAY
)
9222 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9223 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9224 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9225 ref
->u
.ar
.start
[n
]))
9227 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9231 if (gfc_pure (NULL
))
9233 if (lhs
->ts
.type
== BT_DERIVED
9234 && lhs
->expr_type
== EXPR_VARIABLE
9235 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9236 && rhs
->expr_type
== EXPR_VARIABLE
9237 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9238 || gfc_is_coindexed (rhs
)))
9241 if (gfc_is_coindexed (rhs
))
9242 gfc_error ("Coindexed expression at %L is assigned to "
9243 "a derived type variable with a POINTER "
9244 "component in a PURE procedure",
9247 gfc_error ("The impure variable at %L is assigned to "
9248 "a derived type variable with a POINTER "
9249 "component in a PURE procedure (12.6)",
9254 /* Fortran 2008, C1283. */
9255 if (gfc_is_coindexed (lhs
))
9257 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9258 "procedure", &rhs
->where
);
9263 if (gfc_implicit_pure (NULL
))
9265 if (lhs
->expr_type
== EXPR_VARIABLE
9266 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9267 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9268 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9270 if (lhs
->ts
.type
== BT_DERIVED
9271 && lhs
->expr_type
== EXPR_VARIABLE
9272 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9273 && rhs
->expr_type
== EXPR_VARIABLE
9274 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9275 || gfc_is_coindexed (rhs
)))
9276 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9278 /* Fortran 2008, C1283. */
9279 if (gfc_is_coindexed (lhs
))
9280 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9284 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9285 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9286 if (lhs
->ts
.type
== BT_CLASS
)
9288 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9289 "%L - check that there is a matching specific subroutine "
9290 "for '=' operator", &lhs
->where
);
9294 /* F2008, Section 7.2.1.2. */
9295 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9297 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9298 "component in assignment at %L", &lhs
->where
);
9302 gfc_check_assign (lhs
, rhs
, 1);
9307 /* Given a block of code, recursively resolve everything pointed to by this
9311 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9313 int omp_workshare_save
;
9314 int forall_save
, do_concurrent_save
;
9318 frame
.prev
= cs_base
;
9322 find_reachable_labels (code
);
9324 for (; code
; code
= code
->next
)
9326 frame
.current
= code
;
9327 forall_save
= forall_flag
;
9328 do_concurrent_save
= do_concurrent_flag
;
9330 if (code
->op
== EXEC_FORALL
)
9333 gfc_resolve_forall (code
, ns
, forall_save
);
9336 else if (code
->block
)
9338 omp_workshare_save
= -1;
9341 case EXEC_OMP_PARALLEL_WORKSHARE
:
9342 omp_workshare_save
= omp_workshare_flag
;
9343 omp_workshare_flag
= 1;
9344 gfc_resolve_omp_parallel_blocks (code
, ns
);
9346 case EXEC_OMP_PARALLEL
:
9347 case EXEC_OMP_PARALLEL_DO
:
9348 case EXEC_OMP_PARALLEL_SECTIONS
:
9350 omp_workshare_save
= omp_workshare_flag
;
9351 omp_workshare_flag
= 0;
9352 gfc_resolve_omp_parallel_blocks (code
, ns
);
9355 gfc_resolve_omp_do_blocks (code
, ns
);
9357 case EXEC_SELECT_TYPE
:
9358 /* Blocks are handled in resolve_select_type because we have
9359 to transform the SELECT TYPE into ASSOCIATE first. */
9361 case EXEC_DO_CONCURRENT
:
9362 do_concurrent_flag
= 1;
9363 gfc_resolve_blocks (code
->block
, ns
);
9364 do_concurrent_flag
= 2;
9366 case EXEC_OMP_WORKSHARE
:
9367 omp_workshare_save
= omp_workshare_flag
;
9368 omp_workshare_flag
= 1;
9371 gfc_resolve_blocks (code
->block
, ns
);
9375 if (omp_workshare_save
!= -1)
9376 omp_workshare_flag
= omp_workshare_save
;
9380 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9381 t
= gfc_resolve_expr (code
->expr1
);
9382 forall_flag
= forall_save
;
9383 do_concurrent_flag
= do_concurrent_save
;
9385 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
9388 if (code
->op
== EXEC_ALLOCATE
9389 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9395 case EXEC_END_BLOCK
:
9396 case EXEC_END_NESTED_BLOCK
:
9400 case EXEC_ERROR_STOP
:
9404 case EXEC_ASSIGN_CALL
:
9409 case EXEC_SYNC_IMAGES
:
9410 case EXEC_SYNC_MEMORY
:
9411 resolve_sync (code
);
9416 resolve_lock_unlock (code
);
9420 /* Keep track of which entry we are up to. */
9421 current_entry_id
= code
->ext
.entry
->id
;
9425 resolve_where (code
, NULL
);
9429 if (code
->expr1
!= NULL
)
9431 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9432 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9433 "INTEGER variable", &code
->expr1
->where
);
9434 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9435 gfc_error ("Variable '%s' has not been assigned a target "
9436 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9437 &code
->expr1
->where
);
9440 resolve_branch (code
->label1
, code
);
9444 if (code
->expr1
!= NULL
9445 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9446 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9447 "INTEGER return specifier", &code
->expr1
->where
);
9450 case EXEC_INIT_ASSIGN
:
9451 case EXEC_END_PROCEDURE
:
9458 if (gfc_check_vardef_context (code
->expr1
, false, false,
9459 _("assignment")) == FAILURE
)
9462 if (resolve_ordinary_assign (code
, ns
))
9464 if (code
->op
== EXEC_COMPCALL
)
9471 case EXEC_LABEL_ASSIGN
:
9472 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9473 gfc_error ("Label %d referenced at %L is never defined",
9474 code
->label1
->value
, &code
->label1
->where
);
9476 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9477 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9478 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9479 != gfc_default_integer_kind
9480 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9481 gfc_error ("ASSIGN statement at %L requires a scalar "
9482 "default INTEGER variable", &code
->expr1
->where
);
9485 case EXEC_POINTER_ASSIGN
:
9492 /* This is both a variable definition and pointer assignment
9493 context, so check both of them. For rank remapping, a final
9494 array ref may be present on the LHS and fool gfc_expr_attr
9495 used in gfc_check_vardef_context. Remove it. */
9496 e
= remove_last_array_ref (code
->expr1
);
9497 t
= gfc_check_vardef_context (e
, true, false,
9498 _("pointer assignment"));
9500 t
= gfc_check_vardef_context (e
, false, false,
9501 _("pointer assignment"));
9506 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9510 case EXEC_ARITHMETIC_IF
:
9512 && code
->expr1
->ts
.type
!= BT_INTEGER
9513 && code
->expr1
->ts
.type
!= BT_REAL
)
9514 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9515 "expression", &code
->expr1
->where
);
9517 resolve_branch (code
->label1
, code
);
9518 resolve_branch (code
->label2
, code
);
9519 resolve_branch (code
->label3
, code
);
9523 if (t
== SUCCESS
&& code
->expr1
!= NULL
9524 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9525 || code
->expr1
->rank
!= 0))
9526 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9527 &code
->expr1
->where
);
9532 resolve_call (code
);
9537 resolve_typebound_subroutine (code
);
9541 resolve_ppc_call (code
);
9545 /* Select is complicated. Also, a SELECT construct could be
9546 a transformed computed GOTO. */
9547 resolve_select (code
);
9550 case EXEC_SELECT_TYPE
:
9551 resolve_select_type (code
, ns
);
9555 resolve_block_construct (code
);
9559 if (code
->ext
.iterator
!= NULL
)
9561 gfc_iterator
*iter
= code
->ext
.iterator
;
9562 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9563 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9568 if (code
->expr1
== NULL
)
9569 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9571 && (code
->expr1
->rank
!= 0
9572 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9573 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9574 "a scalar LOGICAL expression", &code
->expr1
->where
);
9579 resolve_allocate_deallocate (code
, "ALLOCATE");
9583 case EXEC_DEALLOCATE
:
9585 resolve_allocate_deallocate (code
, "DEALLOCATE");
9590 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9593 resolve_branch (code
->ext
.open
->err
, code
);
9597 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9600 resolve_branch (code
->ext
.close
->err
, code
);
9603 case EXEC_BACKSPACE
:
9607 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9610 resolve_branch (code
->ext
.filepos
->err
, code
);
9614 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9617 resolve_branch (code
->ext
.inquire
->err
, code
);
9621 gcc_assert (code
->ext
.inquire
!= NULL
);
9622 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9625 resolve_branch (code
->ext
.inquire
->err
, code
);
9629 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9632 resolve_branch (code
->ext
.wait
->err
, code
);
9633 resolve_branch (code
->ext
.wait
->end
, code
);
9634 resolve_branch (code
->ext
.wait
->eor
, code
);
9639 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9642 resolve_branch (code
->ext
.dt
->err
, code
);
9643 resolve_branch (code
->ext
.dt
->end
, code
);
9644 resolve_branch (code
->ext
.dt
->eor
, code
);
9648 resolve_transfer (code
);
9651 case EXEC_DO_CONCURRENT
:
9653 resolve_forall_iterators (code
->ext
.forall_iterator
);
9655 if (code
->expr1
!= NULL
9656 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9657 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9658 "expression", &code
->expr1
->where
);
9661 case EXEC_OMP_ATOMIC
:
9662 case EXEC_OMP_BARRIER
:
9663 case EXEC_OMP_CRITICAL
:
9664 case EXEC_OMP_FLUSH
:
9666 case EXEC_OMP_MASTER
:
9667 case EXEC_OMP_ORDERED
:
9668 case EXEC_OMP_SECTIONS
:
9669 case EXEC_OMP_SINGLE
:
9670 case EXEC_OMP_TASKWAIT
:
9671 case EXEC_OMP_TASKYIELD
:
9672 case EXEC_OMP_WORKSHARE
:
9673 gfc_resolve_omp_directive (code
, ns
);
9676 case EXEC_OMP_PARALLEL
:
9677 case EXEC_OMP_PARALLEL_DO
:
9678 case EXEC_OMP_PARALLEL_SECTIONS
:
9679 case EXEC_OMP_PARALLEL_WORKSHARE
:
9681 omp_workshare_save
= omp_workshare_flag
;
9682 omp_workshare_flag
= 0;
9683 gfc_resolve_omp_directive (code
, ns
);
9684 omp_workshare_flag
= omp_workshare_save
;
9688 gfc_internal_error ("resolve_code(): Bad statement code");
9692 cs_base
= frame
.prev
;
9696 /* Resolve initial values and make sure they are compatible with
9700 resolve_values (gfc_symbol
*sym
)
9704 if (sym
->value
== NULL
)
9707 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9708 t
= resolve_structure_cons (sym
->value
, 1);
9710 t
= gfc_resolve_expr (sym
->value
);
9715 gfc_check_assign_symbol (sym
, sym
->value
);
9719 /* Verify the binding labels for common blocks that are BIND(C). The label
9720 for a BIND(C) common block must be identical in all scoping units in which
9721 the common block is declared. Further, the binding label can not collide
9722 with any other global entity in the program. */
9725 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9727 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9729 gfc_gsymbol
*binding_label_gsym
;
9730 gfc_gsymbol
*comm_name_gsym
;
9731 const char * bind_label
= comm_block_tree
->n
.common
->binding_label
9732 ? comm_block_tree
->n
.common
->binding_label
: "";
9734 /* See if a global symbol exists by the common block's name. It may
9735 be NULL if the common block is use-associated. */
9736 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9737 comm_block_tree
->n
.common
->name
);
9738 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9739 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9740 "with the global entity '%s' at %L",
9742 comm_block_tree
->n
.common
->name
,
9743 &(comm_block_tree
->n
.common
->where
),
9744 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9745 else if (comm_name_gsym
!= NULL
9746 && strcmp (comm_name_gsym
->name
,
9747 comm_block_tree
->n
.common
->name
) == 0)
9749 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9751 if (comm_name_gsym
->binding_label
== NULL
)
9752 /* No binding label for common block stored yet; save this one. */
9753 comm_name_gsym
->binding_label
= bind_label
;
9754 else if (strcmp (comm_name_gsym
->binding_label
, bind_label
) != 0)
9756 /* Common block names match but binding labels do not. */
9757 gfc_error ("Binding label '%s' for common block '%s' at %L "
9758 "does not match the binding label '%s' for common "
9761 comm_block_tree
->n
.common
->name
,
9762 &(comm_block_tree
->n
.common
->where
),
9763 comm_name_gsym
->binding_label
,
9764 comm_name_gsym
->name
,
9765 &(comm_name_gsym
->where
));
9770 /* There is no binding label (NAME="") so we have nothing further to
9771 check and nothing to add as a global symbol for the label. */
9772 if (!comm_block_tree
->n
.common
->binding_label
)
9775 binding_label_gsym
=
9776 gfc_find_gsymbol (gfc_gsym_root
,
9777 comm_block_tree
->n
.common
->binding_label
);
9778 if (binding_label_gsym
== NULL
)
9780 /* Need to make a global symbol for the binding label to prevent
9781 it from colliding with another. */
9782 binding_label_gsym
=
9783 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9784 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9785 binding_label_gsym
->type
= GSYM_COMMON
;
9789 /* If comm_name_gsym is NULL, the name common block is use
9790 associated and the name could be colliding. */
9791 if (binding_label_gsym
->type
!= GSYM_COMMON
)
9792 gfc_error ("Binding label '%s' for common block '%s' at %L "
9793 "collides with the global entity '%s' at %L",
9794 comm_block_tree
->n
.common
->binding_label
,
9795 comm_block_tree
->n
.common
->name
,
9796 &(comm_block_tree
->n
.common
->where
),
9797 binding_label_gsym
->name
,
9798 &(binding_label_gsym
->where
));
9799 else if (comm_name_gsym
!= NULL
9800 && (strcmp (binding_label_gsym
->name
,
9801 comm_name_gsym
->binding_label
) != 0)
9802 && (strcmp (binding_label_gsym
->sym_name
,
9803 comm_name_gsym
->name
) != 0))
9804 gfc_error ("Binding label '%s' for common block '%s' at %L "
9805 "collides with global entity '%s' at %L",
9806 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
9807 &(comm_block_tree
->n
.common
->where
),
9808 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9816 /* Verify any BIND(C) derived types in the namespace so we can report errors
9817 for them once, rather than for each variable declared of that type. */
9820 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
9822 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
9823 && derived_sym
->attr
.is_bind_c
== 1)
9824 verify_bind_c_derived_type (derived_sym
);
9830 /* Verify that any binding labels used in a given namespace do not collide
9831 with the names or binding labels of any global symbols. */
9834 gfc_verify_binding_labels (gfc_symbol
*sym
)
9838 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
9839 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
)
9841 gfc_gsymbol
*bind_c_sym
;
9843 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
9844 if (bind_c_sym
!= NULL
9845 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
9847 if (sym
->attr
.if_source
== IFSRC_DECL
9848 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
9849 && bind_c_sym
->type
!= GSYM_FUNCTION
)
9850 && ((sym
->attr
.contained
== 1
9851 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
9852 || (sym
->attr
.use_assoc
== 1
9853 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
9855 /* Make sure global procedures don't collide with anything. */
9856 gfc_error ("Binding label '%s' at %L collides with the global "
9857 "entity '%s' at %L", sym
->binding_label
,
9858 &(sym
->declared_at
), bind_c_sym
->name
,
9859 &(bind_c_sym
->where
));
9862 else if (sym
->attr
.contained
== 0
9863 && (sym
->attr
.if_source
== IFSRC_IFBODY
9864 && sym
->attr
.flavor
== FL_PROCEDURE
)
9865 && (bind_c_sym
->sym_name
!= NULL
9866 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
9868 /* Make sure procedures in interface bodies don't collide. */
9869 gfc_error ("Binding label '%s' in interface body at %L collides "
9870 "with the global entity '%s' at %L",
9872 &(sym
->declared_at
), bind_c_sym
->name
,
9873 &(bind_c_sym
->where
));
9876 else if (sym
->attr
.contained
== 0
9877 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
9878 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
9879 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
9880 || sym
->attr
.use_assoc
== 0)
9882 gfc_error ("Binding label '%s' at %L collides with global "
9883 "entity '%s' at %L", sym
->binding_label
,
9884 &(sym
->declared_at
), bind_c_sym
->name
,
9885 &(bind_c_sym
->where
));
9890 /* Clear the binding label to prevent checking multiple times. */
9891 sym
->binding_label
= NULL
;
9893 else if (bind_c_sym
== NULL
)
9895 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
9896 bind_c_sym
->where
= sym
->declared_at
;
9897 bind_c_sym
->sym_name
= sym
->name
;
9899 if (sym
->attr
.use_assoc
== 1)
9900 bind_c_sym
->mod_name
= sym
->module
;
9902 if (sym
->ns
->proc_name
!= NULL
)
9903 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
9905 if (sym
->attr
.contained
== 0)
9907 if (sym
->attr
.subroutine
)
9908 bind_c_sym
->type
= GSYM_SUBROUTINE
;
9909 else if (sym
->attr
.function
)
9910 bind_c_sym
->type
= GSYM_FUNCTION
;
9918 /* Resolve an index expression. */
9921 resolve_index_expr (gfc_expr
*e
)
9923 if (gfc_resolve_expr (e
) == FAILURE
)
9926 if (gfc_simplify_expr (e
, 0) == FAILURE
)
9929 if (gfc_specification_expr (e
) == FAILURE
)
9936 /* Resolve a charlen structure. */
9939 resolve_charlen (gfc_charlen
*cl
)
9949 if (cl
->length_from_typespec
)
9951 if (gfc_resolve_expr (cl
->length
) == FAILURE
)
9954 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
9959 specification_expr
= 1;
9961 if (resolve_index_expr (cl
->length
) == FAILURE
)
9963 specification_expr
= 0;
9968 /* "If the character length parameter value evaluates to a negative
9969 value, the length of character entities declared is zero." */
9970 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
9972 if (gfc_option
.warn_surprising
)
9973 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9974 " the length has been set to zero",
9975 &cl
->length
->where
, i
);
9976 gfc_replace_expr (cl
->length
,
9977 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
9980 /* Check that the character length is not too large. */
9981 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
9982 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
9983 && cl
->length
->ts
.type
== BT_INTEGER
9984 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
9986 gfc_error ("String length at %L is too large", &cl
->length
->where
);
9994 /* Test for non-constant shape arrays. */
9997 is_non_constant_shape_array (gfc_symbol
*sym
)
10003 not_constant
= false;
10004 if (sym
->as
!= NULL
)
10006 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10007 has not been simplified; parameter array references. Do the
10008 simplification now. */
10009 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10011 e
= sym
->as
->lower
[i
];
10012 if (e
&& (resolve_index_expr (e
) == FAILURE
10013 || !gfc_is_constant_expr (e
)))
10014 not_constant
= true;
10015 e
= sym
->as
->upper
[i
];
10016 if (e
&& (resolve_index_expr (e
) == FAILURE
10017 || !gfc_is_constant_expr (e
)))
10018 not_constant
= true;
10021 return not_constant
;
10024 /* Given a symbol and an initialization expression, add code to initialize
10025 the symbol to the function entry. */
10027 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10031 gfc_namespace
*ns
= sym
->ns
;
10033 /* Search for the function namespace if this is a contained
10034 function without an explicit result. */
10035 if (sym
->attr
.function
&& sym
== sym
->result
10036 && sym
->name
!= sym
->ns
->proc_name
->name
)
10038 ns
= ns
->contained
;
10039 for (;ns
; ns
= ns
->sibling
)
10040 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10046 gfc_free_expr (init
);
10050 /* Build an l-value expression for the result. */
10051 lval
= gfc_lval_expr_from_sym (sym
);
10053 /* Add the code at scope entry. */
10054 init_st
= gfc_get_code ();
10055 init_st
->next
= ns
->code
;
10056 ns
->code
= init_st
;
10058 /* Assign the default initializer to the l-value. */
10059 init_st
->loc
= sym
->declared_at
;
10060 init_st
->op
= EXEC_INIT_ASSIGN
;
10061 init_st
->expr1
= lval
;
10062 init_st
->expr2
= init
;
10065 /* Assign the default initializer to a derived type variable or result. */
10068 apply_default_init (gfc_symbol
*sym
)
10070 gfc_expr
*init
= NULL
;
10072 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10075 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10076 init
= gfc_default_initializer (&sym
->ts
);
10078 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10081 build_init_assign (sym
, init
);
10082 sym
->attr
.referenced
= 1;
10085 /* Build an initializer for a local integer, real, complex, logical, or
10086 character variable, based on the command line flags finit-local-zero,
10087 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10088 null if the symbol should not have a default initialization. */
10090 build_default_init_expr (gfc_symbol
*sym
)
10093 gfc_expr
*init_expr
;
10096 /* These symbols should never have a default initialization. */
10097 if (sym
->attr
.allocatable
10098 || sym
->attr
.external
10100 || sym
->attr
.pointer
10101 || sym
->attr
.in_equivalence
10102 || sym
->attr
.in_common
10105 || sym
->attr
.cray_pointee
10106 || sym
->attr
.cray_pointer
10110 /* Now we'll try to build an initializer expression. */
10111 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10112 &sym
->declared_at
);
10114 /* We will only initialize integers, reals, complex, logicals, and
10115 characters, and only if the corresponding command-line flags
10116 were set. Otherwise, we free init_expr and return null. */
10117 switch (sym
->ts
.type
)
10120 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10121 mpz_set_si (init_expr
->value
.integer
,
10122 gfc_option
.flag_init_integer_value
);
10125 gfc_free_expr (init_expr
);
10131 switch (gfc_option
.flag_init_real
)
10133 case GFC_INIT_REAL_SNAN
:
10134 init_expr
->is_snan
= 1;
10135 /* Fall through. */
10136 case GFC_INIT_REAL_NAN
:
10137 mpfr_set_nan (init_expr
->value
.real
);
10140 case GFC_INIT_REAL_INF
:
10141 mpfr_set_inf (init_expr
->value
.real
, 1);
10144 case GFC_INIT_REAL_NEG_INF
:
10145 mpfr_set_inf (init_expr
->value
.real
, -1);
10148 case GFC_INIT_REAL_ZERO
:
10149 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10153 gfc_free_expr (init_expr
);
10160 switch (gfc_option
.flag_init_real
)
10162 case GFC_INIT_REAL_SNAN
:
10163 init_expr
->is_snan
= 1;
10164 /* Fall through. */
10165 case GFC_INIT_REAL_NAN
:
10166 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10167 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10170 case GFC_INIT_REAL_INF
:
10171 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10172 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10175 case GFC_INIT_REAL_NEG_INF
:
10176 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10177 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10180 case GFC_INIT_REAL_ZERO
:
10181 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10185 gfc_free_expr (init_expr
);
10192 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10193 init_expr
->value
.logical
= 0;
10194 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10195 init_expr
->value
.logical
= 1;
10198 gfc_free_expr (init_expr
);
10204 /* For characters, the length must be constant in order to
10205 create a default initializer. */
10206 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10207 && sym
->ts
.u
.cl
->length
10208 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10210 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10211 init_expr
->value
.character
.length
= char_len
;
10212 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10213 for (i
= 0; i
< char_len
; i
++)
10214 init_expr
->value
.character
.string
[i
]
10215 = (unsigned char) gfc_option
.flag_init_character_value
;
10219 gfc_free_expr (init_expr
);
10222 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10223 && sym
->ts
.u
.cl
->length
)
10225 gfc_actual_arglist
*arg
;
10226 init_expr
= gfc_get_expr ();
10227 init_expr
->where
= sym
->declared_at
;
10228 init_expr
->ts
= sym
->ts
;
10229 init_expr
->expr_type
= EXPR_FUNCTION
;
10230 init_expr
->value
.function
.isym
=
10231 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10232 init_expr
->value
.function
.name
= "repeat";
10233 arg
= gfc_get_actual_arglist ();
10234 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10236 arg
->expr
->value
.character
.string
[0]
10237 = gfc_option
.flag_init_character_value
;
10238 arg
->next
= gfc_get_actual_arglist ();
10239 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10240 init_expr
->value
.function
.actual
= arg
;
10245 gfc_free_expr (init_expr
);
10251 /* Add an initialization expression to a local variable. */
10253 apply_default_init_local (gfc_symbol
*sym
)
10255 gfc_expr
*init
= NULL
;
10257 /* The symbol should be a variable or a function return value. */
10258 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10259 || (sym
->attr
.function
&& sym
->result
!= sym
))
10262 /* Try to build the initializer expression. If we can't initialize
10263 this symbol, then init will be NULL. */
10264 init
= build_default_init_expr (sym
);
10268 /* For saved variables, we don't want to add an initializer at function
10269 entry, so we just add a static initializer. Note that automatic variables
10270 are stack allocated even with -fno-automatic. */
10271 if (sym
->attr
.save
|| sym
->ns
->save_all
10272 || (gfc_option
.flag_max_stack_var_size
== 0
10273 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10275 /* Don't clobber an existing initializer! */
10276 gcc_assert (sym
->value
== NULL
);
10281 build_init_assign (sym
, init
);
10285 /* Resolution of common features of flavors variable and procedure. */
10288 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10290 gfc_array_spec
*as
;
10292 /* Avoid double diagnostics for function result symbols. */
10293 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
10294 && (sym
->ns
!= gfc_current_ns
))
10297 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10298 as
= CLASS_DATA (sym
)->as
;
10302 /* Constraints on deferred shape variable. */
10303 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10305 bool pointer
, allocatable
, dimension
;
10307 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10309 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10310 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10311 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10315 pointer
= sym
->attr
.pointer
;
10316 allocatable
= sym
->attr
.allocatable
;
10317 dimension
= sym
->attr
.dimension
;
10324 gfc_error ("Allocatable array '%s' at %L must have "
10325 "a deferred shape", sym
->name
, &sym
->declared_at
);
10328 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object '%s' at %L "
10329 "may not be ALLOCATABLE", sym
->name
,
10330 &sym
->declared_at
) == FAILURE
)
10334 if (pointer
&& dimension
)
10336 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10337 sym
->name
, &sym
->declared_at
);
10343 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10344 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10346 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10347 sym
->name
, &sym
->declared_at
);
10352 /* Constraints on polymorphic variables. */
10353 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10356 if (sym
->attr
.class_ok
10357 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10359 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10360 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10361 &sym
->declared_at
);
10366 /* Assume that use associated symbols were checked in the module ns.
10367 Class-variables that are associate-names are also something special
10368 and excepted from the test. */
10369 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10371 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10372 "or pointer", sym
->name
, &sym
->declared_at
);
10381 /* Additional checks for symbols with flavor variable and derived
10382 type. To be called from resolve_fl_variable. */
10385 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10387 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10389 /* Check to see if a derived type is blocked from being host
10390 associated by the presence of another class I symbol in the same
10391 namespace. 14.6.1.3 of the standard and the discussion on
10392 comp.lang.fortran. */
10393 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10394 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10397 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10398 if (s
&& s
->attr
.generic
)
10399 s
= gfc_find_dt_in_generic (s
);
10400 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10402 gfc_error ("The type '%s' cannot be host associated at %L "
10403 "because it is blocked by an incompatible object "
10404 "of the same name declared at %L",
10405 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10411 /* 4th constraint in section 11.3: "If an object of a type for which
10412 component-initialization is specified (R429) appears in the
10413 specification-part of a module and does not have the ALLOCATABLE
10414 or POINTER attribute, the object shall have the SAVE attribute."
10416 The check for initializers is performed with
10417 gfc_has_default_initializer because gfc_default_initializer generates
10418 a hidden default for allocatable components. */
10419 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10420 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10421 && !sym
->ns
->save_all
&& !sym
->attr
.save
10422 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10423 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10424 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Implied SAVE for "
10425 "module variable '%s' at %L, needed due to "
10426 "the default initialization", sym
->name
,
10427 &sym
->declared_at
) == FAILURE
)
10430 /* Assign default initializer. */
10431 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10432 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10434 sym
->value
= gfc_default_initializer (&sym
->ts
);
10441 /* Resolve symbols with flavor variable. */
10444 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10446 int no_init_flag
, automatic_flag
;
10448 const char *auto_save_msg
;
10450 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10453 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10456 /* Set this flag to check that variables are parameters of all entries.
10457 This check is effected by the call to gfc_resolve_expr through
10458 is_non_constant_shape_array. */
10459 specification_expr
= 1;
10461 if (sym
->ns
->proc_name
10462 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10463 || sym
->ns
->proc_name
->attr
.is_main_program
)
10464 && !sym
->attr
.use_assoc
10465 && !sym
->attr
.allocatable
10466 && !sym
->attr
.pointer
10467 && is_non_constant_shape_array (sym
))
10469 /* The shape of a main program or module array needs to be
10471 gfc_error ("The module or main program array '%s' at %L must "
10472 "have constant shape", sym
->name
, &sym
->declared_at
);
10473 specification_expr
= 0;
10477 /* Constraints on deferred type parameter. */
10478 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10480 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10481 "requires either the pointer or allocatable attribute",
10482 sym
->name
, &sym
->declared_at
);
10486 if (sym
->ts
.type
== BT_CHARACTER
)
10488 /* Make sure that character string variables with assumed length are
10489 dummy arguments. */
10490 e
= sym
->ts
.u
.cl
->length
;
10491 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10492 && !sym
->ts
.deferred
)
10494 gfc_error ("Entity with assumed character length at %L must be a "
10495 "dummy argument or a PARAMETER", &sym
->declared_at
);
10499 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10501 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10505 if (!gfc_is_constant_expr (e
)
10506 && !(e
->expr_type
== EXPR_VARIABLE
10507 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10509 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10510 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10511 || sym
->ns
->proc_name
->attr
.is_main_program
))
10513 gfc_error ("'%s' at %L must have constant character length "
10514 "in this context", sym
->name
, &sym
->declared_at
);
10517 if (sym
->attr
.in_common
)
10519 gfc_error ("COMMON variable '%s' at %L must have constant "
10520 "character length", sym
->name
, &sym
->declared_at
);
10526 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10527 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10529 /* Determine if the symbol may not have an initializer. */
10530 no_init_flag
= automatic_flag
= 0;
10531 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10532 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10534 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10535 && is_non_constant_shape_array (sym
))
10537 no_init_flag
= automatic_flag
= 1;
10539 /* Also, they must not have the SAVE attribute.
10540 SAVE_IMPLICIT is checked below. */
10541 if (sym
->as
&& sym
->attr
.codimension
)
10543 int corank
= sym
->as
->corank
;
10544 sym
->as
->corank
= 0;
10545 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10546 sym
->as
->corank
= corank
;
10548 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10550 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10555 /* Ensure that any initializer is simplified. */
10557 gfc_simplify_expr (sym
->value
, 1);
10559 /* Reject illegal initializers. */
10560 if (!sym
->mark
&& sym
->value
)
10562 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10563 && CLASS_DATA (sym
)->attr
.allocatable
))
10564 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10565 sym
->name
, &sym
->declared_at
);
10566 else if (sym
->attr
.external
)
10567 gfc_error ("External '%s' at %L cannot have an initializer",
10568 sym
->name
, &sym
->declared_at
);
10569 else if (sym
->attr
.dummy
10570 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10571 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10572 sym
->name
, &sym
->declared_at
);
10573 else if (sym
->attr
.intrinsic
)
10574 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10575 sym
->name
, &sym
->declared_at
);
10576 else if (sym
->attr
.result
)
10577 gfc_error ("Function result '%s' at %L cannot have an initializer",
10578 sym
->name
, &sym
->declared_at
);
10579 else if (automatic_flag
)
10580 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10581 sym
->name
, &sym
->declared_at
);
10583 goto no_init_error
;
10588 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10589 return resolve_fl_variable_derived (sym
, no_init_flag
);
10595 /* Resolve a procedure. */
10598 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10600 gfc_formal_arglist
*arg
;
10602 if (sym
->attr
.function
10603 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10606 if (sym
->ts
.type
== BT_CHARACTER
)
10608 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10610 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10611 && resolve_charlen (cl
) == FAILURE
)
10614 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10615 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10617 gfc_error ("Character-valued statement function '%s' at %L must "
10618 "have constant length", sym
->name
, &sym
->declared_at
);
10623 /* Ensure that derived type for are not of a private type. Internal
10624 module procedures are excluded by 2.2.3.3 - i.e., they are not
10625 externally accessible and can access all the objects accessible in
10627 if (!(sym
->ns
->parent
10628 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10629 && gfc_check_symbol_access (sym
))
10631 gfc_interface
*iface
;
10633 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10636 && arg
->sym
->ts
.type
== BT_DERIVED
10637 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10638 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10639 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
10640 "PRIVATE type and cannot be a dummy argument"
10641 " of '%s', which is PUBLIC at %L",
10642 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10645 /* Stop this message from recurring. */
10646 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10651 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10652 PRIVATE to the containing module. */
10653 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10655 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10658 && arg
->sym
->ts
.type
== BT_DERIVED
10659 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10660 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10661 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10662 "'%s' in PUBLIC interface '%s' at %L "
10663 "takes dummy arguments of '%s' which is "
10664 "PRIVATE", iface
->sym
->name
, sym
->name
,
10665 &iface
->sym
->declared_at
,
10666 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10668 /* Stop this message from recurring. */
10669 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10675 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10676 PRIVATE to the containing module. */
10677 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10679 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10682 && arg
->sym
->ts
.type
== BT_DERIVED
10683 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10684 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10685 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10686 "'%s' in PUBLIC interface '%s' at %L "
10687 "takes dummy arguments of '%s' which is "
10688 "PRIVATE", iface
->sym
->name
, sym
->name
,
10689 &iface
->sym
->declared_at
,
10690 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10692 /* Stop this message from recurring. */
10693 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10700 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10701 && !sym
->attr
.proc_pointer
)
10703 gfc_error ("Function '%s' at %L cannot have an initializer",
10704 sym
->name
, &sym
->declared_at
);
10708 /* An external symbol may not have an initializer because it is taken to be
10709 a procedure. Exception: Procedure Pointers. */
10710 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10712 gfc_error ("External object '%s' at %L may not have an initializer",
10713 sym
->name
, &sym
->declared_at
);
10717 /* An elemental function is required to return a scalar 12.7.1 */
10718 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10720 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10721 "result", sym
->name
, &sym
->declared_at
);
10722 /* Reset so that the error only occurs once. */
10723 sym
->attr
.elemental
= 0;
10727 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10728 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10730 gfc_error ("Statement function '%s' at %L may not have pointer or "
10731 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10735 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10736 char-len-param shall not be array-valued, pointer-valued, recursive
10737 or pure. ....snip... A character value of * may only be used in the
10738 following ways: (i) Dummy arg of procedure - dummy associates with
10739 actual length; (ii) To declare a named constant; or (iii) External
10740 function - but length must be declared in calling scoping unit. */
10741 if (sym
->attr
.function
10742 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
10743 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10745 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10746 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10748 if (sym
->as
&& sym
->as
->rank
)
10749 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10750 "array-valued", sym
->name
, &sym
->declared_at
);
10752 if (sym
->attr
.pointer
)
10753 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10754 "pointer-valued", sym
->name
, &sym
->declared_at
);
10756 if (sym
->attr
.pure
)
10757 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10758 "pure", sym
->name
, &sym
->declared_at
);
10760 if (sym
->attr
.recursive
)
10761 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10762 "recursive", sym
->name
, &sym
->declared_at
);
10767 /* Appendix B.2 of the standard. Contained functions give an
10768 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10769 character length is an F2003 feature. */
10770 if (!sym
->attr
.contained
10771 && gfc_current_form
!= FORM_FIXED
10772 && !sym
->ts
.deferred
)
10773 gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
10774 "CHARACTER(*) function '%s' at %L",
10775 sym
->name
, &sym
->declared_at
);
10778 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10780 gfc_formal_arglist
*curr_arg
;
10781 int has_non_interop_arg
= 0;
10783 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10784 sym
->common_block
) == FAILURE
)
10786 /* Clear these to prevent looking at them again if there was an
10788 sym
->attr
.is_bind_c
= 0;
10789 sym
->attr
.is_c_interop
= 0;
10790 sym
->ts
.is_c_interop
= 0;
10794 /* So far, no errors have been found. */
10795 sym
->attr
.is_c_interop
= 1;
10796 sym
->ts
.is_c_interop
= 1;
10799 curr_arg
= sym
->formal
;
10800 while (curr_arg
!= NULL
)
10802 /* Skip implicitly typed dummy args here. */
10803 if (curr_arg
->sym
->attr
.implicit_type
== 0)
10804 if (gfc_verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
10805 /* If something is found to fail, record the fact so we
10806 can mark the symbol for the procedure as not being
10807 BIND(C) to try and prevent multiple errors being
10809 has_non_interop_arg
= 1;
10811 curr_arg
= curr_arg
->next
;
10814 /* See if any of the arguments were not interoperable and if so, clear
10815 the procedure symbol to prevent duplicate error messages. */
10816 if (has_non_interop_arg
!= 0)
10818 sym
->attr
.is_c_interop
= 0;
10819 sym
->ts
.is_c_interop
= 0;
10820 sym
->attr
.is_bind_c
= 0;
10824 if (!sym
->attr
.proc_pointer
)
10826 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10828 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10829 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10832 if (sym
->attr
.intent
)
10834 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10835 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10838 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
10840 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10841 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10844 if (sym
->attr
.external
&& sym
->attr
.function
10845 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
10846 || sym
->attr
.contained
))
10848 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10849 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10852 if (strcmp ("ppr@", sym
->name
) == 0)
10854 gfc_error ("Procedure pointer result '%s' at %L "
10855 "is missing the pointer attribute",
10856 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
10865 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10866 been defined and we now know their defined arguments, check that they fulfill
10867 the requirements of the standard for procedures used as finalizers. */
10870 gfc_resolve_finalizers (gfc_symbol
* derived
)
10872 gfc_finalizer
* list
;
10873 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
10874 gfc_try result
= SUCCESS
;
10875 bool seen_scalar
= false;
10877 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
10880 /* Walk over the list of finalizer-procedures, check them, and if any one
10881 does not fit in with the standard's definition, print an error and remove
10882 it from the list. */
10883 prev_link
= &derived
->f2k_derived
->finalizers
;
10884 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
10890 /* Skip this finalizer if we already resolved it. */
10891 if (list
->proc_tree
)
10893 prev_link
= &(list
->next
);
10897 /* Check this exists and is a SUBROUTINE. */
10898 if (!list
->proc_sym
->attr
.subroutine
)
10900 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10901 list
->proc_sym
->name
, &list
->where
);
10905 /* We should have exactly one argument. */
10906 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
10908 gfc_error ("FINAL procedure at %L must have exactly one argument",
10912 arg
= list
->proc_sym
->formal
->sym
;
10914 /* This argument must be of our type. */
10915 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
10917 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10918 &arg
->declared_at
, derived
->name
);
10922 /* It must neither be a pointer nor allocatable nor optional. */
10923 if (arg
->attr
.pointer
)
10925 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10926 &arg
->declared_at
);
10929 if (arg
->attr
.allocatable
)
10931 gfc_error ("Argument of FINAL procedure at %L must not be"
10932 " ALLOCATABLE", &arg
->declared_at
);
10935 if (arg
->attr
.optional
)
10937 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10938 &arg
->declared_at
);
10942 /* It must not be INTENT(OUT). */
10943 if (arg
->attr
.intent
== INTENT_OUT
)
10945 gfc_error ("Argument of FINAL procedure at %L must not be"
10946 " INTENT(OUT)", &arg
->declared_at
);
10950 /* Warn if the procedure is non-scalar and not assumed shape. */
10951 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
10952 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
10953 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10954 " shape argument", &arg
->declared_at
);
10956 /* Check that it does not match in kind and rank with a FINAL procedure
10957 defined earlier. To really loop over the *earlier* declarations,
10958 we need to walk the tail of the list as new ones were pushed at the
10960 /* TODO: Handle kind parameters once they are implemented. */
10961 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
10962 for (i
= list
->next
; i
; i
= i
->next
)
10964 /* Argument list might be empty; that is an error signalled earlier,
10965 but we nevertheless continued resolving. */
10966 if (i
->proc_sym
->formal
)
10968 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
10969 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
10970 if (i_rank
== my_rank
)
10972 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10973 " rank (%d) as '%s'",
10974 list
->proc_sym
->name
, &list
->where
, my_rank
,
10975 i
->proc_sym
->name
);
10981 /* Is this the/a scalar finalizer procedure? */
10982 if (!arg
->as
|| arg
->as
->rank
== 0)
10983 seen_scalar
= true;
10985 /* Find the symtree for this procedure. */
10986 gcc_assert (!list
->proc_tree
);
10987 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
10989 prev_link
= &list
->next
;
10992 /* Remove wrong nodes immediately from the list so we don't risk any
10993 troubles in the future when they might fail later expectations. */
10997 *prev_link
= list
->next
;
10998 gfc_free_finalizer (i
);
11001 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11002 were nodes in the list, must have been for arrays. It is surely a good
11003 idea to have a scalar version there if there's something to finalize. */
11004 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
11005 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11006 " defined at %L, suggest also scalar one",
11007 derived
->name
, &derived
->declared_at
);
11009 /* TODO: Remove this error when finalization is finished. */
11010 gfc_error ("Finalization at %L is not yet implemented",
11011 &derived
->declared_at
);
11017 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11020 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11021 const char* generic_name
, locus where
)
11026 gcc_assert (t1
->specific
&& t2
->specific
);
11027 gcc_assert (!t1
->specific
->is_generic
);
11028 gcc_assert (!t2
->specific
->is_generic
);
11029 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11031 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11032 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11037 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11038 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11039 || sym1
->attr
.function
!= sym2
->attr
.function
)
11041 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11042 " GENERIC '%s' at %L",
11043 sym1
->name
, sym2
->name
, generic_name
, &where
);
11047 /* Compare the interfaces. */
11048 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11051 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11052 sym1
->name
, sym2
->name
, generic_name
, &where
);
11060 /* Worker function for resolving a generic procedure binding; this is used to
11061 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11063 The difference between those cases is finding possible inherited bindings
11064 that are overridden, as one has to look for them in tb_sym_root,
11065 tb_uop_root or tb_op, respectively. Thus the caller must already find
11066 the super-type and set p->overridden correctly. */
11069 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11070 gfc_typebound_proc
* p
, const char* name
)
11072 gfc_tbp_generic
* target
;
11073 gfc_symtree
* first_target
;
11074 gfc_symtree
* inherited
;
11076 gcc_assert (p
&& p
->is_generic
);
11078 /* Try to find the specific bindings for the symtrees in our target-list. */
11079 gcc_assert (p
->u
.generic
);
11080 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11081 if (!target
->specific
)
11083 gfc_typebound_proc
* overridden_tbp
;
11084 gfc_tbp_generic
* g
;
11085 const char* target_name
;
11087 target_name
= target
->specific_st
->name
;
11089 /* Defined for this type directly. */
11090 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11092 target
->specific
= target
->specific_st
->n
.tb
;
11093 goto specific_found
;
11096 /* Look for an inherited specific binding. */
11099 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11104 gcc_assert (inherited
->n
.tb
);
11105 target
->specific
= inherited
->n
.tb
;
11106 goto specific_found
;
11110 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11111 " at %L", target_name
, name
, &p
->where
);
11114 /* Once we've found the specific binding, check it is not ambiguous with
11115 other specifics already found or inherited for the same GENERIC. */
11117 gcc_assert (target
->specific
);
11119 /* This must really be a specific binding! */
11120 if (target
->specific
->is_generic
)
11122 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11123 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11127 /* Check those already resolved on this type directly. */
11128 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11129 if (g
!= target
&& g
->specific
11130 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
11134 /* Check for ambiguity with inherited specific targets. */
11135 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11136 overridden_tbp
= overridden_tbp
->overridden
)
11137 if (overridden_tbp
->is_generic
)
11139 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11141 gcc_assert (g
->specific
);
11142 if (check_generic_tbp_ambiguity (target
, g
,
11143 name
, p
->where
) == FAILURE
)
11149 /* If we attempt to "overwrite" a specific binding, this is an error. */
11150 if (p
->overridden
&& !p
->overridden
->is_generic
)
11152 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11153 " the same name", name
, &p
->where
);
11157 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11158 all must have the same attributes here. */
11159 first_target
= p
->u
.generic
->specific
->u
.specific
;
11160 gcc_assert (first_target
);
11161 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11162 p
->function
= first_target
->n
.sym
->attr
.function
;
11168 /* Resolve a GENERIC procedure binding for a derived type. */
11171 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11173 gfc_symbol
* super_type
;
11175 /* Find the overridden binding if any. */
11176 st
->n
.tb
->overridden
= NULL
;
11177 super_type
= gfc_get_derived_super_type (derived
);
11180 gfc_symtree
* overridden
;
11181 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11184 if (overridden
&& overridden
->n
.tb
)
11185 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11188 /* Resolve using worker function. */
11189 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11193 /* Retrieve the target-procedure of an operator binding and do some checks in
11194 common for intrinsic and user-defined type-bound operators. */
11197 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11199 gfc_symbol
* target_proc
;
11201 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11202 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11203 gcc_assert (target_proc
);
11205 /* All operator bindings must have a passed-object dummy argument. */
11206 if (target
->specific
->nopass
)
11208 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11212 return target_proc
;
11216 /* Resolve a type-bound intrinsic operator. */
11219 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11220 gfc_typebound_proc
* p
)
11222 gfc_symbol
* super_type
;
11223 gfc_tbp_generic
* target
;
11225 /* If there's already an error here, do nothing (but don't fail again). */
11229 /* Operators should always be GENERIC bindings. */
11230 gcc_assert (p
->is_generic
);
11232 /* Look for an overridden binding. */
11233 super_type
= gfc_get_derived_super_type (derived
);
11234 if (super_type
&& super_type
->f2k_derived
)
11235 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11238 p
->overridden
= NULL
;
11240 /* Resolve general GENERIC properties using worker function. */
11241 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
11244 /* Check the targets to be procedures of correct interface. */
11245 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11247 gfc_symbol
* target_proc
;
11249 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11253 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11265 /* Resolve a type-bound user operator (tree-walker callback). */
11267 static gfc_symbol
* resolve_bindings_derived
;
11268 static gfc_try resolve_bindings_result
;
11270 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
11273 resolve_typebound_user_op (gfc_symtree
* stree
)
11275 gfc_symbol
* super_type
;
11276 gfc_tbp_generic
* target
;
11278 gcc_assert (stree
&& stree
->n
.tb
);
11280 if (stree
->n
.tb
->error
)
11283 /* Operators should always be GENERIC bindings. */
11284 gcc_assert (stree
->n
.tb
->is_generic
);
11286 /* Find overridden procedure, if any. */
11287 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11288 if (super_type
&& super_type
->f2k_derived
)
11290 gfc_symtree
* overridden
;
11291 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11292 stree
->name
, true, NULL
);
11294 if (overridden
&& overridden
->n
.tb
)
11295 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11298 stree
->n
.tb
->overridden
= NULL
;
11300 /* Resolve basically using worker function. */
11301 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11305 /* Check the targets to be functions of correct interface. */
11306 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11308 gfc_symbol
* target_proc
;
11310 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11314 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11321 resolve_bindings_result
= FAILURE
;
11322 stree
->n
.tb
->error
= 1;
11326 /* Resolve the type-bound procedures for a derived type. */
11329 resolve_typebound_procedure (gfc_symtree
* stree
)
11333 gfc_symbol
* me_arg
;
11334 gfc_symbol
* super_type
;
11335 gfc_component
* comp
;
11337 gcc_assert (stree
);
11339 /* Undefined specific symbol from GENERIC target definition. */
11343 if (stree
->n
.tb
->error
)
11346 /* If this is a GENERIC binding, use that routine. */
11347 if (stree
->n
.tb
->is_generic
)
11349 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11355 /* Get the target-procedure to check it. */
11356 gcc_assert (!stree
->n
.tb
->is_generic
);
11357 gcc_assert (stree
->n
.tb
->u
.specific
);
11358 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11359 where
= stree
->n
.tb
->where
;
11360 proc
->attr
.public_used
= 1;
11362 /* Default access should already be resolved from the parser. */
11363 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11365 /* It should be a module procedure or an external procedure with explicit
11366 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11367 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11368 || (proc
->attr
.proc
!= PROC_MODULE
11369 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11370 || (proc
->attr
.abstract
&& !stree
->n
.tb
->deferred
))
11372 gfc_error ("'%s' must be a module procedure or an external procedure with"
11373 " an explicit interface at %L", proc
->name
, &where
);
11376 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11377 stree
->n
.tb
->function
= proc
->attr
.function
;
11379 /* Find the super-type of the current derived type. We could do this once and
11380 store in a global if speed is needed, but as long as not I believe this is
11381 more readable and clearer. */
11382 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11384 /* If PASS, resolve and check arguments if not already resolved / loaded
11385 from a .mod file. */
11386 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11388 if (stree
->n
.tb
->pass_arg
)
11390 gfc_formal_arglist
* i
;
11392 /* If an explicit passing argument name is given, walk the arg-list
11393 and look for it. */
11396 stree
->n
.tb
->pass_arg_num
= 1;
11397 for (i
= proc
->formal
; i
; i
= i
->next
)
11399 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11404 ++stree
->n
.tb
->pass_arg_num
;
11409 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11411 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11412 stree
->n
.tb
->pass_arg
);
11418 /* Otherwise, take the first one; there should in fact be at least
11420 stree
->n
.tb
->pass_arg_num
= 1;
11423 gfc_error ("Procedure '%s' with PASS at %L must have at"
11424 " least one argument", proc
->name
, &where
);
11427 me_arg
= proc
->formal
->sym
;
11430 /* Now check that the argument-type matches and the passed-object
11431 dummy argument is generally fine. */
11433 gcc_assert (me_arg
);
11435 if (me_arg
->ts
.type
!= BT_CLASS
)
11437 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11438 " at %L", proc
->name
, &where
);
11442 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11443 != resolve_bindings_derived
)
11445 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11446 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11447 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11451 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11452 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
> 0)
11454 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11455 " scalar", proc
->name
, &where
);
11458 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11460 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11461 " be ALLOCATABLE", proc
->name
, &where
);
11464 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11466 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11467 " be POINTER", proc
->name
, &where
);
11472 /* If we are extending some type, check that we don't override a procedure
11473 flagged NON_OVERRIDABLE. */
11474 stree
->n
.tb
->overridden
= NULL
;
11477 gfc_symtree
* overridden
;
11478 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11479 stree
->name
, true, NULL
);
11483 if (overridden
->n
.tb
)
11484 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11486 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
11491 /* See if there's a name collision with a component directly in this type. */
11492 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11493 if (!strcmp (comp
->name
, stree
->name
))
11495 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11497 stree
->name
, &where
, resolve_bindings_derived
->name
);
11501 /* Try to find a name collision with an inherited component. */
11502 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11504 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11505 " component of '%s'",
11506 stree
->name
, &where
, resolve_bindings_derived
->name
);
11510 stree
->n
.tb
->error
= 0;
11514 resolve_bindings_result
= FAILURE
;
11515 stree
->n
.tb
->error
= 1;
11520 resolve_typebound_procedures (gfc_symbol
* derived
)
11523 gfc_symbol
* super_type
;
11525 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11528 super_type
= gfc_get_derived_super_type (derived
);
11530 resolve_typebound_procedures (super_type
);
11532 resolve_bindings_derived
= derived
;
11533 resolve_bindings_result
= SUCCESS
;
11535 /* Make sure the vtab has been generated. */
11536 gfc_find_derived_vtab (derived
);
11538 if (derived
->f2k_derived
->tb_sym_root
)
11539 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11540 &resolve_typebound_procedure
);
11542 if (derived
->f2k_derived
->tb_uop_root
)
11543 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11544 &resolve_typebound_user_op
);
11546 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11548 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11549 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11551 resolve_bindings_result
= FAILURE
;
11554 return resolve_bindings_result
;
11558 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11559 to give all identical derived types the same backend_decl. */
11561 add_dt_to_dt_list (gfc_symbol
*derived
)
11563 gfc_dt_list
*dt_list
;
11565 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11566 if (derived
== dt_list
->derived
)
11569 dt_list
= gfc_get_dt_list ();
11570 dt_list
->next
= gfc_derived_types
;
11571 dt_list
->derived
= derived
;
11572 gfc_derived_types
= dt_list
;
11576 /* Ensure that a derived-type is really not abstract, meaning that every
11577 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11580 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11585 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11587 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11590 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11592 gfc_symtree
* overriding
;
11593 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11596 gcc_assert (overriding
->n
.tb
);
11597 if (overriding
->n
.tb
->deferred
)
11599 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11600 " '%s' is DEFERRED and not overridden",
11601 sub
->name
, &sub
->declared_at
, st
->name
);
11610 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11612 /* The algorithm used here is to recursively travel up the ancestry of sub
11613 and for each ancestor-type, check all bindings. If any of them is
11614 DEFERRED, look it up starting from sub and see if the found (overriding)
11615 binding is not DEFERRED.
11616 This is not the most efficient way to do this, but it should be ok and is
11617 clearer than something sophisticated. */
11619 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11621 if (!ancestor
->attr
.abstract
)
11624 /* Walk bindings of this ancestor. */
11625 if (ancestor
->f2k_derived
)
11628 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11633 /* Find next ancestor type and recurse on it. */
11634 ancestor
= gfc_get_derived_super_type (ancestor
);
11636 return ensure_not_abstract (sub
, ancestor
);
11642 /* Resolve the components of a derived type. This does not have to wait until
11643 resolution stage, but can be done as soon as the dt declaration has been
11647 resolve_fl_derived0 (gfc_symbol
*sym
)
11649 gfc_symbol
* super_type
;
11652 super_type
= gfc_get_derived_super_type (sym
);
11655 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11657 gfc_error ("As extending type '%s' at %L has a coarray component, "
11658 "parent type '%s' shall also have one", sym
->name
,
11659 &sym
->declared_at
, super_type
->name
);
11663 /* Ensure the extended type gets resolved before we do. */
11664 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
11667 /* An ABSTRACT type must be extensible. */
11668 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11670 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11671 sym
->name
, &sym
->declared_at
);
11675 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11678 for ( ; c
!= NULL
; c
= c
->next
)
11680 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11681 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
11683 gfc_error ("Deferred-length character component '%s' at %L is not "
11684 "yet supported", c
->name
, &c
->loc
);
11689 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
11690 && c
->attr
.codimension
11691 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11693 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11694 "deferred shape", c
->name
, &c
->loc
);
11699 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11700 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11702 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11703 "shall not be a coarray", c
->name
, &c
->loc
);
11708 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11709 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11710 || c
->attr
.allocatable
))
11712 gfc_error ("Component '%s' at %L with coarray component "
11713 "shall be a nonpointer, nonallocatable scalar",
11719 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11721 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11722 "is not an array pointer", c
->name
, &c
->loc
);
11726 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11728 if (c
->ts
.interface
->attr
.procedure
&& !sym
->attr
.vtype
)
11729 gfc_error ("Interface '%s', used by procedure pointer component "
11730 "'%s' at %L, is declared in a later PROCEDURE statement",
11731 c
->ts
.interface
->name
, c
->name
, &c
->loc
);
11733 /* Get the attributes from the interface (now resolved). */
11734 if (c
->ts
.interface
->attr
.if_source
11735 || c
->ts
.interface
->attr
.intrinsic
)
11737 gfc_symbol
*ifc
= c
->ts
.interface
;
11739 if (ifc
->formal
&& !ifc
->formal_ns
)
11740 resolve_symbol (ifc
);
11742 if (ifc
->attr
.intrinsic
)
11743 resolve_intrinsic (ifc
, &ifc
->declared_at
);
11747 c
->ts
= ifc
->result
->ts
;
11748 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11749 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11750 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
11751 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
11756 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
11757 c
->attr
.pointer
= ifc
->attr
.pointer
;
11758 c
->attr
.dimension
= ifc
->attr
.dimension
;
11759 c
->as
= gfc_copy_array_spec (ifc
->as
);
11761 c
->ts
.interface
= ifc
;
11762 c
->attr
.function
= ifc
->attr
.function
;
11763 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
11764 gfc_copy_formal_args_ppc (c
, ifc
);
11766 c
->attr
.pure
= ifc
->attr
.pure
;
11767 c
->attr
.elemental
= ifc
->attr
.elemental
;
11768 c
->attr
.recursive
= ifc
->attr
.recursive
;
11769 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
11770 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
11771 /* Replace symbols in array spec. */
11775 for (i
= 0; i
< c
->as
->rank
; i
++)
11777 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
11778 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
11781 /* Copy char length. */
11782 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
11784 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
11785 gfc_expr_replace_comp (cl
->length
, c
);
11786 if (cl
->length
&& !cl
->resolved
11787 && gfc_resolve_expr (cl
->length
) == FAILURE
)
11792 else if (!sym
->attr
.vtype
&& c
->ts
.interface
->name
[0] != '\0')
11794 gfc_error ("Interface '%s' of procedure pointer component "
11795 "'%s' at %L must be explicit", c
->ts
.interface
->name
,
11800 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
11802 /* Since PPCs are not implicitly typed, a PPC without an explicit
11803 interface must be a subroutine. */
11804 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
11807 /* Procedure pointer components: Check PASS arg. */
11808 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
11809 && !sym
->attr
.vtype
)
11811 gfc_symbol
* me_arg
;
11813 if (c
->tb
->pass_arg
)
11815 gfc_formal_arglist
* i
;
11817 /* If an explicit passing argument name is given, walk the arg-list
11818 and look for it. */
11821 c
->tb
->pass_arg_num
= 1;
11822 for (i
= c
->formal
; i
; i
= i
->next
)
11824 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
11829 c
->tb
->pass_arg_num
++;
11834 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11835 "at %L has no argument '%s'", c
->name
,
11836 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
11843 /* Otherwise, take the first one; there should in fact be at least
11845 c
->tb
->pass_arg_num
= 1;
11848 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11849 "must have at least one argument",
11854 me_arg
= c
->formal
->sym
;
11857 /* Now check that the argument-type matches. */
11858 gcc_assert (me_arg
);
11859 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
11860 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
11861 || (me_arg
->ts
.type
== BT_CLASS
11862 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
11864 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11865 " the derived type '%s'", me_arg
->name
, c
->name
,
11866 me_arg
->name
, &c
->loc
, sym
->name
);
11871 /* Check for C453. */
11872 if (me_arg
->attr
.dimension
)
11874 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11875 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
11881 if (me_arg
->attr
.pointer
)
11883 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11884 "may not have the POINTER attribute", me_arg
->name
,
11885 c
->name
, me_arg
->name
, &c
->loc
);
11890 if (me_arg
->attr
.allocatable
)
11892 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11893 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
11894 me_arg
->name
, &c
->loc
);
11899 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
11900 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11901 " at %L", c
->name
, &c
->loc
);
11905 /* Check type-spec if this is not the parent-type component. */
11906 if (((sym
->attr
.is_class
11907 && (!sym
->components
->ts
.u
.derived
->attr
.extension
11908 || c
!= sym
->components
->ts
.u
.derived
->components
))
11909 || (!sym
->attr
.is_class
11910 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
11911 && !sym
->attr
.vtype
11912 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
11915 /* If this type is an extension, set the accessibility of the parent
11918 && ((sym
->attr
.is_class
11919 && c
== sym
->components
->ts
.u
.derived
->components
)
11920 || (!sym
->attr
.is_class
&& c
== sym
->components
))
11921 && strcmp (super_type
->name
, c
->name
) == 0)
11922 c
->attr
.access
= super_type
->attr
.access
;
11924 /* If this type is an extension, see if this component has the same name
11925 as an inherited type-bound procedure. */
11926 if (super_type
&& !sym
->attr
.is_class
11927 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
11929 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11930 " inherited type-bound procedure",
11931 c
->name
, sym
->name
, &c
->loc
);
11935 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
11936 && !c
->ts
.deferred
)
11938 if (c
->ts
.u
.cl
->length
== NULL
11939 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
11940 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
11942 gfc_error ("Character length of component '%s' needs to "
11943 "be a constant specification expression at %L",
11945 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
11950 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
11951 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
11953 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11954 "length must be a POINTER or ALLOCATABLE",
11955 c
->name
, sym
->name
, &c
->loc
);
11959 if (c
->ts
.type
== BT_DERIVED
11960 && sym
->component_access
!= ACCESS_PRIVATE
11961 && gfc_check_symbol_access (sym
)
11962 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
11963 && !c
->ts
.u
.derived
->attr
.use_assoc
11964 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
11965 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: the component '%s' "
11966 "is a PRIVATE type and cannot be a component of "
11967 "'%s', which is PUBLIC at %L", c
->name
,
11968 sym
->name
, &sym
->declared_at
) == FAILURE
)
11971 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
11973 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11974 "type %s", c
->name
, &c
->loc
, sym
->name
);
11978 if (sym
->attr
.sequence
)
11980 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
11982 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11983 "not have the SEQUENCE attribute",
11984 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
11989 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
11990 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
11991 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11992 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
11993 CLASS_DATA (c
)->ts
.u
.derived
11994 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
11996 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
11997 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
11998 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12000 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12001 "that has not been declared", c
->name
, sym
->name
,
12006 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12007 && CLASS_DATA (c
)->attr
.class_pointer
12008 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12009 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
12011 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12012 "that has not been declared", c
->name
, sym
->name
,
12018 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12019 && (!c
->attr
.class_ok
12020 || !(CLASS_DATA (c
)->attr
.class_pointer
12021 || CLASS_DATA (c
)->attr
.allocatable
)))
12023 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12024 "or pointer", c
->name
, &c
->loc
);
12028 /* Ensure that all the derived type components are put on the
12029 derived type list; even in formal namespaces, where derived type
12030 pointer components might not have been declared. */
12031 if (c
->ts
.type
== BT_DERIVED
12033 && c
->ts
.u
.derived
->components
12035 && sym
!= c
->ts
.u
.derived
)
12036 add_dt_to_dt_list (c
->ts
.u
.derived
);
12038 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
12039 || c
->attr
.proc_pointer
12040 || c
->attr
.allocatable
)) == FAILURE
)
12044 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12045 all DEFERRED bindings are overridden. */
12046 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12047 && !sym
->attr
.is_class
12048 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
12051 /* Add derived type to the derived type list. */
12052 add_dt_to_dt_list (sym
);
12058 /* The following procedure does the full resolution of a derived type,
12059 including resolution of all type-bound procedures (if present). In contrast
12060 to 'resolve_fl_derived0' this can only be done after the module has been
12061 parsed completely. */
12064 resolve_fl_derived (gfc_symbol
*sym
)
12066 gfc_symbol
*gen_dt
= NULL
;
12068 if (!sym
->attr
.is_class
)
12069 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12070 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12071 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12072 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12073 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Generic name '%s' of "
12074 "function '%s' at %L being the same name as derived "
12075 "type at %L", sym
->name
,
12076 gen_dt
->generic
->sym
== sym
12077 ? gen_dt
->generic
->next
->sym
->name
12078 : gen_dt
->generic
->sym
->name
,
12079 gen_dt
->generic
->sym
== sym
12080 ? &gen_dt
->generic
->next
->sym
->declared_at
12081 : &gen_dt
->generic
->sym
->declared_at
,
12082 &sym
->declared_at
) == FAILURE
)
12085 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12087 /* Fix up incomplete CLASS symbols. */
12088 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12089 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12090 if (vptr
->ts
.u
.derived
== NULL
)
12092 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12094 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12098 if (resolve_fl_derived0 (sym
) == FAILURE
)
12101 /* Resolve the type-bound procedures. */
12102 if (resolve_typebound_procedures (sym
) == FAILURE
)
12105 /* Resolve the finalizer procedures. */
12106 if (gfc_resolve_finalizers (sym
) == FAILURE
)
12114 resolve_fl_namelist (gfc_symbol
*sym
)
12119 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12121 /* Check again, the check in match only works if NAMELIST comes
12123 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12125 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12126 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12130 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12131 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
12132 "object '%s' with assumed shape in namelist "
12133 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12134 &sym
->declared_at
) == FAILURE
)
12137 if (is_non_constant_shape_array (nl
->sym
)
12138 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
12139 "object '%s' with nonconstant shape in namelist "
12140 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12141 &sym
->declared_at
) == FAILURE
)
12144 if (nl
->sym
->ts
.type
== BT_CHARACTER
12145 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12146 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12147 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
12148 "'%s' with nonconstant character length in "
12149 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
12150 &sym
->declared_at
) == FAILURE
)
12153 /* FIXME: Once UDDTIO is implemented, the following can be
12155 if (nl
->sym
->ts
.type
== BT_CLASS
)
12157 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12158 "polymorphic and requires a defined input/output "
12159 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12163 if (nl
->sym
->ts
.type
== BT_DERIVED
12164 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12165 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12167 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
12168 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12169 "or POINTER components", nl
->sym
->name
,
12170 sym
->name
, &sym
->declared_at
) == FAILURE
)
12173 /* FIXME: Once UDDTIO is implemented, the following can be
12175 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12176 "ALLOCATABLE or POINTER components and thus requires "
12177 "a defined input/output procedure", nl
->sym
->name
,
12178 sym
->name
, &sym
->declared_at
);
12183 /* Reject PRIVATE objects in a PUBLIC namelist. */
12184 if (gfc_check_symbol_access (sym
))
12186 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12188 if (!nl
->sym
->attr
.use_assoc
12189 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12190 && !gfc_check_symbol_access (nl
->sym
))
12192 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12193 "cannot be member of PUBLIC namelist '%s' at %L",
12194 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12198 /* Types with private components that came here by USE-association. */
12199 if (nl
->sym
->ts
.type
== BT_DERIVED
12200 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12202 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12203 "components and cannot be member of namelist '%s' at %L",
12204 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12208 /* Types with private components that are defined in the same module. */
12209 if (nl
->sym
->ts
.type
== BT_DERIVED
12210 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12211 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12213 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12214 "cannot be a member of PUBLIC namelist '%s' at %L",
12215 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12222 /* 14.1.2 A module or internal procedure represent local entities
12223 of the same type as a namelist member and so are not allowed. */
12224 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12226 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12229 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12230 if ((nl
->sym
== sym
->ns
->proc_name
)
12232 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12236 if (nl
->sym
&& nl
->sym
->name
)
12237 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12238 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12240 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12241 "attribute in '%s' at %L", nlsym
->name
,
12242 &sym
->declared_at
);
12252 resolve_fl_parameter (gfc_symbol
*sym
)
12254 /* A parameter array's shape needs to be constant. */
12255 if (sym
->as
!= NULL
12256 && (sym
->as
->type
== AS_DEFERRED
12257 || is_non_constant_shape_array (sym
)))
12259 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12260 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12264 /* Make sure a parameter that has been implicitly typed still
12265 matches the implicit type, since PARAMETER statements can precede
12266 IMPLICIT statements. */
12267 if (sym
->attr
.implicit_type
12268 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12271 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12272 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12276 /* Make sure the types of derived parameters are consistent. This
12277 type checking is deferred until resolution because the type may
12278 refer to a derived type from the host. */
12279 if (sym
->ts
.type
== BT_DERIVED
12280 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12282 gfc_error ("Incompatible derived type in PARAMETER at %L",
12283 &sym
->value
->where
);
12290 /* Do anything necessary to resolve a symbol. Right now, we just
12291 assume that an otherwise unknown symbol is a variable. This sort
12292 of thing commonly happens for symbols in module. */
12295 resolve_symbol (gfc_symbol
*sym
)
12297 int check_constant
, mp_flag
;
12298 gfc_symtree
*symtree
;
12299 gfc_symtree
*this_symtree
;
12302 symbol_attribute class_attr
;
12303 gfc_array_spec
*as
;
12305 if (sym
->attr
.flavor
== FL_UNKNOWN
12306 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12307 && !sym
->attr
.generic
&& !sym
->attr
.external
12308 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12311 /* If we find that a flavorless symbol is an interface in one of the
12312 parent namespaces, find its symtree in this namespace, free the
12313 symbol and set the symtree to point to the interface symbol. */
12314 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12316 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12317 if (symtree
&& (symtree
->n
.sym
->generic
||
12318 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12319 && sym
->ns
->construct_entities
)))
12321 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12323 gfc_release_symbol (sym
);
12324 symtree
->n
.sym
->refs
++;
12325 this_symtree
->n
.sym
= symtree
->n
.sym
;
12330 /* Otherwise give it a flavor according to such attributes as
12332 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12333 && sym
->attr
.intrinsic
== 0)
12334 sym
->attr
.flavor
= FL_VARIABLE
;
12335 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12337 sym
->attr
.flavor
= FL_PROCEDURE
;
12338 if (sym
->attr
.dimension
)
12339 sym
->attr
.function
= 1;
12343 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12344 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12346 if (sym
->attr
.procedure
&& sym
->ts
.interface
12347 && sym
->attr
.if_source
!= IFSRC_DECL
12348 && resolve_procedure_interface (sym
) == FAILURE
)
12351 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12352 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12354 if (sym
->attr
.external
)
12355 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12356 "at %L", &sym
->declared_at
);
12358 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12359 "at %L", &sym
->declared_at
);
12364 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12367 /* Symbols that are module procedures with results (functions) have
12368 the types and array specification copied for type checking in
12369 procedures that call them, as well as for saving to a module
12370 file. These symbols can't stand the scrutiny that their results
12372 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12374 /* Make sure that the intrinsic is consistent with its internal
12375 representation. This needs to be done before assigning a default
12376 type to avoid spurious warnings. */
12377 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12378 && resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12381 /* Resolve associate names. */
12383 resolve_assoc_var (sym
, true);
12385 /* Assign default type to symbols that need one and don't have one. */
12386 if (sym
->ts
.type
== BT_UNKNOWN
)
12388 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12390 gfc_set_default_type (sym
, 1, NULL
);
12393 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12394 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12395 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12396 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12398 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12400 /* The specific case of an external procedure should emit an error
12401 in the case that there is no implicit type. */
12403 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12406 /* Result may be in another namespace. */
12407 resolve_symbol (sym
->result
);
12409 if (!sym
->result
->attr
.proc_pointer
)
12411 sym
->ts
= sym
->result
->ts
;
12412 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12413 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12414 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12415 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12416 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12421 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12422 gfc_resolve_array_spec (sym
->result
->as
, false);
12424 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12426 as
= CLASS_DATA (sym
)->as
;
12427 class_attr
= CLASS_DATA (sym
)->attr
;
12428 class_attr
.pointer
= class_attr
.class_pointer
;
12432 class_attr
= sym
->attr
;
12437 if (sym
->attr
.contiguous
12438 && (!class_attr
.dimension
12439 || (as
->type
!= AS_ASSUMED_SHAPE
&& !class_attr
.pointer
)))
12441 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12442 "array pointer or an assumed-shape array", sym
->name
,
12443 &sym
->declared_at
);
12447 /* Assumed size arrays and assumed shape arrays must be dummy
12448 arguments. Array-spec's of implied-shape should have been resolved to
12449 AS_EXPLICIT already. */
12453 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12454 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12455 || as
->type
== AS_ASSUMED_SHAPE
)
12456 && sym
->attr
.dummy
== 0)
12458 if (as
->type
== AS_ASSUMED_SIZE
)
12459 gfc_error ("Assumed size array at %L must be a dummy argument",
12460 &sym
->declared_at
);
12462 gfc_error ("Assumed shape array at %L must be a dummy argument",
12463 &sym
->declared_at
);
12468 /* Make sure symbols with known intent or optional are really dummy
12469 variable. Because of ENTRY statement, this has to be deferred
12470 until resolution time. */
12472 if (!sym
->attr
.dummy
12473 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12475 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12479 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12481 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12482 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12486 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12488 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12489 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12491 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12492 "attribute must have constant length",
12493 sym
->name
, &sym
->declared_at
);
12497 if (sym
->ts
.is_c_interop
12498 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12500 gfc_error ("C interoperable character dummy variable '%s' at %L "
12501 "with VALUE attribute must have length one",
12502 sym
->name
, &sym
->declared_at
);
12507 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12508 && sym
->ts
.u
.derived
->attr
.generic
)
12510 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12511 if (!sym
->ts
.u
.derived
)
12513 gfc_error ("The derived type '%s' at %L is of type '%s', "
12514 "which has not been defined", sym
->name
,
12515 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12516 sym
->ts
.type
= BT_UNKNOWN
;
12521 if (sym
->ts
.type
== BT_ASSUMED
)
12523 /* TS 29113, C407a. */
12524 if (!sym
->attr
.dummy
)
12526 gfc_error ("Assumed type of variable %s at %L is only permitted "
12527 "for dummy variables", sym
->name
, &sym
->declared_at
);
12530 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12531 || sym
->attr
.pointer
|| sym
->attr
.value
)
12533 gfc_error ("Assumed-type variable %s at %L may not have the "
12534 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
12535 sym
->name
, &sym
->declared_at
);
12538 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
12540 gfc_error ("Assumed-type variable %s at %L shall not be an "
12541 "explicit-shape array", sym
->name
, &sym
->declared_at
);
12546 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12547 do this for something that was implicitly typed because that is handled
12548 in gfc_set_default_type. Handle dummy arguments and procedure
12549 definitions separately. Also, anything that is use associated is not
12550 handled here but instead is handled in the module it is declared in.
12551 Finally, derived type definitions are allowed to be BIND(C) since that
12552 only implies that they're interoperable, and they are checked fully for
12553 interoperability when a variable is declared of that type. */
12554 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12555 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12556 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12558 gfc_try t
= SUCCESS
;
12560 /* First, make sure the variable is declared at the
12561 module-level scope (J3/04-007, Section 15.3). */
12562 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12563 sym
->attr
.in_common
== 0)
12565 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12566 "is neither a COMMON block nor declared at the "
12567 "module level scope", sym
->name
, &(sym
->declared_at
));
12570 else if (sym
->common_head
!= NULL
)
12572 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12576 /* If type() declaration, we need to verify that the components
12577 of the given type are all C interoperable, etc. */
12578 if (sym
->ts
.type
== BT_DERIVED
&&
12579 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12581 /* Make sure the user marked the derived type as BIND(C). If
12582 not, call the verify routine. This could print an error
12583 for the derived type more than once if multiple variables
12584 of that type are declared. */
12585 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12586 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12590 /* Verify the variable itself as C interoperable if it
12591 is BIND(C). It is not possible for this to succeed if
12592 the verify_bind_c_derived_type failed, so don't have to handle
12593 any error returned by verify_bind_c_derived_type. */
12594 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12595 sym
->common_block
);
12600 /* clear the is_bind_c flag to prevent reporting errors more than
12601 once if something failed. */
12602 sym
->attr
.is_bind_c
= 0;
12607 /* If a derived type symbol has reached this point, without its
12608 type being declared, we have an error. Notice that most
12609 conditions that produce undefined derived types have already
12610 been dealt with. However, the likes of:
12611 implicit type(t) (t) ..... call foo (t) will get us here if
12612 the type is not declared in the scope of the implicit
12613 statement. Change the type to BT_UNKNOWN, both because it is so
12614 and to prevent an ICE. */
12615 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12616 && sym
->ts
.u
.derived
->components
== NULL
12617 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12619 gfc_error ("The derived type '%s' at %L is of type '%s', "
12620 "which has not been defined", sym
->name
,
12621 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12622 sym
->ts
.type
= BT_UNKNOWN
;
12626 /* Make sure that the derived type has been resolved and that the
12627 derived type is visible in the symbol's namespace, if it is a
12628 module function and is not PRIVATE. */
12629 if (sym
->ts
.type
== BT_DERIVED
12630 && sym
->ts
.u
.derived
->attr
.use_assoc
12631 && sym
->ns
->proc_name
12632 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12633 && resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12636 /* Unless the derived-type declaration is use associated, Fortran 95
12637 does not allow public entries of private derived types.
12638 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12639 161 in 95-006r3. */
12640 if (sym
->ts
.type
== BT_DERIVED
12641 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12642 && !sym
->ts
.u
.derived
->attr
.use_assoc
12643 && gfc_check_symbol_access (sym
)
12644 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
12645 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
12646 "of PRIVATE derived type '%s'",
12647 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12648 : "variable", sym
->name
, &sym
->declared_at
,
12649 sym
->ts
.u
.derived
->name
) == FAILURE
)
12652 /* F2008, C1302. */
12653 if (sym
->ts
.type
== BT_DERIVED
12654 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
12655 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
12656 || sym
->ts
.u
.derived
->attr
.lock_comp
)
12657 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
12659 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12660 "type LOCK_TYPE must be a coarray", sym
->name
,
12661 &sym
->declared_at
);
12665 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12666 default initialization is defined (5.1.2.4.4). */
12667 if (sym
->ts
.type
== BT_DERIVED
12669 && sym
->attr
.intent
== INTENT_OUT
12671 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12673 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12675 if (c
->initializer
)
12677 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12678 "ASSUMED SIZE and so cannot have a default initializer",
12679 sym
->name
, &sym
->declared_at
);
12686 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
12687 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
12689 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12690 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
12695 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12696 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12697 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12698 || class_attr
.codimension
)
12699 && (sym
->attr
.result
|| sym
->result
== sym
))
12701 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12702 "a coarray component", sym
->name
, &sym
->declared_at
);
12707 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12708 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12710 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12711 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12716 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12717 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12718 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12719 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
12720 || class_attr
.allocatable
))
12722 gfc_error ("Variable '%s' at %L with coarray component "
12723 "shall be a nonpointer, nonallocatable scalar",
12724 sym
->name
, &sym
->declared_at
);
12728 /* F2008, C526. The function-result case was handled above. */
12729 if (class_attr
.codimension
12730 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12731 || sym
->attr
.select_type_temporary
12732 || sym
->ns
->save_all
12733 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12734 || sym
->ns
->proc_name
->attr
.is_main_program
12735 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
12737 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12738 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
12742 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
12743 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
12745 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12746 "deferred shape", sym
->name
, &sym
->declared_at
);
12749 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
12750 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
12752 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12753 "deferred shape", sym
->name
, &sym
->declared_at
);
12758 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12759 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12760 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12761 || (class_attr
.codimension
&& class_attr
.allocatable
))
12762 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
12764 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12765 "allocatable coarray or have coarray components",
12766 sym
->name
, &sym
->declared_at
);
12770 if (class_attr
.codimension
&& sym
->attr
.dummy
12771 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
12773 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12774 "procedure '%s'", sym
->name
, &sym
->declared_at
,
12775 sym
->ns
->proc_name
->name
);
12779 switch (sym
->attr
.flavor
)
12782 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
12787 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
12792 if (resolve_fl_namelist (sym
) == FAILURE
)
12797 if (resolve_fl_parameter (sym
) == FAILURE
)
12805 /* Resolve array specifier. Check as well some constraints
12806 on COMMON blocks. */
12808 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
12810 /* Set the formal_arg_flag so that check_conflict will not throw
12811 an error for host associated variables in the specification
12812 expression for an array_valued function. */
12813 if (sym
->attr
.function
&& sym
->as
)
12814 formal_arg_flag
= 1;
12816 gfc_resolve_array_spec (sym
->as
, check_constant
);
12818 formal_arg_flag
= 0;
12820 /* Resolve formal namespaces. */
12821 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
12822 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
12823 gfc_resolve (sym
->formal_ns
);
12825 /* Make sure the formal namespace is present. */
12826 if (sym
->formal
&& !sym
->formal_ns
)
12828 gfc_formal_arglist
*formal
= sym
->formal
;
12829 while (formal
&& !formal
->sym
)
12830 formal
= formal
->next
;
12834 sym
->formal_ns
= formal
->sym
->ns
;
12835 sym
->formal_ns
->refs
++;
12839 /* Check threadprivate restrictions. */
12840 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
12841 && (!sym
->attr
.in_common
12842 && sym
->module
== NULL
12843 && (sym
->ns
->proc_name
== NULL
12844 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
12845 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
12847 /* If we have come this far we can apply default-initializers, as
12848 described in 14.7.5, to those variables that have not already
12849 been assigned one. */
12850 if (sym
->ts
.type
== BT_DERIVED
12851 && sym
->ns
== gfc_current_ns
12853 && !sym
->attr
.allocatable
12854 && !sym
->attr
.alloc_comp
)
12856 symbol_attribute
*a
= &sym
->attr
;
12858 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
12859 && !a
->in_common
&& !a
->use_assoc
12860 && (a
->referenced
|| a
->result
)
12861 && !(a
->function
&& sym
!= sym
->result
))
12862 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
12863 apply_default_init (sym
);
12866 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
12867 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
12868 && !CLASS_DATA (sym
)->attr
.class_pointer
12869 && !CLASS_DATA (sym
)->attr
.allocatable
)
12870 apply_default_init (sym
);
12872 /* If this symbol has a type-spec, check it. */
12873 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
12874 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
12875 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
12881 /************* Resolve DATA statements *************/
12885 gfc_data_value
*vnode
;
12891 /* Advance the values structure to point to the next value in the data list. */
12894 next_data_value (void)
12896 while (mpz_cmp_ui (values
.left
, 0) == 0)
12899 if (values
.vnode
->next
== NULL
)
12902 values
.vnode
= values
.vnode
->next
;
12903 mpz_set (values
.left
, values
.vnode
->repeat
);
12911 check_data_variable (gfc_data_variable
*var
, locus
*where
)
12917 ar_type mark
= AR_UNKNOWN
;
12919 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
12925 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
12929 mpz_init_set_si (offset
, 0);
12932 if (e
->expr_type
!= EXPR_VARIABLE
)
12933 gfc_internal_error ("check_data_variable(): Bad expression");
12935 sym
= e
->symtree
->n
.sym
;
12937 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
12939 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12940 sym
->name
, &sym
->declared_at
);
12943 if (e
->ref
== NULL
&& sym
->as
)
12945 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12946 " declaration", sym
->name
, where
);
12950 has_pointer
= sym
->attr
.pointer
;
12952 if (gfc_is_coindexed (e
))
12954 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
12959 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12961 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
12965 && ref
->type
== REF_ARRAY
12966 && ref
->u
.ar
.type
!= AR_FULL
)
12968 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12969 "be a full array", sym
->name
, where
);
12974 if (e
->rank
== 0 || has_pointer
)
12976 mpz_init_set_ui (size
, 1);
12983 /* Find the array section reference. */
12984 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12986 if (ref
->type
!= REF_ARRAY
)
12988 if (ref
->u
.ar
.type
== AR_ELEMENT
)
12994 /* Set marks according to the reference pattern. */
12995 switch (ref
->u
.ar
.type
)
13003 /* Get the start position of array section. */
13004 gfc_get_section_index (ar
, section_index
, &offset
);
13009 gcc_unreachable ();
13012 if (gfc_array_size (e
, &size
) == FAILURE
)
13014 gfc_error ("Nonconstant array section at %L in DATA statement",
13016 mpz_clear (offset
);
13023 while (mpz_cmp_ui (size
, 0) > 0)
13025 if (next_data_value () == FAILURE
)
13027 gfc_error ("DATA statement at %L has more variables than values",
13033 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13037 /* If we have more than one element left in the repeat count,
13038 and we have more than one element left in the target variable,
13039 then create a range assignment. */
13040 /* FIXME: Only done for full arrays for now, since array sections
13042 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13043 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13047 if (mpz_cmp (size
, values
.left
) >= 0)
13049 mpz_init_set (range
, values
.left
);
13050 mpz_sub (size
, size
, values
.left
);
13051 mpz_set_ui (values
.left
, 0);
13055 mpz_init_set (range
, size
);
13056 mpz_sub (values
.left
, values
.left
, size
);
13057 mpz_set_ui (size
, 0);
13060 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13063 mpz_add (offset
, offset
, range
);
13070 /* Assign initial value to symbol. */
13073 mpz_sub_ui (values
.left
, values
.left
, 1);
13074 mpz_sub_ui (size
, size
, 1);
13076 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13081 if (mark
== AR_FULL
)
13082 mpz_add_ui (offset
, offset
, 1);
13084 /* Modify the array section indexes and recalculate the offset
13085 for next element. */
13086 else if (mark
== AR_SECTION
)
13087 gfc_advance_section (section_index
, ar
, &offset
);
13091 if (mark
== AR_SECTION
)
13093 for (i
= 0; i
< ar
->dimen
; i
++)
13094 mpz_clear (section_index
[i
]);
13098 mpz_clear (offset
);
13104 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
13106 /* Iterate over a list of elements in a DATA statement. */
13109 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13112 iterator_stack frame
;
13113 gfc_expr
*e
, *start
, *end
, *step
;
13114 gfc_try retval
= SUCCESS
;
13116 mpz_init (frame
.value
);
13119 start
= gfc_copy_expr (var
->iter
.start
);
13120 end
= gfc_copy_expr (var
->iter
.end
);
13121 step
= gfc_copy_expr (var
->iter
.step
);
13123 if (gfc_simplify_expr (start
, 1) == FAILURE
13124 || start
->expr_type
!= EXPR_CONSTANT
)
13126 gfc_error ("start of implied-do loop at %L could not be "
13127 "simplified to a constant value", &start
->where
);
13131 if (gfc_simplify_expr (end
, 1) == FAILURE
13132 || end
->expr_type
!= EXPR_CONSTANT
)
13134 gfc_error ("end of implied-do loop at %L could not be "
13135 "simplified to a constant value", &start
->where
);
13139 if (gfc_simplify_expr (step
, 1) == FAILURE
13140 || step
->expr_type
!= EXPR_CONSTANT
)
13142 gfc_error ("step of implied-do loop at %L could not be "
13143 "simplified to a constant value", &start
->where
);
13148 mpz_set (trip
, end
->value
.integer
);
13149 mpz_sub (trip
, trip
, start
->value
.integer
);
13150 mpz_add (trip
, trip
, step
->value
.integer
);
13152 mpz_div (trip
, trip
, step
->value
.integer
);
13154 mpz_set (frame
.value
, start
->value
.integer
);
13156 frame
.prev
= iter_stack
;
13157 frame
.variable
= var
->iter
.var
->symtree
;
13158 iter_stack
= &frame
;
13160 while (mpz_cmp_ui (trip
, 0) > 0)
13162 if (traverse_data_var (var
->list
, where
) == FAILURE
)
13168 e
= gfc_copy_expr (var
->expr
);
13169 if (gfc_simplify_expr (e
, 1) == FAILURE
)
13176 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13178 mpz_sub_ui (trip
, trip
, 1);
13182 mpz_clear (frame
.value
);
13185 gfc_free_expr (start
);
13186 gfc_free_expr (end
);
13187 gfc_free_expr (step
);
13189 iter_stack
= frame
.prev
;
13194 /* Type resolve variables in the variable list of a DATA statement. */
13197 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13201 for (; var
; var
= var
->next
)
13203 if (var
->expr
== NULL
)
13204 t
= traverse_data_list (var
, where
);
13206 t
= check_data_variable (var
, where
);
13216 /* Resolve the expressions and iterators associated with a data statement.
13217 This is separate from the assignment checking because data lists should
13218 only be resolved once. */
13221 resolve_data_variables (gfc_data_variable
*d
)
13223 for (; d
; d
= d
->next
)
13225 if (d
->list
== NULL
)
13227 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
13232 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
13235 if (resolve_data_variables (d
->list
) == FAILURE
)
13244 /* Resolve a single DATA statement. We implement this by storing a pointer to
13245 the value list into static variables, and then recursively traversing the
13246 variables list, expanding iterators and such. */
13249 resolve_data (gfc_data
*d
)
13252 if (resolve_data_variables (d
->var
) == FAILURE
)
13255 values
.vnode
= d
->value
;
13256 if (d
->value
== NULL
)
13257 mpz_set_ui (values
.left
, 0);
13259 mpz_set (values
.left
, d
->value
->repeat
);
13261 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
13264 /* At this point, we better not have any values left. */
13266 if (next_data_value () == SUCCESS
)
13267 gfc_error ("DATA statement at %L has more values than variables",
13272 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13273 accessed by host or use association, is a dummy argument to a pure function,
13274 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13275 is storage associated with any such variable, shall not be used in the
13276 following contexts: (clients of this function). */
13278 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13279 procedure. Returns zero if assignment is OK, nonzero if there is a
13282 gfc_impure_variable (gfc_symbol
*sym
)
13287 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13290 /* Check if the symbol's ns is inside the pure procedure. */
13291 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13295 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13299 proc
= sym
->ns
->proc_name
;
13300 if (sym
->attr
.dummy
&& gfc_pure (proc
)
13301 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13303 proc
->attr
.function
))
13306 /* TODO: Sort out what can be storage associated, if anything, and include
13307 it here. In principle equivalences should be scanned but it does not
13308 seem to be possible to storage associate an impure variable this way. */
13313 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13314 current namespace is inside a pure procedure. */
13317 gfc_pure (gfc_symbol
*sym
)
13319 symbol_attribute attr
;
13324 /* Check if the current namespace or one of its parents
13325 belongs to a pure procedure. */
13326 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13328 sym
= ns
->proc_name
;
13332 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13340 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13344 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13345 checks if the current namespace is implicitly pure. Note that this
13346 function returns false for a PURE procedure. */
13349 gfc_implicit_pure (gfc_symbol
*sym
)
13355 /* Check if the current procedure is implicit_pure. Walk up
13356 the procedure list until we find a procedure. */
13357 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13359 sym
= ns
->proc_name
;
13363 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13368 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13369 && !sym
->attr
.pure
;
13373 /* Test whether the current procedure is elemental or not. */
13376 gfc_elemental (gfc_symbol
*sym
)
13378 symbol_attribute attr
;
13381 sym
= gfc_current_ns
->proc_name
;
13386 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13390 /* Warn about unused labels. */
13393 warn_unused_fortran_label (gfc_st_label
*label
)
13398 warn_unused_fortran_label (label
->left
);
13400 if (label
->defined
== ST_LABEL_UNKNOWN
)
13403 switch (label
->referenced
)
13405 case ST_LABEL_UNKNOWN
:
13406 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13410 case ST_LABEL_BAD_TARGET
:
13411 gfc_warning ("Label %d at %L defined but cannot be used",
13412 label
->value
, &label
->where
);
13419 warn_unused_fortran_label (label
->right
);
13423 /* Returns the sequence type of a symbol or sequence. */
13426 sequence_type (gfc_typespec ts
)
13435 if (ts
.u
.derived
->components
== NULL
)
13436 return SEQ_NONDEFAULT
;
13438 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13439 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13440 if (sequence_type (c
->ts
) != result
)
13446 if (ts
.kind
!= gfc_default_character_kind
)
13447 return SEQ_NONDEFAULT
;
13449 return SEQ_CHARACTER
;
13452 if (ts
.kind
!= gfc_default_integer_kind
)
13453 return SEQ_NONDEFAULT
;
13455 return SEQ_NUMERIC
;
13458 if (!(ts
.kind
== gfc_default_real_kind
13459 || ts
.kind
== gfc_default_double_kind
))
13460 return SEQ_NONDEFAULT
;
13462 return SEQ_NUMERIC
;
13465 if (ts
.kind
!= gfc_default_complex_kind
)
13466 return SEQ_NONDEFAULT
;
13468 return SEQ_NUMERIC
;
13471 if (ts
.kind
!= gfc_default_logical_kind
)
13472 return SEQ_NONDEFAULT
;
13474 return SEQ_NUMERIC
;
13477 return SEQ_NONDEFAULT
;
13482 /* Resolve derived type EQUIVALENCE object. */
13485 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13487 gfc_component
*c
= derived
->components
;
13492 /* Shall not be an object of nonsequence derived type. */
13493 if (!derived
->attr
.sequence
)
13495 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13496 "attribute to be an EQUIVALENCE object", sym
->name
,
13501 /* Shall not have allocatable components. */
13502 if (derived
->attr
.alloc_comp
)
13504 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13505 "components to be an EQUIVALENCE object",sym
->name
,
13510 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13512 gfc_error ("Derived type variable '%s' at %L with default "
13513 "initialization cannot be in EQUIVALENCE with a variable "
13514 "in COMMON", sym
->name
, &e
->where
);
13518 for (; c
; c
= c
->next
)
13520 if (c
->ts
.type
== BT_DERIVED
13521 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13524 /* Shall not be an object of sequence derived type containing a pointer
13525 in the structure. */
13526 if (c
->attr
.pointer
)
13528 gfc_error ("Derived type variable '%s' at %L with pointer "
13529 "component(s) cannot be an EQUIVALENCE object",
13530 sym
->name
, &e
->where
);
13538 /* Resolve equivalence object.
13539 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13540 an allocatable array, an object of nonsequence derived type, an object of
13541 sequence derived type containing a pointer at any level of component
13542 selection, an automatic object, a function name, an entry name, a result
13543 name, a named constant, a structure component, or a subobject of any of
13544 the preceding objects. A substring shall not have length zero. A
13545 derived type shall not have components with default initialization nor
13546 shall two objects of an equivalence group be initialized.
13547 Either all or none of the objects shall have an protected attribute.
13548 The simple constraints are done in symbol.c(check_conflict) and the rest
13549 are implemented here. */
13552 resolve_equivalence (gfc_equiv
*eq
)
13555 gfc_symbol
*first_sym
;
13558 locus
*last_where
= NULL
;
13559 seq_type eq_type
, last_eq_type
;
13560 gfc_typespec
*last_ts
;
13561 int object
, cnt_protected
;
13564 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13566 first_sym
= eq
->expr
->symtree
->n
.sym
;
13570 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13574 e
->ts
= e
->symtree
->n
.sym
->ts
;
13575 /* match_varspec might not know yet if it is seeing
13576 array reference or substring reference, as it doesn't
13578 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13580 gfc_ref
*ref
= e
->ref
;
13581 sym
= e
->symtree
->n
.sym
;
13583 if (sym
->attr
.dimension
)
13585 ref
->u
.ar
.as
= sym
->as
;
13589 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13590 if (e
->ts
.type
== BT_CHARACTER
13592 && ref
->type
== REF_ARRAY
13593 && ref
->u
.ar
.dimen
== 1
13594 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13595 && ref
->u
.ar
.stride
[0] == NULL
)
13597 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13598 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13601 /* Optimize away the (:) reference. */
13602 if (start
== NULL
&& end
== NULL
)
13605 e
->ref
= ref
->next
;
13607 e
->ref
->next
= ref
->next
;
13612 ref
->type
= REF_SUBSTRING
;
13614 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13616 ref
->u
.ss
.start
= start
;
13617 if (end
== NULL
&& e
->ts
.u
.cl
)
13618 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13619 ref
->u
.ss
.end
= end
;
13620 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13627 /* Any further ref is an error. */
13630 gcc_assert (ref
->type
== REF_ARRAY
);
13631 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13637 if (gfc_resolve_expr (e
) == FAILURE
)
13640 sym
= e
->symtree
->n
.sym
;
13642 if (sym
->attr
.is_protected
)
13644 if (cnt_protected
> 0 && cnt_protected
!= object
)
13646 gfc_error ("Either all or none of the objects in the "
13647 "EQUIVALENCE set at %L shall have the "
13648 "PROTECTED attribute",
13653 /* Shall not equivalence common block variables in a PURE procedure. */
13654 if (sym
->ns
->proc_name
13655 && sym
->ns
->proc_name
->attr
.pure
13656 && sym
->attr
.in_common
)
13658 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13659 "object in the pure procedure '%s'",
13660 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13664 /* Shall not be a named constant. */
13665 if (e
->expr_type
== EXPR_CONSTANT
)
13667 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13668 "object", sym
->name
, &e
->where
);
13672 if (e
->ts
.type
== BT_DERIVED
13673 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13676 /* Check that the types correspond correctly:
13678 A numeric sequence structure may be equivalenced to another sequence
13679 structure, an object of default integer type, default real type, double
13680 precision real type, default logical type such that components of the
13681 structure ultimately only become associated to objects of the same
13682 kind. A character sequence structure may be equivalenced to an object
13683 of default character kind or another character sequence structure.
13684 Other objects may be equivalenced only to objects of the same type and
13685 kind parameters. */
13687 /* Identical types are unconditionally OK. */
13688 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13689 goto identical_types
;
13691 last_eq_type
= sequence_type (*last_ts
);
13692 eq_type
= sequence_type (sym
->ts
);
13694 /* Since the pair of objects is not of the same type, mixed or
13695 non-default sequences can be rejected. */
13697 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13698 "statement at %L with different type objects";
13700 && last_eq_type
== SEQ_MIXED
13701 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13703 || (eq_type
== SEQ_MIXED
13704 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13705 &e
->where
) == FAILURE
))
13708 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13709 "statement at %L with objects of different type";
13711 && last_eq_type
== SEQ_NONDEFAULT
13712 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13713 last_where
) == FAILURE
)
13714 || (eq_type
== SEQ_NONDEFAULT
13715 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13716 &e
->where
) == FAILURE
))
13719 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13720 "EQUIVALENCE statement at %L";
13721 if (last_eq_type
== SEQ_CHARACTER
13722 && eq_type
!= SEQ_CHARACTER
13723 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13724 &e
->where
) == FAILURE
)
13727 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13728 "EQUIVALENCE statement at %L";
13729 if (last_eq_type
== SEQ_NUMERIC
13730 && eq_type
!= SEQ_NUMERIC
13731 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13732 &e
->where
) == FAILURE
)
13737 last_where
= &e
->where
;
13742 /* Shall not be an automatic array. */
13743 if (e
->ref
->type
== REF_ARRAY
13744 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
13746 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13747 "an EQUIVALENCE object", sym
->name
, &e
->where
);
13754 /* Shall not be a structure component. */
13755 if (r
->type
== REF_COMPONENT
)
13757 gfc_error ("Structure component '%s' at %L cannot be an "
13758 "EQUIVALENCE object",
13759 r
->u
.c
.component
->name
, &e
->where
);
13763 /* A substring shall not have length zero. */
13764 if (r
->type
== REF_SUBSTRING
)
13766 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
13768 gfc_error ("Substring at %L has length zero",
13769 &r
->u
.ss
.start
->where
);
13779 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13782 resolve_fntype (gfc_namespace
*ns
)
13784 gfc_entry_list
*el
;
13787 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
13790 /* If there are any entries, ns->proc_name is the entry master
13791 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13793 sym
= ns
->entries
->sym
;
13795 sym
= ns
->proc_name
;
13796 if (sym
->result
== sym
13797 && sym
->ts
.type
== BT_UNKNOWN
13798 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
13799 && !sym
->attr
.untyped
)
13801 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13802 sym
->name
, &sym
->declared_at
);
13803 sym
->attr
.untyped
= 1;
13806 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
13807 && !sym
->attr
.contained
13808 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13809 && gfc_check_symbol_access (sym
))
13811 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
13812 "%L of PRIVATE type '%s'", sym
->name
,
13813 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13817 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
13819 if (el
->sym
->result
== el
->sym
13820 && el
->sym
->ts
.type
== BT_UNKNOWN
13821 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
13822 && !el
->sym
->attr
.untyped
)
13824 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13825 el
->sym
->name
, &el
->sym
->declared_at
);
13826 el
->sym
->attr
.untyped
= 1;
13832 /* 12.3.2.1.1 Defined operators. */
13835 check_uop_procedure (gfc_symbol
*sym
, locus where
)
13837 gfc_formal_arglist
*formal
;
13839 if (!sym
->attr
.function
)
13841 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13842 sym
->name
, &where
);
13846 if (sym
->ts
.type
== BT_CHARACTER
13847 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
13848 && !(sym
->result
&& sym
->result
->ts
.u
.cl
13849 && sym
->result
->ts
.u
.cl
->length
))
13851 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13852 "character length", sym
->name
, &where
);
13856 formal
= sym
->formal
;
13857 if (!formal
|| !formal
->sym
)
13859 gfc_error ("User operator procedure '%s' at %L must have at least "
13860 "one argument", sym
->name
, &where
);
13864 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13866 gfc_error ("First argument of operator interface at %L must be "
13867 "INTENT(IN)", &where
);
13871 if (formal
->sym
->attr
.optional
)
13873 gfc_error ("First argument of operator interface at %L cannot be "
13874 "optional", &where
);
13878 formal
= formal
->next
;
13879 if (!formal
|| !formal
->sym
)
13882 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13884 gfc_error ("Second argument of operator interface at %L must be "
13885 "INTENT(IN)", &where
);
13889 if (formal
->sym
->attr
.optional
)
13891 gfc_error ("Second argument of operator interface at %L cannot be "
13892 "optional", &where
);
13898 gfc_error ("Operator interface at %L must have, at most, two "
13899 "arguments", &where
);
13907 gfc_resolve_uops (gfc_symtree
*symtree
)
13909 gfc_interface
*itr
;
13911 if (symtree
== NULL
)
13914 gfc_resolve_uops (symtree
->left
);
13915 gfc_resolve_uops (symtree
->right
);
13917 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
13918 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
13922 /* Examine all of the expressions associated with a program unit,
13923 assign types to all intermediate expressions, make sure that all
13924 assignments are to compatible types and figure out which names
13925 refer to which functions or subroutines. It doesn't check code
13926 block, which is handled by resolve_code. */
13929 resolve_types (gfc_namespace
*ns
)
13935 gfc_namespace
* old_ns
= gfc_current_ns
;
13937 /* Check that all IMPLICIT types are ok. */
13938 if (!ns
->seen_implicit_none
)
13941 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
13942 if (ns
->set_flag
[letter
]
13943 && resolve_typespec_used (&ns
->default_type
[letter
],
13944 &ns
->implicit_loc
[letter
],
13949 gfc_current_ns
= ns
;
13951 resolve_entries (ns
);
13953 resolve_common_vars (ns
->blank_common
.head
, false);
13954 resolve_common_blocks (ns
->common_root
);
13956 resolve_contained_functions (ns
);
13958 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
13959 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
13960 resolve_formal_arglist (ns
->proc_name
);
13962 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
13964 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
13965 resolve_charlen (cl
);
13967 gfc_traverse_ns (ns
, resolve_symbol
);
13969 resolve_fntype (ns
);
13971 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13973 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
13974 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13975 "also be PURE", n
->proc_name
->name
,
13976 &n
->proc_name
->declared_at
);
13982 do_concurrent_flag
= 0;
13983 gfc_check_interfaces (ns
);
13985 gfc_traverse_ns (ns
, resolve_values
);
13991 for (d
= ns
->data
; d
; d
= d
->next
)
13995 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
13997 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
13999 if (ns
->common_root
!= NULL
)
14000 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
14002 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14003 resolve_equivalence (eq
);
14005 /* Warn about unused labels. */
14006 if (warn_unused_label
)
14007 warn_unused_fortran_label (ns
->st_labels
);
14009 gfc_resolve_uops (ns
->uop_root
);
14011 gfc_current_ns
= old_ns
;
14015 /* Call resolve_code recursively. */
14018 resolve_codes (gfc_namespace
*ns
)
14021 bitmap_obstack old_obstack
;
14023 if (ns
->resolved
== 1)
14026 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14029 gfc_current_ns
= ns
;
14031 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14032 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14035 /* Set to an out of range value. */
14036 current_entry_id
= -1;
14038 old_obstack
= labels_obstack
;
14039 bitmap_obstack_initialize (&labels_obstack
);
14041 resolve_code (ns
->code
, ns
);
14043 bitmap_obstack_release (&labels_obstack
);
14044 labels_obstack
= old_obstack
;
14048 /* This function is called after a complete program unit has been compiled.
14049 Its purpose is to examine all of the expressions associated with a program
14050 unit, assign types to all intermediate expressions, make sure that all
14051 assignments are to compatible types and figure out which names refer to
14052 which functions or subroutines. */
14055 gfc_resolve (gfc_namespace
*ns
)
14057 gfc_namespace
*old_ns
;
14058 code_stack
*old_cs_base
;
14064 old_ns
= gfc_current_ns
;
14065 old_cs_base
= cs_base
;
14067 resolve_types (ns
);
14068 resolve_codes (ns
);
14070 gfc_current_ns
= old_ns
;
14071 cs_base
= old_cs_base
;
14074 gfc_run_passes (ns
);