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 RECURIVE 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
);
1964 for (arg
= arg0
; arg
; arg
= arg
->next
)
1966 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1969 /* Being elemental, the last upper bound of an assumed size array
1970 argument must be present. */
1971 if (resolve_assumed_size_actual (arg
->expr
))
1974 /* Elemental procedure's array actual arguments must conform. */
1977 if (gfc_check_conformance (arg
->expr
, e
,
1978 "elemental procedure") == FAILURE
)
1985 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1986 is an array, the intent inout/out variable needs to be also an array. */
1987 if (rank
> 0 && esym
&& expr
== NULL
)
1988 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1989 arg
= arg
->next
, eformal
= eformal
->next
)
1990 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1991 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1992 && arg
->expr
&& arg
->expr
->rank
== 0)
1994 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1995 "ELEMENTAL subroutine '%s' is a scalar, but another "
1996 "actual argument is an array", &arg
->expr
->where
,
1997 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1998 : "INOUT", eformal
->sym
->name
, esym
->name
);
2005 /* This function does the checking of references to global procedures
2006 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2007 77 and 95 standards. It checks for a gsymbol for the name, making
2008 one if it does not already exist. If it already exists, then the
2009 reference being resolved must correspond to the type of gsymbol.
2010 Otherwise, the new symbol is equipped with the attributes of the
2011 reference. The corresponding code that is called in creating
2012 global entities is parse.c.
2014 In addition, for all but -std=legacy, the gsymbols are used to
2015 check the interfaces of external procedures from the same file.
2016 The namespace of the gsymbol is resolved and then, once this is
2017 done the interface is checked. */
2021 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2023 if (!gsym_ns
->proc_name
->attr
.recursive
)
2026 if (sym
->ns
== gsym_ns
)
2029 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2036 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2038 if (gsym_ns
->entries
)
2040 gfc_entry_list
*entry
= gsym_ns
->entries
;
2042 for (; entry
; entry
= entry
->next
)
2044 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2046 if (strcmp (gsym_ns
->proc_name
->name
,
2047 sym
->ns
->proc_name
->name
) == 0)
2051 && strcmp (gsym_ns
->proc_name
->name
,
2052 sym
->ns
->parent
->proc_name
->name
) == 0)
2061 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2062 gfc_actual_arglist
**actual
, int sub
)
2066 enum gfc_symbol_type type
;
2068 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2070 gsym
= gfc_get_gsymbol (sym
->name
);
2072 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2073 gfc_global_used (gsym
, where
);
2075 if (gfc_option
.flag_whole_file
2076 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2077 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2078 && gsym
->type
!= GSYM_UNKNOWN
2080 && gsym
->ns
->resolved
!= -1
2081 && gsym
->ns
->proc_name
2082 && not_in_recursive (sym
, gsym
->ns
)
2083 && not_entry_self_reference (sym
, gsym
->ns
))
2085 gfc_symbol
*def_sym
;
2087 /* Resolve the gsymbol namespace if needed. */
2088 if (!gsym
->ns
->resolved
)
2090 gfc_dt_list
*old_dt_list
;
2091 struct gfc_omp_saved_state old_omp_state
;
2093 /* Stash away derived types so that the backend_decls do not
2095 old_dt_list
= gfc_derived_types
;
2096 gfc_derived_types
= NULL
;
2097 /* And stash away openmp state. */
2098 gfc_omp_save_and_clear_state (&old_omp_state
);
2100 gfc_resolve (gsym
->ns
);
2102 /* Store the new derived types with the global namespace. */
2103 if (gfc_derived_types
)
2104 gsym
->ns
->derived_types
= gfc_derived_types
;
2106 /* Restore the derived types of this namespace. */
2107 gfc_derived_types
= old_dt_list
;
2108 /* And openmp state. */
2109 gfc_omp_restore_state (&old_omp_state
);
2112 /* Make sure that translation for the gsymbol occurs before
2113 the procedure currently being resolved. */
2114 ns
= gfc_global_ns_list
;
2115 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2117 if (ns
->sibling
== gsym
->ns
)
2119 ns
->sibling
= gsym
->ns
->sibling
;
2120 gsym
->ns
->sibling
= gfc_global_ns_list
;
2121 gfc_global_ns_list
= gsym
->ns
;
2126 def_sym
= gsym
->ns
->proc_name
;
2127 if (def_sym
->attr
.entry_master
)
2129 gfc_entry_list
*entry
;
2130 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2131 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2133 def_sym
= entry
->sym
;
2138 /* Differences in constant character lengths. */
2139 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2141 long int l1
= 0, l2
= 0;
2142 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2143 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2146 && cl1
->length
!= NULL
2147 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2148 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2151 && cl2
->length
!= NULL
2152 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2153 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2155 if (l1
&& l2
&& l1
!= l2
)
2156 gfc_error ("Character length mismatch in return type of "
2157 "function '%s' at %L (%ld/%ld)", sym
->name
,
2158 &sym
->declared_at
, l1
, l2
);
2161 /* Type mismatch of function return type and expected type. */
2162 if (sym
->attr
.function
2163 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2164 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2165 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2166 gfc_typename (&def_sym
->ts
));
2168 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2170 gfc_formal_arglist
*arg
= def_sym
->formal
;
2171 for ( ; arg
; arg
= arg
->next
)
2174 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2175 else if (arg
->sym
->attr
.allocatable
2176 || arg
->sym
->attr
.asynchronous
2177 || arg
->sym
->attr
.optional
2178 || arg
->sym
->attr
.pointer
2179 || arg
->sym
->attr
.target
2180 || arg
->sym
->attr
.value
2181 || arg
->sym
->attr
.volatile_
)
2183 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2184 "has an attribute that requires an explicit "
2185 "interface for this procedure", arg
->sym
->name
,
2186 sym
->name
, &sym
->declared_at
);
2189 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2190 else if (arg
->sym
&& arg
->sym
->as
2191 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2193 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2194 "argument '%s' must have an explicit interface",
2195 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2198 /* F2008, 12.4.2.2 (2c) */
2199 else if (arg
->sym
->attr
.codimension
)
2201 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2202 "'%s' must have an explicit interface",
2203 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2206 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2207 else if (false) /* TODO: is a parametrized derived type */
2209 gfc_error ("Procedure '%s' at %L with parametrized derived "
2210 "type argument '%s' must have an explicit "
2211 "interface", sym
->name
, &sym
->declared_at
,
2215 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2216 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2218 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2219 "argument '%s' must have an explicit interface",
2220 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2225 if (def_sym
->attr
.function
)
2227 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2228 if (def_sym
->as
&& def_sym
->as
->rank
2229 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2230 gfc_error ("The reference to function '%s' at %L either needs an "
2231 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2234 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2235 if ((def_sym
->result
->attr
.pointer
2236 || def_sym
->result
->attr
.allocatable
)
2237 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2238 || def_sym
->result
->attr
.pointer
2239 != sym
->result
->attr
.pointer
2240 || def_sym
->result
->attr
.allocatable
2241 != sym
->result
->attr
.allocatable
))
2242 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2243 "result must have an explicit interface", sym
->name
,
2246 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2247 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2248 && def_sym
->ts
.type
== BT_CHARACTER
&& def_sym
->ts
.u
.cl
->length
!= NULL
)
2250 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2252 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2253 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2255 gfc_error ("Nonconstant character-length function '%s' at %L "
2256 "must have an explicit interface", sym
->name
,
2262 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2263 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2265 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2266 "interface", sym
->name
, &sym
->declared_at
);
2269 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2270 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2272 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2273 "an explicit interface", sym
->name
, &sym
->declared_at
);
2276 if (gfc_option
.flag_whole_file
== 1
2277 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2278 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2279 gfc_errors_to_warnings (1);
2281 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2282 gfc_procedure_use (def_sym
, actual
, where
);
2284 gfc_errors_to_warnings (0);
2287 if (gsym
->type
== GSYM_UNKNOWN
)
2290 gsym
->where
= *where
;
2297 /************* Function resolution *************/
2299 /* Resolve a function call known to be generic.
2300 Section 14.1.2.4.1. */
2303 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2307 if (sym
->attr
.generic
)
2309 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2312 expr
->value
.function
.name
= s
->name
;
2313 expr
->value
.function
.esym
= s
;
2315 if (s
->ts
.type
!= BT_UNKNOWN
)
2317 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2318 expr
->ts
= s
->result
->ts
;
2321 expr
->rank
= s
->as
->rank
;
2322 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2323 expr
->rank
= s
->result
->as
->rank
;
2325 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2330 /* TODO: Need to search for elemental references in generic
2334 if (sym
->attr
.intrinsic
)
2335 return gfc_intrinsic_func_interface (expr
, 0);
2342 resolve_generic_f (gfc_expr
*expr
)
2346 gfc_interface
*intr
= NULL
;
2348 sym
= expr
->symtree
->n
.sym
;
2352 m
= resolve_generic_f0 (expr
, sym
);
2355 else if (m
== MATCH_ERROR
)
2360 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2361 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2364 if (sym
->ns
->parent
== NULL
)
2366 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2370 if (!generic_sym (sym
))
2374 /* Last ditch attempt. See if the reference is to an intrinsic
2375 that possesses a matching interface. 14.1.2.4 */
2376 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2378 gfc_error ("There is no specific function for the generic '%s' "
2379 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2385 if (gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
, NULL
,
2388 return resolve_structure_cons (expr
, 0);
2391 m
= gfc_intrinsic_func_interface (expr
, 0);
2396 gfc_error ("Generic function '%s' at %L is not consistent with a "
2397 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2404 /* Resolve a function call known to be specific. */
2407 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2411 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2413 if (sym
->attr
.dummy
)
2415 sym
->attr
.proc
= PROC_DUMMY
;
2419 sym
->attr
.proc
= PROC_EXTERNAL
;
2423 if (sym
->attr
.proc
== PROC_MODULE
2424 || sym
->attr
.proc
== PROC_ST_FUNCTION
2425 || sym
->attr
.proc
== PROC_INTERNAL
)
2428 if (sym
->attr
.intrinsic
)
2430 m
= gfc_intrinsic_func_interface (expr
, 1);
2434 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2435 "with an intrinsic", sym
->name
, &expr
->where
);
2443 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2446 expr
->ts
= sym
->result
->ts
;
2449 expr
->value
.function
.name
= sym
->name
;
2450 expr
->value
.function
.esym
= sym
;
2451 if (sym
->as
!= NULL
)
2452 expr
->rank
= sym
->as
->rank
;
2459 resolve_specific_f (gfc_expr
*expr
)
2464 sym
= expr
->symtree
->n
.sym
;
2468 m
= resolve_specific_f0 (sym
, expr
);
2471 if (m
== MATCH_ERROR
)
2474 if (sym
->ns
->parent
== NULL
)
2477 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2483 gfc_error ("Unable to resolve the specific function '%s' at %L",
2484 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2490 /* Resolve a procedure call not known to be generic nor specific. */
2493 resolve_unknown_f (gfc_expr
*expr
)
2498 sym
= expr
->symtree
->n
.sym
;
2500 if (sym
->attr
.dummy
)
2502 sym
->attr
.proc
= PROC_DUMMY
;
2503 expr
->value
.function
.name
= sym
->name
;
2507 /* See if we have an intrinsic function reference. */
2509 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2511 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2516 /* The reference is to an external name. */
2518 sym
->attr
.proc
= PROC_EXTERNAL
;
2519 expr
->value
.function
.name
= sym
->name
;
2520 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2522 if (sym
->as
!= NULL
)
2523 expr
->rank
= sym
->as
->rank
;
2525 /* Type of the expression is either the type of the symbol or the
2526 default type of the symbol. */
2529 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2531 if (sym
->ts
.type
!= BT_UNKNOWN
)
2535 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2537 if (ts
->type
== BT_UNKNOWN
)
2539 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2540 sym
->name
, &expr
->where
);
2551 /* Return true, if the symbol is an external procedure. */
2553 is_external_proc (gfc_symbol
*sym
)
2555 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2556 && !(sym
->attr
.intrinsic
2557 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
2558 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2559 && !sym
->attr
.proc_pointer
2560 && !sym
->attr
.use_assoc
2568 /* Figure out if a function reference is pure or not. Also set the name
2569 of the function for a potential error message. Return nonzero if the
2570 function is PURE, zero if not. */
2572 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2575 pure_function (gfc_expr
*e
, const char **name
)
2581 if (e
->symtree
!= NULL
2582 && e
->symtree
->n
.sym
!= NULL
2583 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2584 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2586 if (e
->value
.function
.esym
)
2588 pure
= gfc_pure (e
->value
.function
.esym
);
2589 *name
= e
->value
.function
.esym
->name
;
2591 else if (e
->value
.function
.isym
)
2593 pure
= e
->value
.function
.isym
->pure
2594 || e
->value
.function
.isym
->elemental
;
2595 *name
= e
->value
.function
.isym
->name
;
2599 /* Implicit functions are not pure. */
2601 *name
= e
->value
.function
.name
;
2609 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2610 int *f ATTRIBUTE_UNUSED
)
2614 /* Don't bother recursing into other statement functions
2615 since they will be checked individually for purity. */
2616 if (e
->expr_type
!= EXPR_FUNCTION
2618 || e
->symtree
->n
.sym
== sym
2619 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2622 return pure_function (e
, &name
) ? false : true;
2627 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2629 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2634 is_scalar_expr_ptr (gfc_expr
*expr
)
2636 gfc_try retval
= SUCCESS
;
2641 /* See if we have a gfc_ref, which means we have a substring, array
2642 reference, or a component. */
2643 if (expr
->ref
!= NULL
)
2646 while (ref
->next
!= NULL
)
2652 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2653 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2658 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2660 else if (ref
->u
.ar
.type
== AR_FULL
)
2662 /* The user can give a full array if the array is of size 1. */
2663 if (ref
->u
.ar
.as
!= NULL
2664 && ref
->u
.ar
.as
->rank
== 1
2665 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2666 && ref
->u
.ar
.as
->lower
[0] != NULL
2667 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2668 && ref
->u
.ar
.as
->upper
[0] != NULL
2669 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2671 /* If we have a character string, we need to check if
2672 its length is one. */
2673 if (expr
->ts
.type
== BT_CHARACTER
)
2675 if (expr
->ts
.u
.cl
== NULL
2676 || expr
->ts
.u
.cl
->length
== NULL
2677 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2683 /* We have constant lower and upper bounds. If the
2684 difference between is 1, it can be considered a
2686 FIXME: Use gfc_dep_compare_expr instead. */
2687 start
= (int) mpz_get_si
2688 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2689 end
= (int) mpz_get_si
2690 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2691 if (end
- start
+ 1 != 1)
2706 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2708 /* Character string. Make sure it's of length 1. */
2709 if (expr
->ts
.u
.cl
== NULL
2710 || expr
->ts
.u
.cl
->length
== NULL
2711 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2714 else if (expr
->rank
!= 0)
2721 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2722 and, in the case of c_associated, set the binding label based on
2726 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2727 gfc_symbol
**new_sym
)
2729 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2730 int optional_arg
= 0;
2731 gfc_try retval
= SUCCESS
;
2732 gfc_symbol
*args_sym
;
2733 gfc_typespec
*arg_ts
;
2734 symbol_attribute arg_attr
;
2736 if (args
->expr
->expr_type
== EXPR_CONSTANT
2737 || args
->expr
->expr_type
== EXPR_OP
2738 || args
->expr
->expr_type
== EXPR_NULL
)
2740 gfc_error ("Argument to '%s' at %L is not a variable",
2741 sym
->name
, &(args
->expr
->where
));
2745 args_sym
= args
->expr
->symtree
->n
.sym
;
2747 /* The typespec for the actual arg should be that stored in the expr
2748 and not necessarily that of the expr symbol (args_sym), because
2749 the actual expression could be a part-ref of the expr symbol. */
2750 arg_ts
= &(args
->expr
->ts
);
2751 arg_attr
= gfc_expr_attr (args
->expr
);
2753 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2755 /* If the user gave two args then they are providing something for
2756 the optional arg (the second cptr). Therefore, set the name and
2757 binding label to the c_associated for two cptrs. Otherwise,
2758 set c_associated to expect one cptr. */
2762 sprintf (name
, "%s_2", sym
->name
);
2768 sprintf (name
, "%s_1", sym
->name
);
2772 /* Get a new symbol for the version of c_associated that
2774 *new_sym
= get_iso_c_sym (sym
, name
, NULL
, optional_arg
);
2776 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2777 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2779 sprintf (name
, "%s", sym
->name
);
2781 /* Error check the call. */
2782 if (args
->next
!= NULL
)
2784 gfc_error_now ("More actual than formal arguments in '%s' "
2785 "call at %L", name
, &(args
->expr
->where
));
2788 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2793 /* Make sure we have either the target or pointer attribute. */
2794 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2796 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2797 "a TARGET or an associated pointer",
2799 sym
->name
, &(args
->expr
->where
));
2803 if (gfc_is_coindexed (args
->expr
))
2805 gfc_error_now ("Coindexed argument not permitted"
2806 " in '%s' call at %L", name
,
2807 &(args
->expr
->where
));
2811 /* Follow references to make sure there are no array
2813 seen_section
= false;
2815 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2817 if (ref
->type
== REF_ARRAY
)
2819 if (ref
->u
.ar
.type
== AR_SECTION
)
2820 seen_section
= true;
2822 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2825 for (r
= ref
->next
; r
; r
=r
->next
)
2826 if (r
->type
== REF_COMPONENT
)
2828 gfc_error_now ("Array section not permitted"
2829 " in '%s' call at %L", name
,
2830 &(args
->expr
->where
));
2838 if (seen_section
&& retval
== SUCCESS
)
2839 gfc_warning ("Array section in '%s' call at %L", name
,
2840 &(args
->expr
->where
));
2842 /* See if we have interoperable type and type param. */
2843 if (gfc_verify_c_interop (arg_ts
) == SUCCESS
2844 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2846 if (args_sym
->attr
.target
== 1)
2848 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2849 has the target attribute and is interoperable. */
2850 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2851 allocatable variable that has the TARGET attribute and
2852 is not an array of zero size. */
2853 if (args_sym
->attr
.allocatable
== 1)
2855 if (args_sym
->attr
.dimension
!= 0
2856 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2858 gfc_error_now ("Allocatable variable '%s' used as a "
2859 "parameter to '%s' at %L must not be "
2860 "an array of zero size",
2861 args_sym
->name
, sym
->name
,
2862 &(args
->expr
->where
));
2868 /* A non-allocatable target variable with C
2869 interoperable type and type parameters must be
2871 if (args_sym
&& args_sym
->attr
.dimension
)
2873 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2875 gfc_error ("Assumed-shape array '%s' at %L "
2876 "cannot be an argument to the "
2877 "procedure '%s' because "
2878 "it is not C interoperable",
2880 &(args
->expr
->where
), sym
->name
);
2883 else if (args_sym
->as
->type
== AS_DEFERRED
)
2885 gfc_error ("Deferred-shape array '%s' at %L "
2886 "cannot be an argument to the "
2887 "procedure '%s' because "
2888 "it is not C interoperable",
2890 &(args
->expr
->where
), sym
->name
);
2895 /* Make sure it's not a character string. Arrays of
2896 any type should be ok if the variable is of a C
2897 interoperable type. */
2898 if (arg_ts
->type
== BT_CHARACTER
)
2899 if (arg_ts
->u
.cl
!= NULL
2900 && (arg_ts
->u
.cl
->length
== NULL
2901 || arg_ts
->u
.cl
->length
->expr_type
2904 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2906 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2908 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2909 "at %L must have a length of 1",
2910 args_sym
->name
, sym
->name
,
2911 &(args
->expr
->where
));
2916 else if (arg_attr
.pointer
2917 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2919 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2921 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2922 "associated scalar POINTER", args_sym
->name
,
2923 sym
->name
, &(args
->expr
->where
));
2929 /* The parameter is not required to be C interoperable. If it
2930 is not C interoperable, it must be a nonpolymorphic scalar
2931 with no length type parameters. It still must have either
2932 the pointer or target attribute, and it can be
2933 allocatable (but must be allocated when c_loc is called). */
2934 if (args
->expr
->rank
!= 0
2935 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2937 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2938 "scalar", args_sym
->name
, sym
->name
,
2939 &(args
->expr
->where
));
2942 else if (arg_ts
->type
== BT_CHARACTER
2943 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2945 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2946 "%L must have a length of 1",
2947 args_sym
->name
, sym
->name
,
2948 &(args
->expr
->where
));
2951 else if (arg_ts
->type
== BT_CLASS
)
2953 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2954 "polymorphic", args_sym
->name
, sym
->name
,
2955 &(args
->expr
->where
));
2960 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2962 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2964 /* TODO: Update this error message to allow for procedure
2965 pointers once they are implemented. */
2966 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2968 args_sym
->name
, sym
->name
,
2969 &(args
->expr
->where
));
2972 else if (args_sym
->attr
.is_bind_c
!= 1)
2974 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2976 args_sym
->name
, sym
->name
,
2977 &(args
->expr
->where
));
2982 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2987 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2988 "iso_c_binding function: '%s'!\n", sym
->name
);
2995 /* Resolve a function call, which means resolving the arguments, then figuring
2996 out which entity the name refers to. */
2999 resolve_function (gfc_expr
*expr
)
3001 gfc_actual_arglist
*arg
;
3006 procedure_type p
= PROC_INTRINSIC
;
3007 bool no_formal_args
;
3011 sym
= expr
->symtree
->n
.sym
;
3013 /* If this is a procedure pointer component, it has already been resolved. */
3014 if (gfc_is_proc_ptr_comp (expr
, NULL
))
3017 if (sym
&& sym
->attr
.intrinsic
3018 && resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
3021 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3023 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
3027 /* If this ia a deferred TBP with an abstract interface (which may
3028 of course be referenced), expr->value.function.esym will be set. */
3029 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3031 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3032 sym
->name
, &expr
->where
);
3036 /* Switch off assumed size checking and do this again for certain kinds
3037 of procedure, once the procedure itself is resolved. */
3038 need_full_assumed_size
++;
3040 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3041 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3043 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3044 inquiry_argument
= true;
3045 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
3047 if (resolve_actual_arglist (expr
->value
.function
.actual
,
3048 p
, no_formal_args
) == FAILURE
)
3050 inquiry_argument
= false;
3054 inquiry_argument
= false;
3056 /* Need to setup the call to the correct c_associated, depending on
3057 the number of cptrs to user gives to compare. */
3058 if (sym
&& sym
->attr
.is_iso_c
== 1)
3060 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
3064 /* Get the symtree for the new symbol (resolved func).
3065 the old one will be freed later, when it's no longer used. */
3066 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3069 /* Resume assumed_size checking. */
3070 need_full_assumed_size
--;
3072 /* If the procedure is external, check for usage. */
3073 if (sym
&& is_external_proc (sym
))
3074 resolve_global_procedure (sym
, &expr
->where
,
3075 &expr
->value
.function
.actual
, 0);
3077 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3079 && sym
->ts
.u
.cl
->length
== NULL
3081 && !sym
->ts
.deferred
3082 && expr
->value
.function
.esym
== NULL
3083 && !sym
->attr
.contained
)
3085 /* Internal procedures are taken care of in resolve_contained_fntype. */
3086 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3087 "be used at %L since it is not a dummy argument",
3088 sym
->name
, &expr
->where
);
3092 /* See if function is already resolved. */
3094 if (expr
->value
.function
.name
!= NULL
)
3096 if (expr
->ts
.type
== BT_UNKNOWN
)
3102 /* Apply the rules of section 14.1.2. */
3104 switch (procedure_kind (sym
))
3107 t
= resolve_generic_f (expr
);
3110 case PTYPE_SPECIFIC
:
3111 t
= resolve_specific_f (expr
);
3115 t
= resolve_unknown_f (expr
);
3119 gfc_internal_error ("resolve_function(): bad function type");
3123 /* If the expression is still a function (it might have simplified),
3124 then we check to see if we are calling an elemental function. */
3126 if (expr
->expr_type
!= EXPR_FUNCTION
)
3129 temp
= need_full_assumed_size
;
3130 need_full_assumed_size
= 0;
3132 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3135 if (omp_workshare_flag
3136 && expr
->value
.function
.esym
3137 && ! gfc_elemental (expr
->value
.function
.esym
))
3139 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3140 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3145 #define GENERIC_ID expr->value.function.isym->id
3146 else if (expr
->value
.function
.actual
!= NULL
3147 && expr
->value
.function
.isym
!= NULL
3148 && GENERIC_ID
!= GFC_ISYM_LBOUND
3149 && GENERIC_ID
!= GFC_ISYM_LEN
3150 && GENERIC_ID
!= GFC_ISYM_LOC
3151 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3153 /* Array intrinsics must also have the last upper bound of an
3154 assumed size array argument. UBOUND and SIZE have to be
3155 excluded from the check if the second argument is anything
3158 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3160 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3161 && arg
->next
!= NULL
&& arg
->next
->expr
)
3163 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3166 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3169 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3174 if (arg
->expr
!= NULL
3175 && arg
->expr
->rank
> 0
3176 && resolve_assumed_size_actual (arg
->expr
))
3182 need_full_assumed_size
= temp
;
3185 if (!pure_function (expr
, &name
) && name
)
3189 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3190 "FORALL %s", name
, &expr
->where
,
3191 forall_flag
== 2 ? "mask" : "block");
3194 else if (do_concurrent_flag
)
3196 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3197 "DO CONCURRENT %s", name
, &expr
->where
,
3198 do_concurrent_flag
== 2 ? "mask" : "block");
3201 else if (gfc_pure (NULL
))
3203 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3204 "procedure within a PURE procedure", name
, &expr
->where
);
3208 if (gfc_implicit_pure (NULL
))
3209 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3212 /* Functions without the RECURSIVE attribution are not allowed to
3213 * call themselves. */
3214 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3217 esym
= expr
->value
.function
.esym
;
3219 if (is_illegal_recursion (esym
, gfc_current_ns
))
3221 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3222 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3223 " function '%s' is not RECURSIVE",
3224 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3226 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3227 " is not RECURSIVE", esym
->name
, &expr
->where
);
3233 /* Character lengths of use associated functions may contains references to
3234 symbols not referenced from the current program unit otherwise. Make sure
3235 those symbols are marked as referenced. */
3237 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3238 && expr
->value
.function
.esym
->attr
.use_assoc
)
3240 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3243 /* Make sure that the expression has a typespec that works. */
3244 if (expr
->ts
.type
== BT_UNKNOWN
)
3246 if (expr
->symtree
->n
.sym
->result
3247 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3248 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3249 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3256 /************* Subroutine resolution *************/
3259 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3265 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3266 sym
->name
, &c
->loc
);
3267 else if (do_concurrent_flag
)
3268 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3269 "PURE", sym
->name
, &c
->loc
);
3270 else if (gfc_pure (NULL
))
3271 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3274 if (gfc_implicit_pure (NULL
))
3275 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3280 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3284 if (sym
->attr
.generic
)
3286 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3289 c
->resolved_sym
= s
;
3290 pure_subroutine (c
, s
);
3294 /* TODO: Need to search for elemental references in generic interface. */
3297 if (sym
->attr
.intrinsic
)
3298 return gfc_intrinsic_sub_interface (c
, 0);
3305 resolve_generic_s (gfc_code
*c
)
3310 sym
= c
->symtree
->n
.sym
;
3314 m
= resolve_generic_s0 (c
, sym
);
3317 else if (m
== MATCH_ERROR
)
3321 if (sym
->ns
->parent
== NULL
)
3323 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3327 if (!generic_sym (sym
))
3331 /* Last ditch attempt. See if the reference is to an intrinsic
3332 that possesses a matching interface. 14.1.2.4 */
3333 sym
= c
->symtree
->n
.sym
;
3335 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3337 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3338 sym
->name
, &c
->loc
);
3342 m
= gfc_intrinsic_sub_interface (c
, 0);
3346 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3347 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3353 /* Set the name and binding label of the subroutine symbol in the call
3354 expression represented by 'c' to include the type and kind of the
3355 second parameter. This function is for resolving the appropriate
3356 version of c_f_pointer() and c_f_procpointer(). For example, a
3357 call to c_f_pointer() for a default integer pointer could have a
3358 name of c_f_pointer_i4. If no second arg exists, which is an error
3359 for these two functions, it defaults to the generic symbol's name
3360 and binding label. */
3363 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3364 char *name
, const char **binding_label
)
3366 gfc_expr
*arg
= NULL
;
3370 /* The second arg of c_f_pointer and c_f_procpointer determines
3371 the type and kind for the procedure name. */
3372 arg
= c
->ext
.actual
->next
->expr
;
3376 /* Set up the name to have the given symbol's name,
3377 plus the type and kind. */
3378 /* a derived type is marked with the type letter 'u' */
3379 if (arg
->ts
.type
== BT_DERIVED
)
3382 kind
= 0; /* set the kind as 0 for now */
3386 type
= gfc_type_letter (arg
->ts
.type
);
3387 kind
= arg
->ts
.kind
;
3390 if (arg
->ts
.type
== BT_CHARACTER
)
3391 /* Kind info for character strings not needed. */
3394 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3395 /* Set up the binding label as the given symbol's label plus
3396 the type and kind. */
3397 *binding_label
= gfc_get_string ("%s_%c%d", sym
->binding_label
, type
,
3402 /* If the second arg is missing, set the name and label as
3403 was, cause it should at least be found, and the missing
3404 arg error will be caught by compare_parameters(). */
3405 sprintf (name
, "%s", sym
->name
);
3406 *binding_label
= sym
->binding_label
;
3413 /* Resolve a generic version of the iso_c_binding procedure given
3414 (sym) to the specific one based on the type and kind of the
3415 argument(s). Currently, this function resolves c_f_pointer() and
3416 c_f_procpointer based on the type and kind of the second argument
3417 (FPTR). Other iso_c_binding procedures aren't specially handled.
3418 Upon successfully exiting, c->resolved_sym will hold the resolved
3419 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3423 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3425 gfc_symbol
*new_sym
;
3426 /* this is fine, since we know the names won't use the max */
3427 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3428 const char* binding_label
;
3429 /* default to success; will override if find error */
3430 match m
= MATCH_YES
;
3432 /* Make sure the actual arguments are in the necessary order (based on the
3433 formal args) before resolving. */
3434 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
3436 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3437 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3439 set_name_and_label (c
, sym
, name
, &binding_label
);
3441 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3443 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3445 /* Make sure we got a third arg if the second arg has non-zero
3446 rank. We must also check that the type and rank are
3447 correct since we short-circuit this check in
3448 gfc_procedure_use() (called above to sort actual args). */
3449 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
3451 if(c
->ext
.actual
->next
->next
== NULL
3452 || c
->ext
.actual
->next
->next
->expr
== NULL
)
3455 gfc_error ("Missing SHAPE parameter for call to %s "
3456 "at %L", sym
->name
, &(c
->loc
));
3458 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
3460 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
3463 gfc_error ("SHAPE parameter for call to %s at %L must "
3464 "be a rank 1 INTEGER array", sym
->name
,
3471 if (m
!= MATCH_ERROR
)
3473 /* the 1 means to add the optional arg to formal list */
3474 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3476 /* for error reporting, say it's declared where the original was */
3477 new_sym
->declared_at
= sym
->declared_at
;
3482 /* no differences for c_loc or c_funloc */
3486 /* set the resolved symbol */
3487 if (m
!= MATCH_ERROR
)
3488 c
->resolved_sym
= new_sym
;
3490 c
->resolved_sym
= sym
;
3496 /* Resolve a subroutine call known to be specific. */
3499 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3503 if(sym
->attr
.is_iso_c
)
3505 m
= gfc_iso_c_sub_interface (c
,sym
);
3509 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3511 if (sym
->attr
.dummy
)
3513 sym
->attr
.proc
= PROC_DUMMY
;
3517 sym
->attr
.proc
= PROC_EXTERNAL
;
3521 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3524 if (sym
->attr
.intrinsic
)
3526 m
= gfc_intrinsic_sub_interface (c
, 1);
3530 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3531 "with an intrinsic", sym
->name
, &c
->loc
);
3539 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3541 c
->resolved_sym
= sym
;
3542 pure_subroutine (c
, sym
);
3549 resolve_specific_s (gfc_code
*c
)
3554 sym
= c
->symtree
->n
.sym
;
3558 m
= resolve_specific_s0 (c
, sym
);
3561 if (m
== MATCH_ERROR
)
3564 if (sym
->ns
->parent
== NULL
)
3567 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3573 sym
= c
->symtree
->n
.sym
;
3574 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3575 sym
->name
, &c
->loc
);
3581 /* Resolve a subroutine call not known to be generic nor specific. */
3584 resolve_unknown_s (gfc_code
*c
)
3588 sym
= c
->symtree
->n
.sym
;
3590 if (sym
->attr
.dummy
)
3592 sym
->attr
.proc
= PROC_DUMMY
;
3596 /* See if we have an intrinsic function reference. */
3598 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3600 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3605 /* The reference is to an external name. */
3608 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3610 c
->resolved_sym
= sym
;
3612 pure_subroutine (c
, sym
);
3618 /* Resolve a subroutine call. Although it was tempting to use the same code
3619 for functions, subroutines and functions are stored differently and this
3620 makes things awkward. */
3623 resolve_call (gfc_code
*c
)
3626 procedure_type ptype
= PROC_INTRINSIC
;
3627 gfc_symbol
*csym
, *sym
;
3628 bool no_formal_args
;
3630 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3632 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3634 gfc_error ("'%s' at %L has a type, which is not consistent with "
3635 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3639 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3642 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3643 sym
= st
? st
->n
.sym
: NULL
;
3644 if (sym
&& csym
!= sym
3645 && sym
->ns
== gfc_current_ns
3646 && sym
->attr
.flavor
== FL_PROCEDURE
3647 && sym
->attr
.contained
)
3650 if (csym
->attr
.generic
)
3651 c
->symtree
->n
.sym
= sym
;
3654 csym
= c
->symtree
->n
.sym
;
3658 /* If this ia a deferred TBP with an abstract interface
3659 (which may of course be referenced), c->expr1 will be set. */
3660 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3662 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3663 csym
->name
, &c
->loc
);
3667 /* Subroutines without the RECURSIVE attribution are not allowed to
3668 * call themselves. */
3669 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3671 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3672 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3673 " subroutine '%s' is not RECURSIVE",
3674 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3676 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3677 " is not RECURSIVE", csym
->name
, &c
->loc
);
3682 /* Switch off assumed size checking and do this again for certain kinds
3683 of procedure, once the procedure itself is resolved. */
3684 need_full_assumed_size
++;
3687 ptype
= csym
->attr
.proc
;
3689 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3690 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3691 no_formal_args
) == FAILURE
)
3694 /* Resume assumed_size checking. */
3695 need_full_assumed_size
--;
3697 /* If external, check for usage. */
3698 if (csym
&& is_external_proc (csym
))
3699 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3702 if (c
->resolved_sym
== NULL
)
3704 c
->resolved_isym
= NULL
;
3705 switch (procedure_kind (csym
))
3708 t
= resolve_generic_s (c
);
3711 case PTYPE_SPECIFIC
:
3712 t
= resolve_specific_s (c
);
3716 t
= resolve_unknown_s (c
);
3720 gfc_internal_error ("resolve_subroutine(): bad function type");
3724 /* Some checks of elemental subroutine actual arguments. */
3725 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3732 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3733 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3734 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3735 if their shapes do not match. If either op1->shape or op2->shape is
3736 NULL, return SUCCESS. */
3739 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3746 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3748 for (i
= 0; i
< op1
->rank
; i
++)
3750 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3752 gfc_error ("Shapes for operands at %L and %L are not conformable",
3753 &op1
->where
, &op2
->where
);
3764 /* Resolve an operator expression node. This can involve replacing the
3765 operation with a user defined function call. */
3768 resolve_operator (gfc_expr
*e
)
3770 gfc_expr
*op1
, *op2
;
3772 bool dual_locus_error
;
3775 /* Resolve all subnodes-- give them types. */
3777 switch (e
->value
.op
.op
)
3780 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3783 /* Fall through... */
3786 case INTRINSIC_UPLUS
:
3787 case INTRINSIC_UMINUS
:
3788 case INTRINSIC_PARENTHESES
:
3789 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3794 /* Typecheck the new node. */
3796 op1
= e
->value
.op
.op1
;
3797 op2
= e
->value
.op
.op2
;
3798 dual_locus_error
= false;
3800 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3801 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3803 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3807 switch (e
->value
.op
.op
)
3809 case INTRINSIC_UPLUS
:
3810 case INTRINSIC_UMINUS
:
3811 if (op1
->ts
.type
== BT_INTEGER
3812 || op1
->ts
.type
== BT_REAL
3813 || op1
->ts
.type
== BT_COMPLEX
)
3819 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3820 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3823 case INTRINSIC_PLUS
:
3824 case INTRINSIC_MINUS
:
3825 case INTRINSIC_TIMES
:
3826 case INTRINSIC_DIVIDE
:
3827 case INTRINSIC_POWER
:
3828 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3830 gfc_type_convert_binary (e
, 1);
3835 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3836 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3837 gfc_typename (&op2
->ts
));
3840 case INTRINSIC_CONCAT
:
3841 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3842 && op1
->ts
.kind
== op2
->ts
.kind
)
3844 e
->ts
.type
= BT_CHARACTER
;
3845 e
->ts
.kind
= op1
->ts
.kind
;
3850 _("Operands of string concatenation operator at %%L are %s/%s"),
3851 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3857 case INTRINSIC_NEQV
:
3858 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3860 e
->ts
.type
= BT_LOGICAL
;
3861 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3862 if (op1
->ts
.kind
< e
->ts
.kind
)
3863 gfc_convert_type (op1
, &e
->ts
, 2);
3864 else if (op2
->ts
.kind
< e
->ts
.kind
)
3865 gfc_convert_type (op2
, &e
->ts
, 2);
3869 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3870 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3871 gfc_typename (&op2
->ts
));
3876 if (op1
->ts
.type
== BT_LOGICAL
)
3878 e
->ts
.type
= BT_LOGICAL
;
3879 e
->ts
.kind
= op1
->ts
.kind
;
3883 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3884 gfc_typename (&op1
->ts
));
3888 case INTRINSIC_GT_OS
:
3890 case INTRINSIC_GE_OS
:
3892 case INTRINSIC_LT_OS
:
3894 case INTRINSIC_LE_OS
:
3895 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3897 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3901 /* Fall through... */
3904 case INTRINSIC_EQ_OS
:
3906 case INTRINSIC_NE_OS
:
3907 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3908 && op1
->ts
.kind
== op2
->ts
.kind
)
3910 e
->ts
.type
= BT_LOGICAL
;
3911 e
->ts
.kind
= gfc_default_logical_kind
;
3915 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3917 gfc_type_convert_binary (e
, 1);
3919 e
->ts
.type
= BT_LOGICAL
;
3920 e
->ts
.kind
= gfc_default_logical_kind
;
3924 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3926 _("Logicals at %%L must be compared with %s instead of %s"),
3927 (e
->value
.op
.op
== INTRINSIC_EQ
3928 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3929 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3932 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3933 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3934 gfc_typename (&op2
->ts
));
3938 case INTRINSIC_USER
:
3939 if (e
->value
.op
.uop
->op
== NULL
)
3940 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3941 else if (op2
== NULL
)
3942 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3943 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3946 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3947 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3948 gfc_typename (&op2
->ts
));
3949 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3954 case INTRINSIC_PARENTHESES
:
3956 if (e
->ts
.type
== BT_CHARACTER
)
3957 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3961 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3964 /* Deal with arrayness of an operand through an operator. */
3968 switch (e
->value
.op
.op
)
3970 case INTRINSIC_PLUS
:
3971 case INTRINSIC_MINUS
:
3972 case INTRINSIC_TIMES
:
3973 case INTRINSIC_DIVIDE
:
3974 case INTRINSIC_POWER
:
3975 case INTRINSIC_CONCAT
:
3979 case INTRINSIC_NEQV
:
3981 case INTRINSIC_EQ_OS
:
3983 case INTRINSIC_NE_OS
:
3985 case INTRINSIC_GT_OS
:
3987 case INTRINSIC_GE_OS
:
3989 case INTRINSIC_LT_OS
:
3991 case INTRINSIC_LE_OS
:
3993 if (op1
->rank
== 0 && op2
->rank
== 0)
3996 if (op1
->rank
== 0 && op2
->rank
!= 0)
3998 e
->rank
= op2
->rank
;
4000 if (e
->shape
== NULL
)
4001 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4004 if (op1
->rank
!= 0 && op2
->rank
== 0)
4006 e
->rank
= op1
->rank
;
4008 if (e
->shape
== NULL
)
4009 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4012 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4014 if (op1
->rank
== op2
->rank
)
4016 e
->rank
= op1
->rank
;
4017 if (e
->shape
== NULL
)
4019 t
= compare_shapes (op1
, op2
);
4023 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4028 /* Allow higher level expressions to work. */
4031 /* Try user-defined operators, and otherwise throw an error. */
4032 dual_locus_error
= true;
4034 _("Inconsistent ranks for operator at %%L and %%L"));
4041 case INTRINSIC_PARENTHESES
:
4043 case INTRINSIC_UPLUS
:
4044 case INTRINSIC_UMINUS
:
4045 /* Simply copy arrayness attribute */
4046 e
->rank
= op1
->rank
;
4048 if (e
->shape
== NULL
)
4049 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4057 /* Attempt to simplify the expression. */
4060 t
= gfc_simplify_expr (e
, 0);
4061 /* Some calls do not succeed in simplification and return FAILURE
4062 even though there is no error; e.g. variable references to
4063 PARAMETER arrays. */
4064 if (!gfc_is_constant_expr (e
))
4072 match m
= gfc_extend_expr (e
);
4075 if (m
== MATCH_ERROR
)
4079 if (dual_locus_error
)
4080 gfc_error (msg
, &op1
->where
, &op2
->where
);
4082 gfc_error (msg
, &e
->where
);
4088 /************** Array resolution subroutines **************/
4091 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4094 /* Compare two integer expressions. */
4097 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4101 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4102 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4105 /* If either of the types isn't INTEGER, we must have
4106 raised an error earlier. */
4108 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4111 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4121 /* Compare an integer expression with an integer. */
4124 compare_bound_int (gfc_expr
*a
, int b
)
4128 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4131 if (a
->ts
.type
!= BT_INTEGER
)
4132 gfc_internal_error ("compare_bound_int(): Bad expression");
4134 i
= mpz_cmp_si (a
->value
.integer
, b
);
4144 /* Compare an integer expression with a mpz_t. */
4147 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4151 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4154 if (a
->ts
.type
!= BT_INTEGER
)
4155 gfc_internal_error ("compare_bound_int(): Bad expression");
4157 i
= mpz_cmp (a
->value
.integer
, b
);
4167 /* Compute the last value of a sequence given by a triplet.
4168 Return 0 if it wasn't able to compute the last value, or if the
4169 sequence if empty, and 1 otherwise. */
4172 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4173 gfc_expr
*stride
, mpz_t last
)
4177 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4178 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4179 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4182 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4183 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4186 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4188 if (compare_bound (start
, end
) == CMP_GT
)
4190 mpz_set (last
, end
->value
.integer
);
4194 if (compare_bound_int (stride
, 0) == CMP_GT
)
4196 /* Stride is positive */
4197 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4202 /* Stride is negative */
4203 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4208 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4209 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4210 mpz_sub (last
, end
->value
.integer
, rem
);
4217 /* Compare a single dimension of an array reference to the array
4221 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4225 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4227 gcc_assert (ar
->stride
[i
] == NULL
);
4228 /* This implies [*] as [*:] and [*:3] are not possible. */
4229 if (ar
->start
[i
] == NULL
)
4231 gcc_assert (ar
->end
[i
] == NULL
);
4236 /* Given start, end and stride values, calculate the minimum and
4237 maximum referenced indexes. */
4239 switch (ar
->dimen_type
[i
])
4242 case DIMEN_THIS_IMAGE
:
4247 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4250 gfc_warning ("Array reference at %L is out of bounds "
4251 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4252 mpz_get_si (ar
->start
[i
]->value
.integer
),
4253 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4255 gfc_warning ("Array reference at %L is out of bounds "
4256 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4257 mpz_get_si (ar
->start
[i
]->value
.integer
),
4258 mpz_get_si (as
->lower
[i
]->value
.integer
),
4262 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4265 gfc_warning ("Array reference at %L is out of bounds "
4266 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4267 mpz_get_si (ar
->start
[i
]->value
.integer
),
4268 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4270 gfc_warning ("Array reference at %L is out of bounds "
4271 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4272 mpz_get_si (ar
->start
[i
]->value
.integer
),
4273 mpz_get_si (as
->upper
[i
]->value
.integer
),
4282 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4283 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4285 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4287 /* Check for zero stride, which is not allowed. */
4288 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4290 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4294 /* if start == len || (stride > 0 && start < len)
4295 || (stride < 0 && start > len),
4296 then the array section contains at least one element. In this
4297 case, there is an out-of-bounds access if
4298 (start < lower || start > upper). */
4299 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4300 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4301 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4302 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4303 && comp_start_end
== CMP_GT
))
4305 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4307 gfc_warning ("Lower array reference at %L is out of bounds "
4308 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4309 mpz_get_si (AR_START
->value
.integer
),
4310 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4313 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4315 gfc_warning ("Lower array reference at %L is out of bounds "
4316 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4317 mpz_get_si (AR_START
->value
.integer
),
4318 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4323 /* If we can compute the highest index of the array section,
4324 then it also has to be between lower and upper. */
4325 mpz_init (last_value
);
4326 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4329 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4331 gfc_warning ("Upper array reference at %L is out of bounds "
4332 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4333 mpz_get_si (last_value
),
4334 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4335 mpz_clear (last_value
);
4338 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4340 gfc_warning ("Upper array reference at %L is out of bounds "
4341 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4342 mpz_get_si (last_value
),
4343 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4344 mpz_clear (last_value
);
4348 mpz_clear (last_value
);
4356 gfc_internal_error ("check_dimension(): Bad array reference");
4363 /* Compare an array reference with an array specification. */
4366 compare_spec_to_ref (gfc_array_ref
*ar
)
4373 /* TODO: Full array sections are only allowed as actual parameters. */
4374 if (as
->type
== AS_ASSUMED_SIZE
4375 && (/*ar->type == AR_FULL
4376 ||*/ (ar
->type
== AR_SECTION
4377 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4379 gfc_error ("Rightmost upper bound of assumed size array section "
4380 "not specified at %L", &ar
->where
);
4384 if (ar
->type
== AR_FULL
)
4387 if (as
->rank
!= ar
->dimen
)
4389 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4390 &ar
->where
, ar
->dimen
, as
->rank
);
4394 /* ar->codimen == 0 is a local array. */
4395 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4397 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4398 &ar
->where
, ar
->codimen
, as
->corank
);
4402 for (i
= 0; i
< as
->rank
; i
++)
4403 if (check_dimension (i
, ar
, as
) == FAILURE
)
4406 /* Local access has no coarray spec. */
4407 if (ar
->codimen
!= 0)
4408 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4410 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4411 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4413 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4414 i
+ 1 - as
->rank
, &ar
->where
);
4417 if (check_dimension (i
, ar
, as
) == FAILURE
)
4425 /* Resolve one part of an array index. */
4428 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4429 int force_index_integer_kind
)
4436 if (gfc_resolve_expr (index
) == FAILURE
)
4439 if (check_scalar
&& index
->rank
!= 0)
4441 gfc_error ("Array index at %L must be scalar", &index
->where
);
4445 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4447 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4448 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4452 if (index
->ts
.type
== BT_REAL
)
4453 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
4454 &index
->where
) == FAILURE
)
4457 if ((index
->ts
.kind
!= gfc_index_integer_kind
4458 && force_index_integer_kind
)
4459 || index
->ts
.type
!= BT_INTEGER
)
4462 ts
.type
= BT_INTEGER
;
4463 ts
.kind
= gfc_index_integer_kind
;
4465 gfc_convert_type_warn (index
, &ts
, 2, 0);
4471 /* Resolve one part of an array index. */
4474 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4476 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4479 /* Resolve a dim argument to an intrinsic function. */
4482 gfc_resolve_dim_arg (gfc_expr
*dim
)
4487 if (gfc_resolve_expr (dim
) == FAILURE
)
4492 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4497 if (dim
->ts
.type
!= BT_INTEGER
)
4499 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4503 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4508 ts
.type
= BT_INTEGER
;
4509 ts
.kind
= gfc_index_integer_kind
;
4511 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4517 /* Given an expression that contains array references, update those array
4518 references to point to the right array specifications. While this is
4519 filled in during matching, this information is difficult to save and load
4520 in a module, so we take care of it here.
4522 The idea here is that the original array reference comes from the
4523 base symbol. We traverse the list of reference structures, setting
4524 the stored reference to references. Component references can
4525 provide an additional array specification. */
4528 find_array_spec (gfc_expr
*e
)
4534 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4535 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4537 as
= e
->symtree
->n
.sym
->as
;
4539 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4544 gfc_internal_error ("find_array_spec(): Missing spec");
4551 c
= ref
->u
.c
.component
;
4552 if (c
->attr
.dimension
)
4555 gfc_internal_error ("find_array_spec(): unused as(1)");
4566 gfc_internal_error ("find_array_spec(): unused as(2)");
4570 /* Resolve an array reference. */
4573 resolve_array_ref (gfc_array_ref
*ar
)
4575 int i
, check_scalar
;
4578 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4580 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4582 /* Do not force gfc_index_integer_kind for the start. We can
4583 do fine with any integer kind. This avoids temporary arrays
4584 created for indexing with a vector. */
4585 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4587 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4589 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4594 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4598 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4602 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4603 if (e
->expr_type
== EXPR_VARIABLE
4604 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4605 ar
->start
[i
] = gfc_get_parentheses (e
);
4609 gfc_error ("Array index at %L is an array of rank %d",
4610 &ar
->c_where
[i
], e
->rank
);
4614 /* Fill in the upper bound, which may be lower than the
4615 specified one for something like a(2:10:5), which is
4616 identical to a(2:7:5). Only relevant for strides not equal
4617 to one. Don't try a division by zero. */
4618 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4619 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4620 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4621 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4625 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4627 if (ar
->end
[i
] == NULL
)
4630 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4632 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4634 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4635 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4637 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4648 if (ar
->type
== AR_FULL
)
4650 if (ar
->as
->rank
== 0)
4651 ar
->type
= AR_ELEMENT
;
4653 /* Make sure array is the same as array(:,:), this way
4654 we don't need to special case all the time. */
4655 ar
->dimen
= ar
->as
->rank
;
4656 for (i
= 0; i
< ar
->dimen
; i
++)
4658 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4660 gcc_assert (ar
->start
[i
] == NULL
);
4661 gcc_assert (ar
->end
[i
] == NULL
);
4662 gcc_assert (ar
->stride
[i
] == NULL
);
4666 /* If the reference type is unknown, figure out what kind it is. */
4668 if (ar
->type
== AR_UNKNOWN
)
4670 ar
->type
= AR_ELEMENT
;
4671 for (i
= 0; i
< ar
->dimen
; i
++)
4672 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4673 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4675 ar
->type
= AR_SECTION
;
4680 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4683 if (ar
->as
->corank
&& ar
->codimen
== 0)
4686 ar
->codimen
= ar
->as
->corank
;
4687 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4688 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4696 resolve_substring (gfc_ref
*ref
)
4698 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4700 if (ref
->u
.ss
.start
!= NULL
)
4702 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4705 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4707 gfc_error ("Substring start index at %L must be of type INTEGER",
4708 &ref
->u
.ss
.start
->where
);
4712 if (ref
->u
.ss
.start
->rank
!= 0)
4714 gfc_error ("Substring start index at %L must be scalar",
4715 &ref
->u
.ss
.start
->where
);
4719 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4720 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4721 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4723 gfc_error ("Substring start index at %L is less than one",
4724 &ref
->u
.ss
.start
->where
);
4729 if (ref
->u
.ss
.end
!= NULL
)
4731 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4734 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4736 gfc_error ("Substring end index at %L must be of type INTEGER",
4737 &ref
->u
.ss
.end
->where
);
4741 if (ref
->u
.ss
.end
->rank
!= 0)
4743 gfc_error ("Substring end index at %L must be scalar",
4744 &ref
->u
.ss
.end
->where
);
4748 if (ref
->u
.ss
.length
!= NULL
4749 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4750 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4751 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4753 gfc_error ("Substring end index at %L exceeds the string length",
4754 &ref
->u
.ss
.start
->where
);
4758 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4759 gfc_integer_kinds
[k
].huge
) == CMP_GT
4760 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4761 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4763 gfc_error ("Substring end index at %L is too large",
4764 &ref
->u
.ss
.end
->where
);
4773 /* This function supplies missing substring charlens. */
4776 gfc_resolve_substring_charlen (gfc_expr
*e
)
4779 gfc_expr
*start
, *end
;
4781 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4782 if (char_ref
->type
== REF_SUBSTRING
)
4788 gcc_assert (char_ref
->next
== NULL
);
4792 if (e
->ts
.u
.cl
->length
)
4793 gfc_free_expr (e
->ts
.u
.cl
->length
);
4794 else if (e
->expr_type
== EXPR_VARIABLE
4795 && e
->symtree
->n
.sym
->attr
.dummy
)
4799 e
->ts
.type
= BT_CHARACTER
;
4800 e
->ts
.kind
= gfc_default_character_kind
;
4803 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4805 if (char_ref
->u
.ss
.start
)
4806 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4808 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4810 if (char_ref
->u
.ss
.end
)
4811 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4812 else if (e
->expr_type
== EXPR_VARIABLE
)
4813 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4820 /* Length = (end - start +1). */
4821 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4822 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4823 gfc_get_int_expr (gfc_default_integer_kind
,
4826 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4827 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4829 /* Make sure that the length is simplified. */
4830 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4831 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4835 /* Resolve subtype references. */
4838 resolve_ref (gfc_expr
*expr
)
4840 int current_part_dimension
, n_components
, seen_part_dimension
;
4843 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4844 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4846 find_array_spec (expr
);
4850 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4854 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
4862 if (resolve_substring (ref
) == FAILURE
)
4867 /* Check constraints on part references. */
4869 current_part_dimension
= 0;
4870 seen_part_dimension
= 0;
4873 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4878 switch (ref
->u
.ar
.type
)
4881 /* Coarray scalar. */
4882 if (ref
->u
.ar
.as
->rank
== 0)
4884 current_part_dimension
= 0;
4889 current_part_dimension
= 1;
4893 current_part_dimension
= 0;
4897 gfc_internal_error ("resolve_ref(): Bad array reference");
4903 if (current_part_dimension
|| seen_part_dimension
)
4906 if (ref
->u
.c
.component
->attr
.pointer
4907 || ref
->u
.c
.component
->attr
.proc_pointer
)
4909 gfc_error ("Component to the right of a part reference "
4910 "with nonzero rank must not have the POINTER "
4911 "attribute at %L", &expr
->where
);
4914 else if (ref
->u
.c
.component
->attr
.allocatable
)
4916 gfc_error ("Component to the right of a part reference "
4917 "with nonzero rank must not have the ALLOCATABLE "
4918 "attribute at %L", &expr
->where
);
4930 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4931 || ref
->next
== NULL
)
4932 && current_part_dimension
4933 && seen_part_dimension
)
4935 gfc_error ("Two or more part references with nonzero rank must "
4936 "not be specified at %L", &expr
->where
);
4940 if (ref
->type
== REF_COMPONENT
)
4942 if (current_part_dimension
)
4943 seen_part_dimension
= 1;
4945 /* reset to make sure */
4946 current_part_dimension
= 0;
4954 /* Given an expression, determine its shape. This is easier than it sounds.
4955 Leaves the shape array NULL if it is not possible to determine the shape. */
4958 expression_shape (gfc_expr
*e
)
4960 mpz_t array
[GFC_MAX_DIMENSIONS
];
4963 if (e
->rank
== 0 || e
->shape
!= NULL
)
4966 for (i
= 0; i
< e
->rank
; i
++)
4967 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4970 e
->shape
= gfc_get_shape (e
->rank
);
4972 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4977 for (i
--; i
>= 0; i
--)
4978 mpz_clear (array
[i
]);
4982 /* Given a variable expression node, compute the rank of the expression by
4983 examining the base symbol and any reference structures it may have. */
4986 expression_rank (gfc_expr
*e
)
4991 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4992 could lead to serious confusion... */
4993 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4997 if (e
->expr_type
== EXPR_ARRAY
)
4999 /* Constructors can have a rank different from one via RESHAPE(). */
5001 if (e
->symtree
== NULL
)
5007 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5008 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5014 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5016 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5017 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5018 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5020 if (ref
->type
!= REF_ARRAY
)
5023 if (ref
->u
.ar
.type
== AR_FULL
)
5025 rank
= ref
->u
.ar
.as
->rank
;
5029 if (ref
->u
.ar
.type
== AR_SECTION
)
5031 /* Figure out the rank of the section. */
5033 gfc_internal_error ("expression_rank(): Two array specs");
5035 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5036 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5037 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5047 expression_shape (e
);
5051 /* Resolve a variable expression. */
5054 resolve_variable (gfc_expr
*e
)
5061 if (e
->symtree
== NULL
)
5063 sym
= e
->symtree
->n
.sym
;
5065 /* TS 29113, 407b. */
5066 if (e
->ts
.type
== BT_ASSUMED
&& !assumed_type_expr_allowed
)
5068 gfc_error ("Invalid expression with assumed-type variable %s at %L",
5069 sym
->name
, &e
->where
);
5073 /* TS 29113, 407b. */
5074 if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5075 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5076 && e
->ref
->next
== NULL
))
5078 gfc_error ("Assumed-type variable %s with designator at %L",
5079 sym
->name
, &e
->ref
->u
.ar
.where
);
5083 /* If this is an associate-name, it may be parsed with an array reference
5084 in error even though the target is scalar. Fail directly in this case. */
5085 if (sym
->assoc
&& !sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5088 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5089 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5091 /* On the other hand, the parser may not have known this is an array;
5092 in this case, we have to add a FULL reference. */
5093 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5095 e
->ref
= gfc_get_ref ();
5096 e
->ref
->type
= REF_ARRAY
;
5097 e
->ref
->u
.ar
.type
= AR_FULL
;
5098 e
->ref
->u
.ar
.dimen
= 0;
5101 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
5104 if (sym
->attr
.flavor
== FL_PROCEDURE
5105 && (!sym
->attr
.function
5106 || (sym
->attr
.function
&& sym
->result
5107 && sym
->result
->attr
.proc_pointer
5108 && !sym
->result
->attr
.function
)))
5110 e
->ts
.type
= BT_PROCEDURE
;
5111 goto resolve_procedure
;
5114 if (sym
->ts
.type
!= BT_UNKNOWN
)
5115 gfc_variable_attr (e
, &e
->ts
);
5118 /* Must be a simple variable reference. */
5119 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5124 if (check_assumed_size_reference (sym
, e
))
5127 /* Deal with forward references to entries during resolve_code, to
5128 satisfy, at least partially, 12.5.2.5. */
5129 if (gfc_current_ns
->entries
5130 && current_entry_id
== sym
->entry_id
5133 && cs_base
->current
->op
!= EXEC_ENTRY
)
5135 gfc_entry_list
*entry
;
5136 gfc_formal_arglist
*formal
;
5140 /* If the symbol is a dummy... */
5141 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5143 entry
= gfc_current_ns
->entries
;
5146 /* ...test if the symbol is a parameter of previous entries. */
5147 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5148 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5150 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5154 /* If it has not been seen as a dummy, this is an error. */
5157 if (specification_expr
)
5158 gfc_error ("Variable '%s', used in a specification expression"
5159 ", is referenced at %L before the ENTRY statement "
5160 "in which it is a parameter",
5161 sym
->name
, &cs_base
->current
->loc
);
5163 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5164 "statement in which it is a parameter",
5165 sym
->name
, &cs_base
->current
->loc
);
5170 /* Now do the same check on the specification expressions. */
5171 specification_expr
= 1;
5172 if (sym
->ts
.type
== BT_CHARACTER
5173 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5177 for (n
= 0; n
< sym
->as
->rank
; n
++)
5179 specification_expr
= 1;
5180 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5182 specification_expr
= 1;
5183 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5186 specification_expr
= 0;
5189 /* Update the symbol's entry level. */
5190 sym
->entry_id
= current_entry_id
+ 1;
5193 /* If a symbol has been host_associated mark it. This is used latter,
5194 to identify if aliasing is possible via host association. */
5195 if (sym
->attr
.flavor
== FL_VARIABLE
5196 && gfc_current_ns
->parent
5197 && (gfc_current_ns
->parent
== sym
->ns
5198 || (gfc_current_ns
->parent
->parent
5199 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5200 sym
->attr
.host_assoc
= 1;
5203 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5206 /* F2008, C617 and C1229. */
5207 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5208 && gfc_is_coindexed (e
))
5210 gfc_ref
*ref
, *ref2
= NULL
;
5212 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5214 if (ref
->type
== REF_COMPONENT
)
5216 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5220 for ( ; ref
; ref
= ref
->next
)
5221 if (ref
->type
== REF_COMPONENT
)
5224 /* Expression itself is not coindexed object. */
5225 if (ref
&& e
->ts
.type
== BT_CLASS
)
5227 gfc_error ("Polymorphic subobject of coindexed object at %L",
5232 /* Expression itself is coindexed object. */
5236 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5237 for ( ; c
; c
= c
->next
)
5238 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5240 gfc_error ("Coindexed object with polymorphic allocatable "
5241 "subcomponent at %L", &e
->where
);
5252 /* Checks to see that the correct symbol has been host associated.
5253 The only situation where this arises is that in which a twice
5254 contained function is parsed after the host association is made.
5255 Therefore, on detecting this, change the symbol in the expression
5256 and convert the array reference into an actual arglist if the old
5257 symbol is a variable. */
5259 check_host_association (gfc_expr
*e
)
5261 gfc_symbol
*sym
, *old_sym
;
5265 gfc_actual_arglist
*arg
, *tail
= NULL
;
5266 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5268 /* If the expression is the result of substitution in
5269 interface.c(gfc_extend_expr) because there is no way in
5270 which the host association can be wrong. */
5271 if (e
->symtree
== NULL
5272 || e
->symtree
->n
.sym
== NULL
5273 || e
->user_operator
)
5276 old_sym
= e
->symtree
->n
.sym
;
5278 if (gfc_current_ns
->parent
5279 && old_sym
->ns
!= gfc_current_ns
)
5281 /* Use the 'USE' name so that renamed module symbols are
5282 correctly handled. */
5283 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5285 if (sym
&& old_sym
!= sym
5286 && sym
->ts
.type
== old_sym
->ts
.type
5287 && sym
->attr
.flavor
== FL_PROCEDURE
5288 && sym
->attr
.contained
)
5290 /* Clear the shape, since it might not be valid. */
5291 gfc_free_shape (&e
->shape
, e
->rank
);
5293 /* Give the expression the right symtree! */
5294 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5295 gcc_assert (st
!= NULL
);
5297 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5298 || e
->expr_type
== EXPR_FUNCTION
)
5300 /* Original was function so point to the new symbol, since
5301 the actual argument list is already attached to the
5303 e
->value
.function
.esym
= NULL
;
5308 /* Original was variable so convert array references into
5309 an actual arglist. This does not need any checking now
5310 since resolve_function will take care of it. */
5311 e
->value
.function
.actual
= NULL
;
5312 e
->expr_type
= EXPR_FUNCTION
;
5315 /* Ambiguity will not arise if the array reference is not
5316 the last reference. */
5317 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5318 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5321 gcc_assert (ref
->type
== REF_ARRAY
);
5323 /* Grab the start expressions from the array ref and
5324 copy them into actual arguments. */
5325 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5327 arg
= gfc_get_actual_arglist ();
5328 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5329 if (e
->value
.function
.actual
== NULL
)
5330 tail
= e
->value
.function
.actual
= arg
;
5338 /* Dump the reference list and set the rank. */
5339 gfc_free_ref_list (e
->ref
);
5341 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5344 gfc_resolve_expr (e
);
5348 /* This might have changed! */
5349 return e
->expr_type
== EXPR_FUNCTION
;
5354 gfc_resolve_character_operator (gfc_expr
*e
)
5356 gfc_expr
*op1
= e
->value
.op
.op1
;
5357 gfc_expr
*op2
= e
->value
.op
.op2
;
5358 gfc_expr
*e1
= NULL
;
5359 gfc_expr
*e2
= NULL
;
5361 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5363 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5364 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5365 else if (op1
->expr_type
== EXPR_CONSTANT
)
5366 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5367 op1
->value
.character
.length
);
5369 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5370 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5371 else if (op2
->expr_type
== EXPR_CONSTANT
)
5372 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5373 op2
->value
.character
.length
);
5375 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5380 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5381 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5382 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5383 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5384 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5390 /* Ensure that an character expression has a charlen and, if possible, a
5391 length expression. */
5394 fixup_charlen (gfc_expr
*e
)
5396 /* The cases fall through so that changes in expression type and the need
5397 for multiple fixes are picked up. In all circumstances, a charlen should
5398 be available for the middle end to hang a backend_decl on. */
5399 switch (e
->expr_type
)
5402 gfc_resolve_character_operator (e
);
5405 if (e
->expr_type
== EXPR_ARRAY
)
5406 gfc_resolve_character_array_constructor (e
);
5408 case EXPR_SUBSTRING
:
5409 if (!e
->ts
.u
.cl
&& e
->ref
)
5410 gfc_resolve_substring_charlen (e
);
5414 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5421 /* Update an actual argument to include the passed-object for type-bound
5422 procedures at the right position. */
5424 static gfc_actual_arglist
*
5425 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5428 gcc_assert (argpos
> 0);
5432 gfc_actual_arglist
* result
;
5434 result
= gfc_get_actual_arglist ();
5438 result
->name
= name
;
5444 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5446 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5451 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5454 extract_compcall_passed_object (gfc_expr
* e
)
5458 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5460 if (e
->value
.compcall
.base_object
)
5461 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5464 po
= gfc_get_expr ();
5465 po
->expr_type
= EXPR_VARIABLE
;
5466 po
->symtree
= e
->symtree
;
5467 po
->ref
= gfc_copy_ref (e
->ref
);
5468 po
->where
= e
->where
;
5471 if (gfc_resolve_expr (po
) == FAILURE
)
5478 /* Update the arglist of an EXPR_COMPCALL expression to include the
5482 update_compcall_arglist (gfc_expr
* e
)
5485 gfc_typebound_proc
* tbp
;
5487 tbp
= e
->value
.compcall
.tbp
;
5492 po
= extract_compcall_passed_object (e
);
5496 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5502 gcc_assert (tbp
->pass_arg_num
> 0);
5503 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5511 /* Extract the passed object from a PPC call (a copy of it). */
5514 extract_ppc_passed_object (gfc_expr
*e
)
5519 po
= gfc_get_expr ();
5520 po
->expr_type
= EXPR_VARIABLE
;
5521 po
->symtree
= e
->symtree
;
5522 po
->ref
= gfc_copy_ref (e
->ref
);
5523 po
->where
= e
->where
;
5525 /* Remove PPC reference. */
5527 while ((*ref
)->next
)
5528 ref
= &(*ref
)->next
;
5529 gfc_free_ref_list (*ref
);
5532 if (gfc_resolve_expr (po
) == FAILURE
)
5539 /* Update the actual arglist of a procedure pointer component to include the
5543 update_ppc_arglist (gfc_expr
* e
)
5547 gfc_typebound_proc
* tb
;
5549 if (!gfc_is_proc_ptr_comp (e
, &ppc
))
5556 else if (tb
->nopass
)
5559 po
= extract_ppc_passed_object (e
);
5566 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5571 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5573 gfc_error ("Base object for procedure-pointer component call at %L is of"
5574 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5578 gcc_assert (tb
->pass_arg_num
> 0);
5579 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5587 /* Check that the object a TBP is called on is valid, i.e. it must not be
5588 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5591 check_typebound_baseobject (gfc_expr
* e
)
5594 gfc_try return_value
= FAILURE
;
5596 base
= extract_compcall_passed_object (e
);
5600 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5603 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5605 gfc_error ("Base object for type-bound procedure call at %L is of"
5606 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5610 /* F08:C1230. If the procedure called is NOPASS,
5611 the base object must be scalar. */
5612 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
> 0)
5614 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5615 " be scalar", &e
->where
);
5619 return_value
= SUCCESS
;
5622 gfc_free_expr (base
);
5623 return return_value
;
5627 /* Resolve a call to a type-bound procedure, either function or subroutine,
5628 statically from the data in an EXPR_COMPCALL expression. The adapted
5629 arglist and the target-procedure symtree are returned. */
5632 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5633 gfc_actual_arglist
** actual
)
5635 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5636 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5638 /* Update the actual arglist for PASS. */
5639 if (update_compcall_arglist (e
) == FAILURE
)
5642 *actual
= e
->value
.compcall
.actual
;
5643 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5645 gfc_free_ref_list (e
->ref
);
5647 e
->value
.compcall
.actual
= NULL
;
5649 /* If we find a deferred typebound procedure, check for derived types
5650 that an over-riding typebound procedure has not been missed. */
5651 if (e
->value
.compcall
.tbp
->deferred
5652 && e
->value
.compcall
.name
5653 && !e
->value
.compcall
.tbp
->non_overridable
5654 && e
->value
.compcall
.base_object
5655 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5658 gfc_symbol
*derived
;
5660 /* Use the derived type of the base_object. */
5661 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5664 /* If necessary, go throught the inheritance chain. */
5665 while (!st
&& derived
)
5667 /* Look for the typebound procedure 'name'. */
5668 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5669 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5670 e
->value
.compcall
.name
);
5672 derived
= gfc_get_derived_super_type (derived
);
5675 /* Now find the specific name in the derived type namespace. */
5676 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5677 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5678 derived
->ns
, 1, &st
);
5686 /* Get the ultimate declared type from an expression. In addition,
5687 return the last class/derived type reference and the copy of the
5688 reference list. If check_types is set true, derived types are
5689 identified as well as class references. */
5691 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5692 gfc_expr
*e
, bool check_types
)
5694 gfc_symbol
*declared
;
5701 *new_ref
= gfc_copy_ref (e
->ref
);
5703 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5705 if (ref
->type
!= REF_COMPONENT
)
5708 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5709 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5710 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5712 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5718 if (declared
== NULL
)
5719 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5725 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5726 which of the specific bindings (if any) matches the arglist and transform
5727 the expression into a call of that binding. */
5730 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5732 gfc_typebound_proc
* genproc
;
5733 const char* genname
;
5735 gfc_symbol
*derived
;
5737 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5738 genname
= e
->value
.compcall
.name
;
5739 genproc
= e
->value
.compcall
.tbp
;
5741 if (!genproc
->is_generic
)
5744 /* Try the bindings on this type and in the inheritance hierarchy. */
5745 for (; genproc
; genproc
= genproc
->overridden
)
5749 gcc_assert (genproc
->is_generic
);
5750 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5753 gfc_actual_arglist
* args
;
5756 gcc_assert (g
->specific
);
5758 if (g
->specific
->error
)
5761 target
= g
->specific
->u
.specific
->n
.sym
;
5763 /* Get the right arglist by handling PASS/NOPASS. */
5764 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5765 if (!g
->specific
->nopass
)
5768 po
= extract_compcall_passed_object (e
);
5772 gcc_assert (g
->specific
->pass_arg_num
> 0);
5773 gcc_assert (!g
->specific
->error
);
5774 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5775 g
->specific
->pass_arg
);
5777 resolve_actual_arglist (args
, target
->attr
.proc
,
5778 is_external_proc (target
) && !target
->formal
);
5780 /* Check if this arglist matches the formal. */
5781 matches
= gfc_arglist_matches_symbol (&args
, target
);
5783 /* Clean up and break out of the loop if we've found it. */
5784 gfc_free_actual_arglist (args
);
5787 e
->value
.compcall
.tbp
= g
->specific
;
5788 genname
= g
->specific_st
->name
;
5789 /* Pass along the name for CLASS methods, where the vtab
5790 procedure pointer component has to be referenced. */
5798 /* Nothing matching found! */
5799 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5800 " '%s' at %L", genname
, &e
->where
);
5804 /* Make sure that we have the right specific instance for the name. */
5805 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5807 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5809 e
->value
.compcall
.tbp
= st
->n
.tb
;
5815 /* Resolve a call to a type-bound subroutine. */
5818 resolve_typebound_call (gfc_code
* c
, const char **name
)
5820 gfc_actual_arglist
* newactual
;
5821 gfc_symtree
* target
;
5823 /* Check that's really a SUBROUTINE. */
5824 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5826 gfc_error ("'%s' at %L should be a SUBROUTINE",
5827 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5831 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
5834 /* Pass along the name for CLASS methods, where the vtab
5835 procedure pointer component has to be referenced. */
5837 *name
= c
->expr1
->value
.compcall
.name
;
5839 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
5842 /* Transform into an ordinary EXEC_CALL for now. */
5844 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
5847 c
->ext
.actual
= newactual
;
5848 c
->symtree
= target
;
5849 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5851 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5853 gfc_free_expr (c
->expr1
);
5854 c
->expr1
= gfc_get_expr ();
5855 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5856 c
->expr1
->symtree
= target
;
5857 c
->expr1
->where
= c
->loc
;
5859 return resolve_call (c
);
5863 /* Resolve a component-call expression. */
5865 resolve_compcall (gfc_expr
* e
, const char **name
)
5867 gfc_actual_arglist
* newactual
;
5868 gfc_symtree
* target
;
5870 /* Check that's really a FUNCTION. */
5871 if (!e
->value
.compcall
.tbp
->function
)
5873 gfc_error ("'%s' at %L should be a FUNCTION",
5874 e
->value
.compcall
.name
, &e
->where
);
5878 /* These must not be assign-calls! */
5879 gcc_assert (!e
->value
.compcall
.assign
);
5881 if (check_typebound_baseobject (e
) == FAILURE
)
5884 /* Pass along the name for CLASS methods, where the vtab
5885 procedure pointer component has to be referenced. */
5887 *name
= e
->value
.compcall
.name
;
5889 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
5891 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5893 /* Take the rank from the function's symbol. */
5894 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5895 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5897 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5898 arglist to the TBP's binding target. */
5900 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
5903 e
->value
.function
.actual
= newactual
;
5904 e
->value
.function
.name
= NULL
;
5905 e
->value
.function
.esym
= target
->n
.sym
;
5906 e
->value
.function
.isym
= NULL
;
5907 e
->symtree
= target
;
5908 e
->ts
= target
->n
.sym
->ts
;
5909 e
->expr_type
= EXPR_FUNCTION
;
5911 /* Resolution is not necessary if this is a class subroutine; this
5912 function only has to identify the specific proc. Resolution of
5913 the call will be done next in resolve_typebound_call. */
5914 return gfc_resolve_expr (e
);
5919 /* Resolve a typebound function, or 'method'. First separate all
5920 the non-CLASS references by calling resolve_compcall directly. */
5923 resolve_typebound_function (gfc_expr
* e
)
5925 gfc_symbol
*declared
;
5937 /* Deal with typebound operators for CLASS objects. */
5938 expr
= e
->value
.compcall
.base_object
;
5939 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5940 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5942 /* If the base_object is not a variable, the corresponding actual
5943 argument expression must be stored in e->base_expression so
5944 that the corresponding tree temporary can be used as the base
5945 object in gfc_conv_procedure_call. */
5946 if (expr
->expr_type
!= EXPR_VARIABLE
)
5948 gfc_actual_arglist
*args
;
5950 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5952 if (expr
== args
->expr
)
5957 /* Since the typebound operators are generic, we have to ensure
5958 that any delays in resolution are corrected and that the vtab
5961 declared
= ts
.u
.derived
;
5962 c
= gfc_find_component (declared
, "_vptr", true, true);
5963 if (c
->ts
.u
.derived
== NULL
)
5964 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5966 if (resolve_compcall (e
, &name
) == FAILURE
)
5969 /* Use the generic name if it is there. */
5970 name
= name
? name
: e
->value
.function
.esym
->name
;
5971 e
->symtree
= expr
->symtree
;
5972 e
->ref
= gfc_copy_ref (expr
->ref
);
5973 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5975 /* Trim away the extraneous references that emerge from nested
5976 use of interface.c (extend_expr). */
5977 if (class_ref
&& class_ref
->next
)
5979 gfc_free_ref_list (class_ref
->next
);
5980 class_ref
->next
= NULL
;
5982 else if (e
->ref
&& !class_ref
)
5984 gfc_free_ref_list (e
->ref
);
5988 gfc_add_vptr_component (e
);
5989 gfc_add_component_ref (e
, name
);
5990 e
->value
.function
.esym
= NULL
;
5991 if (expr
->expr_type
!= EXPR_VARIABLE
)
5992 e
->base_expr
= expr
;
5997 return resolve_compcall (e
, NULL
);
5999 if (resolve_ref (e
) == FAILURE
)
6002 /* Get the CLASS declared type. */
6003 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6005 /* Weed out cases of the ultimate component being a derived type. */
6006 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6007 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6009 gfc_free_ref_list (new_ref
);
6010 return resolve_compcall (e
, NULL
);
6013 c
= gfc_find_component (declared
, "_data", true, true);
6014 declared
= c
->ts
.u
.derived
;
6016 /* Treat the call as if it is a typebound procedure, in order to roll
6017 out the correct name for the specific function. */
6018 if (resolve_compcall (e
, &name
) == FAILURE
)
6024 /* Convert the expression to a procedure pointer component call. */
6025 e
->value
.function
.esym
= NULL
;
6031 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6032 gfc_add_vptr_component (e
);
6033 gfc_add_component_ref (e
, name
);
6035 /* Recover the typespec for the expression. This is really only
6036 necessary for generic procedures, where the additional call
6037 to gfc_add_component_ref seems to throw the collection of the
6038 correct typespec. */
6045 /* Resolve a typebound subroutine, or 'method'. First separate all
6046 the non-CLASS references by calling resolve_typebound_call
6050 resolve_typebound_subroutine (gfc_code
*code
)
6052 gfc_symbol
*declared
;
6062 st
= code
->expr1
->symtree
;
6064 /* Deal with typebound operators for CLASS objects. */
6065 expr
= code
->expr1
->value
.compcall
.base_object
;
6066 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6067 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6069 /* If the base_object is not a variable, the corresponding actual
6070 argument expression must be stored in e->base_expression so
6071 that the corresponding tree temporary can be used as the base
6072 object in gfc_conv_procedure_call. */
6073 if (expr
->expr_type
!= EXPR_VARIABLE
)
6075 gfc_actual_arglist
*args
;
6077 args
= code
->expr1
->value
.function
.actual
;
6078 for (; args
; args
= args
->next
)
6079 if (expr
== args
->expr
)
6083 /* Since the typebound operators are generic, we have to ensure
6084 that any delays in resolution are corrected and that the vtab
6086 declared
= expr
->ts
.u
.derived
;
6087 c
= gfc_find_component (declared
, "_vptr", true, true);
6088 if (c
->ts
.u
.derived
== NULL
)
6089 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6091 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6094 /* Use the generic name if it is there. */
6095 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6096 code
->expr1
->symtree
= expr
->symtree
;
6097 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6099 /* Trim away the extraneous references that emerge from nested
6100 use of interface.c (extend_expr). */
6101 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6102 if (class_ref
&& class_ref
->next
)
6104 gfc_free_ref_list (class_ref
->next
);
6105 class_ref
->next
= NULL
;
6107 else if (code
->expr1
->ref
&& !class_ref
)
6109 gfc_free_ref_list (code
->expr1
->ref
);
6110 code
->expr1
->ref
= NULL
;
6113 /* Now use the procedure in the vtable. */
6114 gfc_add_vptr_component (code
->expr1
);
6115 gfc_add_component_ref (code
->expr1
, name
);
6116 code
->expr1
->value
.function
.esym
= NULL
;
6117 if (expr
->expr_type
!= EXPR_VARIABLE
)
6118 code
->expr1
->base_expr
= expr
;
6123 return resolve_typebound_call (code
, NULL
);
6125 if (resolve_ref (code
->expr1
) == FAILURE
)
6128 /* Get the CLASS declared type. */
6129 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6131 /* Weed out cases of the ultimate component being a derived type. */
6132 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6133 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6135 gfc_free_ref_list (new_ref
);
6136 return resolve_typebound_call (code
, NULL
);
6139 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6141 ts
= code
->expr1
->ts
;
6145 /* Convert the expression to a procedure pointer component call. */
6146 code
->expr1
->value
.function
.esym
= NULL
;
6147 code
->expr1
->symtree
= st
;
6150 code
->expr1
->ref
= new_ref
;
6152 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6153 gfc_add_vptr_component (code
->expr1
);
6154 gfc_add_component_ref (code
->expr1
, name
);
6156 /* Recover the typespec for the expression. This is really only
6157 necessary for generic procedures, where the additional call
6158 to gfc_add_component_ref seems to throw the collection of the
6159 correct typespec. */
6160 code
->expr1
->ts
= ts
;
6167 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6170 resolve_ppc_call (gfc_code
* c
)
6172 gfc_component
*comp
;
6175 b
= gfc_is_proc_ptr_comp (c
->expr1
, &comp
);
6178 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6179 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6181 if (!comp
->attr
.subroutine
)
6182 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6184 if (resolve_ref (c
->expr1
) == FAILURE
)
6187 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6190 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6192 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6193 comp
->formal
== NULL
) == FAILURE
)
6196 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6202 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6205 resolve_expr_ppc (gfc_expr
* e
)
6207 gfc_component
*comp
;
6210 b
= gfc_is_proc_ptr_comp (e
, &comp
);
6213 /* Convert to EXPR_FUNCTION. */
6214 e
->expr_type
= EXPR_FUNCTION
;
6215 e
->value
.function
.isym
= NULL
;
6216 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6218 if (comp
->as
!= NULL
)
6219 e
->rank
= comp
->as
->rank
;
6221 if (!comp
->attr
.function
)
6222 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6224 if (resolve_ref (e
) == FAILURE
)
6227 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6228 comp
->formal
== NULL
) == FAILURE
)
6231 if (update_ppc_arglist (e
) == FAILURE
)
6234 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6241 gfc_is_expandable_expr (gfc_expr
*e
)
6243 gfc_constructor
*con
;
6245 if (e
->expr_type
== EXPR_ARRAY
)
6247 /* Traverse the constructor looking for variables that are flavor
6248 parameter. Parameters must be expanded since they are fully used at
6250 con
= gfc_constructor_first (e
->value
.constructor
);
6251 for (; con
; con
= gfc_constructor_next (con
))
6253 if (con
->expr
->expr_type
== EXPR_VARIABLE
6254 && con
->expr
->symtree
6255 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6256 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6258 if (con
->expr
->expr_type
== EXPR_ARRAY
6259 && gfc_is_expandable_expr (con
->expr
))
6267 /* Resolve an expression. That is, make sure that types of operands agree
6268 with their operators, intrinsic operators are converted to function calls
6269 for overloaded types and unresolved function references are resolved. */
6272 gfc_resolve_expr (gfc_expr
*e
)
6280 /* inquiry_argument only applies to variables. */
6281 inquiry_save
= inquiry_argument
;
6282 if (e
->expr_type
!= EXPR_VARIABLE
)
6283 inquiry_argument
= false;
6285 switch (e
->expr_type
)
6288 t
= resolve_operator (e
);
6294 if (check_host_association (e
))
6295 t
= resolve_function (e
);
6298 t
= resolve_variable (e
);
6300 expression_rank (e
);
6303 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6304 && e
->ref
->type
!= REF_SUBSTRING
)
6305 gfc_resolve_substring_charlen (e
);
6310 t
= resolve_typebound_function (e
);
6313 case EXPR_SUBSTRING
:
6314 t
= resolve_ref (e
);
6323 t
= resolve_expr_ppc (e
);
6328 if (resolve_ref (e
) == FAILURE
)
6331 t
= gfc_resolve_array_constructor (e
);
6332 /* Also try to expand a constructor. */
6335 expression_rank (e
);
6336 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6337 gfc_expand_constructor (e
, false);
6340 /* This provides the opportunity for the length of constructors with
6341 character valued function elements to propagate the string length
6342 to the expression. */
6343 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6345 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6346 here rather then add a duplicate test for it above. */
6347 gfc_expand_constructor (e
, false);
6348 t
= gfc_resolve_character_array_constructor (e
);
6353 case EXPR_STRUCTURE
:
6354 t
= resolve_ref (e
);
6358 t
= resolve_structure_cons (e
, 0);
6362 t
= gfc_simplify_expr (e
, 0);
6366 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6369 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6372 inquiry_argument
= inquiry_save
;
6378 /* Resolve an expression from an iterator. They must be scalar and have
6379 INTEGER or (optionally) REAL type. */
6382 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6383 const char *name_msgid
)
6385 if (gfc_resolve_expr (expr
) == FAILURE
)
6388 if (expr
->rank
!= 0)
6390 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6394 if (expr
->ts
.type
!= BT_INTEGER
)
6396 if (expr
->ts
.type
== BT_REAL
)
6399 return gfc_notify_std (GFC_STD_F95_DEL
,
6400 "Deleted feature: %s at %L must be integer",
6401 _(name_msgid
), &expr
->where
);
6404 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6411 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6419 /* Resolve the expressions in an iterator structure. If REAL_OK is
6420 false allow only INTEGER type iterators, otherwise allow REAL types. */
6423 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6425 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6429 if (gfc_check_vardef_context (iter
->var
, false, false, _("iterator variable"))
6433 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6434 "Start expression in DO loop") == FAILURE
)
6437 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6438 "End expression in DO loop") == FAILURE
)
6441 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6442 "Step expression in DO loop") == FAILURE
)
6445 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6447 if ((iter
->step
->ts
.type
== BT_INTEGER
6448 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6449 || (iter
->step
->ts
.type
== BT_REAL
6450 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6452 gfc_error ("Step expression in DO loop at %L cannot be zero",
6453 &iter
->step
->where
);
6458 /* Convert start, end, and step to the same type as var. */
6459 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6460 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6461 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6463 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6464 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6465 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6467 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6468 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6469 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6471 if (iter
->start
->expr_type
== EXPR_CONSTANT
6472 && iter
->end
->expr_type
== EXPR_CONSTANT
6473 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6476 if (iter
->start
->ts
.type
== BT_INTEGER
)
6478 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6479 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6483 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6484 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6486 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6487 gfc_warning ("DO loop at %L will be executed zero times",
6488 &iter
->step
->where
);
6495 /* Traversal function for find_forall_index. f == 2 signals that
6496 that variable itself is not to be checked - only the references. */
6499 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6501 if (expr
->expr_type
!= EXPR_VARIABLE
)
6504 /* A scalar assignment */
6505 if (!expr
->ref
|| *f
== 1)
6507 if (expr
->symtree
->n
.sym
== sym
)
6519 /* Check whether the FORALL index appears in the expression or not.
6520 Returns SUCCESS if SYM is found in EXPR. */
6523 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6525 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6532 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6533 to be a scalar INTEGER variable. The subscripts and stride are scalar
6534 INTEGERs, and if stride is a constant it must be nonzero.
6535 Furthermore "A subscript or stride in a forall-triplet-spec shall
6536 not contain a reference to any index-name in the
6537 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6540 resolve_forall_iterators (gfc_forall_iterator
*it
)
6542 gfc_forall_iterator
*iter
, *iter2
;
6544 for (iter
= it
; iter
; iter
= iter
->next
)
6546 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6547 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6548 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6551 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6552 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6553 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6554 &iter
->start
->where
);
6555 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6556 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6558 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6559 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6560 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6562 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6563 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6565 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6567 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6568 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6569 &iter
->stride
->where
, "INTEGER");
6571 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6572 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6573 gfc_error ("FORALL stride expression at %L cannot be zero",
6574 &iter
->stride
->where
);
6576 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6577 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6580 for (iter
= it
; iter
; iter
= iter
->next
)
6581 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6583 if (find_forall_index (iter2
->start
,
6584 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6585 || find_forall_index (iter2
->end
,
6586 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6587 || find_forall_index (iter2
->stride
,
6588 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6589 gfc_error ("FORALL index '%s' may not appear in triplet "
6590 "specification at %L", iter
->var
->symtree
->name
,
6591 &iter2
->start
->where
);
6596 /* Given a pointer to a symbol that is a derived type, see if it's
6597 inaccessible, i.e. if it's defined in another module and the components are
6598 PRIVATE. The search is recursive if necessary. Returns zero if no
6599 inaccessible components are found, nonzero otherwise. */
6602 derived_inaccessible (gfc_symbol
*sym
)
6606 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6609 for (c
= sym
->components
; c
; c
= c
->next
)
6611 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6619 /* Resolve the argument of a deallocate expression. The expression must be
6620 a pointer or a full array. */
6623 resolve_deallocate_expr (gfc_expr
*e
)
6625 symbol_attribute attr
;
6626 int allocatable
, pointer
;
6631 if (gfc_resolve_expr (e
) == FAILURE
)
6634 if (e
->expr_type
!= EXPR_VARIABLE
)
6637 sym
= e
->symtree
->n
.sym
;
6639 if (sym
->ts
.type
== BT_CLASS
)
6641 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6642 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6646 allocatable
= sym
->attr
.allocatable
;
6647 pointer
= sym
->attr
.pointer
;
6649 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6654 if (ref
->u
.ar
.type
!= AR_FULL
6655 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6656 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6661 c
= ref
->u
.c
.component
;
6662 if (c
->ts
.type
== BT_CLASS
)
6664 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6665 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6669 allocatable
= c
->attr
.allocatable
;
6670 pointer
= c
->attr
.pointer
;
6680 attr
= gfc_expr_attr (e
);
6682 if (allocatable
== 0 && attr
.pointer
== 0)
6685 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6691 if (gfc_is_coindexed (e
))
6693 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6698 && gfc_check_vardef_context (e
, true, true, _("DEALLOCATE object"))
6701 if (gfc_check_vardef_context (e
, false, true, _("DEALLOCATE object"))
6709 /* Returns true if the expression e contains a reference to the symbol sym. */
6711 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6713 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6720 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6722 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6726 /* Given the expression node e for an allocatable/pointer of derived type to be
6727 allocated, get the expression node to be initialized afterwards (needed for
6728 derived types with default initializers, and derived types with allocatable
6729 components that need nullification.) */
6732 gfc_expr_to_initialize (gfc_expr
*e
)
6738 result
= gfc_copy_expr (e
);
6740 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6741 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6742 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6744 ref
->u
.ar
.type
= AR_FULL
;
6746 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6747 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6752 gfc_free_shape (&result
->shape
, result
->rank
);
6754 /* Recalculate rank, shape, etc. */
6755 gfc_resolve_expr (result
);
6760 /* If the last ref of an expression is an array ref, return a copy of the
6761 expression with that one removed. Otherwise, a copy of the original
6762 expression. This is used for allocate-expressions and pointer assignment
6763 LHS, where there may be an array specification that needs to be stripped
6764 off when using gfc_check_vardef_context. */
6767 remove_last_array_ref (gfc_expr
* e
)
6772 e2
= gfc_copy_expr (e
);
6773 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6774 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6776 gfc_free_ref_list (*r
);
6785 /* Used in resolve_allocate_expr to check that a allocation-object and
6786 a source-expr are conformable. This does not catch all possible
6787 cases; in particular a runtime checking is needed. */
6790 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6793 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6795 /* First compare rank. */
6796 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6798 gfc_error ("Source-expr at %L must be scalar or have the "
6799 "same rank as the allocate-object at %L",
6800 &e1
->where
, &e2
->where
);
6811 for (i
= 0; i
< e1
->rank
; i
++)
6813 if (tail
->u
.ar
.end
[i
])
6815 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6816 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6817 mpz_add_ui (s
, s
, 1);
6821 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6824 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6826 gfc_error ("Source-expr at %L and allocate-object at %L must "
6827 "have the same shape", &e1
->where
, &e2
->where
);
6840 /* Resolve the expression in an ALLOCATE statement, doing the additional
6841 checks to see whether the expression is OK or not. The expression must
6842 have a trailing array reference that gives the size of the array. */
6845 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6847 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6850 symbol_attribute attr
;
6851 gfc_ref
*ref
, *ref2
;
6854 gfc_symbol
*sym
= NULL
;
6859 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6860 checking of coarrays. */
6861 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6862 if (ref
->next
== NULL
)
6865 if (ref
&& ref
->type
== REF_ARRAY
)
6866 ref
->u
.ar
.in_allocate
= true;
6868 if (gfc_resolve_expr (e
) == FAILURE
)
6871 /* Make sure the expression is allocatable or a pointer. If it is
6872 pointer, the next-to-last reference must be a pointer. */
6876 sym
= e
->symtree
->n
.sym
;
6878 /* Check whether ultimate component is abstract and CLASS. */
6881 if (e
->expr_type
!= EXPR_VARIABLE
)
6884 attr
= gfc_expr_attr (e
);
6885 pointer
= attr
.pointer
;
6886 dimension
= attr
.dimension
;
6887 codimension
= attr
.codimension
;
6891 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6893 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6894 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6895 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6896 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6897 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6901 allocatable
= sym
->attr
.allocatable
;
6902 pointer
= sym
->attr
.pointer
;
6903 dimension
= sym
->attr
.dimension
;
6904 codimension
= sym
->attr
.codimension
;
6909 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6914 if (ref
->u
.ar
.codimen
> 0)
6917 for (n
= ref
->u
.ar
.dimen
;
6918 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6919 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6926 if (ref
->next
!= NULL
)
6934 gfc_error ("Coindexed allocatable object at %L",
6939 c
= ref
->u
.c
.component
;
6940 if (c
->ts
.type
== BT_CLASS
)
6942 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6943 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6944 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6945 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6946 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6950 allocatable
= c
->attr
.allocatable
;
6951 pointer
= c
->attr
.pointer
;
6952 dimension
= c
->attr
.dimension
;
6953 codimension
= c
->attr
.codimension
;
6954 is_abstract
= c
->attr
.abstract
;
6966 if (allocatable
== 0 && pointer
== 0)
6968 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6973 /* Some checks for the SOURCE tag. */
6976 /* Check F03:C631. */
6977 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6979 gfc_error ("Type of entity at %L is type incompatible with "
6980 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6984 /* Check F03:C632 and restriction following Note 6.18. */
6985 if (code
->expr3
->rank
> 0
6986 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
6989 /* Check F03:C633. */
6990 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
6992 gfc_error ("The allocate-object at %L and the source-expr at %L "
6993 "shall have the same kind type parameter",
6994 &e
->where
, &code
->expr3
->where
);
6998 /* Check F2008, C642. */
6999 if (code
->expr3
->ts
.type
== BT_DERIVED
7000 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7001 || (code
->expr3
->ts
.u
.derived
->from_intmod
7002 == INTMOD_ISO_FORTRAN_ENV
7003 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7004 == ISOFORTRAN_LOCK_TYPE
)))
7006 gfc_error ("The source-expr at %L shall neither be of type "
7007 "LOCK_TYPE nor have a LOCK_TYPE component if "
7008 "allocate-object at %L is a coarray",
7009 &code
->expr3
->where
, &e
->where
);
7014 /* Check F08:C629. */
7015 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7018 gcc_assert (e
->ts
.type
== BT_CLASS
);
7019 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7020 "type-spec or source-expr", sym
->name
, &e
->where
);
7024 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
7026 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7027 code
->ext
.alloc
.ts
.u
.cl
->length
);
7028 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7030 gfc_error ("Allocating %s at %L with type-spec requires the same "
7031 "character-length parameter as in the declaration",
7032 sym
->name
, &e
->where
);
7037 /* In the variable definition context checks, gfc_expr_attr is used
7038 on the expression. This is fooled by the array specification
7039 present in e, thus we have to eliminate that one temporarily. */
7040 e2
= remove_last_array_ref (e
);
7042 if (t
== SUCCESS
&& pointer
)
7043 t
= gfc_check_vardef_context (e2
, true, true, _("ALLOCATE object"));
7045 t
= gfc_check_vardef_context (e2
, false, true, _("ALLOCATE object"));
7050 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7051 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7053 /* For class arrays, the initialization with SOURCE is done
7054 using _copy and trans_call. It is convenient to exploit that
7055 when the allocated type is different from the declared type but
7056 no SOURCE exists by setting expr3. */
7057 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7059 else if (!code
->expr3
)
7061 /* Set up default initializer if needed. */
7065 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7066 ts
= code
->ext
.alloc
.ts
;
7070 if (ts
.type
== BT_CLASS
)
7071 ts
= ts
.u
.derived
->components
->ts
;
7073 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7075 gfc_code
*init_st
= gfc_get_code ();
7076 init_st
->loc
= code
->loc
;
7077 init_st
->op
= EXEC_INIT_ASSIGN
;
7078 init_st
->expr1
= gfc_expr_to_initialize (e
);
7079 init_st
->expr2
= init_e
;
7080 init_st
->next
= code
->next
;
7081 code
->next
= init_st
;
7084 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7086 /* Default initialization via MOLD (non-polymorphic). */
7087 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7088 gfc_resolve_expr (rhs
);
7089 gfc_free_expr (code
->expr3
);
7093 if (e
->ts
.type
== BT_CLASS
)
7095 /* Make sure the vtab symbol is present when
7096 the module variables are generated. */
7097 gfc_typespec ts
= e
->ts
;
7099 ts
= code
->expr3
->ts
;
7100 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7101 ts
= code
->ext
.alloc
.ts
;
7102 gfc_find_derived_vtab (ts
.u
.derived
);
7104 e
= gfc_expr_to_initialize (e
);
7107 if (dimension
== 0 && codimension
== 0)
7110 /* Make sure the last reference node is an array specifiction. */
7112 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7113 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7115 gfc_error ("Array specification required in ALLOCATE statement "
7116 "at %L", &e
->where
);
7120 /* Make sure that the array section reference makes sense in the
7121 context of an ALLOCATE specification. */
7126 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7127 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7129 gfc_error ("Coarray specification required in ALLOCATE statement "
7130 "at %L", &e
->where
);
7134 for (i
= 0; i
< ar
->dimen
; i
++)
7136 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7139 switch (ar
->dimen_type
[i
])
7145 if (ar
->start
[i
] != NULL
7146 && ar
->end
[i
] != NULL
7147 && ar
->stride
[i
] == NULL
)
7150 /* Fall Through... */
7155 case DIMEN_THIS_IMAGE
:
7156 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7162 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7164 sym
= a
->expr
->symtree
->n
.sym
;
7166 /* TODO - check derived type components. */
7167 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7170 if ((ar
->start
[i
] != NULL
7171 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7172 || (ar
->end
[i
] != NULL
7173 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7175 gfc_error ("'%s' must not appear in the array specification at "
7176 "%L in the same ALLOCATE statement where it is "
7177 "itself allocated", sym
->name
, &ar
->where
);
7183 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7185 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7186 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7188 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7190 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7191 "statement at %L", &e
->where
);
7197 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7198 && ar
->stride
[i
] == NULL
)
7201 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7214 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7216 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7217 gfc_alloc
*a
, *p
, *q
;
7220 errmsg
= code
->expr2
;
7222 /* Check the stat variable. */
7225 gfc_check_vardef_context (stat
, false, false, _("STAT variable"));
7227 if ((stat
->ts
.type
!= BT_INTEGER
7228 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7229 || stat
->ref
->type
== REF_COMPONENT
)))
7231 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7232 "variable", &stat
->where
);
7234 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7235 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7237 gfc_ref
*ref1
, *ref2
;
7240 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7241 ref1
= ref1
->next
, ref2
= ref2
->next
)
7243 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7245 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7254 gfc_error ("Stat-variable at %L shall not be %sd within "
7255 "the same %s statement", &stat
->where
, fcn
, fcn
);
7261 /* Check the errmsg variable. */
7265 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7268 gfc_check_vardef_context (errmsg
, false, false, _("ERRMSG variable"));
7270 if ((errmsg
->ts
.type
!= BT_CHARACTER
7272 && (errmsg
->ref
->type
== REF_ARRAY
7273 || errmsg
->ref
->type
== REF_COMPONENT
)))
7274 || errmsg
->rank
> 0 )
7275 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7276 "variable", &errmsg
->where
);
7278 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7279 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7281 gfc_ref
*ref1
, *ref2
;
7284 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7285 ref1
= ref1
->next
, ref2
= ref2
->next
)
7287 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7289 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7298 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7299 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7305 /* Check that an allocate-object appears only once in the statement.
7306 FIXME: Checking derived types is disabled. */
7307 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7310 for (q
= p
->next
; q
; q
= q
->next
)
7313 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7315 /* This is a potential collision. */
7316 gfc_ref
*pr
= pe
->ref
;
7317 gfc_ref
*qr
= qe
->ref
;
7319 /* Follow the references until
7320 a) They start to differ, in which case there is no error;
7321 you can deallocate a%b and a%c in a single statement
7322 b) Both of them stop, which is an error
7323 c) One of them stops, which is also an error. */
7326 if (pr
== NULL
&& qr
== NULL
)
7328 gfc_error ("Allocate-object at %L also appears at %L",
7329 &pe
->where
, &qe
->where
);
7332 else if (pr
!= NULL
&& qr
== NULL
)
7334 gfc_error ("Allocate-object at %L is subobject of"
7335 " object at %L", &pe
->where
, &qe
->where
);
7338 else if (pr
== NULL
&& qr
!= NULL
)
7340 gfc_error ("Allocate-object at %L is subobject of"
7341 " object at %L", &qe
->where
, &pe
->where
);
7344 /* Here, pr != NULL && qr != NULL */
7345 gcc_assert(pr
->type
== qr
->type
);
7346 if (pr
->type
== REF_ARRAY
)
7348 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7350 gcc_assert (qr
->type
== REF_ARRAY
);
7352 if (pr
->next
&& qr
->next
)
7354 gfc_array_ref
*par
= &(pr
->u
.ar
);
7355 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7356 if (gfc_dep_compare_expr (par
->start
[0],
7357 qar
->start
[0]) != 0)
7363 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7374 if (strcmp (fcn
, "ALLOCATE") == 0)
7376 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7377 resolve_allocate_expr (a
->expr
, code
);
7381 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7382 resolve_deallocate_expr (a
->expr
);
7387 /************ SELECT CASE resolution subroutines ************/
7389 /* Callback function for our mergesort variant. Determines interval
7390 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7391 op1 > op2. Assumes we're not dealing with the default case.
7392 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7393 There are nine situations to check. */
7396 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7400 if (op1
->low
== NULL
) /* op1 = (:L) */
7402 /* op2 = (:N), so overlap. */
7404 /* op2 = (M:) or (M:N), L < M */
7405 if (op2
->low
!= NULL
7406 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7409 else if (op1
->high
== NULL
) /* op1 = (K:) */
7411 /* op2 = (M:), so overlap. */
7413 /* op2 = (:N) or (M:N), K > N */
7414 if (op2
->high
!= NULL
7415 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7418 else /* op1 = (K:L) */
7420 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7421 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7423 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7424 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7426 else /* op2 = (M:N) */
7430 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7433 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7442 /* Merge-sort a double linked case list, detecting overlap in the
7443 process. LIST is the head of the double linked case list before it
7444 is sorted. Returns the head of the sorted list if we don't see any
7445 overlap, or NULL otherwise. */
7448 check_case_overlap (gfc_case
*list
)
7450 gfc_case
*p
, *q
, *e
, *tail
;
7451 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7453 /* If the passed list was empty, return immediately. */
7460 /* Loop unconditionally. The only exit from this loop is a return
7461 statement, when we've finished sorting the case list. */
7468 /* Count the number of merges we do in this pass. */
7471 /* Loop while there exists a merge to be done. */
7476 /* Count this merge. */
7479 /* Cut the list in two pieces by stepping INSIZE places
7480 forward in the list, starting from P. */
7483 for (i
= 0; i
< insize
; i
++)
7492 /* Now we have two lists. Merge them! */
7493 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7495 /* See from which the next case to merge comes from. */
7498 /* P is empty so the next case must come from Q. */
7503 else if (qsize
== 0 || q
== NULL
)
7512 cmp
= compare_cases (p
, q
);
7515 /* The whole case range for P is less than the
7523 /* The whole case range for Q is greater than
7524 the case range for P. */
7531 /* The cases overlap, or they are the same
7532 element in the list. Either way, we must
7533 issue an error and get the next case from P. */
7534 /* FIXME: Sort P and Q by line number. */
7535 gfc_error ("CASE label at %L overlaps with CASE "
7536 "label at %L", &p
->where
, &q
->where
);
7544 /* Add the next element to the merged list. */
7553 /* P has now stepped INSIZE places along, and so has Q. So
7554 they're the same. */
7559 /* If we have done only one merge or none at all, we've
7560 finished sorting the cases. */
7569 /* Otherwise repeat, merging lists twice the size. */
7575 /* Check to see if an expression is suitable for use in a CASE statement.
7576 Makes sure that all case expressions are scalar constants of the same
7577 type. Return FAILURE if anything is wrong. */
7580 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7582 if (e
== NULL
) return SUCCESS
;
7584 if (e
->ts
.type
!= case_expr
->ts
.type
)
7586 gfc_error ("Expression in CASE statement at %L must be of type %s",
7587 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7591 /* C805 (R808) For a given case-construct, each case-value shall be of
7592 the same type as case-expr. For character type, length differences
7593 are allowed, but the kind type parameters shall be the same. */
7595 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7597 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7598 &e
->where
, case_expr
->ts
.kind
);
7602 /* Convert the case value kind to that of case expression kind,
7605 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7606 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7610 gfc_error ("Expression in CASE statement at %L must be scalar",
7619 /* Given a completely parsed select statement, we:
7621 - Validate all expressions and code within the SELECT.
7622 - Make sure that the selection expression is not of the wrong type.
7623 - Make sure that no case ranges overlap.
7624 - Eliminate unreachable cases and unreachable code resulting from
7625 removing case labels.
7627 The standard does allow unreachable cases, e.g. CASE (5:3). But
7628 they are a hassle for code generation, and to prevent that, we just
7629 cut them out here. This is not necessary for overlapping cases
7630 because they are illegal and we never even try to generate code.
7632 We have the additional caveat that a SELECT construct could have
7633 been a computed GOTO in the source code. Fortunately we can fairly
7634 easily work around that here: The case_expr for a "real" SELECT CASE
7635 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7636 we have to do is make sure that the case_expr is a scalar integer
7640 resolve_select (gfc_code
*code
)
7643 gfc_expr
*case_expr
;
7644 gfc_case
*cp
, *default_case
, *tail
, *head
;
7645 int seen_unreachable
;
7651 if (code
->expr1
== NULL
)
7653 /* This was actually a computed GOTO statement. */
7654 case_expr
= code
->expr2
;
7655 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7656 gfc_error ("Selection expression in computed GOTO statement "
7657 "at %L must be a scalar integer expression",
7660 /* Further checking is not necessary because this SELECT was built
7661 by the compiler, so it should always be OK. Just move the
7662 case_expr from expr2 to expr so that we can handle computed
7663 GOTOs as normal SELECTs from here on. */
7664 code
->expr1
= code
->expr2
;
7669 case_expr
= code
->expr1
;
7671 type
= case_expr
->ts
.type
;
7672 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7674 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7675 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7677 /* Punt. Going on here just produce more garbage error messages. */
7681 /* Raise a warning if an INTEGER case value exceeds the range of
7682 the case-expr. Later, all expressions will be promoted to the
7683 largest kind of all case-labels. */
7685 if (type
== BT_INTEGER
)
7686 for (body
= code
->block
; body
; body
= body
->block
)
7687 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7690 && gfc_check_integer_range (cp
->low
->value
.integer
,
7691 case_expr
->ts
.kind
) != ARITH_OK
)
7692 gfc_warning ("Expression in CASE statement at %L is "
7693 "not in the range of %s", &cp
->low
->where
,
7694 gfc_typename (&case_expr
->ts
));
7697 && cp
->low
!= cp
->high
7698 && gfc_check_integer_range (cp
->high
->value
.integer
,
7699 case_expr
->ts
.kind
) != ARITH_OK
)
7700 gfc_warning ("Expression in CASE statement at %L is "
7701 "not in the range of %s", &cp
->high
->where
,
7702 gfc_typename (&case_expr
->ts
));
7705 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7706 of the SELECT CASE expression and its CASE values. Walk the lists
7707 of case values, and if we find a mismatch, promote case_expr to
7708 the appropriate kind. */
7710 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7712 for (body
= code
->block
; body
; body
= body
->block
)
7714 /* Walk the case label list. */
7715 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7717 /* Intercept the DEFAULT case. It does not have a kind. */
7718 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7721 /* Unreachable case ranges are discarded, so ignore. */
7722 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7723 && cp
->low
!= cp
->high
7724 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7728 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7729 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7731 if (cp
->high
!= NULL
7732 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7733 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7738 /* Assume there is no DEFAULT case. */
7739 default_case
= NULL
;
7744 for (body
= code
->block
; body
; body
= body
->block
)
7746 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7748 seen_unreachable
= 0;
7750 /* Walk the case label list, making sure that all case labels
7752 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7754 /* Count the number of cases in the whole construct. */
7757 /* Intercept the DEFAULT case. */
7758 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7760 if (default_case
!= NULL
)
7762 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7763 "by a second DEFAULT CASE at %L",
7764 &default_case
->where
, &cp
->where
);
7775 /* Deal with single value cases and case ranges. Errors are
7776 issued from the validation function. */
7777 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
7778 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
7784 if (type
== BT_LOGICAL
7785 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7786 || cp
->low
!= cp
->high
))
7788 gfc_error ("Logical range in CASE statement at %L is not "
7789 "allowed", &cp
->low
->where
);
7794 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7797 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7798 if (value
& seen_logical
)
7800 gfc_error ("Constant logical value in CASE statement "
7801 "is repeated at %L",
7806 seen_logical
|= value
;
7809 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7810 && cp
->low
!= cp
->high
7811 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7813 if (gfc_option
.warn_surprising
)
7814 gfc_warning ("Range specification at %L can never "
7815 "be matched", &cp
->where
);
7817 cp
->unreachable
= 1;
7818 seen_unreachable
= 1;
7822 /* If the case range can be matched, it can also overlap with
7823 other cases. To make sure it does not, we put it in a
7824 double linked list here. We sort that with a merge sort
7825 later on to detect any overlapping cases. */
7829 head
->right
= head
->left
= NULL
;
7834 tail
->right
->left
= tail
;
7841 /* It there was a failure in the previous case label, give up
7842 for this case label list. Continue with the next block. */
7846 /* See if any case labels that are unreachable have been seen.
7847 If so, we eliminate them. This is a bit of a kludge because
7848 the case lists for a single case statement (label) is a
7849 single forward linked lists. */
7850 if (seen_unreachable
)
7852 /* Advance until the first case in the list is reachable. */
7853 while (body
->ext
.block
.case_list
!= NULL
7854 && body
->ext
.block
.case_list
->unreachable
)
7856 gfc_case
*n
= body
->ext
.block
.case_list
;
7857 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7859 gfc_free_case_list (n
);
7862 /* Strip all other unreachable cases. */
7863 if (body
->ext
.block
.case_list
)
7865 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7867 if (cp
->next
->unreachable
)
7869 gfc_case
*n
= cp
->next
;
7870 cp
->next
= cp
->next
->next
;
7872 gfc_free_case_list (n
);
7879 /* See if there were overlapping cases. If the check returns NULL,
7880 there was overlap. In that case we don't do anything. If head
7881 is non-NULL, we prepend the DEFAULT case. The sorted list can
7882 then used during code generation for SELECT CASE constructs with
7883 a case expression of a CHARACTER type. */
7886 head
= check_case_overlap (head
);
7888 /* Prepend the default_case if it is there. */
7889 if (head
!= NULL
&& default_case
)
7891 default_case
->left
= NULL
;
7892 default_case
->right
= head
;
7893 head
->left
= default_case
;
7897 /* Eliminate dead blocks that may be the result if we've seen
7898 unreachable case labels for a block. */
7899 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7901 if (body
->block
->ext
.block
.case_list
== NULL
)
7903 /* Cut the unreachable block from the code chain. */
7904 gfc_code
*c
= body
->block
;
7905 body
->block
= c
->block
;
7907 /* Kill the dead block, but not the blocks below it. */
7909 gfc_free_statements (c
);
7913 /* More than two cases is legal but insane for logical selects.
7914 Issue a warning for it. */
7915 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7917 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7922 /* Check if a derived type is extensible. */
7925 gfc_type_is_extensible (gfc_symbol
*sym
)
7927 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
7931 /* Resolve an associate name: Resolve target and ensure the type-spec is
7932 correct as well as possibly the array-spec. */
7935 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7939 gcc_assert (sym
->assoc
);
7940 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7942 /* If this is for SELECT TYPE, the target may not yet be set. In that
7943 case, return. Resolution will be called later manually again when
7945 target
= sym
->assoc
->target
;
7948 gcc_assert (!sym
->assoc
->dangling
);
7950 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
7953 /* For variable targets, we get some attributes from the target. */
7954 if (target
->expr_type
== EXPR_VARIABLE
)
7958 gcc_assert (target
->symtree
);
7959 tsym
= target
->symtree
->n
.sym
;
7961 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7962 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7964 sym
->attr
.target
= tsym
->attr
.target
7965 || gfc_expr_attr (target
).pointer
;
7968 /* Get type if this was not already set. Note that it can be
7969 some other type than the target in case this is a SELECT TYPE
7970 selector! So we must not update when the type is already there. */
7971 if (sym
->ts
.type
== BT_UNKNOWN
)
7972 sym
->ts
= target
->ts
;
7973 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7975 /* See if this is a valid association-to-variable. */
7976 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7977 && !gfc_has_vector_subscript (target
));
7979 /* Finally resolve if this is an array or not. */
7980 if (sym
->attr
.dimension
&& target
->rank
== 0)
7982 gfc_error ("Associate-name '%s' at %L is used as array",
7983 sym
->name
, &sym
->declared_at
);
7984 sym
->attr
.dimension
= 0;
7987 if (target
->rank
> 0)
7988 sym
->attr
.dimension
= 1;
7990 if (sym
->attr
.dimension
)
7992 sym
->as
= gfc_get_array_spec ();
7993 sym
->as
->rank
= target
->rank
;
7994 sym
->as
->type
= AS_DEFERRED
;
7996 /* Target must not be coindexed, thus the associate-variable
7998 sym
->as
->corank
= 0;
8003 /* Resolve a SELECT TYPE statement. */
8006 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8008 gfc_symbol
*selector_type
;
8009 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8010 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8013 char name
[GFC_MAX_SYMBOL_LEN
];
8017 ns
= code
->ext
.block
.ns
;
8020 /* Check for F03:C813. */
8021 if (code
->expr1
->ts
.type
!= BT_CLASS
8022 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8024 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8025 "at %L", &code
->loc
);
8029 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8034 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8035 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8036 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8039 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8041 /* Loop over TYPE IS / CLASS IS cases. */
8042 for (body
= code
->block
; body
; body
= body
->block
)
8044 c
= body
->ext
.block
.case_list
;
8046 /* Check F03:C815. */
8047 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8048 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8050 gfc_error ("Derived type '%s' at %L must be extensible",
8051 c
->ts
.u
.derived
->name
, &c
->where
);
8056 /* Check F03:C816. */
8057 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8058 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
8060 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8061 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8066 /* Intercept the DEFAULT case. */
8067 if (c
->ts
.type
== BT_UNKNOWN
)
8069 /* Check F03:C818. */
8072 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8073 "by a second DEFAULT CASE at %L",
8074 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8079 default_case
= body
;
8086 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8087 target if present. If there are any EXIT statements referring to the
8088 SELECT TYPE construct, this is no problem because the gfc_code
8089 reference stays the same and EXIT is equally possible from the BLOCK
8090 it is changed to. */
8091 code
->op
= EXEC_BLOCK
;
8094 gfc_association_list
* assoc
;
8096 assoc
= gfc_get_association_list ();
8097 assoc
->st
= code
->expr1
->symtree
;
8098 assoc
->target
= gfc_copy_expr (code
->expr2
);
8099 assoc
->target
->where
= code
->expr2
->where
;
8100 /* assoc->variable will be set by resolve_assoc_var. */
8102 code
->ext
.block
.assoc
= assoc
;
8103 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8105 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8108 code
->ext
.block
.assoc
= NULL
;
8110 /* Add EXEC_SELECT to switch on type. */
8111 new_st
= gfc_get_code ();
8112 new_st
->op
= code
->op
;
8113 new_st
->expr1
= code
->expr1
;
8114 new_st
->expr2
= code
->expr2
;
8115 new_st
->block
= code
->block
;
8116 code
->expr1
= code
->expr2
= NULL
;
8121 ns
->code
->next
= new_st
;
8123 code
->op
= EXEC_SELECT
;
8124 gfc_add_vptr_component (code
->expr1
);
8125 gfc_add_hash_component (code
->expr1
);
8127 /* Loop over TYPE IS / CLASS IS cases. */
8128 for (body
= code
->block
; body
; body
= body
->block
)
8130 c
= body
->ext
.block
.case_list
;
8132 if (c
->ts
.type
== BT_DERIVED
)
8133 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8134 c
->ts
.u
.derived
->hash_value
);
8136 else if (c
->ts
.type
== BT_UNKNOWN
)
8139 /* Associate temporary to selector. This should only be done
8140 when this case is actually true, so build a new ASSOCIATE
8141 that does precisely this here (instead of using the
8144 if (c
->ts
.type
== BT_CLASS
)
8145 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8147 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8148 st
= gfc_find_symtree (ns
->sym_root
, name
);
8149 gcc_assert (st
->n
.sym
->assoc
);
8150 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8151 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8152 if (c
->ts
.type
== BT_DERIVED
)
8153 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8155 new_st
= gfc_get_code ();
8156 new_st
->op
= EXEC_BLOCK
;
8157 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8158 new_st
->ext
.block
.ns
->code
= body
->next
;
8159 body
->next
= new_st
;
8161 /* Chain in the new list only if it is marked as dangling. Otherwise
8162 there is a CASE label overlap and this is already used. Just ignore,
8163 the error is diagonsed elsewhere. */
8164 if (st
->n
.sym
->assoc
->dangling
)
8166 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8167 st
->n
.sym
->assoc
->dangling
= 0;
8170 resolve_assoc_var (st
->n
.sym
, false);
8173 /* Take out CLASS IS cases for separate treatment. */
8175 while (body
&& body
->block
)
8177 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8179 /* Add to class_is list. */
8180 if (class_is
== NULL
)
8182 class_is
= body
->block
;
8187 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8188 tail
->block
= body
->block
;
8191 /* Remove from EXEC_SELECT list. */
8192 body
->block
= body
->block
->block
;
8205 /* Add a default case to hold the CLASS IS cases. */
8206 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8207 tail
->block
= gfc_get_code ();
8209 tail
->op
= EXEC_SELECT_TYPE
;
8210 tail
->ext
.block
.case_list
= gfc_get_case ();
8211 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8213 default_case
= tail
;
8216 /* More than one CLASS IS block? */
8217 if (class_is
->block
)
8221 /* Sort CLASS IS blocks by extension level. */
8225 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8228 /* F03:C817 (check for doubles). */
8229 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8230 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8232 gfc_error ("Double CLASS IS block in SELECT TYPE "
8234 &c2
->ext
.block
.case_list
->where
);
8237 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8238 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8241 (*c1
)->block
= c2
->block
;
8251 /* Generate IF chain. */
8252 if_st
= gfc_get_code ();
8253 if_st
->op
= EXEC_IF
;
8255 for (body
= class_is
; body
; body
= body
->block
)
8257 new_st
->block
= gfc_get_code ();
8258 new_st
= new_st
->block
;
8259 new_st
->op
= EXEC_IF
;
8260 /* Set up IF condition: Call _gfortran_is_extension_of. */
8261 new_st
->expr1
= gfc_get_expr ();
8262 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8263 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8264 new_st
->expr1
->ts
.kind
= 4;
8265 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8266 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8267 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8268 /* Set up arguments. */
8269 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8270 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8271 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8272 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8273 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8274 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8275 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8276 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8277 new_st
->next
= body
->next
;
8279 if (default_case
->next
)
8281 new_st
->block
= gfc_get_code ();
8282 new_st
= new_st
->block
;
8283 new_st
->op
= EXEC_IF
;
8284 new_st
->next
= default_case
->next
;
8287 /* Replace CLASS DEFAULT code by the IF chain. */
8288 default_case
->next
= if_st
;
8291 /* Resolve the internal code. This can not be done earlier because
8292 it requires that the sym->assoc of selectors is set already. */
8293 gfc_current_ns
= ns
;
8294 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8295 gfc_current_ns
= old_ns
;
8297 resolve_select (code
);
8301 /* Resolve a transfer statement. This is making sure that:
8302 -- a derived type being transferred has only non-pointer components
8303 -- a derived type being transferred doesn't have private components, unless
8304 it's being transferred from the module where the type was defined
8305 -- we're not trying to transfer a whole assumed size array. */
8308 resolve_transfer (gfc_code
*code
)
8317 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8318 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8319 exp
= exp
->value
.op
.op1
;
8321 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8323 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8324 "MOLD=", &exp
->where
);
8328 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8329 && exp
->expr_type
!= EXPR_FUNCTION
))
8332 /* If we are reading, the variable will be changed. Note that
8333 code->ext.dt may be NULL if the TRANSFER is related to
8334 an INQUIRE statement -- but in this case, we are not reading, either. */
8335 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8336 && gfc_check_vardef_context (exp
, false, false, _("item in READ"))
8340 sym
= exp
->symtree
->n
.sym
;
8343 /* Go to actual component transferred. */
8344 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8345 if (ref
->type
== REF_COMPONENT
)
8346 ts
= &ref
->u
.c
.component
->ts
;
8348 if (ts
->type
== BT_CLASS
)
8350 /* FIXME: Test for defined input/output. */
8351 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8352 "it is processed by a defined input/output procedure",
8357 if (ts
->type
== BT_DERIVED
)
8359 /* Check that transferred derived type doesn't contain POINTER
8361 if (ts
->u
.derived
->attr
.pointer_comp
)
8363 gfc_error ("Data transfer element at %L cannot have POINTER "
8364 "components unless it is processed by a defined "
8365 "input/output procedure", &code
->loc
);
8370 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8372 gfc_error ("Data transfer element at %L cannot have "
8373 "procedure pointer components", &code
->loc
);
8377 if (ts
->u
.derived
->attr
.alloc_comp
)
8379 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8380 "components unless it is processed by a defined "
8381 "input/output procedure", &code
->loc
);
8385 if (derived_inaccessible (ts
->u
.derived
))
8387 gfc_error ("Data transfer element at %L cannot have "
8388 "PRIVATE components",&code
->loc
);
8393 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8394 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8396 gfc_error ("Data transfer element at %L cannot be a full reference to "
8397 "an assumed-size array", &code
->loc
);
8403 /*********** Toplevel code resolution subroutines ***********/
8405 /* Find the set of labels that are reachable from this block. We also
8406 record the last statement in each block. */
8409 find_reachable_labels (gfc_code
*block
)
8416 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8418 /* Collect labels in this block. We don't keep those corresponding
8419 to END {IF|SELECT}, these are checked in resolve_branch by going
8420 up through the code_stack. */
8421 for (c
= block
; c
; c
= c
->next
)
8423 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8424 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8427 /* Merge with labels from parent block. */
8430 gcc_assert (cs_base
->prev
->reachable_labels
);
8431 bitmap_ior_into (cs_base
->reachable_labels
,
8432 cs_base
->prev
->reachable_labels
);
8438 resolve_lock_unlock (gfc_code
*code
)
8440 if (code
->expr1
->ts
.type
!= BT_DERIVED
8441 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8442 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8443 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8444 || code
->expr1
->rank
!= 0
8445 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8446 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8447 &code
->expr1
->where
);
8451 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8452 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8453 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8454 &code
->expr2
->where
);
8457 && gfc_check_vardef_context (code
->expr2
, false, false,
8458 _("STAT variable")) == FAILURE
)
8463 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8464 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8465 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8466 &code
->expr3
->where
);
8469 && gfc_check_vardef_context (code
->expr3
, false, false,
8470 _("ERRMSG variable")) == FAILURE
)
8473 /* Check ACQUIRED_LOCK. */
8475 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8476 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8477 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8478 "variable", &code
->expr4
->where
);
8481 && gfc_check_vardef_context (code
->expr4
, false, false,
8482 _("ACQUIRED_LOCK variable")) == FAILURE
)
8488 resolve_sync (gfc_code
*code
)
8490 /* Check imageset. The * case matches expr1 == NULL. */
8493 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8494 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8495 "INTEGER expression", &code
->expr1
->where
);
8496 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8497 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8498 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8499 &code
->expr1
->where
);
8500 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8501 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8503 gfc_constructor
*cons
;
8504 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8505 for (; cons
; cons
= gfc_constructor_next (cons
))
8506 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8507 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8508 gfc_error ("Imageset argument at %L must between 1 and "
8509 "num_images()", &cons
->expr
->where
);
8515 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8516 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8517 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8518 &code
->expr2
->where
);
8522 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8523 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8524 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8525 &code
->expr3
->where
);
8529 /* Given a branch to a label, see if the branch is conforming.
8530 The code node describes where the branch is located. */
8533 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8540 /* Step one: is this a valid branching target? */
8542 if (label
->defined
== ST_LABEL_UNKNOWN
)
8544 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8549 if (label
->defined
!= ST_LABEL_TARGET
)
8551 gfc_error ("Statement at %L is not a valid branch target statement "
8552 "for the branch statement at %L", &label
->where
, &code
->loc
);
8556 /* Step two: make sure this branch is not a branch to itself ;-) */
8558 if (code
->here
== label
)
8560 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8564 /* Step three: See if the label is in the same block as the
8565 branching statement. The hard work has been done by setting up
8566 the bitmap reachable_labels. */
8568 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8570 /* Check now whether there is a CRITICAL construct; if so, check
8571 whether the label is still visible outside of the CRITICAL block,
8572 which is invalid. */
8573 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8575 if (stack
->current
->op
== EXEC_CRITICAL
8576 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8577 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8578 "label at %L", &code
->loc
, &label
->where
);
8579 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8580 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8581 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8582 "for label at %L", &code
->loc
, &label
->where
);
8588 /* Step four: If we haven't found the label in the bitmap, it may
8589 still be the label of the END of the enclosing block, in which
8590 case we find it by going up the code_stack. */
8592 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8594 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8596 if (stack
->current
->op
== EXEC_CRITICAL
)
8598 /* Note: A label at END CRITICAL does not leave the CRITICAL
8599 construct as END CRITICAL is still part of it. */
8600 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8601 " at %L", &code
->loc
, &label
->where
);
8604 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8606 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8607 "label at %L", &code
->loc
, &label
->where
);
8614 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8618 /* The label is not in an enclosing block, so illegal. This was
8619 allowed in Fortran 66, so we allow it as extension. No
8620 further checks are necessary in this case. */
8621 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8622 "as the GOTO statement at %L", &label
->where
,
8628 /* Check whether EXPR1 has the same shape as EXPR2. */
8631 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8633 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8634 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8635 gfc_try result
= FAILURE
;
8638 /* Compare the rank. */
8639 if (expr1
->rank
!= expr2
->rank
)
8642 /* Compare the size of each dimension. */
8643 for (i
=0; i
<expr1
->rank
; i
++)
8645 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8648 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8651 if (mpz_cmp (shape
[i
], shape2
[i
]))
8655 /* When either of the two expression is an assumed size array, we
8656 ignore the comparison of dimension sizes. */
8661 gfc_clear_shape (shape
, i
);
8662 gfc_clear_shape (shape2
, i
);
8667 /* Check whether a WHERE assignment target or a WHERE mask expression
8668 has the same shape as the outmost WHERE mask expression. */
8671 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8677 cblock
= code
->block
;
8679 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8680 In case of nested WHERE, only the outmost one is stored. */
8681 if (mask
== NULL
) /* outmost WHERE */
8683 else /* inner WHERE */
8690 /* Check if the mask-expr has a consistent shape with the
8691 outmost WHERE mask-expr. */
8692 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8693 gfc_error ("WHERE mask at %L has inconsistent shape",
8694 &cblock
->expr1
->where
);
8697 /* the assignment statement of a WHERE statement, or the first
8698 statement in where-body-construct of a WHERE construct */
8699 cnext
= cblock
->next
;
8704 /* WHERE assignment statement */
8707 /* Check shape consistent for WHERE assignment target. */
8708 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8709 gfc_error ("WHERE assignment target at %L has "
8710 "inconsistent shape", &cnext
->expr1
->where
);
8714 case EXEC_ASSIGN_CALL
:
8715 resolve_call (cnext
);
8716 if (!cnext
->resolved_sym
->attr
.elemental
)
8717 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8718 &cnext
->ext
.actual
->expr
->where
);
8721 /* WHERE or WHERE construct is part of a where-body-construct */
8723 resolve_where (cnext
, e
);
8727 gfc_error ("Unsupported statement inside WHERE at %L",
8730 /* the next statement within the same where-body-construct */
8731 cnext
= cnext
->next
;
8733 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8734 cblock
= cblock
->block
;
8739 /* Resolve assignment in FORALL construct.
8740 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8741 FORALL index variables. */
8744 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8748 for (n
= 0; n
< nvar
; n
++)
8750 gfc_symbol
*forall_index
;
8752 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8754 /* Check whether the assignment target is one of the FORALL index
8756 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8757 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8758 gfc_error ("Assignment to a FORALL index variable at %L",
8759 &code
->expr1
->where
);
8762 /* If one of the FORALL index variables doesn't appear in the
8763 assignment variable, then there could be a many-to-one
8764 assignment. Emit a warning rather than an error because the
8765 mask could be resolving this problem. */
8766 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
8767 gfc_warning ("The FORALL with index '%s' is not used on the "
8768 "left side of the assignment at %L and so might "
8769 "cause multiple assignment to this object",
8770 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8776 /* Resolve WHERE statement in FORALL construct. */
8779 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8780 gfc_expr
**var_expr
)
8785 cblock
= code
->block
;
8788 /* the assignment statement of a WHERE statement, or the first
8789 statement in where-body-construct of a WHERE construct */
8790 cnext
= cblock
->next
;
8795 /* WHERE assignment statement */
8797 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8800 /* WHERE operator assignment statement */
8801 case EXEC_ASSIGN_CALL
:
8802 resolve_call (cnext
);
8803 if (!cnext
->resolved_sym
->attr
.elemental
)
8804 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8805 &cnext
->ext
.actual
->expr
->where
);
8808 /* WHERE or WHERE construct is part of a where-body-construct */
8810 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8814 gfc_error ("Unsupported statement inside WHERE at %L",
8817 /* the next statement within the same where-body-construct */
8818 cnext
= cnext
->next
;
8820 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8821 cblock
= cblock
->block
;
8826 /* Traverse the FORALL body to check whether the following errors exist:
8827 1. For assignment, check if a many-to-one assignment happens.
8828 2. For WHERE statement, check the WHERE body to see if there is any
8829 many-to-one assignment. */
8832 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8836 c
= code
->block
->next
;
8842 case EXEC_POINTER_ASSIGN
:
8843 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8846 case EXEC_ASSIGN_CALL
:
8850 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8851 there is no need to handle it here. */
8855 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8860 /* The next statement in the FORALL body. */
8866 /* Counts the number of iterators needed inside a forall construct, including
8867 nested forall constructs. This is used to allocate the needed memory
8868 in gfc_resolve_forall. */
8871 gfc_count_forall_iterators (gfc_code
*code
)
8873 int max_iters
, sub_iters
, current_iters
;
8874 gfc_forall_iterator
*fa
;
8876 gcc_assert(code
->op
== EXEC_FORALL
);
8880 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8883 code
= code
->block
->next
;
8887 if (code
->op
== EXEC_FORALL
)
8889 sub_iters
= gfc_count_forall_iterators (code
);
8890 if (sub_iters
> max_iters
)
8891 max_iters
= sub_iters
;
8896 return current_iters
+ max_iters
;
8900 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8901 gfc_resolve_forall_body to resolve the FORALL body. */
8904 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8906 static gfc_expr
**var_expr
;
8907 static int total_var
= 0;
8908 static int nvar
= 0;
8910 gfc_forall_iterator
*fa
;
8915 /* Start to resolve a FORALL construct */
8916 if (forall_save
== 0)
8918 /* Count the total number of FORALL index in the nested FORALL
8919 construct in order to allocate the VAR_EXPR with proper size. */
8920 total_var
= gfc_count_forall_iterators (code
);
8922 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8923 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8926 /* The information about FORALL iterator, including FORALL index start, end
8927 and stride. The FORALL index can not appear in start, end or stride. */
8928 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8930 /* Check if any outer FORALL index name is the same as the current
8932 for (i
= 0; i
< nvar
; i
++)
8934 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8936 gfc_error ("An outer FORALL construct already has an index "
8937 "with this name %L", &fa
->var
->where
);
8941 /* Record the current FORALL index. */
8942 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8946 /* No memory leak. */
8947 gcc_assert (nvar
<= total_var
);
8950 /* Resolve the FORALL body. */
8951 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8953 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8954 gfc_resolve_blocks (code
->block
, ns
);
8958 /* Free only the VAR_EXPRs allocated in this frame. */
8959 for (i
= nvar
; i
< tmp
; i
++)
8960 gfc_free_expr (var_expr
[i
]);
8964 /* We are in the outermost FORALL construct. */
8965 gcc_assert (forall_save
== 0);
8967 /* VAR_EXPR is not needed any more. */
8974 /* Resolve a BLOCK construct statement. */
8977 resolve_block_construct (gfc_code
* code
)
8979 /* Resolve the BLOCK's namespace. */
8980 gfc_resolve (code
->ext
.block
.ns
);
8982 /* For an ASSOCIATE block, the associations (and their targets) are already
8983 resolved during resolve_symbol. */
8987 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8990 static void resolve_code (gfc_code
*, gfc_namespace
*);
8993 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8997 for (; b
; b
= b
->block
)
8999 t
= gfc_resolve_expr (b
->expr1
);
9000 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
9006 if (t
== SUCCESS
&& b
->expr1
!= NULL
9007 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9008 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9015 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9016 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9021 resolve_branch (b
->label1
, b
);
9025 resolve_block_construct (b
);
9029 case EXEC_SELECT_TYPE
:
9033 case EXEC_DO_CONCURRENT
:
9041 case EXEC_OMP_ATOMIC
:
9042 case EXEC_OMP_CRITICAL
:
9044 case EXEC_OMP_MASTER
:
9045 case EXEC_OMP_ORDERED
:
9046 case EXEC_OMP_PARALLEL
:
9047 case EXEC_OMP_PARALLEL_DO
:
9048 case EXEC_OMP_PARALLEL_SECTIONS
:
9049 case EXEC_OMP_PARALLEL_WORKSHARE
:
9050 case EXEC_OMP_SECTIONS
:
9051 case EXEC_OMP_SINGLE
:
9053 case EXEC_OMP_TASKWAIT
:
9054 case EXEC_OMP_TASKYIELD
:
9055 case EXEC_OMP_WORKSHARE
:
9059 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9062 resolve_code (b
->next
, ns
);
9067 /* Does everything to resolve an ordinary assignment. Returns true
9068 if this is an interface assignment. */
9070 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9080 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
9084 if (code
->op
== EXEC_ASSIGN_CALL
)
9086 lhs
= code
->ext
.actual
->expr
;
9087 rhsptr
= &code
->ext
.actual
->next
->expr
;
9091 gfc_actual_arglist
* args
;
9092 gfc_typebound_proc
* tbp
;
9094 gcc_assert (code
->op
== EXEC_COMPCALL
);
9096 args
= code
->expr1
->value
.compcall
.actual
;
9098 rhsptr
= &args
->next
->expr
;
9100 tbp
= code
->expr1
->value
.compcall
.tbp
;
9101 gcc_assert (!tbp
->is_generic
);
9104 /* Make a temporary rhs when there is a default initializer
9105 and rhs is the same symbol as the lhs. */
9106 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9107 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9108 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9109 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9110 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9119 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
9120 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9121 &code
->loc
) == FAILURE
)
9124 /* Handle the case of a BOZ literal on the RHS. */
9125 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9128 if (gfc_option
.warn_surprising
)
9129 gfc_warning ("BOZ literal at %L is bitwise transferred "
9130 "non-integer symbol '%s'", &code
->loc
,
9131 lhs
->symtree
->n
.sym
->name
);
9133 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9135 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9137 if (rc
== ARITH_UNDERFLOW
)
9138 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9139 ". This check can be disabled with the option "
9140 "-fno-range-check", &rhs
->where
);
9141 else if (rc
== ARITH_OVERFLOW
)
9142 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9143 ". This check can be disabled with the option "
9144 "-fno-range-check", &rhs
->where
);
9145 else if (rc
== ARITH_NAN
)
9146 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9147 ". This check can be disabled with the option "
9148 "-fno-range-check", &rhs
->where
);
9153 if (lhs
->ts
.type
== BT_CHARACTER
9154 && gfc_option
.warn_character_truncation
)
9156 if (lhs
->ts
.u
.cl
!= NULL
9157 && lhs
->ts
.u
.cl
->length
!= NULL
9158 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9159 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9161 if (rhs
->expr_type
== EXPR_CONSTANT
)
9162 rlen
= rhs
->value
.character
.length
;
9164 else if (rhs
->ts
.u
.cl
!= NULL
9165 && rhs
->ts
.u
.cl
->length
!= NULL
9166 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9167 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9169 if (rlen
&& llen
&& rlen
> llen
)
9170 gfc_warning_now ("CHARACTER expression will be truncated "
9171 "in assignment (%d/%d) at %L",
9172 llen
, rlen
, &code
->loc
);
9175 /* Ensure that a vector index expression for the lvalue is evaluated
9176 to a temporary if the lvalue symbol is referenced in it. */
9179 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9180 if (ref
->type
== REF_ARRAY
)
9182 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9183 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9184 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9185 ref
->u
.ar
.start
[n
]))
9187 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9191 if (gfc_pure (NULL
))
9193 if (lhs
->ts
.type
== BT_DERIVED
9194 && lhs
->expr_type
== EXPR_VARIABLE
9195 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9196 && rhs
->expr_type
== EXPR_VARIABLE
9197 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9198 || gfc_is_coindexed (rhs
)))
9201 if (gfc_is_coindexed (rhs
))
9202 gfc_error ("Coindexed expression at %L is assigned to "
9203 "a derived type variable with a POINTER "
9204 "component in a PURE procedure",
9207 gfc_error ("The impure variable at %L is assigned to "
9208 "a derived type variable with a POINTER "
9209 "component in a PURE procedure (12.6)",
9214 /* Fortran 2008, C1283. */
9215 if (gfc_is_coindexed (lhs
))
9217 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9218 "procedure", &rhs
->where
);
9223 if (gfc_implicit_pure (NULL
))
9225 if (lhs
->expr_type
== EXPR_VARIABLE
9226 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9227 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9228 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9230 if (lhs
->ts
.type
== BT_DERIVED
9231 && lhs
->expr_type
== EXPR_VARIABLE
9232 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9233 && rhs
->expr_type
== EXPR_VARIABLE
9234 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9235 || gfc_is_coindexed (rhs
)))
9236 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9238 /* Fortran 2008, C1283. */
9239 if (gfc_is_coindexed (lhs
))
9240 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9244 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9245 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9246 if (lhs
->ts
.type
== BT_CLASS
)
9248 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9249 "%L - check that there is a matching specific subroutine "
9250 "for '=' operator", &lhs
->where
);
9254 /* F2008, Section 7.2.1.2. */
9255 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9257 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9258 "component in assignment at %L", &lhs
->where
);
9262 gfc_check_assign (lhs
, rhs
, 1);
9267 /* Given a block of code, recursively resolve everything pointed to by this
9271 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9273 int omp_workshare_save
;
9274 int forall_save
, do_concurrent_save
;
9278 frame
.prev
= cs_base
;
9282 find_reachable_labels (code
);
9284 for (; code
; code
= code
->next
)
9286 frame
.current
= code
;
9287 forall_save
= forall_flag
;
9288 do_concurrent_save
= do_concurrent_flag
;
9290 if (code
->op
== EXEC_FORALL
)
9293 gfc_resolve_forall (code
, ns
, forall_save
);
9296 else if (code
->block
)
9298 omp_workshare_save
= -1;
9301 case EXEC_OMP_PARALLEL_WORKSHARE
:
9302 omp_workshare_save
= omp_workshare_flag
;
9303 omp_workshare_flag
= 1;
9304 gfc_resolve_omp_parallel_blocks (code
, ns
);
9306 case EXEC_OMP_PARALLEL
:
9307 case EXEC_OMP_PARALLEL_DO
:
9308 case EXEC_OMP_PARALLEL_SECTIONS
:
9310 omp_workshare_save
= omp_workshare_flag
;
9311 omp_workshare_flag
= 0;
9312 gfc_resolve_omp_parallel_blocks (code
, ns
);
9315 gfc_resolve_omp_do_blocks (code
, ns
);
9317 case EXEC_SELECT_TYPE
:
9318 /* Blocks are handled in resolve_select_type because we have
9319 to transform the SELECT TYPE into ASSOCIATE first. */
9321 case EXEC_DO_CONCURRENT
:
9322 do_concurrent_flag
= 1;
9323 gfc_resolve_blocks (code
->block
, ns
);
9324 do_concurrent_flag
= 2;
9326 case EXEC_OMP_WORKSHARE
:
9327 omp_workshare_save
= omp_workshare_flag
;
9328 omp_workshare_flag
= 1;
9331 gfc_resolve_blocks (code
->block
, ns
);
9335 if (omp_workshare_save
!= -1)
9336 omp_workshare_flag
= omp_workshare_save
;
9340 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9341 t
= gfc_resolve_expr (code
->expr1
);
9342 forall_flag
= forall_save
;
9343 do_concurrent_flag
= do_concurrent_save
;
9345 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
9348 if (code
->op
== EXEC_ALLOCATE
9349 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9355 case EXEC_END_BLOCK
:
9356 case EXEC_END_NESTED_BLOCK
:
9360 case EXEC_ERROR_STOP
:
9364 case EXEC_ASSIGN_CALL
:
9369 case EXEC_SYNC_IMAGES
:
9370 case EXEC_SYNC_MEMORY
:
9371 resolve_sync (code
);
9376 resolve_lock_unlock (code
);
9380 /* Keep track of which entry we are up to. */
9381 current_entry_id
= code
->ext
.entry
->id
;
9385 resolve_where (code
, NULL
);
9389 if (code
->expr1
!= NULL
)
9391 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9392 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9393 "INTEGER variable", &code
->expr1
->where
);
9394 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9395 gfc_error ("Variable '%s' has not been assigned a target "
9396 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9397 &code
->expr1
->where
);
9400 resolve_branch (code
->label1
, code
);
9404 if (code
->expr1
!= NULL
9405 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9406 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9407 "INTEGER return specifier", &code
->expr1
->where
);
9410 case EXEC_INIT_ASSIGN
:
9411 case EXEC_END_PROCEDURE
:
9418 if (gfc_check_vardef_context (code
->expr1
, false, false,
9419 _("assignment")) == FAILURE
)
9422 if (resolve_ordinary_assign (code
, ns
))
9424 if (code
->op
== EXEC_COMPCALL
)
9431 case EXEC_LABEL_ASSIGN
:
9432 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9433 gfc_error ("Label %d referenced at %L is never defined",
9434 code
->label1
->value
, &code
->label1
->where
);
9436 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9437 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9438 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9439 != gfc_default_integer_kind
9440 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9441 gfc_error ("ASSIGN statement at %L requires a scalar "
9442 "default INTEGER variable", &code
->expr1
->where
);
9445 case EXEC_POINTER_ASSIGN
:
9452 /* This is both a variable definition and pointer assignment
9453 context, so check both of them. For rank remapping, a final
9454 array ref may be present on the LHS and fool gfc_expr_attr
9455 used in gfc_check_vardef_context. Remove it. */
9456 e
= remove_last_array_ref (code
->expr1
);
9457 t
= gfc_check_vardef_context (e
, true, false,
9458 _("pointer assignment"));
9460 t
= gfc_check_vardef_context (e
, false, false,
9461 _("pointer assignment"));
9466 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9470 case EXEC_ARITHMETIC_IF
:
9472 && code
->expr1
->ts
.type
!= BT_INTEGER
9473 && code
->expr1
->ts
.type
!= BT_REAL
)
9474 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9475 "expression", &code
->expr1
->where
);
9477 resolve_branch (code
->label1
, code
);
9478 resolve_branch (code
->label2
, code
);
9479 resolve_branch (code
->label3
, code
);
9483 if (t
== SUCCESS
&& code
->expr1
!= NULL
9484 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9485 || code
->expr1
->rank
!= 0))
9486 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9487 &code
->expr1
->where
);
9492 resolve_call (code
);
9497 resolve_typebound_subroutine (code
);
9501 resolve_ppc_call (code
);
9505 /* Select is complicated. Also, a SELECT construct could be
9506 a transformed computed GOTO. */
9507 resolve_select (code
);
9510 case EXEC_SELECT_TYPE
:
9511 resolve_select_type (code
, ns
);
9515 resolve_block_construct (code
);
9519 if (code
->ext
.iterator
!= NULL
)
9521 gfc_iterator
*iter
= code
->ext
.iterator
;
9522 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9523 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9528 if (code
->expr1
== NULL
)
9529 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9531 && (code
->expr1
->rank
!= 0
9532 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9533 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9534 "a scalar LOGICAL expression", &code
->expr1
->where
);
9539 resolve_allocate_deallocate (code
, "ALLOCATE");
9543 case EXEC_DEALLOCATE
:
9545 resolve_allocate_deallocate (code
, "DEALLOCATE");
9550 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9553 resolve_branch (code
->ext
.open
->err
, code
);
9557 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9560 resolve_branch (code
->ext
.close
->err
, code
);
9563 case EXEC_BACKSPACE
:
9567 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9570 resolve_branch (code
->ext
.filepos
->err
, code
);
9574 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9577 resolve_branch (code
->ext
.inquire
->err
, code
);
9581 gcc_assert (code
->ext
.inquire
!= NULL
);
9582 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9585 resolve_branch (code
->ext
.inquire
->err
, code
);
9589 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9592 resolve_branch (code
->ext
.wait
->err
, code
);
9593 resolve_branch (code
->ext
.wait
->end
, code
);
9594 resolve_branch (code
->ext
.wait
->eor
, code
);
9599 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9602 resolve_branch (code
->ext
.dt
->err
, code
);
9603 resolve_branch (code
->ext
.dt
->end
, code
);
9604 resolve_branch (code
->ext
.dt
->eor
, code
);
9608 resolve_transfer (code
);
9611 case EXEC_DO_CONCURRENT
:
9613 resolve_forall_iterators (code
->ext
.forall_iterator
);
9615 if (code
->expr1
!= NULL
9616 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9617 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9618 "expression", &code
->expr1
->where
);
9621 case EXEC_OMP_ATOMIC
:
9622 case EXEC_OMP_BARRIER
:
9623 case EXEC_OMP_CRITICAL
:
9624 case EXEC_OMP_FLUSH
:
9626 case EXEC_OMP_MASTER
:
9627 case EXEC_OMP_ORDERED
:
9628 case EXEC_OMP_SECTIONS
:
9629 case EXEC_OMP_SINGLE
:
9630 case EXEC_OMP_TASKWAIT
:
9631 case EXEC_OMP_TASKYIELD
:
9632 case EXEC_OMP_WORKSHARE
:
9633 gfc_resolve_omp_directive (code
, ns
);
9636 case EXEC_OMP_PARALLEL
:
9637 case EXEC_OMP_PARALLEL_DO
:
9638 case EXEC_OMP_PARALLEL_SECTIONS
:
9639 case EXEC_OMP_PARALLEL_WORKSHARE
:
9641 omp_workshare_save
= omp_workshare_flag
;
9642 omp_workshare_flag
= 0;
9643 gfc_resolve_omp_directive (code
, ns
);
9644 omp_workshare_flag
= omp_workshare_save
;
9648 gfc_internal_error ("resolve_code(): Bad statement code");
9652 cs_base
= frame
.prev
;
9656 /* Resolve initial values and make sure they are compatible with
9660 resolve_values (gfc_symbol
*sym
)
9664 if (sym
->value
== NULL
)
9667 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9668 t
= resolve_structure_cons (sym
->value
, 1);
9670 t
= gfc_resolve_expr (sym
->value
);
9675 gfc_check_assign_symbol (sym
, sym
->value
);
9679 /* Verify the binding labels for common blocks that are BIND(C). The label
9680 for a BIND(C) common block must be identical in all scoping units in which
9681 the common block is declared. Further, the binding label can not collide
9682 with any other global entity in the program. */
9685 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9687 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9689 gfc_gsymbol
*binding_label_gsym
;
9690 gfc_gsymbol
*comm_name_gsym
;
9691 const char * bind_label
= comm_block_tree
->n
.common
->binding_label
9692 ? comm_block_tree
->n
.common
->binding_label
: "";
9694 /* See if a global symbol exists by the common block's name. It may
9695 be NULL if the common block is use-associated. */
9696 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9697 comm_block_tree
->n
.common
->name
);
9698 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9699 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9700 "with the global entity '%s' at %L",
9702 comm_block_tree
->n
.common
->name
,
9703 &(comm_block_tree
->n
.common
->where
),
9704 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9705 else if (comm_name_gsym
!= NULL
9706 && strcmp (comm_name_gsym
->name
,
9707 comm_block_tree
->n
.common
->name
) == 0)
9709 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9711 if (comm_name_gsym
->binding_label
== NULL
)
9712 /* No binding label for common block stored yet; save this one. */
9713 comm_name_gsym
->binding_label
= bind_label
;
9714 else if (strcmp (comm_name_gsym
->binding_label
, bind_label
) != 0)
9716 /* Common block names match but binding labels do not. */
9717 gfc_error ("Binding label '%s' for common block '%s' at %L "
9718 "does not match the binding label '%s' for common "
9721 comm_block_tree
->n
.common
->name
,
9722 &(comm_block_tree
->n
.common
->where
),
9723 comm_name_gsym
->binding_label
,
9724 comm_name_gsym
->name
,
9725 &(comm_name_gsym
->where
));
9730 /* There is no binding label (NAME="") so we have nothing further to
9731 check and nothing to add as a global symbol for the label. */
9732 if (!comm_block_tree
->n
.common
->binding_label
)
9735 binding_label_gsym
=
9736 gfc_find_gsymbol (gfc_gsym_root
,
9737 comm_block_tree
->n
.common
->binding_label
);
9738 if (binding_label_gsym
== NULL
)
9740 /* Need to make a global symbol for the binding label to prevent
9741 it from colliding with another. */
9742 binding_label_gsym
=
9743 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9744 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9745 binding_label_gsym
->type
= GSYM_COMMON
;
9749 /* If comm_name_gsym is NULL, the name common block is use
9750 associated and the name could be colliding. */
9751 if (binding_label_gsym
->type
!= GSYM_COMMON
)
9752 gfc_error ("Binding label '%s' for common block '%s' at %L "
9753 "collides with the global entity '%s' at %L",
9754 comm_block_tree
->n
.common
->binding_label
,
9755 comm_block_tree
->n
.common
->name
,
9756 &(comm_block_tree
->n
.common
->where
),
9757 binding_label_gsym
->name
,
9758 &(binding_label_gsym
->where
));
9759 else if (comm_name_gsym
!= NULL
9760 && (strcmp (binding_label_gsym
->name
,
9761 comm_name_gsym
->binding_label
) != 0)
9762 && (strcmp (binding_label_gsym
->sym_name
,
9763 comm_name_gsym
->name
) != 0))
9764 gfc_error ("Binding label '%s' for common block '%s' at %L "
9765 "collides with global entity '%s' at %L",
9766 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
9767 &(comm_block_tree
->n
.common
->where
),
9768 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9776 /* Verify any BIND(C) derived types in the namespace so we can report errors
9777 for them once, rather than for each variable declared of that type. */
9780 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
9782 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
9783 && derived_sym
->attr
.is_bind_c
== 1)
9784 verify_bind_c_derived_type (derived_sym
);
9790 /* Verify that any binding labels used in a given namespace do not collide
9791 with the names or binding labels of any global symbols. */
9794 gfc_verify_binding_labels (gfc_symbol
*sym
)
9798 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
9799 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
)
9801 gfc_gsymbol
*bind_c_sym
;
9803 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
9804 if (bind_c_sym
!= NULL
9805 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
9807 if (sym
->attr
.if_source
== IFSRC_DECL
9808 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
9809 && bind_c_sym
->type
!= GSYM_FUNCTION
)
9810 && ((sym
->attr
.contained
== 1
9811 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
9812 || (sym
->attr
.use_assoc
== 1
9813 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
9815 /* Make sure global procedures don't collide with anything. */
9816 gfc_error ("Binding label '%s' at %L collides with the global "
9817 "entity '%s' at %L", sym
->binding_label
,
9818 &(sym
->declared_at
), bind_c_sym
->name
,
9819 &(bind_c_sym
->where
));
9822 else if (sym
->attr
.contained
== 0
9823 && (sym
->attr
.if_source
== IFSRC_IFBODY
9824 && sym
->attr
.flavor
== FL_PROCEDURE
)
9825 && (bind_c_sym
->sym_name
!= NULL
9826 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
9828 /* Make sure procedures in interface bodies don't collide. */
9829 gfc_error ("Binding label '%s' in interface body at %L collides "
9830 "with the global entity '%s' at %L",
9832 &(sym
->declared_at
), bind_c_sym
->name
,
9833 &(bind_c_sym
->where
));
9836 else if (sym
->attr
.contained
== 0
9837 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
9838 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
9839 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
9840 || sym
->attr
.use_assoc
== 0)
9842 gfc_error ("Binding label '%s' at %L collides with global "
9843 "entity '%s' at %L", sym
->binding_label
,
9844 &(sym
->declared_at
), bind_c_sym
->name
,
9845 &(bind_c_sym
->where
));
9850 /* Clear the binding label to prevent checking multiple times. */
9851 sym
->binding_label
= NULL
;
9853 else if (bind_c_sym
== NULL
)
9855 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
9856 bind_c_sym
->where
= sym
->declared_at
;
9857 bind_c_sym
->sym_name
= sym
->name
;
9859 if (sym
->attr
.use_assoc
== 1)
9860 bind_c_sym
->mod_name
= sym
->module
;
9862 if (sym
->ns
->proc_name
!= NULL
)
9863 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
9865 if (sym
->attr
.contained
== 0)
9867 if (sym
->attr
.subroutine
)
9868 bind_c_sym
->type
= GSYM_SUBROUTINE
;
9869 else if (sym
->attr
.function
)
9870 bind_c_sym
->type
= GSYM_FUNCTION
;
9878 /* Resolve an index expression. */
9881 resolve_index_expr (gfc_expr
*e
)
9883 if (gfc_resolve_expr (e
) == FAILURE
)
9886 if (gfc_simplify_expr (e
, 0) == FAILURE
)
9889 if (gfc_specification_expr (e
) == FAILURE
)
9896 /* Resolve a charlen structure. */
9899 resolve_charlen (gfc_charlen
*cl
)
9908 specification_expr
= 1;
9910 if (resolve_index_expr (cl
->length
) == FAILURE
)
9912 specification_expr
= 0;
9916 /* "If the character length parameter value evaluates to a negative
9917 value, the length of character entities declared is zero." */
9918 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
9920 if (gfc_option
.warn_surprising
)
9921 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9922 " the length has been set to zero",
9923 &cl
->length
->where
, i
);
9924 gfc_replace_expr (cl
->length
,
9925 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
9928 /* Check that the character length is not too large. */
9929 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
9930 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
9931 && cl
->length
->ts
.type
== BT_INTEGER
9932 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
9934 gfc_error ("String length at %L is too large", &cl
->length
->where
);
9942 /* Test for non-constant shape arrays. */
9945 is_non_constant_shape_array (gfc_symbol
*sym
)
9951 not_constant
= false;
9952 if (sym
->as
!= NULL
)
9954 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9955 has not been simplified; parameter array references. Do the
9956 simplification now. */
9957 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
9959 e
= sym
->as
->lower
[i
];
9960 if (e
&& (resolve_index_expr (e
) == FAILURE
9961 || !gfc_is_constant_expr (e
)))
9962 not_constant
= true;
9963 e
= sym
->as
->upper
[i
];
9964 if (e
&& (resolve_index_expr (e
) == FAILURE
9965 || !gfc_is_constant_expr (e
)))
9966 not_constant
= true;
9969 return not_constant
;
9972 /* Given a symbol and an initialization expression, add code to initialize
9973 the symbol to the function entry. */
9975 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
9979 gfc_namespace
*ns
= sym
->ns
;
9981 /* Search for the function namespace if this is a contained
9982 function without an explicit result. */
9983 if (sym
->attr
.function
&& sym
== sym
->result
9984 && sym
->name
!= sym
->ns
->proc_name
->name
)
9987 for (;ns
; ns
= ns
->sibling
)
9988 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
9994 gfc_free_expr (init
);
9998 /* Build an l-value expression for the result. */
9999 lval
= gfc_lval_expr_from_sym (sym
);
10001 /* Add the code at scope entry. */
10002 init_st
= gfc_get_code ();
10003 init_st
->next
= ns
->code
;
10004 ns
->code
= init_st
;
10006 /* Assign the default initializer to the l-value. */
10007 init_st
->loc
= sym
->declared_at
;
10008 init_st
->op
= EXEC_INIT_ASSIGN
;
10009 init_st
->expr1
= lval
;
10010 init_st
->expr2
= init
;
10013 /* Assign the default initializer to a derived type variable or result. */
10016 apply_default_init (gfc_symbol
*sym
)
10018 gfc_expr
*init
= NULL
;
10020 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10023 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10024 init
= gfc_default_initializer (&sym
->ts
);
10026 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10029 build_init_assign (sym
, init
);
10030 sym
->attr
.referenced
= 1;
10033 /* Build an initializer for a local integer, real, complex, logical, or
10034 character variable, based on the command line flags finit-local-zero,
10035 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10036 null if the symbol should not have a default initialization. */
10038 build_default_init_expr (gfc_symbol
*sym
)
10041 gfc_expr
*init_expr
;
10044 /* These symbols should never have a default initialization. */
10045 if (sym
->attr
.allocatable
10046 || sym
->attr
.external
10048 || sym
->attr
.pointer
10049 || sym
->attr
.in_equivalence
10050 || sym
->attr
.in_common
10053 || sym
->attr
.cray_pointee
10054 || sym
->attr
.cray_pointer
)
10057 /* Now we'll try to build an initializer expression. */
10058 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10059 &sym
->declared_at
);
10061 /* We will only initialize integers, reals, complex, logicals, and
10062 characters, and only if the corresponding command-line flags
10063 were set. Otherwise, we free init_expr and return null. */
10064 switch (sym
->ts
.type
)
10067 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10068 mpz_set_si (init_expr
->value
.integer
,
10069 gfc_option
.flag_init_integer_value
);
10072 gfc_free_expr (init_expr
);
10078 switch (gfc_option
.flag_init_real
)
10080 case GFC_INIT_REAL_SNAN
:
10081 init_expr
->is_snan
= 1;
10082 /* Fall through. */
10083 case GFC_INIT_REAL_NAN
:
10084 mpfr_set_nan (init_expr
->value
.real
);
10087 case GFC_INIT_REAL_INF
:
10088 mpfr_set_inf (init_expr
->value
.real
, 1);
10091 case GFC_INIT_REAL_NEG_INF
:
10092 mpfr_set_inf (init_expr
->value
.real
, -1);
10095 case GFC_INIT_REAL_ZERO
:
10096 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10100 gfc_free_expr (init_expr
);
10107 switch (gfc_option
.flag_init_real
)
10109 case GFC_INIT_REAL_SNAN
:
10110 init_expr
->is_snan
= 1;
10111 /* Fall through. */
10112 case GFC_INIT_REAL_NAN
:
10113 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10114 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10117 case GFC_INIT_REAL_INF
:
10118 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10119 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10122 case GFC_INIT_REAL_NEG_INF
:
10123 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10124 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10127 case GFC_INIT_REAL_ZERO
:
10128 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10132 gfc_free_expr (init_expr
);
10139 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10140 init_expr
->value
.logical
= 0;
10141 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10142 init_expr
->value
.logical
= 1;
10145 gfc_free_expr (init_expr
);
10151 /* For characters, the length must be constant in order to
10152 create a default initializer. */
10153 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10154 && sym
->ts
.u
.cl
->length
10155 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10157 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10158 init_expr
->value
.character
.length
= char_len
;
10159 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10160 for (i
= 0; i
< char_len
; i
++)
10161 init_expr
->value
.character
.string
[i
]
10162 = (unsigned char) gfc_option
.flag_init_character_value
;
10166 gfc_free_expr (init_expr
);
10169 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10170 && sym
->ts
.u
.cl
->length
)
10172 gfc_actual_arglist
*arg
;
10173 init_expr
= gfc_get_expr ();
10174 init_expr
->where
= sym
->declared_at
;
10175 init_expr
->ts
= sym
->ts
;
10176 init_expr
->expr_type
= EXPR_FUNCTION
;
10177 init_expr
->value
.function
.isym
=
10178 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10179 init_expr
->value
.function
.name
= "repeat";
10180 arg
= gfc_get_actual_arglist ();
10181 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10183 arg
->expr
->value
.character
.string
[0]
10184 = gfc_option
.flag_init_character_value
;
10185 arg
->next
= gfc_get_actual_arglist ();
10186 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10187 init_expr
->value
.function
.actual
= arg
;
10192 gfc_free_expr (init_expr
);
10198 /* Add an initialization expression to a local variable. */
10200 apply_default_init_local (gfc_symbol
*sym
)
10202 gfc_expr
*init
= NULL
;
10204 /* The symbol should be a variable or a function return value. */
10205 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10206 || (sym
->attr
.function
&& sym
->result
!= sym
))
10209 /* Try to build the initializer expression. If we can't initialize
10210 this symbol, then init will be NULL. */
10211 init
= build_default_init_expr (sym
);
10215 /* For saved variables, we don't want to add an initializer at function
10216 entry, so we just add a static initializer. Note that automatic variables
10217 are stack allocated even with -fno-automatic. */
10218 if (sym
->attr
.save
|| sym
->ns
->save_all
10219 || (gfc_option
.flag_max_stack_var_size
== 0
10220 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10222 /* Don't clobber an existing initializer! */
10223 gcc_assert (sym
->value
== NULL
);
10228 build_init_assign (sym
, init
);
10232 /* Resolution of common features of flavors variable and procedure. */
10235 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10237 gfc_array_spec
*as
;
10239 /* Avoid double diagnostics for function result symbols. */
10240 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
10241 && (sym
->ns
!= gfc_current_ns
))
10244 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10245 as
= CLASS_DATA (sym
)->as
;
10249 /* Constraints on deferred shape variable. */
10250 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10252 bool pointer
, allocatable
, dimension
;
10254 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10256 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10257 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10258 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10262 pointer
= sym
->attr
.pointer
;
10263 allocatable
= sym
->attr
.allocatable
;
10264 dimension
= sym
->attr
.dimension
;
10271 gfc_error ("Allocatable array '%s' at %L must have "
10272 "a deferred shape", sym
->name
, &sym
->declared_at
);
10275 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object '%s' at %L "
10276 "may not be ALLOCATABLE", sym
->name
,
10277 &sym
->declared_at
) == FAILURE
)
10281 if (pointer
&& dimension
)
10283 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10284 sym
->name
, &sym
->declared_at
);
10290 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10291 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10293 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10294 sym
->name
, &sym
->declared_at
);
10299 /* Constraints on polymorphic variables. */
10300 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10303 if (sym
->attr
.class_ok
10304 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10306 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10307 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10308 &sym
->declared_at
);
10313 /* Assume that use associated symbols were checked in the module ns.
10314 Class-variables that are associate-names are also something special
10315 and excepted from the test. */
10316 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10318 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10319 "or pointer", sym
->name
, &sym
->declared_at
);
10328 /* Additional checks for symbols with flavor variable and derived
10329 type. To be called from resolve_fl_variable. */
10332 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10334 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10336 /* Check to see if a derived type is blocked from being host
10337 associated by the presence of another class I symbol in the same
10338 namespace. 14.6.1.3 of the standard and the discussion on
10339 comp.lang.fortran. */
10340 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10341 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10344 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10345 if (s
&& s
->attr
.generic
)
10346 s
= gfc_find_dt_in_generic (s
);
10347 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10349 gfc_error ("The type '%s' cannot be host associated at %L "
10350 "because it is blocked by an incompatible object "
10351 "of the same name declared at %L",
10352 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10358 /* 4th constraint in section 11.3: "If an object of a type for which
10359 component-initialization is specified (R429) appears in the
10360 specification-part of a module and does not have the ALLOCATABLE
10361 or POINTER attribute, the object shall have the SAVE attribute."
10363 The check for initializers is performed with
10364 gfc_has_default_initializer because gfc_default_initializer generates
10365 a hidden default for allocatable components. */
10366 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10367 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10368 && !sym
->ns
->save_all
&& !sym
->attr
.save
10369 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10370 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10371 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Implied SAVE for "
10372 "module variable '%s' at %L, needed due to "
10373 "the default initialization", sym
->name
,
10374 &sym
->declared_at
) == FAILURE
)
10377 /* Assign default initializer. */
10378 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10379 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10381 sym
->value
= gfc_default_initializer (&sym
->ts
);
10388 /* Resolve symbols with flavor variable. */
10391 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10393 int no_init_flag
, automatic_flag
;
10395 const char *auto_save_msg
;
10397 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10400 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10403 /* Set this flag to check that variables are parameters of all entries.
10404 This check is effected by the call to gfc_resolve_expr through
10405 is_non_constant_shape_array. */
10406 specification_expr
= 1;
10408 if (sym
->ns
->proc_name
10409 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10410 || sym
->ns
->proc_name
->attr
.is_main_program
)
10411 && !sym
->attr
.use_assoc
10412 && !sym
->attr
.allocatable
10413 && !sym
->attr
.pointer
10414 && is_non_constant_shape_array (sym
))
10416 /* The shape of a main program or module array needs to be
10418 gfc_error ("The module or main program array '%s' at %L must "
10419 "have constant shape", sym
->name
, &sym
->declared_at
);
10420 specification_expr
= 0;
10424 /* Constraints on deferred type parameter. */
10425 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10427 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10428 "requires either the pointer or allocatable attribute",
10429 sym
->name
, &sym
->declared_at
);
10433 if (sym
->ts
.type
== BT_CHARACTER
)
10435 /* Make sure that character string variables with assumed length are
10436 dummy arguments. */
10437 e
= sym
->ts
.u
.cl
->length
;
10438 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10439 && !sym
->ts
.deferred
)
10441 gfc_error ("Entity with assumed character length at %L must be a "
10442 "dummy argument or a PARAMETER", &sym
->declared_at
);
10446 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10448 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10452 if (!gfc_is_constant_expr (e
)
10453 && !(e
->expr_type
== EXPR_VARIABLE
10454 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10456 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10457 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10458 || sym
->ns
->proc_name
->attr
.is_main_program
))
10460 gfc_error ("'%s' at %L must have constant character length "
10461 "in this context", sym
->name
, &sym
->declared_at
);
10464 if (sym
->attr
.in_common
)
10466 gfc_error ("COMMON variable '%s' at %L must have constant "
10467 "character length", sym
->name
, &sym
->declared_at
);
10473 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10474 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10476 /* Determine if the symbol may not have an initializer. */
10477 no_init_flag
= automatic_flag
= 0;
10478 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10479 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10481 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10482 && is_non_constant_shape_array (sym
))
10484 no_init_flag
= automatic_flag
= 1;
10486 /* Also, they must not have the SAVE attribute.
10487 SAVE_IMPLICIT is checked below. */
10488 if (sym
->as
&& sym
->attr
.codimension
)
10490 int corank
= sym
->as
->corank
;
10491 sym
->as
->corank
= 0;
10492 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10493 sym
->as
->corank
= corank
;
10495 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10497 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10502 /* Ensure that any initializer is simplified. */
10504 gfc_simplify_expr (sym
->value
, 1);
10506 /* Reject illegal initializers. */
10507 if (!sym
->mark
&& sym
->value
)
10509 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10510 && CLASS_DATA (sym
)->attr
.allocatable
))
10511 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10512 sym
->name
, &sym
->declared_at
);
10513 else if (sym
->attr
.external
)
10514 gfc_error ("External '%s' at %L cannot have an initializer",
10515 sym
->name
, &sym
->declared_at
);
10516 else if (sym
->attr
.dummy
10517 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10518 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10519 sym
->name
, &sym
->declared_at
);
10520 else if (sym
->attr
.intrinsic
)
10521 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10522 sym
->name
, &sym
->declared_at
);
10523 else if (sym
->attr
.result
)
10524 gfc_error ("Function result '%s' at %L cannot have an initializer",
10525 sym
->name
, &sym
->declared_at
);
10526 else if (automatic_flag
)
10527 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10528 sym
->name
, &sym
->declared_at
);
10530 goto no_init_error
;
10535 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10536 return resolve_fl_variable_derived (sym
, no_init_flag
);
10542 /* Resolve a procedure. */
10545 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10547 gfc_formal_arglist
*arg
;
10549 if (sym
->attr
.function
10550 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10553 if (sym
->ts
.type
== BT_CHARACTER
)
10555 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10557 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10558 && resolve_charlen (cl
) == FAILURE
)
10561 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10562 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10564 gfc_error ("Character-valued statement function '%s' at %L must "
10565 "have constant length", sym
->name
, &sym
->declared_at
);
10570 /* Ensure that derived type for are not of a private type. Internal
10571 module procedures are excluded by 2.2.3.3 - i.e., they are not
10572 externally accessible and can access all the objects accessible in
10574 if (!(sym
->ns
->parent
10575 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10576 && gfc_check_symbol_access (sym
))
10578 gfc_interface
*iface
;
10580 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10583 && arg
->sym
->ts
.type
== BT_DERIVED
10584 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10585 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10586 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
10587 "PRIVATE type and cannot be a dummy argument"
10588 " of '%s', which is PUBLIC at %L",
10589 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10592 /* Stop this message from recurring. */
10593 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10598 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10599 PRIVATE to the containing module. */
10600 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10602 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10605 && arg
->sym
->ts
.type
== BT_DERIVED
10606 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10607 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10608 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10609 "'%s' in PUBLIC interface '%s' at %L "
10610 "takes dummy arguments of '%s' which is "
10611 "PRIVATE", iface
->sym
->name
, sym
->name
,
10612 &iface
->sym
->declared_at
,
10613 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10615 /* Stop this message from recurring. */
10616 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10622 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10623 PRIVATE to the containing module. */
10624 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10626 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10629 && arg
->sym
->ts
.type
== BT_DERIVED
10630 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10631 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10632 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10633 "'%s' in PUBLIC interface '%s' at %L "
10634 "takes dummy arguments of '%s' which is "
10635 "PRIVATE", iface
->sym
->name
, sym
->name
,
10636 &iface
->sym
->declared_at
,
10637 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10639 /* Stop this message from recurring. */
10640 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10647 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10648 && !sym
->attr
.proc_pointer
)
10650 gfc_error ("Function '%s' at %L cannot have an initializer",
10651 sym
->name
, &sym
->declared_at
);
10655 /* An external symbol may not have an initializer because it is taken to be
10656 a procedure. Exception: Procedure Pointers. */
10657 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10659 gfc_error ("External object '%s' at %L may not have an initializer",
10660 sym
->name
, &sym
->declared_at
);
10664 /* An elemental function is required to return a scalar 12.7.1 */
10665 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10667 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10668 "result", sym
->name
, &sym
->declared_at
);
10669 /* Reset so that the error only occurs once. */
10670 sym
->attr
.elemental
= 0;
10674 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10675 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10677 gfc_error ("Statement function '%s' at %L may not have pointer or "
10678 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10682 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10683 char-len-param shall not be array-valued, pointer-valued, recursive
10684 or pure. ....snip... A character value of * may only be used in the
10685 following ways: (i) Dummy arg of procedure - dummy associates with
10686 actual length; (ii) To declare a named constant; or (iii) External
10687 function - but length must be declared in calling scoping unit. */
10688 if (sym
->attr
.function
10689 && sym
->ts
.type
== BT_CHARACTER
10690 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10692 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10693 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10695 if (sym
->as
&& sym
->as
->rank
)
10696 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10697 "array-valued", sym
->name
, &sym
->declared_at
);
10699 if (sym
->attr
.pointer
)
10700 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10701 "pointer-valued", sym
->name
, &sym
->declared_at
);
10703 if (sym
->attr
.pure
)
10704 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10705 "pure", sym
->name
, &sym
->declared_at
);
10707 if (sym
->attr
.recursive
)
10708 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10709 "recursive", sym
->name
, &sym
->declared_at
);
10714 /* Appendix B.2 of the standard. Contained functions give an
10715 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10716 character length is an F2003 feature. */
10717 if (!sym
->attr
.contained
10718 && gfc_current_form
!= FORM_FIXED
10719 && !sym
->ts
.deferred
)
10720 gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
10721 "CHARACTER(*) function '%s' at %L",
10722 sym
->name
, &sym
->declared_at
);
10725 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10727 gfc_formal_arglist
*curr_arg
;
10728 int has_non_interop_arg
= 0;
10730 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10731 sym
->common_block
) == FAILURE
)
10733 /* Clear these to prevent looking at them again if there was an
10735 sym
->attr
.is_bind_c
= 0;
10736 sym
->attr
.is_c_interop
= 0;
10737 sym
->ts
.is_c_interop
= 0;
10741 /* So far, no errors have been found. */
10742 sym
->attr
.is_c_interop
= 1;
10743 sym
->ts
.is_c_interop
= 1;
10746 curr_arg
= sym
->formal
;
10747 while (curr_arg
!= NULL
)
10749 /* Skip implicitly typed dummy args here. */
10750 if (curr_arg
->sym
->attr
.implicit_type
== 0)
10751 if (gfc_verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
10752 /* If something is found to fail, record the fact so we
10753 can mark the symbol for the procedure as not being
10754 BIND(C) to try and prevent multiple errors being
10756 has_non_interop_arg
= 1;
10758 curr_arg
= curr_arg
->next
;
10761 /* See if any of the arguments were not interoperable and if so, clear
10762 the procedure symbol to prevent duplicate error messages. */
10763 if (has_non_interop_arg
!= 0)
10765 sym
->attr
.is_c_interop
= 0;
10766 sym
->ts
.is_c_interop
= 0;
10767 sym
->attr
.is_bind_c
= 0;
10771 if (!sym
->attr
.proc_pointer
)
10773 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10775 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10776 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10779 if (sym
->attr
.intent
)
10781 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10782 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10785 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
10787 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10788 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10791 if (sym
->attr
.external
&& sym
->attr
.function
10792 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
10793 || sym
->attr
.contained
))
10795 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10796 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10799 if (strcmp ("ppr@", sym
->name
) == 0)
10801 gfc_error ("Procedure pointer result '%s' at %L "
10802 "is missing the pointer attribute",
10803 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
10812 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10813 been defined and we now know their defined arguments, check that they fulfill
10814 the requirements of the standard for procedures used as finalizers. */
10817 gfc_resolve_finalizers (gfc_symbol
* derived
)
10819 gfc_finalizer
* list
;
10820 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
10821 gfc_try result
= SUCCESS
;
10822 bool seen_scalar
= false;
10824 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
10827 /* Walk over the list of finalizer-procedures, check them, and if any one
10828 does not fit in with the standard's definition, print an error and remove
10829 it from the list. */
10830 prev_link
= &derived
->f2k_derived
->finalizers
;
10831 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
10837 /* Skip this finalizer if we already resolved it. */
10838 if (list
->proc_tree
)
10840 prev_link
= &(list
->next
);
10844 /* Check this exists and is a SUBROUTINE. */
10845 if (!list
->proc_sym
->attr
.subroutine
)
10847 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10848 list
->proc_sym
->name
, &list
->where
);
10852 /* We should have exactly one argument. */
10853 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
10855 gfc_error ("FINAL procedure at %L must have exactly one argument",
10859 arg
= list
->proc_sym
->formal
->sym
;
10861 /* This argument must be of our type. */
10862 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
10864 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10865 &arg
->declared_at
, derived
->name
);
10869 /* It must neither be a pointer nor allocatable nor optional. */
10870 if (arg
->attr
.pointer
)
10872 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10873 &arg
->declared_at
);
10876 if (arg
->attr
.allocatable
)
10878 gfc_error ("Argument of FINAL procedure at %L must not be"
10879 " ALLOCATABLE", &arg
->declared_at
);
10882 if (arg
->attr
.optional
)
10884 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10885 &arg
->declared_at
);
10889 /* It must not be INTENT(OUT). */
10890 if (arg
->attr
.intent
== INTENT_OUT
)
10892 gfc_error ("Argument of FINAL procedure at %L must not be"
10893 " INTENT(OUT)", &arg
->declared_at
);
10897 /* Warn if the procedure is non-scalar and not assumed shape. */
10898 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
10899 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
10900 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10901 " shape argument", &arg
->declared_at
);
10903 /* Check that it does not match in kind and rank with a FINAL procedure
10904 defined earlier. To really loop over the *earlier* declarations,
10905 we need to walk the tail of the list as new ones were pushed at the
10907 /* TODO: Handle kind parameters once they are implemented. */
10908 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
10909 for (i
= list
->next
; i
; i
= i
->next
)
10911 /* Argument list might be empty; that is an error signalled earlier,
10912 but we nevertheless continued resolving. */
10913 if (i
->proc_sym
->formal
)
10915 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
10916 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
10917 if (i_rank
== my_rank
)
10919 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10920 " rank (%d) as '%s'",
10921 list
->proc_sym
->name
, &list
->where
, my_rank
,
10922 i
->proc_sym
->name
);
10928 /* Is this the/a scalar finalizer procedure? */
10929 if (!arg
->as
|| arg
->as
->rank
== 0)
10930 seen_scalar
= true;
10932 /* Find the symtree for this procedure. */
10933 gcc_assert (!list
->proc_tree
);
10934 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
10936 prev_link
= &list
->next
;
10939 /* Remove wrong nodes immediately from the list so we don't risk any
10940 troubles in the future when they might fail later expectations. */
10944 *prev_link
= list
->next
;
10945 gfc_free_finalizer (i
);
10948 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10949 were nodes in the list, must have been for arrays. It is surely a good
10950 idea to have a scalar version there if there's something to finalize. */
10951 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
10952 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10953 " defined at %L, suggest also scalar one",
10954 derived
->name
, &derived
->declared_at
);
10956 /* TODO: Remove this error when finalization is finished. */
10957 gfc_error ("Finalization at %L is not yet implemented",
10958 &derived
->declared_at
);
10964 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10967 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
10968 const char* generic_name
, locus where
)
10973 gcc_assert (t1
->specific
&& t2
->specific
);
10974 gcc_assert (!t1
->specific
->is_generic
);
10975 gcc_assert (!t2
->specific
->is_generic
);
10976 gcc_assert (t1
->is_operator
== t2
->is_operator
);
10978 sym1
= t1
->specific
->u
.specific
->n
.sym
;
10979 sym2
= t2
->specific
->u
.specific
->n
.sym
;
10984 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10985 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
10986 || sym1
->attr
.function
!= sym2
->attr
.function
)
10988 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10989 " GENERIC '%s' at %L",
10990 sym1
->name
, sym2
->name
, generic_name
, &where
);
10994 /* Compare the interfaces. */
10995 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
10998 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10999 sym1
->name
, sym2
->name
, generic_name
, &where
);
11007 /* Worker function for resolving a generic procedure binding; this is used to
11008 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11010 The difference between those cases is finding possible inherited bindings
11011 that are overridden, as one has to look for them in tb_sym_root,
11012 tb_uop_root or tb_op, respectively. Thus the caller must already find
11013 the super-type and set p->overridden correctly. */
11016 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11017 gfc_typebound_proc
* p
, const char* name
)
11019 gfc_tbp_generic
* target
;
11020 gfc_symtree
* first_target
;
11021 gfc_symtree
* inherited
;
11023 gcc_assert (p
&& p
->is_generic
);
11025 /* Try to find the specific bindings for the symtrees in our target-list. */
11026 gcc_assert (p
->u
.generic
);
11027 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11028 if (!target
->specific
)
11030 gfc_typebound_proc
* overridden_tbp
;
11031 gfc_tbp_generic
* g
;
11032 const char* target_name
;
11034 target_name
= target
->specific_st
->name
;
11036 /* Defined for this type directly. */
11037 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11039 target
->specific
= target
->specific_st
->n
.tb
;
11040 goto specific_found
;
11043 /* Look for an inherited specific binding. */
11046 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11051 gcc_assert (inherited
->n
.tb
);
11052 target
->specific
= inherited
->n
.tb
;
11053 goto specific_found
;
11057 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11058 " at %L", target_name
, name
, &p
->where
);
11061 /* Once we've found the specific binding, check it is not ambiguous with
11062 other specifics already found or inherited for the same GENERIC. */
11064 gcc_assert (target
->specific
);
11066 /* This must really be a specific binding! */
11067 if (target
->specific
->is_generic
)
11069 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11070 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11074 /* Check those already resolved on this type directly. */
11075 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11076 if (g
!= target
&& g
->specific
11077 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
11081 /* Check for ambiguity with inherited specific targets. */
11082 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11083 overridden_tbp
= overridden_tbp
->overridden
)
11084 if (overridden_tbp
->is_generic
)
11086 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11088 gcc_assert (g
->specific
);
11089 if (check_generic_tbp_ambiguity (target
, g
,
11090 name
, p
->where
) == FAILURE
)
11096 /* If we attempt to "overwrite" a specific binding, this is an error. */
11097 if (p
->overridden
&& !p
->overridden
->is_generic
)
11099 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11100 " the same name", name
, &p
->where
);
11104 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11105 all must have the same attributes here. */
11106 first_target
= p
->u
.generic
->specific
->u
.specific
;
11107 gcc_assert (first_target
);
11108 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11109 p
->function
= first_target
->n
.sym
->attr
.function
;
11115 /* Resolve a GENERIC procedure binding for a derived type. */
11118 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11120 gfc_symbol
* super_type
;
11122 /* Find the overridden binding if any. */
11123 st
->n
.tb
->overridden
= NULL
;
11124 super_type
= gfc_get_derived_super_type (derived
);
11127 gfc_symtree
* overridden
;
11128 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11131 if (overridden
&& overridden
->n
.tb
)
11132 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11135 /* Resolve using worker function. */
11136 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11140 /* Retrieve the target-procedure of an operator binding and do some checks in
11141 common for intrinsic and user-defined type-bound operators. */
11144 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11146 gfc_symbol
* target_proc
;
11148 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11149 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11150 gcc_assert (target_proc
);
11152 /* All operator bindings must have a passed-object dummy argument. */
11153 if (target
->specific
->nopass
)
11155 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11159 return target_proc
;
11163 /* Resolve a type-bound intrinsic operator. */
11166 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11167 gfc_typebound_proc
* p
)
11169 gfc_symbol
* super_type
;
11170 gfc_tbp_generic
* target
;
11172 /* If there's already an error here, do nothing (but don't fail again). */
11176 /* Operators should always be GENERIC bindings. */
11177 gcc_assert (p
->is_generic
);
11179 /* Look for an overridden binding. */
11180 super_type
= gfc_get_derived_super_type (derived
);
11181 if (super_type
&& super_type
->f2k_derived
)
11182 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11185 p
->overridden
= NULL
;
11187 /* Resolve general GENERIC properties using worker function. */
11188 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
11191 /* Check the targets to be procedures of correct interface. */
11192 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11194 gfc_symbol
* target_proc
;
11196 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11200 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11212 /* Resolve a type-bound user operator (tree-walker callback). */
11214 static gfc_symbol
* resolve_bindings_derived
;
11215 static gfc_try resolve_bindings_result
;
11217 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
11220 resolve_typebound_user_op (gfc_symtree
* stree
)
11222 gfc_symbol
* super_type
;
11223 gfc_tbp_generic
* target
;
11225 gcc_assert (stree
&& stree
->n
.tb
);
11227 if (stree
->n
.tb
->error
)
11230 /* Operators should always be GENERIC bindings. */
11231 gcc_assert (stree
->n
.tb
->is_generic
);
11233 /* Find overridden procedure, if any. */
11234 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11235 if (super_type
&& super_type
->f2k_derived
)
11237 gfc_symtree
* overridden
;
11238 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11239 stree
->name
, true, NULL
);
11241 if (overridden
&& overridden
->n
.tb
)
11242 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11245 stree
->n
.tb
->overridden
= NULL
;
11247 /* Resolve basically using worker function. */
11248 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11252 /* Check the targets to be functions of correct interface. */
11253 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11255 gfc_symbol
* target_proc
;
11257 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11261 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11268 resolve_bindings_result
= FAILURE
;
11269 stree
->n
.tb
->error
= 1;
11273 /* Resolve the type-bound procedures for a derived type. */
11276 resolve_typebound_procedure (gfc_symtree
* stree
)
11280 gfc_symbol
* me_arg
;
11281 gfc_symbol
* super_type
;
11282 gfc_component
* comp
;
11284 gcc_assert (stree
);
11286 /* Undefined specific symbol from GENERIC target definition. */
11290 if (stree
->n
.tb
->error
)
11293 /* If this is a GENERIC binding, use that routine. */
11294 if (stree
->n
.tb
->is_generic
)
11296 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11302 /* Get the target-procedure to check it. */
11303 gcc_assert (!stree
->n
.tb
->is_generic
);
11304 gcc_assert (stree
->n
.tb
->u
.specific
);
11305 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11306 where
= stree
->n
.tb
->where
;
11308 /* Default access should already be resolved from the parser. */
11309 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11311 /* It should be a module procedure or an external procedure with explicit
11312 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11313 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11314 || (proc
->attr
.proc
!= PROC_MODULE
11315 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11316 || (proc
->attr
.abstract
&& !stree
->n
.tb
->deferred
))
11318 gfc_error ("'%s' must be a module procedure or an external procedure with"
11319 " an explicit interface at %L", proc
->name
, &where
);
11322 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11323 stree
->n
.tb
->function
= proc
->attr
.function
;
11325 /* Find the super-type of the current derived type. We could do this once and
11326 store in a global if speed is needed, but as long as not I believe this is
11327 more readable and clearer. */
11328 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11330 /* If PASS, resolve and check arguments if not already resolved / loaded
11331 from a .mod file. */
11332 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11334 if (stree
->n
.tb
->pass_arg
)
11336 gfc_formal_arglist
* i
;
11338 /* If an explicit passing argument name is given, walk the arg-list
11339 and look for it. */
11342 stree
->n
.tb
->pass_arg_num
= 1;
11343 for (i
= proc
->formal
; i
; i
= i
->next
)
11345 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11350 ++stree
->n
.tb
->pass_arg_num
;
11355 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11357 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11358 stree
->n
.tb
->pass_arg
);
11364 /* Otherwise, take the first one; there should in fact be at least
11366 stree
->n
.tb
->pass_arg_num
= 1;
11369 gfc_error ("Procedure '%s' with PASS at %L must have at"
11370 " least one argument", proc
->name
, &where
);
11373 me_arg
= proc
->formal
->sym
;
11376 /* Now check that the argument-type matches and the passed-object
11377 dummy argument is generally fine. */
11379 gcc_assert (me_arg
);
11381 if (me_arg
->ts
.type
!= BT_CLASS
)
11383 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11384 " at %L", proc
->name
, &where
);
11388 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11389 != resolve_bindings_derived
)
11391 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11392 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11393 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11397 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11398 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
> 0)
11400 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11401 " scalar", proc
->name
, &where
);
11404 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11406 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11407 " be ALLOCATABLE", proc
->name
, &where
);
11410 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11412 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11413 " be POINTER", proc
->name
, &where
);
11418 /* If we are extending some type, check that we don't override a procedure
11419 flagged NON_OVERRIDABLE. */
11420 stree
->n
.tb
->overridden
= NULL
;
11423 gfc_symtree
* overridden
;
11424 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11425 stree
->name
, true, NULL
);
11429 if (overridden
->n
.tb
)
11430 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11432 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
11437 /* See if there's a name collision with a component directly in this type. */
11438 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11439 if (!strcmp (comp
->name
, stree
->name
))
11441 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11443 stree
->name
, &where
, resolve_bindings_derived
->name
);
11447 /* Try to find a name collision with an inherited component. */
11448 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11450 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11451 " component of '%s'",
11452 stree
->name
, &where
, resolve_bindings_derived
->name
);
11456 stree
->n
.tb
->error
= 0;
11460 resolve_bindings_result
= FAILURE
;
11461 stree
->n
.tb
->error
= 1;
11466 resolve_typebound_procedures (gfc_symbol
* derived
)
11469 gfc_symbol
* super_type
;
11471 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11474 super_type
= gfc_get_derived_super_type (derived
);
11476 resolve_typebound_procedures (super_type
);
11478 resolve_bindings_derived
= derived
;
11479 resolve_bindings_result
= SUCCESS
;
11481 /* Make sure the vtab has been generated. */
11482 gfc_find_derived_vtab (derived
);
11484 if (derived
->f2k_derived
->tb_sym_root
)
11485 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11486 &resolve_typebound_procedure
);
11488 if (derived
->f2k_derived
->tb_uop_root
)
11489 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11490 &resolve_typebound_user_op
);
11492 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11494 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11495 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11497 resolve_bindings_result
= FAILURE
;
11500 return resolve_bindings_result
;
11504 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11505 to give all identical derived types the same backend_decl. */
11507 add_dt_to_dt_list (gfc_symbol
*derived
)
11509 gfc_dt_list
*dt_list
;
11511 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11512 if (derived
== dt_list
->derived
)
11515 dt_list
= gfc_get_dt_list ();
11516 dt_list
->next
= gfc_derived_types
;
11517 dt_list
->derived
= derived
;
11518 gfc_derived_types
= dt_list
;
11522 /* Ensure that a derived-type is really not abstract, meaning that every
11523 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11526 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11531 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11533 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11536 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11538 gfc_symtree
* overriding
;
11539 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11542 gcc_assert (overriding
->n
.tb
);
11543 if (overriding
->n
.tb
->deferred
)
11545 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11546 " '%s' is DEFERRED and not overridden",
11547 sub
->name
, &sub
->declared_at
, st
->name
);
11556 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11558 /* The algorithm used here is to recursively travel up the ancestry of sub
11559 and for each ancestor-type, check all bindings. If any of them is
11560 DEFERRED, look it up starting from sub and see if the found (overriding)
11561 binding is not DEFERRED.
11562 This is not the most efficient way to do this, but it should be ok and is
11563 clearer than something sophisticated. */
11565 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11567 if (!ancestor
->attr
.abstract
)
11570 /* Walk bindings of this ancestor. */
11571 if (ancestor
->f2k_derived
)
11574 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11579 /* Find next ancestor type and recurse on it. */
11580 ancestor
= gfc_get_derived_super_type (ancestor
);
11582 return ensure_not_abstract (sub
, ancestor
);
11588 /* Resolve the components of a derived type. This does not have to wait until
11589 resolution stage, but can be done as soon as the dt declaration has been
11593 resolve_fl_derived0 (gfc_symbol
*sym
)
11595 gfc_symbol
* super_type
;
11598 super_type
= gfc_get_derived_super_type (sym
);
11601 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11603 gfc_error ("As extending type '%s' at %L has a coarray component, "
11604 "parent type '%s' shall also have one", sym
->name
,
11605 &sym
->declared_at
, super_type
->name
);
11609 /* Ensure the extended type gets resolved before we do. */
11610 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
11613 /* An ABSTRACT type must be extensible. */
11614 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11616 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11617 sym
->name
, &sym
->declared_at
);
11621 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11624 for ( ; c
!= NULL
; c
= c
->next
)
11626 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11627 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
)
11629 gfc_error ("Deferred-length character component '%s' at %L is not "
11630 "yet supported", c
->name
, &c
->loc
);
11635 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
11636 && c
->attr
.codimension
11637 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11639 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11640 "deferred shape", c
->name
, &c
->loc
);
11645 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11646 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11648 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11649 "shall not be a coarray", c
->name
, &c
->loc
);
11654 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11655 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11656 || c
->attr
.allocatable
))
11658 gfc_error ("Component '%s' at %L with coarray component "
11659 "shall be a nonpointer, nonallocatable scalar",
11665 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11667 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11668 "is not an array pointer", c
->name
, &c
->loc
);
11672 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11674 if (c
->ts
.interface
->attr
.procedure
&& !sym
->attr
.vtype
)
11675 gfc_error ("Interface '%s', used by procedure pointer component "
11676 "'%s' at %L, is declared in a later PROCEDURE statement",
11677 c
->ts
.interface
->name
, c
->name
, &c
->loc
);
11679 /* Get the attributes from the interface (now resolved). */
11680 if (c
->ts
.interface
->attr
.if_source
11681 || c
->ts
.interface
->attr
.intrinsic
)
11683 gfc_symbol
*ifc
= c
->ts
.interface
;
11685 if (ifc
->formal
&& !ifc
->formal_ns
)
11686 resolve_symbol (ifc
);
11688 if (ifc
->attr
.intrinsic
)
11689 resolve_intrinsic (ifc
, &ifc
->declared_at
);
11693 c
->ts
= ifc
->result
->ts
;
11694 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11695 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11696 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
11697 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
11702 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
11703 c
->attr
.pointer
= ifc
->attr
.pointer
;
11704 c
->attr
.dimension
= ifc
->attr
.dimension
;
11705 c
->as
= gfc_copy_array_spec (ifc
->as
);
11707 c
->ts
.interface
= ifc
;
11708 c
->attr
.function
= ifc
->attr
.function
;
11709 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
11710 gfc_copy_formal_args_ppc (c
, ifc
);
11712 c
->attr
.pure
= ifc
->attr
.pure
;
11713 c
->attr
.elemental
= ifc
->attr
.elemental
;
11714 c
->attr
.recursive
= ifc
->attr
.recursive
;
11715 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
11716 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
11717 /* Replace symbols in array spec. */
11721 for (i
= 0; i
< c
->as
->rank
; i
++)
11723 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
11724 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
11727 /* Copy char length. */
11728 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
11730 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
11731 gfc_expr_replace_comp (cl
->length
, c
);
11732 if (cl
->length
&& !cl
->resolved
11733 && gfc_resolve_expr (cl
->length
) == FAILURE
)
11738 else if (!sym
->attr
.vtype
&& c
->ts
.interface
->name
[0] != '\0')
11740 gfc_error ("Interface '%s' of procedure pointer component "
11741 "'%s' at %L must be explicit", c
->ts
.interface
->name
,
11746 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
11748 /* Since PPCs are not implicitly typed, a PPC without an explicit
11749 interface must be a subroutine. */
11750 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
11753 /* Procedure pointer components: Check PASS arg. */
11754 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
11755 && !sym
->attr
.vtype
)
11757 gfc_symbol
* me_arg
;
11759 if (c
->tb
->pass_arg
)
11761 gfc_formal_arglist
* i
;
11763 /* If an explicit passing argument name is given, walk the arg-list
11764 and look for it. */
11767 c
->tb
->pass_arg_num
= 1;
11768 for (i
= c
->formal
; i
; i
= i
->next
)
11770 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
11775 c
->tb
->pass_arg_num
++;
11780 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11781 "at %L has no argument '%s'", c
->name
,
11782 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
11789 /* Otherwise, take the first one; there should in fact be at least
11791 c
->tb
->pass_arg_num
= 1;
11794 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11795 "must have at least one argument",
11800 me_arg
= c
->formal
->sym
;
11803 /* Now check that the argument-type matches. */
11804 gcc_assert (me_arg
);
11805 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
11806 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
11807 || (me_arg
->ts
.type
== BT_CLASS
11808 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
11810 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11811 " the derived type '%s'", me_arg
->name
, c
->name
,
11812 me_arg
->name
, &c
->loc
, sym
->name
);
11817 /* Check for C453. */
11818 if (me_arg
->attr
.dimension
)
11820 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11821 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
11827 if (me_arg
->attr
.pointer
)
11829 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11830 "may not have the POINTER attribute", me_arg
->name
,
11831 c
->name
, me_arg
->name
, &c
->loc
);
11836 if (me_arg
->attr
.allocatable
)
11838 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11839 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
11840 me_arg
->name
, &c
->loc
);
11845 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
11846 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11847 " at %L", c
->name
, &c
->loc
);
11851 /* Check type-spec if this is not the parent-type component. */
11852 if (((sym
->attr
.is_class
11853 && (!sym
->components
->ts
.u
.derived
->attr
.extension
11854 || c
!= sym
->components
->ts
.u
.derived
->components
))
11855 || (!sym
->attr
.is_class
11856 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
11857 && !sym
->attr
.vtype
11858 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
11861 /* If this type is an extension, set the accessibility of the parent
11864 && ((sym
->attr
.is_class
11865 && c
== sym
->components
->ts
.u
.derived
->components
)
11866 || (!sym
->attr
.is_class
&& c
== sym
->components
))
11867 && strcmp (super_type
->name
, c
->name
) == 0)
11868 c
->attr
.access
= super_type
->attr
.access
;
11870 /* If this type is an extension, see if this component has the same name
11871 as an inherited type-bound procedure. */
11872 if (super_type
&& !sym
->attr
.is_class
11873 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
11875 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11876 " inherited type-bound procedure",
11877 c
->name
, sym
->name
, &c
->loc
);
11881 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
11882 && !c
->ts
.deferred
)
11884 if (c
->ts
.u
.cl
->length
== NULL
11885 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
11886 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
11888 gfc_error ("Character length of component '%s' needs to "
11889 "be a constant specification expression at %L",
11891 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
11896 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
11897 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
11899 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11900 "length must be a POINTER or ALLOCATABLE",
11901 c
->name
, sym
->name
, &c
->loc
);
11905 if (c
->ts
.type
== BT_DERIVED
11906 && sym
->component_access
!= ACCESS_PRIVATE
11907 && gfc_check_symbol_access (sym
)
11908 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
11909 && !c
->ts
.u
.derived
->attr
.use_assoc
11910 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
11911 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: the component '%s' "
11912 "is a PRIVATE type and cannot be a component of "
11913 "'%s', which is PUBLIC at %L", c
->name
,
11914 sym
->name
, &sym
->declared_at
) == FAILURE
)
11917 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
11919 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11920 "type %s", c
->name
, &c
->loc
, sym
->name
);
11924 if (sym
->attr
.sequence
)
11926 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
11928 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11929 "not have the SEQUENCE attribute",
11930 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
11935 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
11936 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
11937 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11938 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
11939 CLASS_DATA (c
)->ts
.u
.derived
11940 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
11942 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
11943 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
11944 && !c
->ts
.u
.derived
->attr
.zero_comp
)
11946 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11947 "that has not been declared", c
->name
, sym
->name
,
11952 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
11953 && CLASS_DATA (c
)->attr
.class_pointer
11954 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
11955 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
11957 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11958 "that has not been declared", c
->name
, sym
->name
,
11964 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
11965 && (!c
->attr
.class_ok
11966 || !(CLASS_DATA (c
)->attr
.class_pointer
11967 || CLASS_DATA (c
)->attr
.allocatable
)))
11969 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11970 "or pointer", c
->name
, &c
->loc
);
11974 /* Ensure that all the derived type components are put on the
11975 derived type list; even in formal namespaces, where derived type
11976 pointer components might not have been declared. */
11977 if (c
->ts
.type
== BT_DERIVED
11979 && c
->ts
.u
.derived
->components
11981 && sym
!= c
->ts
.u
.derived
)
11982 add_dt_to_dt_list (c
->ts
.u
.derived
);
11984 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
11985 || c
->attr
.proc_pointer
11986 || c
->attr
.allocatable
)) == FAILURE
)
11990 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11991 all DEFERRED bindings are overridden. */
11992 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
11993 && !sym
->attr
.is_class
11994 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
11997 /* Add derived type to the derived type list. */
11998 add_dt_to_dt_list (sym
);
12004 /* The following procedure does the full resolution of a derived type,
12005 including resolution of all type-bound procedures (if present). In contrast
12006 to 'resolve_fl_derived0' this can only be done after the module has been
12007 parsed completely. */
12010 resolve_fl_derived (gfc_symbol
*sym
)
12012 gfc_symbol
*gen_dt
= NULL
;
12014 if (!sym
->attr
.is_class
)
12015 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12016 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12017 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Generic name '%s' of "
12018 "function '%s' at %L being the same name as derived "
12019 "type at %L", sym
->name
,
12020 gen_dt
->generic
->sym
== sym
12021 ? gen_dt
->generic
->next
->sym
->name
12022 : gen_dt
->generic
->sym
->name
,
12023 gen_dt
->generic
->sym
== sym
12024 ? &gen_dt
->generic
->next
->sym
->declared_at
12025 : &gen_dt
->generic
->sym
->declared_at
,
12026 &sym
->declared_at
) == FAILURE
)
12029 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12031 /* Fix up incomplete CLASS symbols. */
12032 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12033 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12034 if (vptr
->ts
.u
.derived
== NULL
)
12036 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12038 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12042 if (resolve_fl_derived0 (sym
) == FAILURE
)
12045 /* Resolve the type-bound procedures. */
12046 if (resolve_typebound_procedures (sym
) == FAILURE
)
12049 /* Resolve the finalizer procedures. */
12050 if (gfc_resolve_finalizers (sym
) == FAILURE
)
12058 resolve_fl_namelist (gfc_symbol
*sym
)
12063 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12065 /* Check again, the check in match only works if NAMELIST comes
12067 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12069 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12070 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12074 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12075 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
12076 "object '%s' with assumed shape in namelist "
12077 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12078 &sym
->declared_at
) == FAILURE
)
12081 if (is_non_constant_shape_array (nl
->sym
)
12082 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
12083 "object '%s' with nonconstant shape in namelist "
12084 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12085 &sym
->declared_at
) == FAILURE
)
12088 if (nl
->sym
->ts
.type
== BT_CHARACTER
12089 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12090 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12091 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
12092 "'%s' with nonconstant character length in "
12093 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
12094 &sym
->declared_at
) == FAILURE
)
12097 /* FIXME: Once UDDTIO is implemented, the following can be
12099 if (nl
->sym
->ts
.type
== BT_CLASS
)
12101 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12102 "polymorphic and requires a defined input/output "
12103 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12107 if (nl
->sym
->ts
.type
== BT_DERIVED
12108 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12109 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12111 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
12112 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12113 "or POINTER components", nl
->sym
->name
,
12114 sym
->name
, &sym
->declared_at
) == FAILURE
)
12117 /* FIXME: Once UDDTIO is implemented, the following can be
12119 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12120 "ALLOCATABLE or POINTER components and thus requires "
12121 "a defined input/output procedure", nl
->sym
->name
,
12122 sym
->name
, &sym
->declared_at
);
12127 /* Reject PRIVATE objects in a PUBLIC namelist. */
12128 if (gfc_check_symbol_access (sym
))
12130 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12132 if (!nl
->sym
->attr
.use_assoc
12133 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12134 && !gfc_check_symbol_access (nl
->sym
))
12136 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12137 "cannot be member of PUBLIC namelist '%s' at %L",
12138 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12142 /* Types with private components that came here by USE-association. */
12143 if (nl
->sym
->ts
.type
== BT_DERIVED
12144 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12146 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12147 "components and cannot be member of namelist '%s' at %L",
12148 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12152 /* Types with private components that are defined in the same module. */
12153 if (nl
->sym
->ts
.type
== BT_DERIVED
12154 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12155 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12157 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12158 "cannot be a member of PUBLIC namelist '%s' at %L",
12159 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12166 /* 14.1.2 A module or internal procedure represent local entities
12167 of the same type as a namelist member and so are not allowed. */
12168 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12170 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12173 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12174 if ((nl
->sym
== sym
->ns
->proc_name
)
12176 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12180 if (nl
->sym
&& nl
->sym
->name
)
12181 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12182 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12184 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12185 "attribute in '%s' at %L", nlsym
->name
,
12186 &sym
->declared_at
);
12196 resolve_fl_parameter (gfc_symbol
*sym
)
12198 /* A parameter array's shape needs to be constant. */
12199 if (sym
->as
!= NULL
12200 && (sym
->as
->type
== AS_DEFERRED
12201 || is_non_constant_shape_array (sym
)))
12203 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12204 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12208 /* Make sure a parameter that has been implicitly typed still
12209 matches the implicit type, since PARAMETER statements can precede
12210 IMPLICIT statements. */
12211 if (sym
->attr
.implicit_type
12212 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12215 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12216 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12220 /* Make sure the types of derived parameters are consistent. This
12221 type checking is deferred until resolution because the type may
12222 refer to a derived type from the host. */
12223 if (sym
->ts
.type
== BT_DERIVED
12224 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12226 gfc_error ("Incompatible derived type in PARAMETER at %L",
12227 &sym
->value
->where
);
12234 /* Do anything necessary to resolve a symbol. Right now, we just
12235 assume that an otherwise unknown symbol is a variable. This sort
12236 of thing commonly happens for symbols in module. */
12239 resolve_symbol (gfc_symbol
*sym
)
12241 int check_constant
, mp_flag
;
12242 gfc_symtree
*symtree
;
12243 gfc_symtree
*this_symtree
;
12246 symbol_attribute class_attr
;
12247 gfc_array_spec
*as
;
12249 if (sym
->attr
.flavor
== FL_UNKNOWN
12250 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12251 && !sym
->attr
.generic
&& !sym
->attr
.external
12252 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12255 /* If we find that a flavorless symbol is an interface in one of the
12256 parent namespaces, find its symtree in this namespace, free the
12257 symbol and set the symtree to point to the interface symbol. */
12258 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12260 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12261 if (symtree
&& (symtree
->n
.sym
->generic
||
12262 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12263 && sym
->ns
->construct_entities
)))
12265 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12267 gfc_release_symbol (sym
);
12268 symtree
->n
.sym
->refs
++;
12269 this_symtree
->n
.sym
= symtree
->n
.sym
;
12274 /* Otherwise give it a flavor according to such attributes as
12276 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12277 && sym
->attr
.intrinsic
== 0)
12278 sym
->attr
.flavor
= FL_VARIABLE
;
12279 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12281 sym
->attr
.flavor
= FL_PROCEDURE
;
12282 if (sym
->attr
.dimension
)
12283 sym
->attr
.function
= 1;
12287 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12288 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12290 if (sym
->attr
.procedure
&& sym
->ts
.interface
12291 && sym
->attr
.if_source
!= IFSRC_DECL
12292 && resolve_procedure_interface (sym
) == FAILURE
)
12295 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12296 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12298 if (sym
->attr
.external
)
12299 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12300 "at %L", &sym
->declared_at
);
12302 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12303 "at %L", &sym
->declared_at
);
12308 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12311 /* Symbols that are module procedures with results (functions) have
12312 the types and array specification copied for type checking in
12313 procedures that call them, as well as for saving to a module
12314 file. These symbols can't stand the scrutiny that their results
12316 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12318 /* Make sure that the intrinsic is consistent with its internal
12319 representation. This needs to be done before assigning a default
12320 type to avoid spurious warnings. */
12321 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12322 && resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12325 /* Resolve associate names. */
12327 resolve_assoc_var (sym
, true);
12329 /* Assign default type to symbols that need one and don't have one. */
12330 if (sym
->ts
.type
== BT_UNKNOWN
)
12332 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12334 gfc_set_default_type (sym
, 1, NULL
);
12337 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12338 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12339 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12340 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12342 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12344 /* The specific case of an external procedure should emit an error
12345 in the case that there is no implicit type. */
12347 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12350 /* Result may be in another namespace. */
12351 resolve_symbol (sym
->result
);
12353 if (!sym
->result
->attr
.proc_pointer
)
12355 sym
->ts
= sym
->result
->ts
;
12356 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12357 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12358 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12359 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12360 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12365 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12366 gfc_resolve_array_spec (sym
->result
->as
, false);
12368 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12370 as
= CLASS_DATA (sym
)->as
;
12371 class_attr
= CLASS_DATA (sym
)->attr
;
12372 class_attr
.pointer
= class_attr
.class_pointer
;
12376 class_attr
= sym
->attr
;
12381 if (sym
->attr
.contiguous
12382 && (!class_attr
.dimension
12383 || (as
->type
!= AS_ASSUMED_SHAPE
&& !class_attr
.pointer
)))
12385 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12386 "array pointer or an assumed-shape array", sym
->name
,
12387 &sym
->declared_at
);
12391 /* Assumed size arrays and assumed shape arrays must be dummy
12392 arguments. Array-spec's of implied-shape should have been resolved to
12393 AS_EXPLICIT already. */
12397 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12398 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12399 || as
->type
== AS_ASSUMED_SHAPE
)
12400 && sym
->attr
.dummy
== 0)
12402 if (as
->type
== AS_ASSUMED_SIZE
)
12403 gfc_error ("Assumed size array at %L must be a dummy argument",
12404 &sym
->declared_at
);
12406 gfc_error ("Assumed shape array at %L must be a dummy argument",
12407 &sym
->declared_at
);
12412 /* Make sure symbols with known intent or optional are really dummy
12413 variable. Because of ENTRY statement, this has to be deferred
12414 until resolution time. */
12416 if (!sym
->attr
.dummy
12417 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12419 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12423 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12425 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12426 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12430 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12432 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12433 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12435 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12436 "attribute must have constant length",
12437 sym
->name
, &sym
->declared_at
);
12441 if (sym
->ts
.is_c_interop
12442 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12444 gfc_error ("C interoperable character dummy variable '%s' at %L "
12445 "with VALUE attribute must have length one",
12446 sym
->name
, &sym
->declared_at
);
12451 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12452 && sym
->ts
.u
.derived
->attr
.generic
)
12454 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12455 if (!sym
->ts
.u
.derived
)
12457 gfc_error ("The derived type '%s' at %L is of type '%s', "
12458 "which has not been defined", sym
->name
,
12459 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12460 sym
->ts
.type
= BT_UNKNOWN
;
12465 if (sym
->ts
.type
== BT_ASSUMED
)
12467 /* TS 29113, C407a. */
12468 if (!sym
->attr
.dummy
)
12470 gfc_error ("Assumed type of variable %s at %L is only permitted "
12471 "for dummy variables", sym
->name
, &sym
->declared_at
);
12474 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12475 || sym
->attr
.pointer
|| sym
->attr
.value
)
12477 gfc_error ("Assumed-type variable %s at %L may not have the "
12478 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
12479 sym
->name
, &sym
->declared_at
);
12482 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
12484 gfc_error ("Assumed-type variable %s at %L shall not be an "
12485 "explicit-shape array", sym
->name
, &sym
->declared_at
);
12490 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12491 do this for something that was implicitly typed because that is handled
12492 in gfc_set_default_type. Handle dummy arguments and procedure
12493 definitions separately. Also, anything that is use associated is not
12494 handled here but instead is handled in the module it is declared in.
12495 Finally, derived type definitions are allowed to be BIND(C) since that
12496 only implies that they're interoperable, and they are checked fully for
12497 interoperability when a variable is declared of that type. */
12498 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12499 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12500 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12502 gfc_try t
= SUCCESS
;
12504 /* First, make sure the variable is declared at the
12505 module-level scope (J3/04-007, Section 15.3). */
12506 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12507 sym
->attr
.in_common
== 0)
12509 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12510 "is neither a COMMON block nor declared at the "
12511 "module level scope", sym
->name
, &(sym
->declared_at
));
12514 else if (sym
->common_head
!= NULL
)
12516 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12520 /* If type() declaration, we need to verify that the components
12521 of the given type are all C interoperable, etc. */
12522 if (sym
->ts
.type
== BT_DERIVED
&&
12523 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12525 /* Make sure the user marked the derived type as BIND(C). If
12526 not, call the verify routine. This could print an error
12527 for the derived type more than once if multiple variables
12528 of that type are declared. */
12529 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12530 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12534 /* Verify the variable itself as C interoperable if it
12535 is BIND(C). It is not possible for this to succeed if
12536 the verify_bind_c_derived_type failed, so don't have to handle
12537 any error returned by verify_bind_c_derived_type. */
12538 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12539 sym
->common_block
);
12544 /* clear the is_bind_c flag to prevent reporting errors more than
12545 once if something failed. */
12546 sym
->attr
.is_bind_c
= 0;
12551 /* If a derived type symbol has reached this point, without its
12552 type being declared, we have an error. Notice that most
12553 conditions that produce undefined derived types have already
12554 been dealt with. However, the likes of:
12555 implicit type(t) (t) ..... call foo (t) will get us here if
12556 the type is not declared in the scope of the implicit
12557 statement. Change the type to BT_UNKNOWN, both because it is so
12558 and to prevent an ICE. */
12559 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12560 && sym
->ts
.u
.derived
->components
== NULL
12561 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12563 gfc_error ("The derived type '%s' at %L is of type '%s', "
12564 "which has not been defined", sym
->name
,
12565 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12566 sym
->ts
.type
= BT_UNKNOWN
;
12570 /* Make sure that the derived type has been resolved and that the
12571 derived type is visible in the symbol's namespace, if it is a
12572 module function and is not PRIVATE. */
12573 if (sym
->ts
.type
== BT_DERIVED
12574 && sym
->ts
.u
.derived
->attr
.use_assoc
12575 && sym
->ns
->proc_name
12576 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12577 && resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12580 /* Unless the derived-type declaration is use associated, Fortran 95
12581 does not allow public entries of private derived types.
12582 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12583 161 in 95-006r3. */
12584 if (sym
->ts
.type
== BT_DERIVED
12585 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12586 && !sym
->ts
.u
.derived
->attr
.use_assoc
12587 && gfc_check_symbol_access (sym
)
12588 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
12589 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
12590 "of PRIVATE derived type '%s'",
12591 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12592 : "variable", sym
->name
, &sym
->declared_at
,
12593 sym
->ts
.u
.derived
->name
) == FAILURE
)
12596 /* F2008, C1302. */
12597 if (sym
->ts
.type
== BT_DERIVED
12598 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
12599 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
12600 || sym
->ts
.u
.derived
->attr
.lock_comp
)
12601 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
12603 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12604 "type LOCK_TYPE must be a coarray", sym
->name
,
12605 &sym
->declared_at
);
12609 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12610 default initialization is defined (5.1.2.4.4). */
12611 if (sym
->ts
.type
== BT_DERIVED
12613 && sym
->attr
.intent
== INTENT_OUT
12615 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12617 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12619 if (c
->initializer
)
12621 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12622 "ASSUMED SIZE and so cannot have a default initializer",
12623 sym
->name
, &sym
->declared_at
);
12630 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
12631 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
12633 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12634 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
12639 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12640 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12641 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12642 || class_attr
.codimension
)
12643 && (sym
->attr
.result
|| sym
->result
== sym
))
12645 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12646 "a coarray component", sym
->name
, &sym
->declared_at
);
12651 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12652 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12654 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12655 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12660 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12661 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12662 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12663 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
12664 || class_attr
.allocatable
))
12666 gfc_error ("Variable '%s' at %L with coarray component "
12667 "shall be a nonpointer, nonallocatable scalar",
12668 sym
->name
, &sym
->declared_at
);
12672 /* F2008, C526. The function-result case was handled above. */
12673 if (class_attr
.codimension
12674 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12675 || sym
->attr
.select_type_temporary
12676 || sym
->ns
->save_all
12677 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12678 || sym
->ns
->proc_name
->attr
.is_main_program
12679 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
12681 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12682 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
12686 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
12687 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
12689 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12690 "deferred shape", sym
->name
, &sym
->declared_at
);
12693 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
12694 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
12696 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12697 "deferred shape", sym
->name
, &sym
->declared_at
);
12702 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12703 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12704 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12705 || (class_attr
.codimension
&& class_attr
.allocatable
))
12706 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
12708 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12709 "allocatable coarray or have coarray components",
12710 sym
->name
, &sym
->declared_at
);
12714 if (class_attr
.codimension
&& sym
->attr
.dummy
12715 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
12717 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12718 "procedure '%s'", sym
->name
, &sym
->declared_at
,
12719 sym
->ns
->proc_name
->name
);
12723 switch (sym
->attr
.flavor
)
12726 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
12731 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
12736 if (resolve_fl_namelist (sym
) == FAILURE
)
12741 if (resolve_fl_parameter (sym
) == FAILURE
)
12749 /* Resolve array specifier. Check as well some constraints
12750 on COMMON blocks. */
12752 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
12754 /* Set the formal_arg_flag so that check_conflict will not throw
12755 an error for host associated variables in the specification
12756 expression for an array_valued function. */
12757 if (sym
->attr
.function
&& sym
->as
)
12758 formal_arg_flag
= 1;
12760 gfc_resolve_array_spec (sym
->as
, check_constant
);
12762 formal_arg_flag
= 0;
12764 /* Resolve formal namespaces. */
12765 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
12766 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
12767 gfc_resolve (sym
->formal_ns
);
12769 /* Make sure the formal namespace is present. */
12770 if (sym
->formal
&& !sym
->formal_ns
)
12772 gfc_formal_arglist
*formal
= sym
->formal
;
12773 while (formal
&& !formal
->sym
)
12774 formal
= formal
->next
;
12778 sym
->formal_ns
= formal
->sym
->ns
;
12779 sym
->formal_ns
->refs
++;
12783 /* Check threadprivate restrictions. */
12784 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
12785 && (!sym
->attr
.in_common
12786 && sym
->module
== NULL
12787 && (sym
->ns
->proc_name
== NULL
12788 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
12789 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
12791 /* If we have come this far we can apply default-initializers, as
12792 described in 14.7.5, to those variables that have not already
12793 been assigned one. */
12794 if (sym
->ts
.type
== BT_DERIVED
12795 && sym
->ns
== gfc_current_ns
12797 && !sym
->attr
.allocatable
12798 && !sym
->attr
.alloc_comp
)
12800 symbol_attribute
*a
= &sym
->attr
;
12802 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
12803 && !a
->in_common
&& !a
->use_assoc
12804 && (a
->referenced
|| a
->result
)
12805 && !(a
->function
&& sym
!= sym
->result
))
12806 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
12807 apply_default_init (sym
);
12810 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
12811 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
12812 && !CLASS_DATA (sym
)->attr
.class_pointer
12813 && !CLASS_DATA (sym
)->attr
.allocatable
)
12814 apply_default_init (sym
);
12816 /* If this symbol has a type-spec, check it. */
12817 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
12818 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
12819 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
12825 /************* Resolve DATA statements *************/
12829 gfc_data_value
*vnode
;
12835 /* Advance the values structure to point to the next value in the data list. */
12838 next_data_value (void)
12840 while (mpz_cmp_ui (values
.left
, 0) == 0)
12843 if (values
.vnode
->next
== NULL
)
12846 values
.vnode
= values
.vnode
->next
;
12847 mpz_set (values
.left
, values
.vnode
->repeat
);
12855 check_data_variable (gfc_data_variable
*var
, locus
*where
)
12861 ar_type mark
= AR_UNKNOWN
;
12863 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
12869 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
12873 mpz_init_set_si (offset
, 0);
12876 if (e
->expr_type
!= EXPR_VARIABLE
)
12877 gfc_internal_error ("check_data_variable(): Bad expression");
12879 sym
= e
->symtree
->n
.sym
;
12881 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
12883 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12884 sym
->name
, &sym
->declared_at
);
12887 if (e
->ref
== NULL
&& sym
->as
)
12889 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12890 " declaration", sym
->name
, where
);
12894 has_pointer
= sym
->attr
.pointer
;
12896 if (gfc_is_coindexed (e
))
12898 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
12903 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12905 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
12909 && ref
->type
== REF_ARRAY
12910 && ref
->u
.ar
.type
!= AR_FULL
)
12912 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12913 "be a full array", sym
->name
, where
);
12918 if (e
->rank
== 0 || has_pointer
)
12920 mpz_init_set_ui (size
, 1);
12927 /* Find the array section reference. */
12928 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12930 if (ref
->type
!= REF_ARRAY
)
12932 if (ref
->u
.ar
.type
== AR_ELEMENT
)
12938 /* Set marks according to the reference pattern. */
12939 switch (ref
->u
.ar
.type
)
12947 /* Get the start position of array section. */
12948 gfc_get_section_index (ar
, section_index
, &offset
);
12953 gcc_unreachable ();
12956 if (gfc_array_size (e
, &size
) == FAILURE
)
12958 gfc_error ("Nonconstant array section at %L in DATA statement",
12960 mpz_clear (offset
);
12967 while (mpz_cmp_ui (size
, 0) > 0)
12969 if (next_data_value () == FAILURE
)
12971 gfc_error ("DATA statement at %L has more variables than values",
12977 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
12981 /* If we have more than one element left in the repeat count,
12982 and we have more than one element left in the target variable,
12983 then create a range assignment. */
12984 /* FIXME: Only done for full arrays for now, since array sections
12986 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
12987 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
12991 if (mpz_cmp (size
, values
.left
) >= 0)
12993 mpz_init_set (range
, values
.left
);
12994 mpz_sub (size
, size
, values
.left
);
12995 mpz_set_ui (values
.left
, 0);
12999 mpz_init_set (range
, size
);
13000 mpz_sub (values
.left
, values
.left
, size
);
13001 mpz_set_ui (size
, 0);
13004 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13007 mpz_add (offset
, offset
, range
);
13014 /* Assign initial value to symbol. */
13017 mpz_sub_ui (values
.left
, values
.left
, 1);
13018 mpz_sub_ui (size
, size
, 1);
13020 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13025 if (mark
== AR_FULL
)
13026 mpz_add_ui (offset
, offset
, 1);
13028 /* Modify the array section indexes and recalculate the offset
13029 for next element. */
13030 else if (mark
== AR_SECTION
)
13031 gfc_advance_section (section_index
, ar
, &offset
);
13035 if (mark
== AR_SECTION
)
13037 for (i
= 0; i
< ar
->dimen
; i
++)
13038 mpz_clear (section_index
[i
]);
13042 mpz_clear (offset
);
13048 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
13050 /* Iterate over a list of elements in a DATA statement. */
13053 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13056 iterator_stack frame
;
13057 gfc_expr
*e
, *start
, *end
, *step
;
13058 gfc_try retval
= SUCCESS
;
13060 mpz_init (frame
.value
);
13063 start
= gfc_copy_expr (var
->iter
.start
);
13064 end
= gfc_copy_expr (var
->iter
.end
);
13065 step
= gfc_copy_expr (var
->iter
.step
);
13067 if (gfc_simplify_expr (start
, 1) == FAILURE
13068 || start
->expr_type
!= EXPR_CONSTANT
)
13070 gfc_error ("start of implied-do loop at %L could not be "
13071 "simplified to a constant value", &start
->where
);
13075 if (gfc_simplify_expr (end
, 1) == FAILURE
13076 || end
->expr_type
!= EXPR_CONSTANT
)
13078 gfc_error ("end of implied-do loop at %L could not be "
13079 "simplified to a constant value", &start
->where
);
13083 if (gfc_simplify_expr (step
, 1) == FAILURE
13084 || step
->expr_type
!= EXPR_CONSTANT
)
13086 gfc_error ("step of implied-do loop at %L could not be "
13087 "simplified to a constant value", &start
->where
);
13092 mpz_set (trip
, end
->value
.integer
);
13093 mpz_sub (trip
, trip
, start
->value
.integer
);
13094 mpz_add (trip
, trip
, step
->value
.integer
);
13096 mpz_div (trip
, trip
, step
->value
.integer
);
13098 mpz_set (frame
.value
, start
->value
.integer
);
13100 frame
.prev
= iter_stack
;
13101 frame
.variable
= var
->iter
.var
->symtree
;
13102 iter_stack
= &frame
;
13104 while (mpz_cmp_ui (trip
, 0) > 0)
13106 if (traverse_data_var (var
->list
, where
) == FAILURE
)
13112 e
= gfc_copy_expr (var
->expr
);
13113 if (gfc_simplify_expr (e
, 1) == FAILURE
)
13120 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13122 mpz_sub_ui (trip
, trip
, 1);
13126 mpz_clear (frame
.value
);
13129 gfc_free_expr (start
);
13130 gfc_free_expr (end
);
13131 gfc_free_expr (step
);
13133 iter_stack
= frame
.prev
;
13138 /* Type resolve variables in the variable list of a DATA statement. */
13141 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13145 for (; var
; var
= var
->next
)
13147 if (var
->expr
== NULL
)
13148 t
= traverse_data_list (var
, where
);
13150 t
= check_data_variable (var
, where
);
13160 /* Resolve the expressions and iterators associated with a data statement.
13161 This is separate from the assignment checking because data lists should
13162 only be resolved once. */
13165 resolve_data_variables (gfc_data_variable
*d
)
13167 for (; d
; d
= d
->next
)
13169 if (d
->list
== NULL
)
13171 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
13176 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
13179 if (resolve_data_variables (d
->list
) == FAILURE
)
13188 /* Resolve a single DATA statement. We implement this by storing a pointer to
13189 the value list into static variables, and then recursively traversing the
13190 variables list, expanding iterators and such. */
13193 resolve_data (gfc_data
*d
)
13196 if (resolve_data_variables (d
->var
) == FAILURE
)
13199 values
.vnode
= d
->value
;
13200 if (d
->value
== NULL
)
13201 mpz_set_ui (values
.left
, 0);
13203 mpz_set (values
.left
, d
->value
->repeat
);
13205 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
13208 /* At this point, we better not have any values left. */
13210 if (next_data_value () == SUCCESS
)
13211 gfc_error ("DATA statement at %L has more values than variables",
13216 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13217 accessed by host or use association, is a dummy argument to a pure function,
13218 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13219 is storage associated with any such variable, shall not be used in the
13220 following contexts: (clients of this function). */
13222 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13223 procedure. Returns zero if assignment is OK, nonzero if there is a
13226 gfc_impure_variable (gfc_symbol
*sym
)
13231 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13234 /* Check if the symbol's ns is inside the pure procedure. */
13235 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13239 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13243 proc
= sym
->ns
->proc_name
;
13244 if (sym
->attr
.dummy
&& gfc_pure (proc
)
13245 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13247 proc
->attr
.function
))
13250 /* TODO: Sort out what can be storage associated, if anything, and include
13251 it here. In principle equivalences should be scanned but it does not
13252 seem to be possible to storage associate an impure variable this way. */
13257 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13258 current namespace is inside a pure procedure. */
13261 gfc_pure (gfc_symbol
*sym
)
13263 symbol_attribute attr
;
13268 /* Check if the current namespace or one of its parents
13269 belongs to a pure procedure. */
13270 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13272 sym
= ns
->proc_name
;
13276 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13284 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13288 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13289 checks if the current namespace is implicitly pure. Note that this
13290 function returns false for a PURE procedure. */
13293 gfc_implicit_pure (gfc_symbol
*sym
)
13299 /* Check if the current procedure is implicit_pure. Walk up
13300 the procedure list until we find a procedure. */
13301 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13303 sym
= ns
->proc_name
;
13307 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13312 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13313 && !sym
->attr
.pure
;
13317 /* Test whether the current procedure is elemental or not. */
13320 gfc_elemental (gfc_symbol
*sym
)
13322 symbol_attribute attr
;
13325 sym
= gfc_current_ns
->proc_name
;
13330 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13334 /* Warn about unused labels. */
13337 warn_unused_fortran_label (gfc_st_label
*label
)
13342 warn_unused_fortran_label (label
->left
);
13344 if (label
->defined
== ST_LABEL_UNKNOWN
)
13347 switch (label
->referenced
)
13349 case ST_LABEL_UNKNOWN
:
13350 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13354 case ST_LABEL_BAD_TARGET
:
13355 gfc_warning ("Label %d at %L defined but cannot be used",
13356 label
->value
, &label
->where
);
13363 warn_unused_fortran_label (label
->right
);
13367 /* Returns the sequence type of a symbol or sequence. */
13370 sequence_type (gfc_typespec ts
)
13379 if (ts
.u
.derived
->components
== NULL
)
13380 return SEQ_NONDEFAULT
;
13382 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13383 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13384 if (sequence_type (c
->ts
) != result
)
13390 if (ts
.kind
!= gfc_default_character_kind
)
13391 return SEQ_NONDEFAULT
;
13393 return SEQ_CHARACTER
;
13396 if (ts
.kind
!= gfc_default_integer_kind
)
13397 return SEQ_NONDEFAULT
;
13399 return SEQ_NUMERIC
;
13402 if (!(ts
.kind
== gfc_default_real_kind
13403 || ts
.kind
== gfc_default_double_kind
))
13404 return SEQ_NONDEFAULT
;
13406 return SEQ_NUMERIC
;
13409 if (ts
.kind
!= gfc_default_complex_kind
)
13410 return SEQ_NONDEFAULT
;
13412 return SEQ_NUMERIC
;
13415 if (ts
.kind
!= gfc_default_logical_kind
)
13416 return SEQ_NONDEFAULT
;
13418 return SEQ_NUMERIC
;
13421 return SEQ_NONDEFAULT
;
13426 /* Resolve derived type EQUIVALENCE object. */
13429 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13431 gfc_component
*c
= derived
->components
;
13436 /* Shall not be an object of nonsequence derived type. */
13437 if (!derived
->attr
.sequence
)
13439 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13440 "attribute to be an EQUIVALENCE object", sym
->name
,
13445 /* Shall not have allocatable components. */
13446 if (derived
->attr
.alloc_comp
)
13448 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13449 "components to be an EQUIVALENCE object",sym
->name
,
13454 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13456 gfc_error ("Derived type variable '%s' at %L with default "
13457 "initialization cannot be in EQUIVALENCE with a variable "
13458 "in COMMON", sym
->name
, &e
->where
);
13462 for (; c
; c
= c
->next
)
13464 if (c
->ts
.type
== BT_DERIVED
13465 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13468 /* Shall not be an object of sequence derived type containing a pointer
13469 in the structure. */
13470 if (c
->attr
.pointer
)
13472 gfc_error ("Derived type variable '%s' at %L with pointer "
13473 "component(s) cannot be an EQUIVALENCE object",
13474 sym
->name
, &e
->where
);
13482 /* Resolve equivalence object.
13483 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13484 an allocatable array, an object of nonsequence derived type, an object of
13485 sequence derived type containing a pointer at any level of component
13486 selection, an automatic object, a function name, an entry name, a result
13487 name, a named constant, a structure component, or a subobject of any of
13488 the preceding objects. A substring shall not have length zero. A
13489 derived type shall not have components with default initialization nor
13490 shall two objects of an equivalence group be initialized.
13491 Either all or none of the objects shall have an protected attribute.
13492 The simple constraints are done in symbol.c(check_conflict) and the rest
13493 are implemented here. */
13496 resolve_equivalence (gfc_equiv
*eq
)
13499 gfc_symbol
*first_sym
;
13502 locus
*last_where
= NULL
;
13503 seq_type eq_type
, last_eq_type
;
13504 gfc_typespec
*last_ts
;
13505 int object
, cnt_protected
;
13508 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13510 first_sym
= eq
->expr
->symtree
->n
.sym
;
13514 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13518 e
->ts
= e
->symtree
->n
.sym
->ts
;
13519 /* match_varspec might not know yet if it is seeing
13520 array reference or substring reference, as it doesn't
13522 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13524 gfc_ref
*ref
= e
->ref
;
13525 sym
= e
->symtree
->n
.sym
;
13527 if (sym
->attr
.dimension
)
13529 ref
->u
.ar
.as
= sym
->as
;
13533 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13534 if (e
->ts
.type
== BT_CHARACTER
13536 && ref
->type
== REF_ARRAY
13537 && ref
->u
.ar
.dimen
== 1
13538 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13539 && ref
->u
.ar
.stride
[0] == NULL
)
13541 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13542 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13545 /* Optimize away the (:) reference. */
13546 if (start
== NULL
&& end
== NULL
)
13549 e
->ref
= ref
->next
;
13551 e
->ref
->next
= ref
->next
;
13556 ref
->type
= REF_SUBSTRING
;
13558 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13560 ref
->u
.ss
.start
= start
;
13561 if (end
== NULL
&& e
->ts
.u
.cl
)
13562 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13563 ref
->u
.ss
.end
= end
;
13564 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13571 /* Any further ref is an error. */
13574 gcc_assert (ref
->type
== REF_ARRAY
);
13575 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13581 if (gfc_resolve_expr (e
) == FAILURE
)
13584 sym
= e
->symtree
->n
.sym
;
13586 if (sym
->attr
.is_protected
)
13588 if (cnt_protected
> 0 && cnt_protected
!= object
)
13590 gfc_error ("Either all or none of the objects in the "
13591 "EQUIVALENCE set at %L shall have the "
13592 "PROTECTED attribute",
13597 /* Shall not equivalence common block variables in a PURE procedure. */
13598 if (sym
->ns
->proc_name
13599 && sym
->ns
->proc_name
->attr
.pure
13600 && sym
->attr
.in_common
)
13602 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13603 "object in the pure procedure '%s'",
13604 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13608 /* Shall not be a named constant. */
13609 if (e
->expr_type
== EXPR_CONSTANT
)
13611 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13612 "object", sym
->name
, &e
->where
);
13616 if (e
->ts
.type
== BT_DERIVED
13617 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13620 /* Check that the types correspond correctly:
13622 A numeric sequence structure may be equivalenced to another sequence
13623 structure, an object of default integer type, default real type, double
13624 precision real type, default logical type such that components of the
13625 structure ultimately only become associated to objects of the same
13626 kind. A character sequence structure may be equivalenced to an object
13627 of default character kind or another character sequence structure.
13628 Other objects may be equivalenced only to objects of the same type and
13629 kind parameters. */
13631 /* Identical types are unconditionally OK. */
13632 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13633 goto identical_types
;
13635 last_eq_type
= sequence_type (*last_ts
);
13636 eq_type
= sequence_type (sym
->ts
);
13638 /* Since the pair of objects is not of the same type, mixed or
13639 non-default sequences can be rejected. */
13641 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13642 "statement at %L with different type objects";
13644 && last_eq_type
== SEQ_MIXED
13645 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13647 || (eq_type
== SEQ_MIXED
13648 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13649 &e
->where
) == FAILURE
))
13652 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13653 "statement at %L with objects of different type";
13655 && last_eq_type
== SEQ_NONDEFAULT
13656 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13657 last_where
) == FAILURE
)
13658 || (eq_type
== SEQ_NONDEFAULT
13659 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13660 &e
->where
) == FAILURE
))
13663 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13664 "EQUIVALENCE statement at %L";
13665 if (last_eq_type
== SEQ_CHARACTER
13666 && eq_type
!= SEQ_CHARACTER
13667 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13668 &e
->where
) == FAILURE
)
13671 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13672 "EQUIVALENCE statement at %L";
13673 if (last_eq_type
== SEQ_NUMERIC
13674 && eq_type
!= SEQ_NUMERIC
13675 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13676 &e
->where
) == FAILURE
)
13681 last_where
= &e
->where
;
13686 /* Shall not be an automatic array. */
13687 if (e
->ref
->type
== REF_ARRAY
13688 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
13690 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13691 "an EQUIVALENCE object", sym
->name
, &e
->where
);
13698 /* Shall not be a structure component. */
13699 if (r
->type
== REF_COMPONENT
)
13701 gfc_error ("Structure component '%s' at %L cannot be an "
13702 "EQUIVALENCE object",
13703 r
->u
.c
.component
->name
, &e
->where
);
13707 /* A substring shall not have length zero. */
13708 if (r
->type
== REF_SUBSTRING
)
13710 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
13712 gfc_error ("Substring at %L has length zero",
13713 &r
->u
.ss
.start
->where
);
13723 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13726 resolve_fntype (gfc_namespace
*ns
)
13728 gfc_entry_list
*el
;
13731 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
13734 /* If there are any entries, ns->proc_name is the entry master
13735 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13737 sym
= ns
->entries
->sym
;
13739 sym
= ns
->proc_name
;
13740 if (sym
->result
== sym
13741 && sym
->ts
.type
== BT_UNKNOWN
13742 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
13743 && !sym
->attr
.untyped
)
13745 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13746 sym
->name
, &sym
->declared_at
);
13747 sym
->attr
.untyped
= 1;
13750 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
13751 && !sym
->attr
.contained
13752 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13753 && gfc_check_symbol_access (sym
))
13755 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
13756 "%L of PRIVATE type '%s'", sym
->name
,
13757 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13761 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
13763 if (el
->sym
->result
== el
->sym
13764 && el
->sym
->ts
.type
== BT_UNKNOWN
13765 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
13766 && !el
->sym
->attr
.untyped
)
13768 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13769 el
->sym
->name
, &el
->sym
->declared_at
);
13770 el
->sym
->attr
.untyped
= 1;
13776 /* 12.3.2.1.1 Defined operators. */
13779 check_uop_procedure (gfc_symbol
*sym
, locus where
)
13781 gfc_formal_arglist
*formal
;
13783 if (!sym
->attr
.function
)
13785 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13786 sym
->name
, &where
);
13790 if (sym
->ts
.type
== BT_CHARACTER
13791 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
13792 && !(sym
->result
&& sym
->result
->ts
.u
.cl
13793 && sym
->result
->ts
.u
.cl
->length
))
13795 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13796 "character length", sym
->name
, &where
);
13800 formal
= sym
->formal
;
13801 if (!formal
|| !formal
->sym
)
13803 gfc_error ("User operator procedure '%s' at %L must have at least "
13804 "one argument", sym
->name
, &where
);
13808 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13810 gfc_error ("First argument of operator interface at %L must be "
13811 "INTENT(IN)", &where
);
13815 if (formal
->sym
->attr
.optional
)
13817 gfc_error ("First argument of operator interface at %L cannot be "
13818 "optional", &where
);
13822 formal
= formal
->next
;
13823 if (!formal
|| !formal
->sym
)
13826 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13828 gfc_error ("Second argument of operator interface at %L must be "
13829 "INTENT(IN)", &where
);
13833 if (formal
->sym
->attr
.optional
)
13835 gfc_error ("Second argument of operator interface at %L cannot be "
13836 "optional", &where
);
13842 gfc_error ("Operator interface at %L must have, at most, two "
13843 "arguments", &where
);
13851 gfc_resolve_uops (gfc_symtree
*symtree
)
13853 gfc_interface
*itr
;
13855 if (symtree
== NULL
)
13858 gfc_resolve_uops (symtree
->left
);
13859 gfc_resolve_uops (symtree
->right
);
13861 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
13862 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
13866 /* Examine all of the expressions associated with a program unit,
13867 assign types to all intermediate expressions, make sure that all
13868 assignments are to compatible types and figure out which names
13869 refer to which functions or subroutines. It doesn't check code
13870 block, which is handled by resolve_code. */
13873 resolve_types (gfc_namespace
*ns
)
13879 gfc_namespace
* old_ns
= gfc_current_ns
;
13881 /* Check that all IMPLICIT types are ok. */
13882 if (!ns
->seen_implicit_none
)
13885 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
13886 if (ns
->set_flag
[letter
]
13887 && resolve_typespec_used (&ns
->default_type
[letter
],
13888 &ns
->implicit_loc
[letter
],
13893 gfc_current_ns
= ns
;
13895 resolve_entries (ns
);
13897 resolve_common_vars (ns
->blank_common
.head
, false);
13898 resolve_common_blocks (ns
->common_root
);
13900 resolve_contained_functions (ns
);
13902 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
13903 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
13904 resolve_formal_arglist (ns
->proc_name
);
13906 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
13908 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
13909 resolve_charlen (cl
);
13911 gfc_traverse_ns (ns
, resolve_symbol
);
13913 resolve_fntype (ns
);
13915 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13917 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
13918 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13919 "also be PURE", n
->proc_name
->name
,
13920 &n
->proc_name
->declared_at
);
13926 do_concurrent_flag
= 0;
13927 gfc_check_interfaces (ns
);
13929 gfc_traverse_ns (ns
, resolve_values
);
13935 for (d
= ns
->data
; d
; d
= d
->next
)
13939 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
13941 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
13943 if (ns
->common_root
!= NULL
)
13944 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
13946 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
13947 resolve_equivalence (eq
);
13949 /* Warn about unused labels. */
13950 if (warn_unused_label
)
13951 warn_unused_fortran_label (ns
->st_labels
);
13953 gfc_resolve_uops (ns
->uop_root
);
13955 gfc_current_ns
= old_ns
;
13959 /* Call resolve_code recursively. */
13962 resolve_codes (gfc_namespace
*ns
)
13965 bitmap_obstack old_obstack
;
13967 if (ns
->resolved
== 1)
13970 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13973 gfc_current_ns
= ns
;
13975 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13976 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
13979 /* Set to an out of range value. */
13980 current_entry_id
= -1;
13982 old_obstack
= labels_obstack
;
13983 bitmap_obstack_initialize (&labels_obstack
);
13985 resolve_code (ns
->code
, ns
);
13987 bitmap_obstack_release (&labels_obstack
);
13988 labels_obstack
= old_obstack
;
13992 /* This function is called after a complete program unit has been compiled.
13993 Its purpose is to examine all of the expressions associated with a program
13994 unit, assign types to all intermediate expressions, make sure that all
13995 assignments are to compatible types and figure out which names refer to
13996 which functions or subroutines. */
13999 gfc_resolve (gfc_namespace
*ns
)
14001 gfc_namespace
*old_ns
;
14002 code_stack
*old_cs_base
;
14008 old_ns
= gfc_current_ns
;
14009 old_cs_base
= cs_base
;
14011 resolve_types (ns
);
14012 resolve_codes (ns
);
14014 gfc_current_ns
= old_ns
;
14015 cs_base
= old_cs_base
;
14018 gfc_run_passes (ns
);