1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2023 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 #include "target-memory.h" /* for gfc_simplify_transfer */
31 #include "constructor.h"
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and gfc_resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code
*head
, *current
;
46 struct code_stack
*prev
;
48 /* This bitmap keeps track of the targets valid for a branch from
49 inside this block except for END {IF|SELECT}s of enclosing
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
60 static int forall_flag
;
61 int gfc_do_concurrent_flag
;
63 /* True when we are resolving an expression that is an actual argument to
65 static bool actual_arg
= false;
66 /* True when we are resolving an expression that is the first actual argument
68 static bool first_actual_arg
= false;
71 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
73 static int omp_workshare_flag
;
75 /* True if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static bool formal_arg_flag
= false;
79 /* True if we are resolving a specification expression. */
80 static bool specification_expr
= false;
82 /* The id of the last entry seen. */
83 static int current_entry_id
;
85 /* We use bitmaps to determine if a branch target is valid. */
86 static bitmap_obstack labels_obstack
;
88 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89 static bool inquiry_argument
= false;
93 gfc_is_formal_arg (void)
95 return formal_arg_flag
;
98 /* Is the symbol host associated? */
100 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
102 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
111 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
116 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
118 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name
, where
, ts
->u
.derived
->name
);
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts
->u
.derived
->name
, where
);
138 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
140 /* Several checks for F08:C1216. */
141 if (ifc
->attr
.procedure
)
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc
->name
, where
);
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface
*gen
= ifc
->generic
;
152 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
156 gfc_error ("Interface %qs at %L may not be generic",
161 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
163 gfc_error ("Interface %qs at %L may not be a statement function",
167 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
168 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
169 ifc
->attr
.intrinsic
= 1;
170 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc
->name
, where
);
176 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
178 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
185 static void resolve_symbol (gfc_symbol
*sym
);
188 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
191 resolve_procedure_interface (gfc_symbol
*sym
)
193 gfc_symbol
*ifc
= sym
->ts
.interface
;
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym
->name
, &sym
->declared_at
);
204 if (!check_proc_interface (ifc
, &sym
->declared_at
))
207 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc
);
211 if (ifc
->attr
.intrinsic
)
212 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
216 sym
->ts
= ifc
->result
->ts
;
217 sym
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
218 sym
->attr
.pointer
= ifc
->result
->attr
.pointer
;
219 sym
->attr
.dimension
= ifc
->result
->attr
.dimension
;
220 sym
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
221 sym
->as
= gfc_copy_array_spec (ifc
->result
->as
);
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.dimension
= ifc
->attr
.dimension
;
230 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
231 sym
->as
= gfc_copy_array_spec (ifc
->as
);
233 sym
->ts
.interface
= ifc
;
234 sym
->attr
.function
= ifc
->attr
.function
;
235 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
237 sym
->attr
.pure
= ifc
->attr
.pure
;
238 sym
->attr
.elemental
= ifc
->attr
.elemental
;
239 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
240 sym
->attr
.recursive
= ifc
->attr
.recursive
;
241 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
242 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
243 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
244 /* Copy char length. */
245 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
247 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
248 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
249 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
258 /* Resolve types of formal argument lists. These have to be done early so that
259 the formal argument lists of module procedures can be copied to the
260 containing module before the individual procedures are resolved
261 individually. We also resolve argument lists of procedures in interface
262 blocks because they are self-contained scoping units.
264 Since a dummy argument cannot be a non-dummy procedure, the only
265 resort left for untyped names are the IMPLICIT types. */
268 gfc_resolve_formal_arglist (gfc_symbol
*proc
)
270 gfc_formal_arglist
*f
;
272 bool saved_specification_expr
;
275 if (proc
->result
!= NULL
)
280 if (gfc_elemental (proc
)
281 || sym
->attr
.pointer
|| sym
->attr
.allocatable
282 || (sym
->as
&& sym
->as
->rank
!= 0))
284 proc
->attr
.always_explicit
= 1;
285 sym
->attr
.always_explicit
= 1;
288 formal_arg_flag
= true;
290 for (f
= proc
->formal
; f
; f
= f
->next
)
298 /* Alternate return placeholder. */
299 if (gfc_elemental (proc
))
300 gfc_error ("Alternate return specifier in elemental subroutine "
301 "%qs at %L is not allowed", proc
->name
,
303 if (proc
->attr
.function
)
304 gfc_error ("Alternate return specifier in function "
305 "%qs at %L is not allowed", proc
->name
,
309 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
310 && !resolve_procedure_interface (sym
))
313 if (strcmp (proc
->name
, sym
->name
) == 0)
315 gfc_error ("Self-referential argument "
316 "%qs at %L is not allowed", sym
->name
,
321 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
322 gfc_resolve_formal_arglist (sym
);
324 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
326 if (sym
->attr
.flavor
== FL_UNKNOWN
)
327 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
331 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
332 && (!sym
->attr
.function
|| sym
->result
== sym
))
333 gfc_set_default_type (sym
, 1, sym
->ns
);
336 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
337 ? CLASS_DATA (sym
)->as
: sym
->as
;
339 saved_specification_expr
= specification_expr
;
340 specification_expr
= true;
341 gfc_resolve_array_spec (as
, 0);
342 specification_expr
= saved_specification_expr
;
344 /* We can't tell if an array with dimension (:) is assumed or deferred
345 shape until we know if it has the pointer or allocatable attributes.
347 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
348 && ((sym
->ts
.type
!= BT_CLASS
349 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
350 || (sym
->ts
.type
== BT_CLASS
351 && !(CLASS_DATA (sym
)->attr
.class_pointer
352 || CLASS_DATA (sym
)->attr
.allocatable
)))
353 && sym
->attr
.flavor
!= FL_PROCEDURE
)
355 as
->type
= AS_ASSUMED_SHAPE
;
356 for (i
= 0; i
< as
->rank
; i
++)
357 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
360 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
361 || (as
&& as
->type
== AS_ASSUMED_RANK
)
362 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
363 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
364 && (CLASS_DATA (sym
)->attr
.class_pointer
365 || CLASS_DATA (sym
)->attr
.allocatable
366 || CLASS_DATA (sym
)->attr
.target
))
367 || sym
->attr
.optional
)
369 proc
->attr
.always_explicit
= 1;
371 proc
->result
->attr
.always_explicit
= 1;
374 /* If the flavor is unknown at this point, it has to be a variable.
375 A procedure specification would have already set the type. */
377 if (sym
->attr
.flavor
== FL_UNKNOWN
)
378 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
382 if (sym
->attr
.flavor
== FL_PROCEDURE
)
387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 "also be PURE", sym
->name
, &sym
->declared_at
);
392 else if (!sym
->attr
.pointer
)
394 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
397 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
398 " of pure function %qs at %L with VALUE "
399 "attribute but without INTENT(IN)",
400 sym
->name
, proc
->name
, &sym
->declared_at
);
402 gfc_error ("Argument %qs of pure function %qs at %L must "
403 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
407 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
410 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
411 " of pure subroutine %qs at %L with VALUE "
412 "attribute but without INTENT", sym
->name
,
413 proc
->name
, &sym
->declared_at
);
415 gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 "must have its INTENT specified or have the "
417 "VALUE attribute", sym
->name
, proc
->name
,
423 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 " may not be polymorphic", sym
->name
, proc
->name
,
432 if (proc
->attr
.implicit_pure
)
434 if (sym
->attr
.flavor
== FL_PROCEDURE
)
437 proc
->attr
.implicit_pure
= 0;
439 else if (!sym
->attr
.pointer
)
441 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
443 proc
->attr
.implicit_pure
= 0;
445 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
447 proc
->attr
.implicit_pure
= 0;
451 if (gfc_elemental (proc
))
454 if (sym
->attr
.codimension
455 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
456 && CLASS_DATA (sym
)->attr
.codimension
))
458 gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 "procedure", sym
->name
, &sym
->declared_at
);
463 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
464 && CLASS_DATA (sym
)->as
))
466 gfc_error ("Argument %qs of elemental procedure at %L must "
467 "be scalar", sym
->name
, &sym
->declared_at
);
471 if (sym
->attr
.allocatable
472 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
473 && CLASS_DATA (sym
)->attr
.allocatable
))
475 gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 "have the ALLOCATABLE attribute", sym
->name
,
481 if (sym
->attr
.pointer
482 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
483 && CLASS_DATA (sym
)->attr
.class_pointer
))
485 gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 "have the POINTER attribute", sym
->name
,
491 if (sym
->attr
.flavor
== FL_PROCEDURE
)
493 gfc_error ("Dummy procedure %qs not allowed in elemental "
494 "procedure %qs at %L", sym
->name
, proc
->name
,
499 /* Fortran 2008 Corrigendum 1, C1290a. */
500 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
502 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 "have its INTENT specified or have the VALUE "
504 "attribute", sym
->name
, proc
->name
,
510 /* Each dummy shall be specified to be scalar. */
511 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
515 /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 shall be specified, explicitly or implicitly, to be scalar. */
517 gfc_error ("Argument %qs of statement function %qs at %L "
518 "must be scalar", sym
->name
, proc
->name
,
523 if (sym
->ts
.type
== BT_CHARACTER
)
525 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
526 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
528 gfc_error ("Character-valued argument %qs of statement "
529 "function at %L must have constant length",
530 sym
->name
, &sym
->declared_at
);
536 formal_arg_flag
= false;
540 /* Work function called when searching for symbols that have argument lists
541 associated with them. */
544 find_arglists (gfc_symbol
*sym
)
546 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
547 || gfc_fl_struct (sym
->attr
.flavor
) || sym
->attr
.intrinsic
)
550 gfc_resolve_formal_arglist (sym
);
554 /* Given a namespace, resolve all formal argument lists within the namespace.
558 resolve_formal_arglists (gfc_namespace
*ns
)
563 gfc_traverse_ns (ns
, find_arglists
);
568 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
572 if (sym
&& sym
->attr
.flavor
== FL_PROCEDURE
574 && sym
->ns
->parent
->proc_name
575 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_PROCEDURE
576 && !strcmp (sym
->name
, sym
->ns
->parent
->proc_name
->name
))
577 gfc_error ("Contained procedure %qs at %L has the same name as its "
578 "encompassing procedure", sym
->name
, &sym
->declared_at
);
580 /* If this namespace is not a function or an entry master function,
582 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
583 || sym
->attr
.entry_master
)
589 /* Try to find out of what the return type is. */
590 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
592 t
= gfc_set_default_type (sym
->result
, 0, ns
);
594 if (!t
&& !sym
->result
->attr
.untyped
)
596 if (sym
->result
== sym
)
597 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
598 sym
->name
, &sym
->declared_at
);
599 else if (!sym
->result
->attr
.proc_pointer
)
600 gfc_error ("Result %qs of contained function %qs at %L has "
601 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
602 &sym
->result
->declared_at
);
603 sym
->result
->attr
.untyped
= 1;
607 /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
608 type, lists the only ways a character length value of * can be used:
609 dummy arguments of procedures, named constants, function results and
610 in allocate statements if the allocate_object is an assumed length dummy
611 in external functions. Internal function results and results of module
612 procedures are not on this list, ergo, not permitted. */
614 if (sym
->result
->ts
.type
== BT_CHARACTER
)
616 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
617 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
619 /* See if this is a module-procedure and adapt error message
622 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
623 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
625 gfc_error (module_proc
626 ? G_("Character-valued module procedure %qs at %L"
627 " must not be assumed length")
628 : G_("Character-valued internal function %qs at %L"
629 " must not be assumed length"),
630 sym
->name
, &sym
->declared_at
);
636 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
637 introduce duplicates. */
640 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
642 gfc_formal_arglist
*f
, *new_arglist
;
645 for (; new_args
!= NULL
; new_args
= new_args
->next
)
647 new_sym
= new_args
->sym
;
648 /* See if this arg is already in the formal argument list. */
649 for (f
= proc
->formal
; f
; f
= f
->next
)
651 if (new_sym
== f
->sym
)
658 /* Add a new argument. Argument order is not important. */
659 new_arglist
= gfc_get_formal_arglist ();
660 new_arglist
->sym
= new_sym
;
661 new_arglist
->next
= proc
->formal
;
662 proc
->formal
= new_arglist
;
667 /* Flag the arguments that are not present in all entries. */
670 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
672 gfc_formal_arglist
*f
, *head
;
675 for (f
= proc
->formal
; f
; f
= f
->next
)
680 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
682 if (new_args
->sym
== f
->sym
)
689 f
->sym
->attr
.not_always_present
= 1;
694 /* Resolve alternate entry points. If a symbol has multiple entry points we
695 create a new master symbol for the main routine, and turn the existing
696 symbol into an entry point. */
699 resolve_entries (gfc_namespace
*ns
)
701 gfc_namespace
*old_ns
;
705 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
706 static int master_count
= 0;
708 if (ns
->proc_name
== NULL
)
711 /* No need to do anything if this procedure doesn't have alternate entry
716 /* We may already have resolved alternate entry points. */
717 if (ns
->proc_name
->attr
.entry_master
)
720 /* If this isn't a procedure something has gone horribly wrong. */
721 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
723 /* Remember the current namespace. */
724 old_ns
= gfc_current_ns
;
728 /* Add the main entry point to the list of entry points. */
729 el
= gfc_get_entry_list ();
730 el
->sym
= ns
->proc_name
;
732 el
->next
= ns
->entries
;
734 ns
->proc_name
->attr
.entry
= 1;
736 /* If it is a module function, it needs to be in the right namespace
737 so that gfc_get_fake_result_decl can gather up the results. The
738 need for this arose in get_proc_name, where these beasts were
739 left in their own namespace, to keep prior references linked to
740 the entry declaration.*/
741 if (ns
->proc_name
->attr
.function
742 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
745 /* Do the same for entries where the master is not a module
746 procedure. These are retained in the module namespace because
747 of the module procedure declaration. */
748 for (el
= el
->next
; el
; el
= el
->next
)
749 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
750 && el
->sym
->attr
.mod_proc
)
754 /* Add an entry statement for it. */
755 c
= gfc_get_code (EXEC_ENTRY
);
760 /* Create a new symbol for the master function. */
761 /* Give the internal function a unique name (within this file).
762 Also include the function name so the user has some hope of figuring
763 out what is going on. */
764 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
765 master_count
++, ns
->proc_name
->name
);
766 gfc_get_ha_symbol (name
, &proc
);
767 gcc_assert (proc
!= NULL
);
769 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
770 if (ns
->proc_name
->attr
.subroutine
)
771 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
775 gfc_typespec
*ts
, *fts
;
776 gfc_array_spec
*as
, *fas
;
777 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
779 fas
= ns
->entries
->sym
->as
;
780 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
781 fts
= &ns
->entries
->sym
->result
->ts
;
782 if (fts
->type
== BT_UNKNOWN
)
783 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
784 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
786 ts
= &el
->sym
->result
->ts
;
788 as
= as
? as
: el
->sym
->result
->as
;
789 if (ts
->type
== BT_UNKNOWN
)
790 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
792 if (! gfc_compare_types (ts
, fts
)
793 || (el
->sym
->result
->attr
.dimension
794 != ns
->entries
->sym
->result
->attr
.dimension
)
795 || (el
->sym
->result
->attr
.pointer
796 != ns
->entries
->sym
->result
->attr
.pointer
))
798 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
799 && gfc_compare_array_spec (as
, fas
) == 0)
800 gfc_error ("Function %s at %L has entries with mismatched "
801 "array specifications", ns
->entries
->sym
->name
,
802 &ns
->entries
->sym
->declared_at
);
803 /* The characteristics need to match and thus both need to have
804 the same string length, i.e. both len=*, or both len=4.
805 Having both len=<variable> is also possible, but difficult to
806 check at compile time. */
807 else if (ts
->type
== BT_CHARACTER
808 && (el
->sym
->result
->attr
.allocatable
809 != ns
->entries
->sym
->result
->attr
.allocatable
))
811 gfc_error ("Function %s at %L has entry %s with mismatched "
812 "characteristics", ns
->entries
->sym
->name
,
813 &ns
->entries
->sym
->declared_at
, el
->sym
->name
);
816 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
817 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
818 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
820 && ts
->u
.cl
->length
->expr_type
821 != fts
->u
.cl
->length
->expr_type
)
823 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
824 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
825 fts
->u
.cl
->length
->value
.integer
) != 0)))
826 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
827 "entries returning variables of different "
828 "string lengths", ns
->entries
->sym
->name
,
829 &ns
->entries
->sym
->declared_at
);
834 sym
= ns
->entries
->sym
->result
;
835 /* All result types the same. */
837 if (sym
->attr
.dimension
)
838 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
839 if (sym
->attr
.pointer
)
840 gfc_add_pointer (&proc
->attr
, NULL
);
844 /* Otherwise the result will be passed through a union by
846 proc
->attr
.mixed_entry_master
= 1;
847 for (el
= ns
->entries
; el
; el
= el
->next
)
849 sym
= el
->sym
->result
;
850 if (sym
->attr
.dimension
)
852 if (el
== ns
->entries
)
853 gfc_error ("FUNCTION result %s cannot be an array in "
854 "FUNCTION %s at %L", sym
->name
,
855 ns
->entries
->sym
->name
, &sym
->declared_at
);
857 gfc_error ("ENTRY result %s cannot be an array in "
858 "FUNCTION %s at %L", sym
->name
,
859 ns
->entries
->sym
->name
, &sym
->declared_at
);
861 else if (sym
->attr
.pointer
)
863 if (el
== ns
->entries
)
864 gfc_error ("FUNCTION result %s cannot be a POINTER in "
865 "FUNCTION %s at %L", sym
->name
,
866 ns
->entries
->sym
->name
, &sym
->declared_at
);
868 gfc_error ("ENTRY result %s cannot be a POINTER in "
869 "FUNCTION %s at %L", sym
->name
,
870 ns
->entries
->sym
->name
, &sym
->declared_at
);
875 if (ts
->type
== BT_UNKNOWN
)
876 ts
= gfc_get_default_type (sym
->name
, NULL
);
880 if (ts
->kind
== gfc_default_integer_kind
)
884 if (ts
->kind
== gfc_default_real_kind
885 || ts
->kind
== gfc_default_double_kind
)
889 if (ts
->kind
== gfc_default_complex_kind
)
893 if (ts
->kind
== gfc_default_logical_kind
)
897 /* We will issue error elsewhere. */
905 if (el
== ns
->entries
)
906 gfc_error ("FUNCTION result %s cannot be of type %s "
907 "in FUNCTION %s at %L", sym
->name
,
908 gfc_typename (ts
), ns
->entries
->sym
->name
,
911 gfc_error ("ENTRY result %s cannot be of type %s "
912 "in FUNCTION %s at %L", sym
->name
,
913 gfc_typename (ts
), ns
->entries
->sym
->name
,
922 proc
->attr
.access
= ACCESS_PRIVATE
;
923 proc
->attr
.entry_master
= 1;
925 /* Merge all the entry point arguments. */
926 for (el
= ns
->entries
; el
; el
= el
->next
)
927 merge_argument_lists (proc
, el
->sym
->formal
);
929 /* Check the master formal arguments for any that are not
930 present in all entry points. */
931 for (el
= ns
->entries
; el
; el
= el
->next
)
932 check_argument_lists (proc
, el
->sym
->formal
);
934 /* Use the master function for the function body. */
935 ns
->proc_name
= proc
;
937 /* Finalize the new symbols. */
938 gfc_commit_symbols ();
940 /* Restore the original namespace. */
941 gfc_current_ns
= old_ns
;
945 /* Resolve common variables. */
947 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
949 gfc_symbol
*csym
= common_block
->head
;
952 for (; csym
; csym
= csym
->common_next
)
954 gsym
= gfc_find_gsymbol (gfc_gsym_root
, csym
->name
);
955 if (gsym
&& (gsym
->type
== GSYM_MODULE
|| gsym
->type
== GSYM_PROGRAM
))
957 if (csym
->common_block
)
958 gfc_error_now ("Global entity %qs at %L cannot appear in a "
959 "COMMON block at %L", gsym
->name
,
960 &gsym
->where
, &csym
->common_block
->where
);
962 gfc_error_now ("Global entity %qs at %L cannot appear in a "
963 "COMMON block", gsym
->name
, &gsym
->where
);
966 /* gfc_add_in_common may have been called before, but the reported errors
967 have been ignored to continue parsing.
968 We do the checks again here. */
969 if (!csym
->attr
.use_assoc
)
971 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
972 gfc_notify_std (GFC_STD_F2018_OBS
, "COMMON block at %L",
973 &common_block
->where
);
976 if (csym
->value
|| csym
->attr
.data
)
978 if (!csym
->ns
->is_block_data
)
979 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
980 "but only in BLOCK DATA initialization is "
981 "allowed", csym
->name
, &csym
->declared_at
);
982 else if (!named_common
)
983 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
984 "in a blank COMMON but initialization is only "
985 "allowed in named common blocks", csym
->name
,
989 if (UNLIMITED_POLY (csym
))
990 gfc_error_now ("%qs at %L cannot appear in COMMON "
991 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
993 if (csym
->ts
.type
!= BT_DERIVED
)
996 if (!(csym
->ts
.u
.derived
->attr
.sequence
997 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
998 gfc_error_now ("Derived type variable %qs in COMMON at %L "
999 "has neither the SEQUENCE nor the BIND(C) "
1000 "attribute", csym
->name
, &csym
->declared_at
);
1001 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
1002 gfc_error_now ("Derived type variable %qs in COMMON at %L "
1003 "has an ultimate component that is "
1004 "allocatable", csym
->name
, &csym
->declared_at
);
1005 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
1006 gfc_error_now ("Derived type variable %qs in COMMON at %L "
1007 "may not have default initializer", csym
->name
,
1008 &csym
->declared_at
);
1010 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
1011 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
1015 /* Resolve common blocks. */
1017 resolve_common_blocks (gfc_symtree
*common_root
)
1022 if (common_root
== NULL
)
1025 if (common_root
->left
)
1026 resolve_common_blocks (common_root
->left
);
1027 if (common_root
->right
)
1028 resolve_common_blocks (common_root
->right
);
1030 resolve_common_vars (common_root
->n
.common
, true);
1032 /* The common name is a global name - in Fortran 2003 also if it has a
1033 C binding name, since Fortran 2008 only the C binding name is a global
1035 if (!common_root
->n
.common
->binding_label
1036 || gfc_notification_std (GFC_STD_F2008
))
1038 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1039 common_root
->n
.common
->name
);
1041 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1042 && gsym
->type
== GSYM_COMMON
1043 && ((common_root
->n
.common
->binding_label
1044 && (!gsym
->binding_label
1045 || strcmp (common_root
->n
.common
->binding_label
,
1046 gsym
->binding_label
) != 0))
1047 || (!common_root
->n
.common
->binding_label
1048 && gsym
->binding_label
)))
1050 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1051 "identifier and must thus have the same binding name "
1052 "as the same-named COMMON block at %L: %s vs %s",
1053 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1055 common_root
->n
.common
->binding_label
1056 ? common_root
->n
.common
->binding_label
: "(blank)",
1057 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1061 if (gsym
&& gsym
->type
!= GSYM_COMMON
1062 && !common_root
->n
.common
->binding_label
)
1064 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1066 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1070 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1072 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1073 "%L sharing the identifier with global non-COMMON-block "
1074 "entity at %L", common_root
->n
.common
->name
,
1075 &common_root
->n
.common
->where
, &gsym
->where
);
1080 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
, false);
1081 gsym
->type
= GSYM_COMMON
;
1082 gsym
->where
= common_root
->n
.common
->where
;
1088 if (common_root
->n
.common
->binding_label
)
1090 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1091 common_root
->n
.common
->binding_label
);
1092 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1094 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1095 "global identifier as entity at %L",
1096 &common_root
->n
.common
->where
,
1097 common_root
->n
.common
->binding_label
, &gsym
->where
);
1102 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
, true);
1103 gsym
->type
= GSYM_COMMON
;
1104 gsym
->where
= common_root
->n
.common
->where
;
1110 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1114 if (sym
->attr
.flavor
== FL_PARAMETER
)
1115 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1116 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1118 if (sym
->attr
.external
)
1119 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1120 sym
->name
, &common_root
->n
.common
->where
);
1122 if (sym
->attr
.intrinsic
)
1123 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1124 sym
->name
, &common_root
->n
.common
->where
);
1125 else if (sym
->attr
.result
1126 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1127 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1128 "that is also a function result", sym
->name
,
1129 &common_root
->n
.common
->where
);
1130 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1131 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1132 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1133 "that is also a global procedure", sym
->name
,
1134 &common_root
->n
.common
->where
);
1138 /* Resolve contained function types. Because contained functions can call one
1139 another, they have to be worked out before any of the contained procedures
1142 The good news is that if a function doesn't already have a type, the only
1143 way it can get one is through an IMPLICIT type or a RESULT variable, because
1144 by definition contained functions are contained namespace they're contained
1145 in, not in a sibling or parent namespace. */
1148 resolve_contained_functions (gfc_namespace
*ns
)
1150 gfc_namespace
*child
;
1153 resolve_formal_arglists (ns
);
1155 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1157 /* Resolve alternate entry points first. */
1158 resolve_entries (child
);
1160 /* Then check function return types. */
1161 resolve_contained_fntype (child
->proc_name
, child
);
1162 for (el
= child
->entries
; el
; el
= el
->next
)
1163 resolve_contained_fntype (el
->sym
, child
);
1169 /* A Parameterized Derived Type constructor must contain values for
1170 the PDT KIND parameters or they must have a default initializer.
1171 Go through the constructor picking out the KIND expressions,
1172 storing them in 'param_list' and then call gfc_get_pdt_instance
1173 to obtain the PDT instance. */
1175 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1178 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1180 param
= gfc_get_actual_arglist ();
1182 param_list
= param_tail
= param
;
1185 param_tail
->next
= param
;
1186 param_tail
= param_tail
->next
;
1189 param_tail
->name
= c
->name
;
1191 param_tail
->expr
= gfc_copy_expr (expr
);
1192 else if (c
->initializer
)
1193 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1196 param_tail
->spec_type
= SPEC_ASSUMED
;
1197 if (c
->attr
.pdt_kind
)
1199 gfc_error ("The KIND parameter %qs in the PDT constructor "
1200 "at %C has no value", param
->name
);
1209 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1210 gfc_symbol
*derived
)
1212 gfc_constructor
*cons
= NULL
;
1213 gfc_component
*comp
;
1216 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1217 cons
= gfc_constructor_first (expr
->value
.constructor
);
1222 comp
= derived
->components
;
1224 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1227 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1228 && comp
->ts
.type
== BT_DERIVED
)
1230 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1234 else if (comp
->ts
.type
== BT_DERIVED
)
1236 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1240 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1241 && derived
->attr
.pdt_template
)
1243 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1252 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1253 static bool resolve_fl_struct (gfc_symbol
*sym
);
1256 /* Resolve all of the elements of a structure constructor and make sure that
1257 the types are correct. The 'init' flag indicates that the given
1258 constructor is an initializer. */
1261 resolve_structure_cons (gfc_expr
*expr
, int init
)
1263 gfc_constructor
*cons
;
1264 gfc_component
*comp
;
1270 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1272 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1273 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1275 resolve_fl_struct (expr
->ts
.u
.derived
);
1277 /* If this is a Parameterized Derived Type template, find the
1278 instance corresponding to the PDT kind parameters. */
1279 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1282 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1285 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1287 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1290 gfc_free_actual_arglist (param_list
);
1292 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1297 /* A constructor may have references if it is the result of substituting a
1298 parameter variable. In this case we just pull out the component we
1301 comp
= expr
->ref
->u
.c
.sym
->components
;
1302 else if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
1303 || expr
->ts
.type
== BT_UNION
)
1304 && expr
->ts
.u
.derived
)
1305 comp
= expr
->ts
.u
.derived
->components
;
1309 cons
= gfc_constructor_first (expr
->value
.constructor
);
1311 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1318 /* Unions use an EXPR_NULL contrived expression to tell the translation
1319 phase to generate an initializer of the appropriate length.
1321 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1324 if (!gfc_resolve_expr (cons
->expr
))
1330 rank
= comp
->as
? comp
->as
->rank
: 0;
1331 if (comp
->ts
.type
== BT_CLASS
1332 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1333 && CLASS_DATA (comp
)->as
)
1334 rank
= CLASS_DATA (comp
)->as
->rank
;
1336 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1337 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1339 gfc_error ("The rank of the element in the structure "
1340 "constructor at %L does not match that of the "
1341 "component (%d/%d)", &cons
->expr
->where
,
1342 cons
->expr
->rank
, rank
);
1346 /* If we don't have the right type, try to convert it. */
1348 if (!comp
->attr
.proc_pointer
&&
1349 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1351 if (strcmp (comp
->name
, "_extends") == 0)
1353 /* Can afford to be brutal with the _extends initializer.
1354 The derived type can get lost because it is PRIVATE
1355 but it is not usage constrained by the standard. */
1356 cons
->expr
->ts
= comp
->ts
;
1358 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1360 gfc_error ("The element in the structure constructor at %L, "
1361 "for pointer component %qs, is %s but should be %s",
1362 &cons
->expr
->where
, comp
->name
,
1363 gfc_basic_typename (cons
->expr
->ts
.type
),
1364 gfc_basic_typename (comp
->ts
.type
));
1369 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1375 /* For strings, the length of the constructor should be the same as
1376 the one of the structure, ensure this if the lengths are known at
1377 compile time and when we are dealing with PARAMETER or structure
1379 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1380 && comp
->ts
.u
.cl
->length
1381 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1382 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1383 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1384 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1385 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1387 if (comp
->attr
.pointer
)
1389 HOST_WIDE_INT la
, lb
;
1390 la
= gfc_mpz_get_hwi (comp
->ts
.u
.cl
->length
->value
.integer
);
1391 lb
= gfc_mpz_get_hwi (cons
->expr
->ts
.u
.cl
->length
->value
.integer
);
1392 gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1393 "component %qs in constructor at %L",
1394 la
, lb
, comp
->name
, &cons
->expr
->where
);
1398 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1399 && cons
->expr
->rank
!= 0
1400 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1402 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1403 to make use of the gfc_resolve_character_array_constructor
1404 machinery. The expression is later simplified away to
1405 an array of string literals. */
1406 gfc_expr
*para
= cons
->expr
;
1407 cons
->expr
= gfc_get_expr ();
1408 cons
->expr
->ts
= para
->ts
;
1409 cons
->expr
->where
= para
->where
;
1410 cons
->expr
->expr_type
= EXPR_ARRAY
;
1411 cons
->expr
->rank
= para
->rank
;
1412 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1413 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1414 para
, &cons
->expr
->where
);
1417 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1419 /* Rely on the cleanup of the namespace to deal correctly with
1420 the old charlen. (There was a block here that attempted to
1421 remove the charlen but broke the chain in so doing.) */
1422 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1423 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1424 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1425 gfc_resolve_character_array_constructor (cons
->expr
);
1429 if (cons
->expr
->expr_type
== EXPR_NULL
1430 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1431 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1432 || (comp
->ts
.type
== BT_CLASS
1433 && (CLASS_DATA (comp
)->attr
.class_pointer
1434 || CLASS_DATA (comp
)->attr
.allocatable
))))
1437 gfc_error ("The NULL in the structure constructor at %L is "
1438 "being applied to component %qs, which is neither "
1439 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1443 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1445 /* Check procedure pointer interface. */
1446 gfc_symbol
*s2
= NULL
;
1451 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1454 s2
= c2
->ts
.interface
;
1457 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1459 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1460 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1462 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1464 s2
= cons
->expr
->symtree
->n
.sym
;
1465 name
= cons
->expr
->symtree
->n
.sym
->name
;
1468 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1469 err
, sizeof (err
), NULL
, NULL
))
1471 gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1472 "component %qs in structure constructor at %L:"
1473 " %s", comp
->name
, &cons
->expr
->where
, err
);
1478 /* Validate shape, except for dynamic or PDT arrays. */
1479 if (cons
->expr
->expr_type
== EXPR_ARRAY
&& rank
== cons
->expr
->rank
1480 && comp
->as
&& !comp
->attr
.allocatable
&& !comp
->attr
.pointer
1481 && !comp
->attr
.pdt_array
)
1485 for (int n
= 0; n
< rank
; n
++)
1487 if (comp
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
1488 || comp
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
)
1490 gfc_error ("Bad array spec of component %qs referenced in "
1491 "structure constructor at %L",
1492 comp
->name
, &cons
->expr
->where
);
1496 if (cons
->expr
->shape
== NULL
)
1498 mpz_set_ui (len
, 1);
1499 mpz_add (len
, len
, comp
->as
->upper
[n
]->value
.integer
);
1500 mpz_sub (len
, len
, comp
->as
->lower
[n
]->value
.integer
);
1501 if (mpz_cmp (cons
->expr
->shape
[n
], len
) != 0)
1503 gfc_error ("The shape of component %qs in the structure "
1504 "constructor at %L differs from the shape of the "
1505 "declared component for dimension %d (%ld/%ld)",
1506 comp
->name
, &cons
->expr
->where
, n
+1,
1507 mpz_get_si (cons
->expr
->shape
[n
]),
1515 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1516 || cons
->expr
->expr_type
== EXPR_NULL
)
1519 a
= gfc_expr_attr (cons
->expr
);
1521 if (!a
.pointer
&& !a
.target
)
1524 gfc_error ("The element in the structure constructor at %L, "
1525 "for pointer component %qs should be a POINTER or "
1526 "a TARGET", &cons
->expr
->where
, comp
->name
);
1531 /* F08:C461. Additional checks for pointer initialization. */
1535 gfc_error ("Pointer initialization target at %L "
1536 "must not be ALLOCATABLE", &cons
->expr
->where
);
1541 gfc_error ("Pointer initialization target at %L "
1542 "must have the SAVE attribute", &cons
->expr
->where
);
1546 /* F2003, C1272 (3). */
1547 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1548 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1549 || gfc_is_coindexed (cons
->expr
));
1550 if (impure
&& gfc_pure (NULL
))
1553 gfc_error ("Invalid expression in the structure constructor for "
1554 "pointer component %qs at %L in PURE procedure",
1555 comp
->name
, &cons
->expr
->where
);
1559 gfc_unset_implicit_pure (NULL
);
1566 /****************** Expression name resolution ******************/
1568 /* Returns 0 if a symbol was not declared with a type or
1569 attribute declaration statement, nonzero otherwise. */
1572 was_declared (gfc_symbol
*sym
)
1578 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1581 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1582 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1583 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1584 || a
.asynchronous
|| a
.codimension
)
1591 /* Determine if a symbol is generic or not. */
1594 generic_sym (gfc_symbol
*sym
)
1598 if (sym
->attr
.generic
||
1599 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1602 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1605 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1612 return generic_sym (s
);
1619 /* Determine if a symbol is specific or not. */
1622 specific_sym (gfc_symbol
*sym
)
1626 if (sym
->attr
.if_source
== IFSRC_IFBODY
1627 || sym
->attr
.proc
== PROC_MODULE
1628 || sym
->attr
.proc
== PROC_INTERNAL
1629 || sym
->attr
.proc
== PROC_ST_FUNCTION
1630 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1631 || sym
->attr
.external
)
1634 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1637 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1639 return (s
== NULL
) ? 0 : specific_sym (s
);
1643 /* Figure out if the procedure is specific, generic or unknown. */
1646 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1649 procedure_kind (gfc_symbol
*sym
)
1651 if (generic_sym (sym
))
1652 return PTYPE_GENERIC
;
1654 if (specific_sym (sym
))
1655 return PTYPE_SPECIFIC
;
1657 return PTYPE_UNKNOWN
;
1660 /* Check references to assumed size arrays. The flag need_full_assumed_size
1661 is nonzero when matching actual arguments. */
1663 static int need_full_assumed_size
= 0;
1666 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1668 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1671 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1672 What should it be? */
1675 && (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1676 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1677 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1679 gfc_error ("The upper bound in the last dimension must "
1680 "appear in the reference to the assumed size "
1681 "array %qs at %L", sym
->name
, &e
->where
);
1688 /* Look for bad assumed size array references in argument expressions
1689 of elemental and array valued intrinsic procedures. Since this is
1690 called from procedure resolution functions, it only recurses at
1694 resolve_assumed_size_actual (gfc_expr
*e
)
1699 switch (e
->expr_type
)
1702 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1707 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1708 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1719 /* Check a generic procedure, passed as an actual argument, to see if
1720 there is a matching specific name. If none, it is an error, and if
1721 more than one, the reference is ambiguous. */
1723 count_specific_procs (gfc_expr
*e
)
1730 sym
= e
->symtree
->n
.sym
;
1732 for (p
= sym
->generic
; p
; p
= p
->next
)
1733 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1735 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1741 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1745 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1746 "argument at %L", sym
->name
, &e
->where
);
1752 /* See if a call to sym could possibly be a not allowed RECURSION because of
1753 a missing RECURSIVE declaration. This means that either sym is the current
1754 context itself, or sym is the parent of a contained procedure calling its
1755 non-RECURSIVE containing procedure.
1756 This also works if sym is an ENTRY. */
1759 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1761 gfc_symbol
* proc_sym
;
1762 gfc_symbol
* context_proc
;
1763 gfc_namespace
* real_context
;
1765 if (sym
->attr
.flavor
== FL_PROGRAM
1766 || gfc_fl_struct (sym
->attr
.flavor
))
1769 /* If we've got an ENTRY, find real procedure. */
1770 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1771 proc_sym
= sym
->ns
->entries
->sym
;
1775 /* If sym is RECURSIVE, all is well of course. */
1776 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1779 /* Find the context procedure's "real" symbol if it has entries.
1780 We look for a procedure symbol, so recurse on the parents if we don't
1781 find one (like in case of a BLOCK construct). */
1782 for (real_context
= context
; ; real_context
= real_context
->parent
)
1784 /* We should find something, eventually! */
1785 gcc_assert (real_context
);
1787 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1788 : real_context
->proc_name
);
1790 /* In some special cases, there may not be a proc_name, like for this
1792 real(bad_kind()) function foo () ...
1793 when checking the call to bad_kind ().
1794 In these cases, we simply return here and assume that the
1799 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1803 /* A call from sym's body to itself is recursion, of course. */
1804 if (context_proc
== proc_sym
)
1807 /* The same is true if context is a contained procedure and sym the
1809 if (context_proc
->attr
.contained
)
1811 gfc_symbol
* parent_proc
;
1813 gcc_assert (context
->parent
);
1814 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1815 : context
->parent
->proc_name
);
1817 if (parent_proc
== proc_sym
)
1825 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1826 its typespec and formal argument list. */
1829 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1831 gfc_intrinsic_sym
* isym
= NULL
;
1834 if (sym
->resolve_symbol_called
>= 2)
1837 sym
->resolve_symbol_called
= 2;
1839 /* Already resolved. */
1840 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1843 /* We already know this one is an intrinsic, so we don't call
1844 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1845 gfc_find_subroutine directly to check whether it is a function or
1848 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1850 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1851 isym
= gfc_intrinsic_subroutine_by_id (id
);
1853 else if (sym
->intmod_sym_id
)
1855 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1856 isym
= gfc_intrinsic_function_by_id (id
);
1858 else if (!sym
->attr
.subroutine
)
1859 isym
= gfc_find_function (sym
->name
);
1861 if (isym
&& !sym
->attr
.subroutine
)
1863 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1864 && !sym
->attr
.implicit_type
)
1865 gfc_warning (OPT_Wsurprising
,
1866 "Type specified for intrinsic function %qs at %L is"
1867 " ignored", sym
->name
, &sym
->declared_at
);
1869 if (!sym
->attr
.function
&&
1870 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1875 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1877 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1879 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1880 " specifier", sym
->name
, &sym
->declared_at
);
1884 if (!sym
->attr
.subroutine
&&
1885 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1890 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1895 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1897 sym
->attr
.pure
= isym
->pure
;
1898 sym
->attr
.elemental
= isym
->elemental
;
1900 /* Check it is actually available in the standard settings. */
1901 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1903 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1904 "available in the current standard settings but %s. Use "
1905 "an appropriate %<-std=*%> option or enable "
1906 "%<-fall-intrinsics%> in order to use it.",
1907 sym
->name
, &sym
->declared_at
, symstd
);
1915 /* Resolve a procedure expression, like passing it to a called procedure or as
1916 RHS for a procedure pointer assignment. */
1919 resolve_procedure_expression (gfc_expr
* expr
)
1923 if (expr
->expr_type
!= EXPR_VARIABLE
)
1925 gcc_assert (expr
->symtree
);
1927 sym
= expr
->symtree
->n
.sym
;
1929 if (sym
->attr
.intrinsic
)
1930 gfc_resolve_intrinsic (sym
, &expr
->where
);
1932 if (sym
->attr
.flavor
!= FL_PROCEDURE
1933 || (sym
->attr
.function
&& sym
->result
== sym
))
1936 /* A non-RECURSIVE procedure that is used as procedure expression within its
1937 own body is in danger of being called recursively. */
1938 if (is_illegal_recursion (sym
, gfc_current_ns
))
1939 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1940 " itself recursively. Declare it RECURSIVE or use"
1941 " %<-frecursive%>", sym
->name
, &expr
->where
);
1947 /* Check that name is not a derived type. */
1950 is_dt_name (const char *name
)
1952 gfc_symbol
*dt_list
, *dt_first
;
1954 dt_list
= dt_first
= gfc_derived_types
;
1955 for (; dt_list
; dt_list
= dt_list
->dt_next
)
1957 if (strcmp(dt_list
->name
, name
) == 0)
1959 if (dt_first
== dt_list
->dt_next
)
1966 /* Resolve an actual argument list. Most of the time, this is just
1967 resolving the expressions in the list.
1968 The exception is that we sometimes have to decide whether arguments
1969 that look like procedure arguments are really simple variable
1973 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1974 bool no_formal_args
)
1977 gfc_symtree
*parent_st
;
1979 gfc_component
*comp
;
1980 int save_need_full_assumed_size
;
1981 bool return_value
= false;
1982 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1985 first_actual_arg
= true;
1987 for (; arg
; arg
= arg
->next
)
1992 /* Check the label is a valid branching target. */
1995 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1997 gfc_error ("Label %d referenced at %L is never defined",
1998 arg
->label
->value
, &arg
->label
->where
);
2002 first_actual_arg
= false;
2006 if (e
->expr_type
== EXPR_VARIABLE
2007 && e
->symtree
->n
.sym
->attr
.generic
2009 && count_specific_procs (e
) != 1)
2012 if (e
->ts
.type
!= BT_PROCEDURE
)
2014 save_need_full_assumed_size
= need_full_assumed_size
;
2015 if (e
->expr_type
!= EXPR_VARIABLE
)
2016 need_full_assumed_size
= 0;
2017 if (!gfc_resolve_expr (e
))
2019 need_full_assumed_size
= save_need_full_assumed_size
;
2023 /* See if the expression node should really be a variable reference. */
2025 sym
= e
->symtree
->n
.sym
;
2027 if (sym
->attr
.flavor
== FL_PROCEDURE
&& is_dt_name (sym
->name
))
2029 gfc_error ("Derived type %qs is used as an actual "
2030 "argument at %L", sym
->name
, &e
->where
);
2034 if (sym
->attr
.flavor
== FL_PROCEDURE
2035 || sym
->attr
.intrinsic
2036 || sym
->attr
.external
)
2040 /* If a procedure is not already determined to be something else
2041 check if it is intrinsic. */
2042 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
2043 sym
->attr
.intrinsic
= 1;
2045 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2047 gfc_error ("Statement function %qs at %L is not allowed as an "
2048 "actual argument", sym
->name
, &e
->where
);
2051 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
2052 sym
->attr
.subroutine
);
2053 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
2055 gfc_error ("Intrinsic %qs at %L is not allowed as an "
2056 "actual argument", sym
->name
, &e
->where
);
2059 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
2060 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
2062 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
2063 " used as actual argument at %L",
2064 sym
->name
, &e
->where
))
2068 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
2070 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2071 "allowed as an actual argument at %L", sym
->name
,
2075 /* Check if a generic interface has a specific procedure
2076 with the same name before emitting an error. */
2077 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
2080 /* Just in case a specific was found for the expression. */
2081 sym
= e
->symtree
->n
.sym
;
2083 /* If the symbol is the function that names the current (or
2084 parent) scope, then we really have a variable reference. */
2086 if (gfc_is_function_return_value (sym
, sym
->ns
))
2089 /* If all else fails, see if we have a specific intrinsic. */
2090 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
2092 gfc_intrinsic_sym
*isym
;
2094 isym
= gfc_find_function (sym
->name
);
2095 if (isym
== NULL
|| !isym
->specific
)
2097 gfc_error ("Unable to find a specific INTRINSIC procedure "
2098 "for the reference %qs at %L", sym
->name
,
2103 sym
->attr
.intrinsic
= 1;
2104 sym
->attr
.function
= 1;
2107 if (!gfc_resolve_expr (e
))
2112 /* See if the name is a module procedure in a parent unit. */
2114 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2117 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2119 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2123 if (parent_st
== NULL
)
2126 sym
= parent_st
->n
.sym
;
2127 e
->symtree
= parent_st
; /* Point to the right thing. */
2129 if (sym
->attr
.flavor
== FL_PROCEDURE
2130 || sym
->attr
.intrinsic
2131 || sym
->attr
.external
)
2133 if (!gfc_resolve_expr (e
))
2139 e
->expr_type
= EXPR_VARIABLE
;
2141 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2142 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2143 && CLASS_DATA (sym
)->as
))
2145 e
->rank
= sym
->ts
.type
== BT_CLASS
2146 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2147 e
->ref
= gfc_get_ref ();
2148 e
->ref
->type
= REF_ARRAY
;
2149 e
->ref
->u
.ar
.type
= AR_FULL
;
2150 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2151 ? CLASS_DATA (sym
)->as
: sym
->as
;
2154 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2155 primary.cc (match_actual_arg). If above code determines that it
2156 is a variable instead, it needs to be resolved as it was not
2157 done at the beginning of this function. */
2158 save_need_full_assumed_size
= need_full_assumed_size
;
2159 if (e
->expr_type
!= EXPR_VARIABLE
)
2160 need_full_assumed_size
= 0;
2161 if (!gfc_resolve_expr (e
))
2163 need_full_assumed_size
= save_need_full_assumed_size
;
2166 /* Check argument list functions %VAL, %LOC and %REF. There is
2167 nothing to do for %REF. */
2168 if (arg
->name
&& arg
->name
[0] == '%')
2170 if (strcmp ("%VAL", arg
->name
) == 0)
2172 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2174 gfc_error ("By-value argument at %L is not of numeric "
2181 gfc_error ("By-value argument at %L cannot be an array or "
2182 "an array section", &e
->where
);
2186 /* Intrinsics are still PROC_UNKNOWN here. However,
2187 since same file external procedures are not resolvable
2188 in gfortran, it is a good deal easier to leave them to
2190 if (ptype
!= PROC_UNKNOWN
2191 && ptype
!= PROC_DUMMY
2192 && ptype
!= PROC_EXTERNAL
2193 && ptype
!= PROC_MODULE
)
2195 gfc_error ("By-value argument at %L is not allowed "
2196 "in this context", &e
->where
);
2201 /* Statement functions have already been excluded above. */
2202 else if (strcmp ("%LOC", arg
->name
) == 0
2203 && e
->ts
.type
== BT_PROCEDURE
)
2205 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2207 gfc_error ("Passing internal procedure at %L by location "
2208 "not allowed", &e
->where
);
2214 comp
= gfc_get_proc_ptr_comp(e
);
2215 if (e
->expr_type
== EXPR_VARIABLE
2216 && comp
&& comp
->attr
.elemental
)
2218 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2219 "allowed as an actual argument at %L", comp
->name
,
2223 /* Fortran 2008, C1237. */
2224 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2225 && gfc_has_ultimate_pointer (e
))
2227 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2228 "component", &e
->where
);
2232 first_actual_arg
= false;
2235 return_value
= true;
2238 actual_arg
= actual_arg_sav
;
2239 first_actual_arg
= first_actual_arg_sav
;
2241 return return_value
;
2245 /* Do the checks of the actual argument list that are specific to elemental
2246 procedures. If called with c == NULL, we have a function, otherwise if
2247 expr == NULL, we have a subroutine. */
2250 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2252 gfc_actual_arglist
*arg0
;
2253 gfc_actual_arglist
*arg
;
2254 gfc_symbol
*esym
= NULL
;
2255 gfc_intrinsic_sym
*isym
= NULL
;
2257 gfc_intrinsic_arg
*iformal
= NULL
;
2258 gfc_formal_arglist
*eformal
= NULL
;
2259 bool formal_optional
= false;
2260 bool set_by_optional
= false;
2264 /* Is this an elemental procedure? */
2265 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2267 if (expr
->value
.function
.esym
!= NULL
2268 && expr
->value
.function
.esym
->attr
.elemental
)
2270 arg0
= expr
->value
.function
.actual
;
2271 esym
= expr
->value
.function
.esym
;
2273 else if (expr
->value
.function
.isym
!= NULL
2274 && expr
->value
.function
.isym
->elemental
)
2276 arg0
= expr
->value
.function
.actual
;
2277 isym
= expr
->value
.function
.isym
;
2282 else if (c
&& c
->ext
.actual
!= NULL
)
2284 arg0
= c
->ext
.actual
;
2286 if (c
->resolved_sym
)
2287 esym
= c
->resolved_sym
;
2289 esym
= c
->symtree
->n
.sym
;
2292 if (!esym
->attr
.elemental
)
2298 /* The rank of an elemental is the rank of its array argument(s). */
2299 for (arg
= arg0
; arg
; arg
= arg
->next
)
2301 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2303 rank
= arg
->expr
->rank
;
2304 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2305 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2306 set_by_optional
= true;
2308 /* Function specific; set the result rank and shape. */
2312 if (!expr
->shape
&& arg
->expr
->shape
)
2314 expr
->shape
= gfc_get_shape (rank
);
2315 for (i
= 0; i
< rank
; i
++)
2316 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2323 /* If it is an array, it shall not be supplied as an actual argument
2324 to an elemental procedure unless an array of the same rank is supplied
2325 as an actual argument corresponding to a nonoptional dummy argument of
2326 that elemental procedure(12.4.1.5). */
2327 formal_optional
= false;
2329 iformal
= isym
->formal
;
2331 eformal
= esym
->formal
;
2333 for (arg
= arg0
; arg
; arg
= arg
->next
)
2337 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2338 formal_optional
= true;
2339 eformal
= eformal
->next
;
2341 else if (isym
&& iformal
)
2343 if (iformal
->optional
)
2344 formal_optional
= true;
2345 iformal
= iformal
->next
;
2348 formal_optional
= true;
2350 if (pedantic
&& arg
->expr
!= NULL
2351 && arg
->expr
->expr_type
== EXPR_VARIABLE
2352 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2355 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2356 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2359 gfc_actual_arglist
*a
;
2361 /* Scan the argument list for a non-optional argument with the
2362 same rank as arg. */
2363 for (a
= arg0
; a
; a
= a
->next
)
2365 && a
->expr
->rank
== arg
->expr
->rank
2366 && !a
->expr
->symtree
->n
.sym
->attr
.optional
)
2373 gfc_warning (OPT_Wpedantic
,
2374 "%qs at %L is an array and OPTIONAL; If it is not "
2375 "present, then it cannot be the actual argument of "
2376 "an ELEMENTAL procedure unless there is a non-optional"
2377 " argument with the same rank "
2378 "(Fortran 2018, 15.5.2.12)",
2379 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2383 for (arg
= arg0
; arg
; arg
= arg
->next
)
2385 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2388 /* Being elemental, the last upper bound of an assumed size array
2389 argument must be present. */
2390 if (resolve_assumed_size_actual (arg
->expr
))
2393 /* Elemental procedure's array actual arguments must conform. */
2396 if (!gfc_check_conformance (arg
->expr
, e
, _("elemental procedure")))
2403 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2404 is an array, the intent inout/out variable needs to be also an array. */
2405 if (rank
> 0 && esym
&& expr
== NULL
)
2406 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2407 arg
= arg
->next
, eformal
= eformal
->next
)
2409 && (eformal
->sym
->attr
.intent
== INTENT_OUT
2410 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2411 && arg
->expr
&& arg
->expr
->rank
== 0)
2413 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2414 "ELEMENTAL subroutine %qs is a scalar, but another "
2415 "actual argument is an array", &arg
->expr
->where
,
2416 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2417 : "INOUT", eformal
->sym
->name
, esym
->name
);
2424 /* This function does the checking of references to global procedures
2425 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2426 77 and 95 standards. It checks for a gsymbol for the name, making
2427 one if it does not already exist. If it already exists, then the
2428 reference being resolved must correspond to the type of gsymbol.
2429 Otherwise, the new symbol is equipped with the attributes of the
2430 reference. The corresponding code that is called in creating
2431 global entities is parse.cc.
2433 In addition, for all but -std=legacy, the gsymbols are used to
2434 check the interfaces of external procedures from the same file.
2435 The namespace of the gsymbol is resolved and then, once this is
2436 done the interface is checked. */
2440 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2442 if (!gsym_ns
->proc_name
->attr
.recursive
)
2445 if (sym
->ns
== gsym_ns
)
2448 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2455 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2457 if (gsym_ns
->entries
)
2459 gfc_entry_list
*entry
= gsym_ns
->entries
;
2461 for (; entry
; entry
= entry
->next
)
2463 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2465 if (strcmp (gsym_ns
->proc_name
->name
,
2466 sym
->ns
->proc_name
->name
) == 0)
2470 && strcmp (gsym_ns
->proc_name
->name
,
2471 sym
->ns
->parent
->proc_name
->name
) == 0)
2480 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2483 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2485 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2487 for ( ; arg
; arg
= arg
->next
)
2492 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2494 strncpy (errmsg
, _("allocatable argument"), err_len
);
2497 else if (arg
->sym
->attr
.asynchronous
)
2499 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2502 else if (arg
->sym
->attr
.optional
)
2504 strncpy (errmsg
, _("optional argument"), err_len
);
2507 else if (arg
->sym
->attr
.pointer
)
2509 strncpy (errmsg
, _("pointer argument"), err_len
);
2512 else if (arg
->sym
->attr
.target
)
2514 strncpy (errmsg
, _("target argument"), err_len
);
2517 else if (arg
->sym
->attr
.value
)
2519 strncpy (errmsg
, _("value argument"), err_len
);
2522 else if (arg
->sym
->attr
.volatile_
)
2524 strncpy (errmsg
, _("volatile argument"), err_len
);
2527 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2529 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2532 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2534 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2537 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2539 strncpy (errmsg
, _("coarray argument"), err_len
);
2542 else if (false) /* (2d) TODO: parametrized derived type */
2544 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2547 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2549 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2552 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2554 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2557 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2559 /* As assumed-type is unlimited polymorphic (cf. above).
2560 See also TS 29113, Note 6.1. */
2561 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2566 if (sym
->attr
.function
)
2568 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2570 if (res
->attr
.dimension
) /* (3a) */
2572 strncpy (errmsg
, _("array result"), err_len
);
2575 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2577 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2580 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2581 && res
->ts
.u
.cl
->length
2582 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2584 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2589 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2591 strncpy (errmsg
, _("elemental procedure"), err_len
);
2594 else if (sym
->attr
.is_bind_c
) /* (5) */
2596 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2605 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
2609 enum gfc_symbol_type type
;
2612 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2614 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2615 sym
->binding_label
!= NULL
);
2617 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2618 gfc_global_used (gsym
, where
);
2620 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2621 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2622 && gsym
->type
!= GSYM_UNKNOWN
2623 && !gsym
->binding_label
2625 && gsym
->ns
->proc_name
2626 && not_in_recursive (sym
, gsym
->ns
)
2627 && not_entry_self_reference (sym
, gsym
->ns
))
2629 gfc_symbol
*def_sym
;
2630 def_sym
= gsym
->ns
->proc_name
;
2632 if (gsym
->ns
->resolved
!= -1)
2635 /* Resolve the gsymbol namespace if needed. */
2636 if (!gsym
->ns
->resolved
)
2638 gfc_symbol
*old_dt_list
;
2640 /* Stash away derived types so that the backend_decls
2641 do not get mixed up. */
2642 old_dt_list
= gfc_derived_types
;
2643 gfc_derived_types
= NULL
;
2645 gfc_resolve (gsym
->ns
);
2647 /* Store the new derived types with the global namespace. */
2648 if (gfc_derived_types
)
2649 gsym
->ns
->derived_types
= gfc_derived_types
;
2651 /* Restore the derived types of this namespace. */
2652 gfc_derived_types
= old_dt_list
;
2655 /* Make sure that translation for the gsymbol occurs before
2656 the procedure currently being resolved. */
2657 ns
= gfc_global_ns_list
;
2658 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2660 if (ns
->sibling
== gsym
->ns
)
2662 ns
->sibling
= gsym
->ns
->sibling
;
2663 gsym
->ns
->sibling
= gfc_global_ns_list
;
2664 gfc_global_ns_list
= gsym
->ns
;
2669 /* This can happen if a binding name has been specified. */
2670 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2671 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2673 if (def_sym
->attr
.entry_master
|| def_sym
->attr
.entry
)
2675 gfc_entry_list
*entry
;
2676 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2677 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2679 def_sym
= entry
->sym
;
2685 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2687 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2688 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2689 gfc_typename (&def_sym
->ts
));
2693 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2694 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2696 gfc_error ("Explicit interface required for %qs at %L: %s",
2697 sym
->name
, &sym
->declared_at
, reason
);
2701 bool bad_result_characteristics
;
2702 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2703 reason
, sizeof(reason
), NULL
, NULL
,
2704 &bad_result_characteristics
))
2706 /* Turn erros into warnings with -std=gnu and -std=legacy,
2707 unless a function returns a wrong type, which can lead
2708 to all kinds of ICEs and wrong code. */
2710 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
)
2711 && !bad_result_characteristics
)
2712 gfc_errors_to_warnings (true);
2714 gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2715 sym
->name
, &sym
->declared_at
, reason
);
2717 gfc_errors_to_warnings (false);
2724 if (gsym
->type
== GSYM_UNKNOWN
)
2727 gsym
->where
= *where
;
2734 /************* Function resolution *************/
2736 /* Resolve a function call known to be generic.
2737 Section 14.1.2.4.1. */
2740 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2744 if (sym
->attr
.generic
)
2746 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2749 expr
->value
.function
.name
= s
->name
;
2750 expr
->value
.function
.esym
= s
;
2752 if (s
->ts
.type
!= BT_UNKNOWN
)
2754 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2755 expr
->ts
= s
->result
->ts
;
2758 expr
->rank
= s
->as
->rank
;
2759 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2760 expr
->rank
= s
->result
->as
->rank
;
2762 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2767 /* TODO: Need to search for elemental references in generic
2771 if (sym
->attr
.intrinsic
)
2772 return gfc_intrinsic_func_interface (expr
, 0);
2779 resolve_generic_f (gfc_expr
*expr
)
2783 gfc_interface
*intr
= NULL
;
2785 sym
= expr
->symtree
->n
.sym
;
2789 m
= resolve_generic_f0 (expr
, sym
);
2792 else if (m
== MATCH_ERROR
)
2797 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2798 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2801 if (sym
->ns
->parent
== NULL
)
2803 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2807 if (!generic_sym (sym
))
2811 /* Last ditch attempt. See if the reference is to an intrinsic
2812 that possesses a matching interface. 14.1.2.4 */
2813 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2815 if (gfc_init_expr_flag
)
2816 gfc_error ("Function %qs in initialization expression at %L "
2817 "must be an intrinsic function",
2818 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2820 gfc_error ("There is no specific function for the generic %qs "
2821 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2827 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2830 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2832 return resolve_structure_cons (expr
, 0);
2835 m
= gfc_intrinsic_func_interface (expr
, 0);
2840 gfc_error ("Generic function %qs at %L is not consistent with a "
2841 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2848 /* Resolve a function call known to be specific. */
2851 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2855 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2857 if (sym
->attr
.dummy
)
2859 sym
->attr
.proc
= PROC_DUMMY
;
2863 sym
->attr
.proc
= PROC_EXTERNAL
;
2867 if (sym
->attr
.proc
== PROC_MODULE
2868 || sym
->attr
.proc
== PROC_ST_FUNCTION
2869 || sym
->attr
.proc
== PROC_INTERNAL
)
2872 if (sym
->attr
.intrinsic
)
2874 m
= gfc_intrinsic_func_interface (expr
, 1);
2878 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2879 "with an intrinsic", sym
->name
, &expr
->where
);
2887 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2890 expr
->ts
= sym
->result
->ts
;
2893 expr
->value
.function
.name
= sym
->name
;
2894 expr
->value
.function
.esym
= sym
;
2895 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2897 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2899 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2900 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2901 else if (sym
->as
!= NULL
)
2902 expr
->rank
= sym
->as
->rank
;
2909 resolve_specific_f (gfc_expr
*expr
)
2914 sym
= expr
->symtree
->n
.sym
;
2918 m
= resolve_specific_f0 (sym
, expr
);
2921 if (m
== MATCH_ERROR
)
2924 if (sym
->ns
->parent
== NULL
)
2927 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2933 gfc_error ("Unable to resolve the specific function %qs at %L",
2934 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2939 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2940 candidates in CANDIDATES_LEN. */
2943 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2945 size_t &candidates_len
)
2951 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2952 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2953 vec_push (candidates
, candidates_len
, sym
->name
);
2957 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2961 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2965 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2968 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2970 char **candidates
= NULL
;
2971 size_t candidates_len
= 0;
2972 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2973 return gfc_closest_fuzzy_match (fn
, candidates
);
2977 /* Resolve a procedure call not known to be generic nor specific. */
2980 resolve_unknown_f (gfc_expr
*expr
)
2985 sym
= expr
->symtree
->n
.sym
;
2987 if (sym
->attr
.dummy
)
2989 sym
->attr
.proc
= PROC_DUMMY
;
2990 expr
->value
.function
.name
= sym
->name
;
2994 /* See if we have an intrinsic function reference. */
2996 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2998 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
3003 /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3004 /* Intrinsics were handled above, only non-intrinsics left here. */
3005 if (sym
->attr
.flavor
== FL_PROCEDURE
3006 && sym
->attr
.implicit_type
3008 && sym
->ns
->has_implicit_none_export
)
3010 gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3011 "for symbol %qs at %L", sym
->name
, &sym
->declared_at
);
3016 /* The reference is to an external name. */
3018 sym
->attr
.proc
= PROC_EXTERNAL
;
3019 expr
->value
.function
.name
= sym
->name
;
3020 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
3022 if (sym
->as
!= NULL
)
3023 expr
->rank
= sym
->as
->rank
;
3025 /* Type of the expression is either the type of the symbol or the
3026 default type of the symbol. */
3029 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
3031 if (sym
->ts
.type
!= BT_UNKNOWN
)
3035 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
3037 if (ts
->type
== BT_UNKNOWN
)
3040 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3042 gfc_error ("Function %qs at %L has no IMPLICIT type"
3043 "; did you mean %qs?",
3044 sym
->name
, &expr
->where
, guessed
);
3046 gfc_error ("Function %qs at %L has no IMPLICIT type",
3047 sym
->name
, &expr
->where
);
3058 /* Return true, if the symbol is an external procedure. */
3060 is_external_proc (gfc_symbol
*sym
)
3062 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
3063 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
3064 && sym
->attr
.proc
!= PROC_ST_FUNCTION
3065 && !sym
->attr
.proc_pointer
3066 && !sym
->attr
.use_assoc
3074 /* Figure out if a function reference is pure or not. Also set the name
3075 of the function for a potential error message. Return nonzero if the
3076 function is PURE, zero if not. */
3078 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
3081 gfc_pure_function (gfc_expr
*e
, const char **name
)
3084 gfc_component
*comp
;
3088 if (e
->symtree
!= NULL
3089 && e
->symtree
->n
.sym
!= NULL
3090 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3091 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
3093 comp
= gfc_get_proc_ptr_comp (e
);
3096 pure
= gfc_pure (comp
->ts
.interface
);
3099 else if (e
->value
.function
.esym
)
3101 pure
= gfc_pure (e
->value
.function
.esym
);
3102 *name
= e
->value
.function
.esym
->name
;
3104 else if (e
->value
.function
.isym
)
3106 pure
= e
->value
.function
.isym
->pure
3107 || e
->value
.function
.isym
->elemental
;
3108 *name
= e
->value
.function
.isym
->name
;
3112 /* Implicit functions are not pure. */
3114 *name
= e
->value
.function
.name
;
3121 /* Check if the expression is a reference to an implicitly pure function. */
3124 gfc_implicit_pure_function (gfc_expr
*e
)
3126 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
3128 return gfc_implicit_pure (comp
->ts
.interface
);
3129 else if (e
->value
.function
.esym
)
3130 return gfc_implicit_pure (e
->value
.function
.esym
);
3137 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3138 int *f ATTRIBUTE_UNUSED
)
3142 /* Don't bother recursing into other statement functions
3143 since they will be checked individually for purity. */
3144 if (e
->expr_type
!= EXPR_FUNCTION
3146 || e
->symtree
->n
.sym
== sym
3147 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3150 return gfc_pure_function (e
, &name
) ? false : true;
3155 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3157 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3161 /* Check if an impure function is allowed in the current context. */
3163 static bool check_pure_function (gfc_expr
*e
)
3165 const char *name
= NULL
;
3166 if (!gfc_pure_function (e
, &name
) && name
)
3170 gfc_error ("Reference to impure function %qs at %L inside a "
3171 "FORALL %s", name
, &e
->where
,
3172 forall_flag
== 2 ? "mask" : "block");
3175 else if (gfc_do_concurrent_flag
)
3177 gfc_error ("Reference to impure function %qs at %L inside a "
3178 "DO CONCURRENT %s", name
, &e
->where
,
3179 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3182 else if (gfc_pure (NULL
))
3184 gfc_error ("Reference to impure function %qs at %L "
3185 "within a PURE procedure", name
, &e
->where
);
3188 if (!gfc_implicit_pure_function (e
))
3189 gfc_unset_implicit_pure (NULL
);
3195 /* Update current procedure's array_outer_dependency flag, considering
3196 a call to procedure SYM. */
3199 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3201 /* Check to see if this is a sibling function that has not yet
3203 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3204 for (; sibling
; sibling
= sibling
->sibling
)
3206 if (sibling
->proc_name
== sym
)
3208 gfc_resolve (sibling
);
3213 /* If SYM has references to outer arrays, so has the procedure calling
3214 SYM. If SYM is a procedure pointer, we can assume the worst. */
3215 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3216 && gfc_current_ns
->proc_name
)
3217 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3221 /* Resolve a function call, which means resolving the arguments, then figuring
3222 out which entity the name refers to. */
3225 resolve_function (gfc_expr
*expr
)
3227 gfc_actual_arglist
*arg
;
3231 procedure_type p
= PROC_INTRINSIC
;
3232 bool no_formal_args
;
3236 sym
= expr
->symtree
->n
.sym
;
3238 /* If this is a procedure pointer component, it has already been resolved. */
3239 if (gfc_is_proc_ptr_comp (expr
))
3242 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3244 if (sym
&& sym
->attr
.intrinsic
3245 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3246 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3251 gfc_error ("Unexpected junk after %qs at %L", expr
->symtree
->n
.sym
->name
,
3256 if (sym
&& sym
->attr
.intrinsic
3257 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3260 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3262 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3266 /* If this is a deferred TBP with an abstract interface (which may
3267 of course be referenced), expr->value.function.esym will be set. */
3268 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3270 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3271 sym
->name
, &expr
->where
);
3275 /* If this is a deferred TBP with an abstract interface, its result
3276 cannot be an assumed length character (F2003: C418). */
3277 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3278 && sym
->result
->ts
.u
.cl
3279 && sym
->result
->ts
.u
.cl
->length
== NULL
3280 && !sym
->result
->ts
.deferred
)
3282 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3283 "character length result (F2008: C418)", sym
->name
,
3288 /* Switch off assumed size checking and do this again for certain kinds
3289 of procedure, once the procedure itself is resolved. */
3290 need_full_assumed_size
++;
3292 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3293 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3295 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3296 inquiry_argument
= true;
3297 no_formal_args
= sym
&& is_external_proc (sym
)
3298 && gfc_sym_get_dummy_args (sym
) == NULL
;
3300 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3303 inquiry_argument
= false;
3307 inquiry_argument
= false;
3309 /* Resume assumed_size checking. */
3310 need_full_assumed_size
--;
3312 /* If the procedure is external, check for usage. */
3313 if (sym
&& is_external_proc (sym
))
3314 resolve_global_procedure (sym
, &expr
->where
, 0);
3316 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3318 && sym
->ts
.u
.cl
->length
== NULL
3320 && !sym
->ts
.deferred
3321 && expr
->value
.function
.esym
== NULL
3322 && !sym
->attr
.contained
)
3324 /* Internal procedures are taken care of in resolve_contained_fntype. */
3325 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3326 "be used at %L since it is not a dummy argument",
3327 sym
->name
, &expr
->where
);
3331 /* See if function is already resolved. */
3333 if (expr
->value
.function
.name
!= NULL
3334 || expr
->value
.function
.isym
!= NULL
)
3336 if (expr
->ts
.type
== BT_UNKNOWN
)
3342 /* Apply the rules of section 14.1.2. */
3344 switch (procedure_kind (sym
))
3347 t
= resolve_generic_f (expr
);
3350 case PTYPE_SPECIFIC
:
3351 t
= resolve_specific_f (expr
);
3355 t
= resolve_unknown_f (expr
);
3359 gfc_internal_error ("resolve_function(): bad function type");
3363 /* If the expression is still a function (it might have simplified),
3364 then we check to see if we are calling an elemental function. */
3366 if (expr
->expr_type
!= EXPR_FUNCTION
)
3369 /* Walk the argument list looking for invalid BOZ. */
3370 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3371 if (arg
->expr
&& arg
->expr
->ts
.type
== BT_BOZ
)
3373 gfc_error ("A BOZ literal constant at %L cannot appear as an "
3374 "actual argument in a function reference",
3379 temp
= need_full_assumed_size
;
3380 need_full_assumed_size
= 0;
3382 if (!resolve_elemental_actual (expr
, NULL
))
3385 if (omp_workshare_flag
3386 && expr
->value
.function
.esym
3387 && ! gfc_elemental (expr
->value
.function
.esym
))
3389 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3390 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3395 #define GENERIC_ID expr->value.function.isym->id
3396 else if (expr
->value
.function
.actual
!= NULL
3397 && expr
->value
.function
.isym
!= NULL
3398 && GENERIC_ID
!= GFC_ISYM_LBOUND
3399 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3400 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3401 && GENERIC_ID
!= GFC_ISYM_LEN
3402 && GENERIC_ID
!= GFC_ISYM_LOC
3403 && GENERIC_ID
!= GFC_ISYM_C_LOC
3404 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3406 /* Array intrinsics must also have the last upper bound of an
3407 assumed size array argument. UBOUND and SIZE have to be
3408 excluded from the check if the second argument is anything
3411 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3413 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3414 && arg
== expr
->value
.function
.actual
3415 && arg
->next
!= NULL
&& arg
->next
->expr
)
3417 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3420 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3423 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3428 if (arg
->expr
!= NULL
3429 && arg
->expr
->rank
> 0
3430 && resolve_assumed_size_actual (arg
->expr
))
3436 need_full_assumed_size
= temp
;
3438 if (!check_pure_function(expr
))
3441 /* Functions without the RECURSIVE attribution are not allowed to
3442 * call themselves. */
3443 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3446 esym
= expr
->value
.function
.esym
;
3448 if (is_illegal_recursion (esym
, gfc_current_ns
))
3450 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3451 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3452 " function %qs is not RECURSIVE",
3453 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3455 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3456 " is not RECURSIVE", esym
->name
, &expr
->where
);
3462 /* Character lengths of use associated functions may contains references to
3463 symbols not referenced from the current program unit otherwise. Make sure
3464 those symbols are marked as referenced. */
3466 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3467 && expr
->value
.function
.esym
->attr
.use_assoc
)
3469 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3472 /* Make sure that the expression has a typespec that works. */
3473 if (expr
->ts
.type
== BT_UNKNOWN
)
3475 if (expr
->symtree
->n
.sym
->result
3476 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3477 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3478 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3481 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3483 if (expr
->value
.function
.esym
)
3484 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3486 update_current_proc_array_outer_dependency (sym
);
3489 /* typebound procedure: Assume the worst. */
3490 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3492 if (expr
->value
.function
.esym
3493 && expr
->value
.function
.esym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
))
3494 gfc_warning (OPT_Wdeprecated_declarations
,
3495 "Using function %qs at %L is deprecated",
3496 sym
->name
, &expr
->where
);
3501 /************* Subroutine resolution *************/
3504 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3511 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3515 else if (gfc_do_concurrent_flag
)
3517 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3521 else if (gfc_pure (NULL
))
3523 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3527 gfc_unset_implicit_pure (NULL
);
3533 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3537 if (sym
->attr
.generic
)
3539 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3542 c
->resolved_sym
= s
;
3543 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3548 /* TODO: Need to search for elemental references in generic interface. */
3551 if (sym
->attr
.intrinsic
)
3552 return gfc_intrinsic_sub_interface (c
, 0);
3559 resolve_generic_s (gfc_code
*c
)
3564 sym
= c
->symtree
->n
.sym
;
3568 m
= resolve_generic_s0 (c
, sym
);
3571 else if (m
== MATCH_ERROR
)
3575 if (sym
->ns
->parent
== NULL
)
3577 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3581 if (!generic_sym (sym
))
3585 /* Last ditch attempt. See if the reference is to an intrinsic
3586 that possesses a matching interface. 14.1.2.4 */
3587 sym
= c
->symtree
->n
.sym
;
3589 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3591 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3592 sym
->name
, &c
->loc
);
3596 m
= gfc_intrinsic_sub_interface (c
, 0);
3600 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3601 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3607 /* Resolve a subroutine call known to be specific. */
3610 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3614 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3616 if (sym
->attr
.dummy
)
3618 sym
->attr
.proc
= PROC_DUMMY
;
3622 sym
->attr
.proc
= PROC_EXTERNAL
;
3626 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3629 if (sym
->attr
.intrinsic
)
3631 m
= gfc_intrinsic_sub_interface (c
, 1);
3635 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3636 "with an intrinsic", sym
->name
, &c
->loc
);
3644 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3646 c
->resolved_sym
= sym
;
3647 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3655 resolve_specific_s (gfc_code
*c
)
3660 sym
= c
->symtree
->n
.sym
;
3664 m
= resolve_specific_s0 (c
, sym
);
3667 if (m
== MATCH_ERROR
)
3670 if (sym
->ns
->parent
== NULL
)
3673 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3679 sym
= c
->symtree
->n
.sym
;
3680 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3681 sym
->name
, &c
->loc
);
3687 /* Resolve a subroutine call not known to be generic nor specific. */
3690 resolve_unknown_s (gfc_code
*c
)
3694 sym
= c
->symtree
->n
.sym
;
3696 if (sym
->attr
.dummy
)
3698 sym
->attr
.proc
= PROC_DUMMY
;
3702 /* See if we have an intrinsic function reference. */
3704 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3706 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3711 /* The reference is to an external name. */
3714 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3716 c
->resolved_sym
= sym
;
3718 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3722 /* Resolve a subroutine call. Although it was tempting to use the same code
3723 for functions, subroutines and functions are stored differently and this
3724 makes things awkward. */
3727 resolve_call (gfc_code
*c
)
3730 procedure_type ptype
= PROC_INTRINSIC
;
3731 gfc_symbol
*csym
, *sym
;
3732 bool no_formal_args
;
3734 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3736 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3738 gfc_error ("%qs at %L has a type, which is not consistent with "
3739 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3743 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3746 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3747 sym
= st
? st
->n
.sym
: NULL
;
3748 if (sym
&& csym
!= sym
3749 && sym
->ns
== gfc_current_ns
3750 && sym
->attr
.flavor
== FL_PROCEDURE
3751 && sym
->attr
.contained
)
3754 if (csym
->attr
.generic
)
3755 c
->symtree
->n
.sym
= sym
;
3758 csym
= c
->symtree
->n
.sym
;
3762 /* If this ia a deferred TBP, c->expr1 will be set. */
3763 if (!c
->expr1
&& csym
)
3765 if (csym
->attr
.abstract
)
3767 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3768 csym
->name
, &c
->loc
);
3772 /* Subroutines without the RECURSIVE attribution are not allowed to
3774 if (is_illegal_recursion (csym
, gfc_current_ns
))
3776 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3777 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3778 "as subroutine %qs is not RECURSIVE",
3779 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3781 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3782 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3788 /* Switch off assumed size checking and do this again for certain kinds
3789 of procedure, once the procedure itself is resolved. */
3790 need_full_assumed_size
++;
3793 ptype
= csym
->attr
.proc
;
3795 no_formal_args
= csym
&& is_external_proc (csym
)
3796 && gfc_sym_get_dummy_args (csym
) == NULL
;
3797 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3800 /* Resume assumed_size checking. */
3801 need_full_assumed_size
--;
3803 /* If external, check for usage. */
3804 if (csym
&& is_external_proc (csym
))
3805 resolve_global_procedure (csym
, &c
->loc
, 1);
3808 if (c
->resolved_sym
== NULL
)
3810 c
->resolved_isym
= NULL
;
3811 switch (procedure_kind (csym
))
3814 t
= resolve_generic_s (c
);
3817 case PTYPE_SPECIFIC
:
3818 t
= resolve_specific_s (c
);
3822 t
= resolve_unknown_s (c
);
3826 gfc_internal_error ("resolve_subroutine(): bad function type");
3830 /* Some checks of elemental subroutine actual arguments. */
3831 if (!resolve_elemental_actual (NULL
, c
))
3835 update_current_proc_array_outer_dependency (csym
);
3837 /* Typebound procedure: Assume the worst. */
3838 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3841 && c
->resolved_sym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
))
3842 gfc_warning (OPT_Wdeprecated_declarations
,
3843 "Using subroutine %qs at %L is deprecated",
3844 c
->resolved_sym
->name
, &c
->loc
);
3850 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3851 op1->shape and op2->shape are non-NULL return true if their shapes
3852 match. If both op1->shape and op2->shape are non-NULL return false
3853 if their shapes do not match. If either op1->shape or op2->shape is
3854 NULL, return true. */
3857 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3864 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3866 for (i
= 0; i
< op1
->rank
; i
++)
3868 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3870 gfc_error ("Shapes for operands at %L and %L are not conformable",
3871 &op1
->where
, &op2
->where
);
3881 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3882 For example A .AND. B becomes IAND(A, B). */
3884 logical_to_bitwise (gfc_expr
*e
)
3886 gfc_expr
*tmp
, *op1
, *op2
;
3888 gfc_actual_arglist
*args
= NULL
;
3890 gcc_assert (e
->expr_type
== EXPR_OP
);
3892 isym
= GFC_ISYM_NONE
;
3893 op1
= e
->value
.op
.op1
;
3894 op2
= e
->value
.op
.op2
;
3896 switch (e
->value
.op
.op
)
3899 isym
= GFC_ISYM_NOT
;
3902 isym
= GFC_ISYM_IAND
;
3905 isym
= GFC_ISYM_IOR
;
3907 case INTRINSIC_NEQV
:
3908 isym
= GFC_ISYM_IEOR
;
3911 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3912 Change the old expression to NEQV, which will get replaced by IEOR,
3913 and wrap it in NOT. */
3914 tmp
= gfc_copy_expr (e
);
3915 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3916 tmp
= logical_to_bitwise (tmp
);
3917 isym
= GFC_ISYM_NOT
;
3922 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3925 /* Inherit the original operation's operands as arguments. */
3926 args
= gfc_get_actual_arglist ();
3930 args
->next
= gfc_get_actual_arglist ();
3931 args
->next
->expr
= op2
;
3934 /* Convert the expression to a function call. */
3935 e
->expr_type
= EXPR_FUNCTION
;
3936 e
->value
.function
.actual
= args
;
3937 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3938 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3939 e
->value
.function
.esym
= NULL
;
3941 /* Make up a pre-resolved function call symtree if we need to. */
3942 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3945 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3946 sym
= e
->symtree
->n
.sym
;
3948 sym
->attr
.flavor
= FL_PROCEDURE
;
3949 sym
->attr
.function
= 1;
3950 sym
->attr
.elemental
= 1;
3952 sym
->attr
.referenced
= 1;
3953 gfc_intrinsic_symbol (sym
);
3954 gfc_commit_symbol (sym
);
3957 args
->name
= e
->value
.function
.isym
->formal
->name
;
3958 if (e
->value
.function
.isym
->formal
->next
)
3959 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3964 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3965 candidates in CANDIDATES_LEN. */
3967 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3969 size_t &candidates_len
)
3976 /* Not sure how to properly filter here. Use all for a start.
3977 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3978 these as i suppose they don't make terribly sense. */
3980 if (uop
->n
.uop
->op
!= NULL
)
3981 vec_push (candidates
, candidates_len
, uop
->name
);
3985 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3989 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3992 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3995 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3997 char **candidates
= NULL
;
3998 size_t candidates_len
= 0;
3999 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
4000 return gfc_closest_fuzzy_match (op
, candidates
);
4004 /* Callback finding an impure function as an operand to an .and. or
4005 .or. expression. Remember the last function warned about to
4006 avoid double warnings when recursing. */
4009 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4014 static gfc_expr
*last
= NULL
;
4015 bool *found
= (bool *) data
;
4017 if (f
->expr_type
== EXPR_FUNCTION
)
4020 if (f
!= last
&& !gfc_pure_function (f
, &name
)
4021 && !gfc_implicit_pure_function (f
))
4024 gfc_warning (OPT_Wfunction_elimination
,
4025 "Impure function %qs at %L might not be evaluated",
4028 gfc_warning (OPT_Wfunction_elimination
,
4029 "Impure function at %L might not be evaluated",
4038 /* Return true if TYPE is character based, false otherwise. */
4041 is_character_based (bt type
)
4043 return type
== BT_CHARACTER
|| type
== BT_HOLLERITH
;
4047 /* If expression is a hollerith, convert it to character and issue a warning
4048 for the conversion. */
4051 convert_hollerith_to_character (gfc_expr
*e
)
4053 if (e
->ts
.type
== BT_HOLLERITH
)
4057 t
.type
= BT_CHARACTER
;
4058 t
.kind
= e
->ts
.kind
;
4059 gfc_convert_type_warn (e
, &t
, 2, 1);
4063 /* Convert to numeric and issue a warning for the conversion. */
4066 convert_to_numeric (gfc_expr
*a
, gfc_expr
*b
)
4070 t
.type
= b
->ts
.type
;
4071 t
.kind
= b
->ts
.kind
;
4072 gfc_convert_type_warn (a
, &t
, 2, 1);
4075 /* Resolve an operator expression node. This can involve replacing the
4076 operation with a user defined function call. */
4079 resolve_operator (gfc_expr
*e
)
4081 gfc_expr
*op1
, *op2
;
4082 /* One error uses 3 names; additional space for wording (also via gettext). */
4083 char msg
[3*GFC_MAX_SYMBOL_LEN
+ 1 + 50];
4084 bool dual_locus_error
;
4087 /* Resolve all subnodes-- give them types. */
4089 switch (e
->value
.op
.op
)
4092 if (!gfc_resolve_expr (e
->value
.op
.op2
))
4098 case INTRINSIC_UPLUS
:
4099 case INTRINSIC_UMINUS
:
4100 case INTRINSIC_PARENTHESES
:
4101 if (!gfc_resolve_expr (e
->value
.op
.op1
))
4104 && e
->value
.op
.op1
->ts
.type
== BT_BOZ
&& !e
->value
.op
.op2
)
4106 gfc_error ("BOZ literal constant at %L cannot be an operand of "
4107 "unary operator %qs", &e
->value
.op
.op1
->where
,
4108 gfc_op2string (e
->value
.op
.op
));
4114 /* Typecheck the new node. */
4116 op1
= e
->value
.op
.op1
;
4117 op2
= e
->value
.op
.op2
;
4118 if (op1
== NULL
&& op2
== NULL
)
4120 /* Error out if op2 did not resolve. We already diagnosed op1. */
4124 dual_locus_error
= false;
4126 /* op1 and op2 cannot both be BOZ. */
4127 if (op1
&& op1
->ts
.type
== BT_BOZ
4128 && op2
&& op2
->ts
.type
== BT_BOZ
)
4130 gfc_error ("Operands at %L and %L cannot appear as operands of "
4131 "binary operator %qs", &op1
->where
, &op2
->where
,
4132 gfc_op2string (e
->value
.op
.op
));
4136 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
4137 || (op2
&& op2
->expr_type
== EXPR_NULL
))
4139 snprintf (msg
, sizeof (msg
),
4140 _("Invalid context for NULL() pointer at %%L"));
4144 switch (e
->value
.op
.op
)
4146 case INTRINSIC_UPLUS
:
4147 case INTRINSIC_UMINUS
:
4148 if (op1
->ts
.type
== BT_INTEGER
4149 || op1
->ts
.type
== BT_REAL
4150 || op1
->ts
.type
== BT_COMPLEX
)
4156 snprintf (msg
, sizeof (msg
),
4157 _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
4158 gfc_op2string (e
->value
.op
.op
), gfc_typename (e
));
4161 case INTRINSIC_PLUS
:
4162 case INTRINSIC_MINUS
:
4163 case INTRINSIC_TIMES
:
4164 case INTRINSIC_DIVIDE
:
4165 case INTRINSIC_POWER
:
4166 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4168 gfc_type_convert_binary (e
, 1);
4172 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
4173 snprintf (msg
, sizeof (msg
),
4174 _("Unexpected derived-type entities in binary intrinsic "
4175 "numeric operator %%<%s%%> at %%L"),
4176 gfc_op2string (e
->value
.op
.op
));
4178 snprintf (msg
, sizeof(msg
),
4179 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
4180 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4181 gfc_typename (op2
));
4184 case INTRINSIC_CONCAT
:
4185 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4186 && op1
->ts
.kind
== op2
->ts
.kind
)
4188 e
->ts
.type
= BT_CHARACTER
;
4189 e
->ts
.kind
= op1
->ts
.kind
;
4193 snprintf (msg
, sizeof (msg
),
4194 _("Operands of string concatenation operator at %%L are %s/%s"),
4195 gfc_typename (op1
), gfc_typename (op2
));
4201 case INTRINSIC_NEQV
:
4202 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4204 e
->ts
.type
= BT_LOGICAL
;
4205 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4206 if (op1
->ts
.kind
< e
->ts
.kind
)
4207 gfc_convert_type (op1
, &e
->ts
, 2);
4208 else if (op2
->ts
.kind
< e
->ts
.kind
)
4209 gfc_convert_type (op2
, &e
->ts
, 2);
4211 if (flag_frontend_optimize
&&
4212 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4214 /* Warn about short-circuiting
4215 with impure function as second operand. */
4217 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4222 /* Logical ops on integers become bitwise ops with -fdec. */
4224 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4226 e
->ts
.type
= BT_INTEGER
;
4227 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4228 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4229 gfc_convert_type (op1
, &e
->ts
, 1);
4230 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4231 gfc_convert_type (op2
, &e
->ts
, 1);
4232 e
= logical_to_bitwise (e
);
4236 snprintf (msg
, sizeof (msg
),
4237 _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4238 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4239 gfc_typename (op2
));
4244 /* Logical ops on integers become bitwise ops with -fdec. */
4245 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4247 e
->ts
.type
= BT_INTEGER
;
4248 e
->ts
.kind
= op1
->ts
.kind
;
4249 e
= logical_to_bitwise (e
);
4253 if (op1
->ts
.type
== BT_LOGICAL
)
4255 e
->ts
.type
= BT_LOGICAL
;
4256 e
->ts
.kind
= op1
->ts
.kind
;
4260 snprintf (msg
, sizeof (msg
), _("Operand of .not. operator at %%L is %s"),
4261 gfc_typename (op1
));
4265 case INTRINSIC_GT_OS
:
4267 case INTRINSIC_GE_OS
:
4269 case INTRINSIC_LT_OS
:
4271 case INTRINSIC_LE_OS
:
4272 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4274 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4281 case INTRINSIC_EQ_OS
:
4283 case INTRINSIC_NE_OS
:
4286 && is_character_based (op1
->ts
.type
)
4287 && is_character_based (op2
->ts
.type
))
4289 convert_hollerith_to_character (op1
);
4290 convert_hollerith_to_character (op2
);
4293 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4294 && op1
->ts
.kind
== op2
->ts
.kind
)
4296 e
->ts
.type
= BT_LOGICAL
;
4297 e
->ts
.kind
= gfc_default_logical_kind
;
4301 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4302 if (op1
->ts
.type
== BT_BOZ
)
4304 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4305 "as an operand of a relational operator"),
4309 if (op2
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op1
, op2
->ts
.kind
))
4312 if (op2
->ts
.type
== BT_REAL
&& !gfc_boz2real (op1
, op2
->ts
.kind
))
4316 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4317 if (op2
->ts
.type
== BT_BOZ
)
4319 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4320 " as an operand of a relational operator"),
4324 if (op1
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op2
, op1
->ts
.kind
))
4327 if (op1
->ts
.type
== BT_REAL
&& !gfc_boz2real (op2
, op1
->ts
.kind
))
4331 && op1
->ts
.type
== BT_HOLLERITH
&& gfc_numeric_ts (&op2
->ts
))
4332 convert_to_numeric (op1
, op2
);
4335 && gfc_numeric_ts (&op1
->ts
) && op2
->ts
.type
== BT_HOLLERITH
)
4336 convert_to_numeric (op2
, op1
);
4338 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4340 gfc_type_convert_binary (e
, 1);
4342 e
->ts
.type
= BT_LOGICAL
;
4343 e
->ts
.kind
= gfc_default_logical_kind
;
4345 if (warn_compare_reals
)
4347 gfc_intrinsic_op op
= e
->value
.op
.op
;
4349 /* Type conversion has made sure that the types of op1 and op2
4350 agree, so it is only necessary to check the first one. */
4351 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4352 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4353 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4357 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4358 msg
= G_("Equality comparison for %s at %L");
4360 msg
= G_("Inequality comparison for %s at %L");
4362 gfc_warning (OPT_Wcompare_reals
, msg
,
4363 gfc_typename (op1
), &op1
->where
);
4370 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4371 snprintf (msg
, sizeof (msg
),
4372 _("Logicals at %%L must be compared with %s instead of %s"),
4373 (e
->value
.op
.op
== INTRINSIC_EQ
4374 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4375 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4377 snprintf (msg
, sizeof (msg
),
4378 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4379 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4380 gfc_typename (op2
));
4384 case INTRINSIC_USER
:
4385 if (e
->value
.op
.uop
->op
== NULL
)
4387 const char *name
= e
->value
.op
.uop
->name
;
4388 const char *guessed
;
4389 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4391 snprintf (msg
, sizeof (msg
),
4392 _("Unknown operator %%<%s%%> at %%L; did you mean "
4393 "%%<%s%%>?"), name
, guessed
);
4395 snprintf (msg
, sizeof (msg
), _("Unknown operator %%<%s%%> at %%L"),
4398 else if (op2
== NULL
)
4399 snprintf (msg
, sizeof (msg
),
4400 _("Operand of user operator %%<%s%%> at %%L is %s"),
4401 e
->value
.op
.uop
->name
, gfc_typename (op1
));
4404 snprintf (msg
, sizeof (msg
),
4405 _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4406 e
->value
.op
.uop
->name
, gfc_typename (op1
),
4407 gfc_typename (op2
));
4408 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4413 case INTRINSIC_PARENTHESES
:
4415 if (e
->ts
.type
== BT_CHARACTER
)
4416 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4420 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4423 /* Deal with arrayness of an operand through an operator. */
4425 switch (e
->value
.op
.op
)
4427 case INTRINSIC_PLUS
:
4428 case INTRINSIC_MINUS
:
4429 case INTRINSIC_TIMES
:
4430 case INTRINSIC_DIVIDE
:
4431 case INTRINSIC_POWER
:
4432 case INTRINSIC_CONCAT
:
4436 case INTRINSIC_NEQV
:
4438 case INTRINSIC_EQ_OS
:
4440 case INTRINSIC_NE_OS
:
4442 case INTRINSIC_GT_OS
:
4444 case INTRINSIC_GE_OS
:
4446 case INTRINSIC_LT_OS
:
4448 case INTRINSIC_LE_OS
:
4450 if (op1
->rank
== 0 && op2
->rank
== 0)
4453 if (op1
->rank
== 0 && op2
->rank
!= 0)
4455 e
->rank
= op2
->rank
;
4457 if (e
->shape
== NULL
)
4458 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4461 if (op1
->rank
!= 0 && op2
->rank
== 0)
4463 e
->rank
= op1
->rank
;
4465 if (e
->shape
== NULL
)
4466 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4469 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4471 if (op1
->rank
== op2
->rank
)
4473 e
->rank
= op1
->rank
;
4474 if (e
->shape
== NULL
)
4476 t
= compare_shapes (op1
, op2
);
4480 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4485 /* Allow higher level expressions to work. */
4488 /* Try user-defined operators, and otherwise throw an error. */
4489 dual_locus_error
= true;
4490 snprintf (msg
, sizeof (msg
),
4491 _("Inconsistent ranks for operator at %%L and %%L"));
4498 case INTRINSIC_PARENTHESES
:
4500 case INTRINSIC_UPLUS
:
4501 case INTRINSIC_UMINUS
:
4502 /* Simply copy arrayness attribute */
4503 e
->rank
= op1
->rank
;
4505 if (e
->shape
== NULL
)
4506 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4516 /* Attempt to simplify the expression. */
4519 t
= gfc_simplify_expr (e
, 0);
4520 /* Some calls do not succeed in simplification and return false
4521 even though there is no error; e.g. variable references to
4522 PARAMETER arrays. */
4523 if (!gfc_is_constant_expr (e
))
4531 match m
= gfc_extend_expr (e
);
4534 if (m
== MATCH_ERROR
)
4538 if (dual_locus_error
)
4539 gfc_error (msg
, &op1
->where
, &op2
->where
);
4541 gfc_error (msg
, &e
->where
);
4547 /************** Array resolution subroutines **************/
4550 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4552 /* Compare two integer expressions. */
4554 static compare_result
4555 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4559 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4560 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4563 /* If either of the types isn't INTEGER, we must have
4564 raised an error earlier. */
4566 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4569 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4579 /* Compare an integer expression with an integer. */
4581 static compare_result
4582 compare_bound_int (gfc_expr
*a
, int b
)
4587 || a
->expr_type
!= EXPR_CONSTANT
4588 || a
->ts
.type
!= BT_INTEGER
)
4591 i
= mpz_cmp_si (a
->value
.integer
, b
);
4601 /* Compare an integer expression with a mpz_t. */
4603 static compare_result
4604 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4609 || a
->expr_type
!= EXPR_CONSTANT
4610 || a
->ts
.type
!= BT_INTEGER
)
4613 i
= mpz_cmp (a
->value
.integer
, b
);
4623 /* Compute the last value of a sequence given by a triplet.
4624 Return 0 if it wasn't able to compute the last value, or if the
4625 sequence if empty, and 1 otherwise. */
4628 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4629 gfc_expr
*stride
, mpz_t last
)
4633 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4634 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4635 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4638 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4639 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4642 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4644 if (compare_bound (start
, end
) == CMP_GT
)
4646 mpz_set (last
, end
->value
.integer
);
4650 if (compare_bound_int (stride
, 0) == CMP_GT
)
4652 /* Stride is positive */
4653 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4658 /* Stride is negative */
4659 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4664 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4665 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4666 mpz_sub (last
, end
->value
.integer
, rem
);
4673 /* Compare a single dimension of an array reference to the array
4677 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4681 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4683 gcc_assert (ar
->stride
[i
] == NULL
);
4684 /* This implies [*] as [*:] and [*:3] are not possible. */
4685 if (ar
->start
[i
] == NULL
)
4687 gcc_assert (ar
->end
[i
] == NULL
);
4692 /* Given start, end and stride values, calculate the minimum and
4693 maximum referenced indexes. */
4695 switch (ar
->dimen_type
[i
])
4698 case DIMEN_THIS_IMAGE
:
4703 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4706 gfc_warning (0, "Array reference at %L is out of bounds "
4707 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4708 mpz_get_si (ar
->start
[i
]->value
.integer
),
4709 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4711 gfc_warning (0, "Array reference at %L is out of bounds "
4712 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4713 mpz_get_si (ar
->start
[i
]->value
.integer
),
4714 mpz_get_si (as
->lower
[i
]->value
.integer
),
4718 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4721 gfc_warning (0, "Array reference at %L is out of bounds "
4722 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4723 mpz_get_si (ar
->start
[i
]->value
.integer
),
4724 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4726 gfc_warning (0, "Array reference at %L is out of bounds "
4727 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4728 mpz_get_si (ar
->start
[i
]->value
.integer
),
4729 mpz_get_si (as
->upper
[i
]->value
.integer
),
4738 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4739 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4741 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4742 compare_result comp_stride_zero
= compare_bound_int (ar
->stride
[i
], 0);
4744 /* Check for zero stride, which is not allowed. */
4745 if (comp_stride_zero
== CMP_EQ
)
4747 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4751 /* if start == end || (stride > 0 && start < end)
4752 || (stride < 0 && start > end),
4753 then the array section contains at least one element. In this
4754 case, there is an out-of-bounds access if
4755 (start < lower || start > upper). */
4756 if (comp_start_end
== CMP_EQ
4757 || ((comp_stride_zero
== CMP_GT
|| ar
->stride
[i
] == NULL
)
4758 && comp_start_end
== CMP_LT
)
4759 || (comp_stride_zero
== CMP_LT
4760 && comp_start_end
== CMP_GT
))
4762 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4764 gfc_warning (0, "Lower array reference at %L is out of bounds "
4765 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4766 mpz_get_si (AR_START
->value
.integer
),
4767 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4770 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4772 gfc_warning (0, "Lower array reference at %L is out of bounds "
4773 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4774 mpz_get_si (AR_START
->value
.integer
),
4775 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4780 /* If we can compute the highest index of the array section,
4781 then it also has to be between lower and upper. */
4782 mpz_init (last_value
);
4783 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4786 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4788 gfc_warning (0, "Upper array reference at %L is out of bounds "
4789 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4790 mpz_get_si (last_value
),
4791 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4792 mpz_clear (last_value
);
4795 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4797 gfc_warning (0, "Upper array reference at %L is out of bounds "
4798 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4799 mpz_get_si (last_value
),
4800 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4801 mpz_clear (last_value
);
4805 mpz_clear (last_value
);
4813 gfc_internal_error ("check_dimension(): Bad array reference");
4820 /* Compare an array reference with an array specification. */
4823 compare_spec_to_ref (gfc_array_ref
*ar
)
4830 /* TODO: Full array sections are only allowed as actual parameters. */
4831 if (as
->type
== AS_ASSUMED_SIZE
4832 && (/*ar->type == AR_FULL
4833 ||*/ (ar
->type
== AR_SECTION
4834 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4836 gfc_error ("Rightmost upper bound of assumed size array section "
4837 "not specified at %L", &ar
->where
);
4841 if (ar
->type
== AR_FULL
)
4844 if (as
->rank
!= ar
->dimen
)
4846 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4847 &ar
->where
, ar
->dimen
, as
->rank
);
4851 /* ar->codimen == 0 is a local array. */
4852 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4854 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4855 &ar
->where
, ar
->codimen
, as
->corank
);
4859 for (i
= 0; i
< as
->rank
; i
++)
4860 if (!check_dimension (i
, ar
, as
))
4863 /* Local access has no coarray spec. */
4864 if (ar
->codimen
!= 0)
4865 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4867 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4868 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4870 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4871 i
+ 1 - as
->rank
, &ar
->where
);
4874 if (!check_dimension (i
, ar
, as
))
4882 /* Resolve one part of an array index. */
4885 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4886 int force_index_integer_kind
)
4893 if (!gfc_resolve_expr (index
))
4896 if (check_scalar
&& index
->rank
!= 0)
4898 gfc_error ("Array index at %L must be scalar", &index
->where
);
4902 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4904 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4905 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4909 if (index
->ts
.type
== BT_REAL
)
4910 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4914 if ((index
->ts
.kind
!= gfc_index_integer_kind
4915 && force_index_integer_kind
)
4916 || index
->ts
.type
!= BT_INTEGER
)
4919 ts
.type
= BT_INTEGER
;
4920 ts
.kind
= gfc_index_integer_kind
;
4922 gfc_convert_type_warn (index
, &ts
, 2, 0);
4928 /* Resolve one part of an array index. */
4931 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4933 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4936 /* Resolve a dim argument to an intrinsic function. */
4939 gfc_resolve_dim_arg (gfc_expr
*dim
)
4944 if (!gfc_resolve_expr (dim
))
4949 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4954 if (dim
->ts
.type
!= BT_INTEGER
)
4956 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4960 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4965 ts
.type
= BT_INTEGER
;
4966 ts
.kind
= gfc_index_integer_kind
;
4968 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4974 /* Given an expression that contains array references, update those array
4975 references to point to the right array specifications. While this is
4976 filled in during matching, this information is difficult to save and load
4977 in a module, so we take care of it here.
4979 The idea here is that the original array reference comes from the
4980 base symbol. We traverse the list of reference structures, setting
4981 the stored reference to references. Component references can
4982 provide an additional array specification. */
4984 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
);
4987 find_array_spec (gfc_expr
*e
)
4992 bool class_as
= false;
4994 if (e
->symtree
->n
.sym
->assoc
)
4996 if (e
->symtree
->n
.sym
->assoc
->target
)
4997 gfc_resolve_expr (e
->symtree
->n
.sym
->assoc
->target
);
4998 resolve_assoc_var (e
->symtree
->n
.sym
, false);
5001 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
5003 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
5007 as
= e
->symtree
->n
.sym
->as
;
5009 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5015 locus loc
= ref
->u
.ar
.where
.lb
? ref
->u
.ar
.where
: e
->where
;
5016 gfc_error ("Invalid array reference of a non-array entity at %L",
5026 c
= ref
->u
.c
.component
;
5027 if (c
->attr
.dimension
)
5029 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
5030 gfc_internal_error ("find_array_spec(): unused as(1)");
5042 gfc_internal_error ("find_array_spec(): unused as(2)");
5048 /* Resolve an array reference. */
5051 resolve_array_ref (gfc_array_ref
*ar
)
5053 int i
, check_scalar
;
5056 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
5058 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
5060 /* Do not force gfc_index_integer_kind for the start. We can
5061 do fine with any integer kind. This avoids temporary arrays
5062 created for indexing with a vector. */
5063 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
5065 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
5067 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
5072 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
5076 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
5080 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
5081 if (e
->expr_type
== EXPR_VARIABLE
5082 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
5083 ar
->start
[i
] = gfc_get_parentheses (e
);
5087 gfc_error ("Array index at %L is an array of rank %d",
5088 &ar
->c_where
[i
], e
->rank
);
5092 /* Fill in the upper bound, which may be lower than the
5093 specified one for something like a(2:10:5), which is
5094 identical to a(2:7:5). Only relevant for strides not equal
5095 to one. Don't try a division by zero. */
5096 if (ar
->dimen_type
[i
] == DIMEN_RANGE
5097 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
5098 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
5099 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
5103 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
5105 if (ar
->end
[i
] == NULL
)
5108 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
5110 mpz_set (ar
->end
[i
]->value
.integer
, end
);
5112 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
5113 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
5115 mpz_set (ar
->end
[i
]->value
.integer
, end
);
5126 if (ar
->type
== AR_FULL
)
5128 if (ar
->as
->rank
== 0)
5129 ar
->type
= AR_ELEMENT
;
5131 /* Make sure array is the same as array(:,:), this way
5132 we don't need to special case all the time. */
5133 ar
->dimen
= ar
->as
->rank
;
5134 for (i
= 0; i
< ar
->dimen
; i
++)
5136 ar
->dimen_type
[i
] = DIMEN_RANGE
;
5138 gcc_assert (ar
->start
[i
] == NULL
);
5139 gcc_assert (ar
->end
[i
] == NULL
);
5140 gcc_assert (ar
->stride
[i
] == NULL
);
5144 /* If the reference type is unknown, figure out what kind it is. */
5146 if (ar
->type
== AR_UNKNOWN
)
5148 ar
->type
= AR_ELEMENT
;
5149 for (i
= 0; i
< ar
->dimen
; i
++)
5150 if (ar
->dimen_type
[i
] == DIMEN_RANGE
5151 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5153 ar
->type
= AR_SECTION
;
5158 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
5161 if (ar
->as
->corank
&& ar
->codimen
== 0)
5164 ar
->codimen
= ar
->as
->corank
;
5165 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
5166 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
5174 gfc_resolve_substring (gfc_ref
*ref
, bool *equal_length
)
5176 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5178 if (ref
->u
.ss
.start
!= NULL
)
5180 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
5183 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
5185 gfc_error ("Substring start index at %L must be of type INTEGER",
5186 &ref
->u
.ss
.start
->where
);
5190 if (ref
->u
.ss
.start
->rank
!= 0)
5192 gfc_error ("Substring start index at %L must be scalar",
5193 &ref
->u
.ss
.start
->where
);
5197 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
5198 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5199 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5201 gfc_error ("Substring start index at %L is less than one",
5202 &ref
->u
.ss
.start
->where
);
5207 if (ref
->u
.ss
.end
!= NULL
)
5209 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
5212 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
5214 gfc_error ("Substring end index at %L must be of type INTEGER",
5215 &ref
->u
.ss
.end
->where
);
5219 if (ref
->u
.ss
.end
->rank
!= 0)
5221 gfc_error ("Substring end index at %L must be scalar",
5222 &ref
->u
.ss
.end
->where
);
5226 if (ref
->u
.ss
.length
!= NULL
5227 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
5228 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5229 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5231 gfc_error ("Substring end index at %L exceeds the string length",
5232 &ref
->u
.ss
.start
->where
);
5236 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
5237 gfc_integer_kinds
[k
].huge
) == CMP_GT
5238 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5239 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5241 gfc_error ("Substring end index at %L is too large",
5242 &ref
->u
.ss
.end
->where
);
5245 /* If the substring has the same length as the original
5246 variable, the reference itself can be deleted. */
5248 if (ref
->u
.ss
.length
!= NULL
5249 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
5250 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
5251 *equal_length
= true;
5258 /* This function supplies missing substring charlens. */
5261 gfc_resolve_substring_charlen (gfc_expr
*e
)
5264 gfc_expr
*start
, *end
;
5265 gfc_typespec
*ts
= NULL
;
5268 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5270 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5272 if (char_ref
->type
== REF_COMPONENT
)
5273 ts
= &char_ref
->u
.c
.component
->ts
;
5276 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5279 gcc_assert (char_ref
->next
== NULL
);
5283 if (e
->ts
.u
.cl
->length
)
5284 gfc_free_expr (e
->ts
.u
.cl
->length
);
5285 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5290 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5292 if (char_ref
->u
.ss
.start
)
5293 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5295 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5297 if (char_ref
->u
.ss
.end
)
5298 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5299 else if (e
->expr_type
== EXPR_VARIABLE
)
5302 ts
= &e
->symtree
->n
.sym
->ts
;
5303 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5310 gfc_free_expr (start
);
5311 gfc_free_expr (end
);
5315 /* Length = (end - start + 1).
5316 Check first whether it has a constant length. */
5317 if (gfc_dep_difference (end
, start
, &diff
))
5319 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5322 mpz_add_ui (len
->value
.integer
, diff
, 1);
5324 e
->ts
.u
.cl
->length
= len
;
5325 /* The check for length < 0 is handled below */
5329 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5330 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5331 gfc_get_int_expr (gfc_charlen_int_kind
,
5335 /* F2008, 6.4.1: Both the starting point and the ending point shall
5336 be within the range 1, 2, ..., n unless the starting point exceeds
5337 the ending point, in which case the substring has length zero. */
5339 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5340 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5342 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5343 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5345 /* Make sure that the length is simplified. */
5346 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5347 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5351 /* Resolve subtype references. */
5354 gfc_resolve_ref (gfc_expr
*expr
)
5356 int current_part_dimension
, n_components
, seen_part_dimension
, dim
;
5357 gfc_ref
*ref
, **prev
, *array_ref
;
5360 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5361 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5363 if (!find_array_spec (expr
))
5368 for (prev
= &expr
->ref
; *prev
!= NULL
;
5369 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5370 switch ((*prev
)->type
)
5373 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5382 equal_length
= false;
5383 if (!gfc_resolve_substring (*prev
, &equal_length
))
5386 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5388 /* Remove the reference and move the charlen, if any. */
5392 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5393 ref
->u
.ss
.length
= NULL
;
5394 gfc_free_ref_list (ref
);
5399 /* Check constraints on part references. */
5401 current_part_dimension
= 0;
5402 seen_part_dimension
= 0;
5406 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5412 switch (ref
->u
.ar
.type
)
5415 /* Coarray scalar. */
5416 if (ref
->u
.ar
.as
->rank
== 0)
5418 current_part_dimension
= 0;
5423 current_part_dimension
= 1;
5428 current_part_dimension
= 0;
5432 gfc_internal_error ("resolve_ref(): Bad array reference");
5438 if (current_part_dimension
|| seen_part_dimension
)
5441 if (ref
->u
.c
.component
->attr
.pointer
5442 || ref
->u
.c
.component
->attr
.proc_pointer
5443 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5444 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5446 gfc_error ("Component to the right of a part reference "
5447 "with nonzero rank must not have the POINTER "
5448 "attribute at %L", &expr
->where
);
5451 else if (ref
->u
.c
.component
->attr
.allocatable
5452 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5453 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5456 gfc_error ("Component to the right of a part reference "
5457 "with nonzero rank must not have the ALLOCATABLE "
5458 "attribute at %L", &expr
->where
);
5470 /* Implement requirement in note 9.7 of F2018 that the result of the
5471 LEN inquiry be a scalar. */
5472 if (ref
->u
.i
== INQUIRY_LEN
&& array_ref
&& expr
->ts
.deferred
)
5474 array_ref
->u
.ar
.type
= AR_ELEMENT
;
5476 /* INQUIRY_LEN is not evaluated from the rest of the expr
5477 but directly from the string length. This means that setting
5478 the array indices to one does not matter but might trigger
5479 a runtime bounds error. Suppress the check. */
5480 expr
->no_bounds_check
= 1;
5481 for (dim
= 0; dim
< array_ref
->u
.ar
.dimen
; dim
++)
5483 array_ref
->u
.ar
.dimen_type
[dim
] = DIMEN_ELEMENT
;
5484 if (array_ref
->u
.ar
.start
[dim
])
5485 gfc_free_expr (array_ref
->u
.ar
.start
[dim
]);
5486 array_ref
->u
.ar
.start
[dim
]
5487 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
5488 if (array_ref
->u
.ar
.end
[dim
])
5489 gfc_free_expr (array_ref
->u
.ar
.end
[dim
]);
5490 if (array_ref
->u
.ar
.stride
[dim
])
5491 gfc_free_expr (array_ref
->u
.ar
.stride
[dim
]);
5497 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5498 || ref
->next
== NULL
)
5499 && current_part_dimension
5500 && seen_part_dimension
)
5502 gfc_error ("Two or more part references with nonzero rank must "
5503 "not be specified at %L", &expr
->where
);
5507 if (ref
->type
== REF_COMPONENT
)
5509 if (current_part_dimension
)
5510 seen_part_dimension
= 1;
5512 /* reset to make sure */
5513 current_part_dimension
= 0;
5521 /* Given an expression, determine its shape. This is easier than it sounds.
5522 Leaves the shape array NULL if it is not possible to determine the shape. */
5525 expression_shape (gfc_expr
*e
)
5527 mpz_t array
[GFC_MAX_DIMENSIONS
];
5530 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5533 for (i
= 0; i
< e
->rank
; i
++)
5534 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5537 e
->shape
= gfc_get_shape (e
->rank
);
5539 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5544 for (i
--; i
>= 0; i
--)
5545 mpz_clear (array
[i
]);
5549 /* Given a variable expression node, compute the rank of the expression by
5550 examining the base symbol and any reference structures it may have. */
5553 gfc_expression_rank (gfc_expr
*e
)
5558 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5559 could lead to serious confusion... */
5560 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5564 if (e
->expr_type
== EXPR_ARRAY
)
5566 /* Constructors can have a rank different from one via RESHAPE(). */
5568 e
->rank
= ((e
->symtree
== NULL
|| e
->symtree
->n
.sym
->as
== NULL
)
5569 ? 0 : e
->symtree
->n
.sym
->as
->rank
);
5575 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5577 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5578 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5579 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5581 if (ref
->type
!= REF_ARRAY
)
5584 if (ref
->u
.ar
.type
== AR_FULL
)
5586 rank
= ref
->u
.ar
.as
->rank
;
5590 if (ref
->u
.ar
.type
== AR_SECTION
)
5592 /* Figure out the rank of the section. */
5594 gfc_internal_error ("gfc_expression_rank(): Two array specs");
5596 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5597 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5598 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5608 expression_shape (e
);
5613 add_caf_get_intrinsic (gfc_expr
*e
)
5615 gfc_expr
*wrapper
, *tmp_expr
;
5619 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5620 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5625 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5626 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5629 tmp_expr
= XCNEW (gfc_expr
);
5631 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5632 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5633 wrapper
->ts
= e
->ts
;
5634 wrapper
->rank
= e
->rank
;
5636 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5643 remove_caf_get_intrinsic (gfc_expr
*e
)
5645 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5646 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5647 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5648 e
->value
.function
.actual
->expr
= NULL
;
5649 gfc_free_actual_arglist (e
->value
.function
.actual
);
5650 gfc_free_shape (&e
->shape
, e
->rank
);
5656 /* Resolve a variable expression. */
5659 resolve_variable (gfc_expr
*e
)
5666 if (e
->symtree
== NULL
)
5668 sym
= e
->symtree
->n
.sym
;
5670 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5671 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5672 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5674 if (!actual_arg
|| inquiry_argument
)
5676 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5677 "be used as actual argument", sym
->name
, &e
->where
);
5681 /* TS 29113, 407b. */
5682 else if (e
->ts
.type
== BT_ASSUMED
)
5686 gfc_error ("Assumed-type variable %s at %L may only be used "
5687 "as actual argument", sym
->name
, &e
->where
);
5690 else if (inquiry_argument
&& !first_actual_arg
)
5692 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5693 for all inquiry functions in resolve_function; the reason is
5694 that the function-name resolution happens too late in that
5696 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5697 "an inquiry function shall be the first argument",
5698 sym
->name
, &e
->where
);
5702 /* TS 29113, C535b. */
5703 else if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5704 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
5705 && CLASS_DATA (sym
)->as
5706 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5707 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5708 && sym
->as
->type
== AS_ASSUMED_RANK
))
5709 && !sym
->attr
.select_rank_temporary
)
5712 && !(cs_base
&& cs_base
->current
5713 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
5715 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5716 "actual argument", sym
->name
, &e
->where
);
5719 else if (inquiry_argument
&& !first_actual_arg
)
5721 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5722 for all inquiry functions in resolve_function; the reason is
5723 that the function-name resolution happens too late in that
5725 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5726 "to an inquiry function shall be the first argument",
5727 sym
->name
, &e
->where
);
5732 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5733 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5734 && e
->ref
->next
== NULL
))
5736 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5737 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5740 /* TS 29113, 407b. */
5741 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5742 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5743 && e
->ref
->next
== NULL
))
5745 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5746 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5750 /* TS 29113, C535b. */
5751 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5752 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
5753 && CLASS_DATA (sym
)->as
5754 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5755 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5756 && sym
->as
->type
== AS_ASSUMED_RANK
))
5758 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5759 && e
->ref
->next
== NULL
))
5761 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5762 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5766 /* For variables that are used in an associate (target => object) where
5767 the object's basetype is array valued while the target is scalar,
5768 the ts' type of the component refs is still array valued, which
5769 can't be translated that way. */
5770 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5771 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5772 && sym
->assoc
->target
->ts
.u
.derived
5773 && CLASS_DATA (sym
->assoc
->target
)
5774 && CLASS_DATA (sym
->assoc
->target
)->as
)
5776 gfc_ref
*ref
= e
->ref
;
5782 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5783 /* Stop the loop. */
5793 /* If this is an associate-name, it may be parsed with an array reference
5794 in error even though the target is scalar. Fail directly in this case.
5795 TODO Understand why class scalar expressions must be excluded. */
5796 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5798 if (sym
->ts
.type
== BT_CLASS
)
5799 gfc_fix_class_refs (e
);
5800 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5802 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5804 /* This can happen because the parser did not detect that the
5805 associate name is an array and the expression had no array
5807 gfc_ref
*ref
= gfc_get_ref ();
5808 ref
->type
= REF_ARRAY
;
5809 ref
->u
.ar
.type
= AR_FULL
;
5812 ref
->u
.ar
.as
= sym
->as
;
5813 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5821 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5822 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5824 /* On the other hand, the parser may not have known this is an array;
5825 in this case, we have to add a FULL reference. */
5826 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5828 e
->ref
= gfc_get_ref ();
5829 e
->ref
->type
= REF_ARRAY
;
5830 e
->ref
->u
.ar
.type
= AR_FULL
;
5831 e
->ref
->u
.ar
.dimen
= 0;
5834 /* Like above, but for class types, where the checking whether an array
5835 ref is present is more complicated. Furthermore make sure not to add
5836 the full array ref to _vptr or _len refs. */
5837 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5839 && CLASS_DATA (sym
)->attr
.dimension
5840 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5842 gfc_ref
*ref
, *newref
;
5844 newref
= gfc_get_ref ();
5845 newref
->type
= REF_ARRAY
;
5846 newref
->u
.ar
.type
= AR_FULL
;
5847 newref
->u
.ar
.dimen
= 0;
5848 /* Because this is an associate var and the first ref either is a ref to
5849 the _data component or not, no traversal of the ref chain is
5850 needed. The array ref needs to be inserted after the _data ref,
5851 or when that is not present, which may happend for polymorphic
5852 types, then at the first position. */
5856 else if (ref
->type
== REF_COMPONENT
5857 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5859 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5861 newref
->next
= ref
->next
;
5865 /* Array ref present already. */
5866 gfc_free_ref_list (newref
);
5868 else if (ref
->type
== REF_ARRAY
)
5869 /* Array ref present already. */
5870 gfc_free_ref_list (newref
);
5878 if (e
->ref
&& !gfc_resolve_ref (e
))
5881 if (sym
->attr
.flavor
== FL_PROCEDURE
5882 && (!sym
->attr
.function
5883 || (sym
->attr
.function
&& sym
->result
5884 && sym
->result
->attr
.proc_pointer
5885 && !sym
->result
->attr
.function
)))
5887 e
->ts
.type
= BT_PROCEDURE
;
5888 goto resolve_procedure
;
5891 if (sym
->ts
.type
!= BT_UNKNOWN
)
5892 gfc_variable_attr (e
, &e
->ts
);
5893 else if (sym
->attr
.flavor
== FL_PROCEDURE
5894 && sym
->attr
.function
&& sym
->result
5895 && sym
->result
->ts
.type
!= BT_UNKNOWN
5896 && sym
->result
->attr
.proc_pointer
)
5897 e
->ts
= sym
->result
->ts
;
5900 /* Must be a simple variable reference. */
5901 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5906 if (check_assumed_size_reference (sym
, e
))
5909 /* Deal with forward references to entries during gfc_resolve_code, to
5910 satisfy, at least partially, 12.5.2.5. */
5911 if (gfc_current_ns
->entries
5912 && current_entry_id
== sym
->entry_id
5915 && cs_base
->current
->op
!= EXEC_ENTRY
)
5917 gfc_entry_list
*entry
;
5918 gfc_formal_arglist
*formal
;
5920 bool seen
, saved_specification_expr
;
5922 /* If the symbol is a dummy... */
5923 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5925 entry
= gfc_current_ns
->entries
;
5928 /* ...test if the symbol is a parameter of previous entries. */
5929 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5930 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5932 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5939 /* If it has not been seen as a dummy, this is an error. */
5942 if (specification_expr
)
5943 gfc_error ("Variable %qs, used in a specification expression"
5944 ", is referenced at %L before the ENTRY statement "
5945 "in which it is a parameter",
5946 sym
->name
, &cs_base
->current
->loc
);
5948 gfc_error ("Variable %qs is used at %L before the ENTRY "
5949 "statement in which it is a parameter",
5950 sym
->name
, &cs_base
->current
->loc
);
5955 /* Now do the same check on the specification expressions. */
5956 saved_specification_expr
= specification_expr
;
5957 specification_expr
= true;
5958 if (sym
->ts
.type
== BT_CHARACTER
5959 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5963 for (n
= 0; n
< sym
->as
->rank
; n
++)
5965 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5967 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5970 specification_expr
= saved_specification_expr
;
5973 /* Update the symbol's entry level. */
5974 sym
->entry_id
= current_entry_id
+ 1;
5977 /* If a symbol has been host_associated mark it. This is used latter,
5978 to identify if aliasing is possible via host association. */
5979 if (sym
->attr
.flavor
== FL_VARIABLE
5980 && gfc_current_ns
->parent
5981 && (gfc_current_ns
->parent
== sym
->ns
5982 || (gfc_current_ns
->parent
->parent
5983 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5984 sym
->attr
.host_assoc
= 1;
5986 if (gfc_current_ns
->proc_name
5987 && sym
->attr
.dimension
5988 && (sym
->ns
!= gfc_current_ns
5989 || sym
->attr
.use_assoc
5990 || sym
->attr
.in_common
))
5991 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5994 if (t
&& !resolve_procedure_expression (e
))
5997 /* F2008, C617 and C1229. */
5998 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5999 && gfc_is_coindexed (e
))
6001 gfc_ref
*ref
, *ref2
= NULL
;
6003 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6005 if (ref
->type
== REF_COMPONENT
)
6007 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
6011 for ( ; ref
; ref
= ref
->next
)
6012 if (ref
->type
== REF_COMPONENT
)
6015 /* Expression itself is not coindexed object. */
6016 if (ref
&& e
->ts
.type
== BT_CLASS
)
6018 gfc_error ("Polymorphic subobject of coindexed object at %L",
6023 /* Expression itself is coindexed object. */
6027 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
6028 for ( ; c
; c
= c
->next
)
6029 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
6031 gfc_error ("Coindexed object with polymorphic allocatable "
6032 "subcomponent at %L", &e
->where
);
6040 gfc_expression_rank (e
);
6042 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
6043 add_caf_get_intrinsic (e
);
6045 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
) && sym
!= sym
->result
)
6046 gfc_warning (OPT_Wdeprecated_declarations
,
6047 "Using variable %qs at %L is deprecated",
6048 sym
->name
, &e
->where
);
6049 /* Simplify cases where access to a parameter array results in a
6050 single constant. Suppress errors since those will have been
6051 issued before, as warnings. */
6052 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
6054 gfc_push_suppress_errors ();
6055 gfc_simplify_expr (e
, 1);
6056 gfc_pop_suppress_errors ();
6063 /* Checks to see that the correct symbol has been host associated.
6064 The only situation where this arises is that in which a twice
6065 contained function is parsed after the host association is made.
6066 Therefore, on detecting this, change the symbol in the expression
6067 and convert the array reference into an actual arglist if the old
6068 symbol is a variable. */
6070 check_host_association (gfc_expr
*e
)
6072 gfc_symbol
*sym
, *old_sym
;
6076 gfc_actual_arglist
*arg
, *tail
= NULL
;
6077 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
6079 /* If the expression is the result of substitution in
6080 interface.cc(gfc_extend_expr) because there is no way in
6081 which the host association can be wrong. */
6082 if (e
->symtree
== NULL
6083 || e
->symtree
->n
.sym
== NULL
6084 || e
->user_operator
)
6087 old_sym
= e
->symtree
->n
.sym
;
6089 if (gfc_current_ns
->parent
6090 && old_sym
->ns
!= gfc_current_ns
)
6092 /* Use the 'USE' name so that renamed module symbols are
6093 correctly handled. */
6094 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
6096 if (sym
&& old_sym
!= sym
6097 && sym
->attr
.flavor
== FL_PROCEDURE
6098 && sym
->attr
.contained
)
6100 /* Clear the shape, since it might not be valid. */
6101 gfc_free_shape (&e
->shape
, e
->rank
);
6103 /* Give the expression the right symtree! */
6104 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
6105 gcc_assert (st
!= NULL
);
6107 if (old_sym
->attr
.flavor
== FL_PROCEDURE
6108 || e
->expr_type
== EXPR_FUNCTION
)
6110 /* Original was function so point to the new symbol, since
6111 the actual argument list is already attached to the
6113 e
->value
.function
.esym
= NULL
;
6118 /* Original was variable so convert array references into
6119 an actual arglist. This does not need any checking now
6120 since resolve_function will take care of it. */
6121 e
->value
.function
.actual
= NULL
;
6122 e
->expr_type
= EXPR_FUNCTION
;
6125 /* Ambiguity will not arise if the array reference is not
6126 the last reference. */
6127 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6128 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6131 if ((ref
== NULL
|| ref
->type
!= REF_ARRAY
)
6132 && sym
->attr
.proc
== PROC_INTERNAL
)
6134 gfc_error ("%qs at %L is host associated at %L into "
6135 "a contained procedure with an internal "
6136 "procedure of the same name", sym
->name
,
6137 &old_sym
->declared_at
, &e
->where
);
6144 gcc_assert (ref
->type
== REF_ARRAY
);
6146 /* Grab the start expressions from the array ref and
6147 copy them into actual arguments. */
6148 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6150 arg
= gfc_get_actual_arglist ();
6151 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
6152 if (e
->value
.function
.actual
== NULL
)
6153 tail
= e
->value
.function
.actual
= arg
;
6161 /* Dump the reference list and set the rank. */
6162 gfc_free_ref_list (e
->ref
);
6164 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
6167 gfc_resolve_expr (e
);
6171 /* This might have changed! */
6172 return e
->expr_type
== EXPR_FUNCTION
;
6177 gfc_resolve_character_operator (gfc_expr
*e
)
6179 gfc_expr
*op1
= e
->value
.op
.op1
;
6180 gfc_expr
*op2
= e
->value
.op
.op2
;
6181 gfc_expr
*e1
= NULL
;
6182 gfc_expr
*e2
= NULL
;
6184 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
6186 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
6187 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
6188 else if (op1
->expr_type
== EXPR_CONSTANT
)
6189 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
6190 op1
->value
.character
.length
);
6192 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
6193 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
6194 else if (op2
->expr_type
== EXPR_CONSTANT
)
6195 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
6196 op2
->value
.character
.length
);
6198 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6208 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
6209 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
6210 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
6211 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
6212 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
6218 /* Ensure that an character expression has a charlen and, if possible, a
6219 length expression. */
6222 fixup_charlen (gfc_expr
*e
)
6224 /* The cases fall through so that changes in expression type and the need
6225 for multiple fixes are picked up. In all circumstances, a charlen should
6226 be available for the middle end to hang a backend_decl on. */
6227 switch (e
->expr_type
)
6230 gfc_resolve_character_operator (e
);
6234 if (e
->expr_type
== EXPR_ARRAY
)
6235 gfc_resolve_character_array_constructor (e
);
6238 case EXPR_SUBSTRING
:
6239 if (!e
->ts
.u
.cl
&& e
->ref
)
6240 gfc_resolve_substring_charlen (e
);
6245 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6252 /* Update an actual argument to include the passed-object for type-bound
6253 procedures at the right position. */
6255 static gfc_actual_arglist
*
6256 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
6259 gcc_assert (argpos
> 0);
6263 gfc_actual_arglist
* result
;
6265 result
= gfc_get_actual_arglist ();
6269 result
->name
= name
;
6275 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
6277 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
6282 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6285 extract_compcall_passed_object (gfc_expr
* e
)
6289 if (e
->expr_type
== EXPR_UNKNOWN
)
6291 gfc_error ("Error in typebound call at %L",
6296 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6298 if (e
->value
.compcall
.base_object
)
6299 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
6302 po
= gfc_get_expr ();
6303 po
->expr_type
= EXPR_VARIABLE
;
6304 po
->symtree
= e
->symtree
;
6305 po
->ref
= gfc_copy_ref (e
->ref
);
6306 po
->where
= e
->where
;
6309 if (!gfc_resolve_expr (po
))
6316 /* Update the arglist of an EXPR_COMPCALL expression to include the
6320 update_compcall_arglist (gfc_expr
* e
)
6323 gfc_typebound_proc
* tbp
;
6325 tbp
= e
->value
.compcall
.tbp
;
6330 po
= extract_compcall_passed_object (e
);
6334 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6340 if (tbp
->pass_arg_num
<= 0)
6343 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6351 /* Extract the passed object from a PPC call (a copy of it). */
6354 extract_ppc_passed_object (gfc_expr
*e
)
6359 po
= gfc_get_expr ();
6360 po
->expr_type
= EXPR_VARIABLE
;
6361 po
->symtree
= e
->symtree
;
6362 po
->ref
= gfc_copy_ref (e
->ref
);
6363 po
->where
= e
->where
;
6365 /* Remove PPC reference. */
6367 while ((*ref
)->next
)
6368 ref
= &(*ref
)->next
;
6369 gfc_free_ref_list (*ref
);
6372 if (!gfc_resolve_expr (po
))
6379 /* Update the actual arglist of a procedure pointer component to include the
6383 update_ppc_arglist (gfc_expr
* e
)
6387 gfc_typebound_proc
* tb
;
6389 ppc
= gfc_get_proc_ptr_comp (e
);
6397 else if (tb
->nopass
)
6400 po
= extract_ppc_passed_object (e
);
6407 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6412 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6414 gfc_error ("Base object for procedure-pointer component call at %L is of"
6415 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6419 gcc_assert (tb
->pass_arg_num
> 0);
6420 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6428 /* Check that the object a TBP is called on is valid, i.e. it must not be
6429 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6432 check_typebound_baseobject (gfc_expr
* e
)
6435 bool return_value
= false;
6437 base
= extract_compcall_passed_object (e
);
6441 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6443 gfc_error ("Error in typebound call at %L", &e
->where
);
6447 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6451 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6453 gfc_error ("Base object for type-bound procedure call at %L is of"
6454 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6458 /* F08:C1230. If the procedure called is NOPASS,
6459 the base object must be scalar. */
6460 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6462 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6463 " be scalar", &e
->where
);
6467 return_value
= true;
6470 gfc_free_expr (base
);
6471 return return_value
;
6475 /* Resolve a call to a type-bound procedure, either function or subroutine,
6476 statically from the data in an EXPR_COMPCALL expression. The adapted
6477 arglist and the target-procedure symtree are returned. */
6480 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6481 gfc_actual_arglist
** actual
)
6483 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6484 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6486 /* Update the actual arglist for PASS. */
6487 if (!update_compcall_arglist (e
))
6490 *actual
= e
->value
.compcall
.actual
;
6491 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6493 gfc_free_ref_list (e
->ref
);
6495 e
->value
.compcall
.actual
= NULL
;
6497 /* If we find a deferred typebound procedure, check for derived types
6498 that an overriding typebound procedure has not been missed. */
6499 if (e
->value
.compcall
.name
6500 && !e
->value
.compcall
.tbp
->non_overridable
6501 && e
->value
.compcall
.base_object
6502 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6505 gfc_symbol
*derived
;
6507 /* Use the derived type of the base_object. */
6508 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6511 /* If necessary, go through the inheritance chain. */
6512 while (!st
&& derived
)
6514 /* Look for the typebound procedure 'name'. */
6515 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6516 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6517 e
->value
.compcall
.name
);
6519 derived
= gfc_get_derived_super_type (derived
);
6522 /* Now find the specific name in the derived type namespace. */
6523 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6524 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6525 derived
->ns
, 1, &st
);
6533 /* Get the ultimate declared type from an expression. In addition,
6534 return the last class/derived type reference and the copy of the
6535 reference list. If check_types is set true, derived types are
6536 identified as well as class references. */
6538 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6539 gfc_expr
*e
, bool check_types
)
6541 gfc_symbol
*declared
;
6548 *new_ref
= gfc_copy_ref (e
->ref
);
6550 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6552 if (ref
->type
!= REF_COMPONENT
)
6555 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6556 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6557 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6559 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6565 if (declared
== NULL
)
6566 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6572 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6573 which of the specific bindings (if any) matches the arglist and transform
6574 the expression into a call of that binding. */
6577 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6579 gfc_typebound_proc
* genproc
;
6580 const char* genname
;
6582 gfc_symbol
*derived
;
6584 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6585 genname
= e
->value
.compcall
.name
;
6586 genproc
= e
->value
.compcall
.tbp
;
6588 if (!genproc
->is_generic
)
6591 /* Try the bindings on this type and in the inheritance hierarchy. */
6592 for (; genproc
; genproc
= genproc
->overridden
)
6596 gcc_assert (genproc
->is_generic
);
6597 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6600 gfc_actual_arglist
* args
;
6603 gcc_assert (g
->specific
);
6605 if (g
->specific
->error
)
6608 target
= g
->specific
->u
.specific
->n
.sym
;
6610 /* Get the right arglist by handling PASS/NOPASS. */
6611 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6612 if (!g
->specific
->nopass
)
6615 po
= extract_compcall_passed_object (e
);
6618 gfc_free_actual_arglist (args
);
6622 gcc_assert (g
->specific
->pass_arg_num
> 0);
6623 gcc_assert (!g
->specific
->error
);
6624 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6625 g
->specific
->pass_arg
);
6627 resolve_actual_arglist (args
, target
->attr
.proc
,
6628 is_external_proc (target
)
6629 && gfc_sym_get_dummy_args (target
) == NULL
);
6631 /* Check if this arglist matches the formal. */
6632 matches
= gfc_arglist_matches_symbol (&args
, target
);
6634 /* Clean up and break out of the loop if we've found it. */
6635 gfc_free_actual_arglist (args
);
6638 e
->value
.compcall
.tbp
= g
->specific
;
6639 genname
= g
->specific_st
->name
;
6640 /* Pass along the name for CLASS methods, where the vtab
6641 procedure pointer component has to be referenced. */
6649 /* Nothing matching found! */
6650 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6651 " %qs at %L", genname
, &e
->where
);
6655 /* Make sure that we have the right specific instance for the name. */
6656 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6658 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6660 e
->value
.compcall
.tbp
= st
->n
.tb
;
6666 /* Resolve a call to a type-bound subroutine. */
6669 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6671 gfc_actual_arglist
* newactual
;
6672 gfc_symtree
* target
;
6674 /* Check that's really a SUBROUTINE. */
6675 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6677 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6678 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6679 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6680 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6681 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6684 gfc_error ("%qs at %L should be a SUBROUTINE",
6685 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6690 if (!check_typebound_baseobject (c
->expr1
))
6693 /* Pass along the name for CLASS methods, where the vtab
6694 procedure pointer component has to be referenced. */
6696 *name
= c
->expr1
->value
.compcall
.name
;
6698 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6701 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6703 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6705 /* Transform into an ordinary EXEC_CALL for now. */
6707 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6710 c
->ext
.actual
= newactual
;
6711 c
->symtree
= target
;
6712 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6714 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6716 gfc_free_expr (c
->expr1
);
6717 c
->expr1
= gfc_get_expr ();
6718 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6719 c
->expr1
->symtree
= target
;
6720 c
->expr1
->where
= c
->loc
;
6722 return resolve_call (c
);
6726 /* Resolve a component-call expression. */
6728 resolve_compcall (gfc_expr
* e
, const char **name
)
6730 gfc_actual_arglist
* newactual
;
6731 gfc_symtree
* target
;
6733 /* Check that's really a FUNCTION. */
6734 if (!e
->value
.compcall
.tbp
->function
)
6736 gfc_error ("%qs at %L should be a FUNCTION",
6737 e
->value
.compcall
.name
, &e
->where
);
6742 /* These must not be assign-calls! */
6743 gcc_assert (!e
->value
.compcall
.assign
);
6745 if (!check_typebound_baseobject (e
))
6748 /* Pass along the name for CLASS methods, where the vtab
6749 procedure pointer component has to be referenced. */
6751 *name
= e
->value
.compcall
.name
;
6753 if (!resolve_typebound_generic_call (e
, name
))
6755 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6757 /* Take the rank from the function's symbol. */
6758 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6759 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6761 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6762 arglist to the TBP's binding target. */
6764 if (!resolve_typebound_static (e
, &target
, &newactual
))
6767 e
->value
.function
.actual
= newactual
;
6768 e
->value
.function
.name
= NULL
;
6769 e
->value
.function
.esym
= target
->n
.sym
;
6770 e
->value
.function
.isym
= NULL
;
6771 e
->symtree
= target
;
6772 e
->ts
= target
->n
.sym
->ts
;
6773 e
->expr_type
= EXPR_FUNCTION
;
6775 /* Resolution is not necessary if this is a class subroutine; this
6776 function only has to identify the specific proc. Resolution of
6777 the call will be done next in resolve_typebound_call. */
6778 return gfc_resolve_expr (e
);
6782 static bool resolve_fl_derived (gfc_symbol
*sym
);
6785 /* Resolve a typebound function, or 'method'. First separate all
6786 the non-CLASS references by calling resolve_compcall directly. */
6789 resolve_typebound_function (gfc_expr
* e
)
6791 gfc_symbol
*declared
;
6803 /* Deal with typebound operators for CLASS objects. */
6804 expr
= e
->value
.compcall
.base_object
;
6805 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6806 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6808 /* Since the typebound operators are generic, we have to ensure
6809 that any delays in resolution are corrected and that the vtab
6812 declared
= ts
.u
.derived
;
6813 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6814 if (c
->ts
.u
.derived
== NULL
)
6815 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6817 if (!resolve_compcall (e
, &name
))
6820 /* Use the generic name if it is there. */
6821 name
= name
? name
: e
->value
.function
.esym
->name
;
6822 e
->symtree
= expr
->symtree
;
6823 e
->ref
= gfc_copy_ref (expr
->ref
);
6824 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6826 /* Trim away the extraneous references that emerge from nested
6827 use of interface.cc (extend_expr). */
6828 if (class_ref
&& class_ref
->next
)
6830 gfc_free_ref_list (class_ref
->next
);
6831 class_ref
->next
= NULL
;
6833 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6835 gfc_free_ref_list (e
->ref
);
6839 gfc_add_vptr_component (e
);
6840 gfc_add_component_ref (e
, name
);
6841 e
->value
.function
.esym
= NULL
;
6842 if (expr
->expr_type
!= EXPR_VARIABLE
)
6843 e
->base_expr
= expr
;
6848 return resolve_compcall (e
, NULL
);
6850 if (!gfc_resolve_ref (e
))
6853 /* Get the CLASS declared type. */
6854 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6856 if (!resolve_fl_derived (declared
))
6859 /* Weed out cases of the ultimate component being a derived type. */
6860 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6861 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6863 gfc_free_ref_list (new_ref
);
6864 return resolve_compcall (e
, NULL
);
6867 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6869 /* Treat the call as if it is a typebound procedure, in order to roll
6870 out the correct name for the specific function. */
6871 if (!resolve_compcall (e
, &name
))
6873 gfc_free_ref_list (new_ref
);
6880 /* Convert the expression to a procedure pointer component call. */
6881 e
->value
.function
.esym
= NULL
;
6887 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6888 gfc_add_vptr_component (e
);
6889 gfc_add_component_ref (e
, name
);
6891 /* Recover the typespec for the expression. This is really only
6892 necessary for generic procedures, where the additional call
6893 to gfc_add_component_ref seems to throw the collection of the
6894 correct typespec. */
6898 gfc_free_ref_list (new_ref
);
6903 /* Resolve a typebound subroutine, or 'method'. First separate all
6904 the non-CLASS references by calling resolve_typebound_call
6908 resolve_typebound_subroutine (gfc_code
*code
)
6910 gfc_symbol
*declared
;
6920 st
= code
->expr1
->symtree
;
6922 /* Deal with typebound operators for CLASS objects. */
6923 expr
= code
->expr1
->value
.compcall
.base_object
;
6924 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6925 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6927 /* If the base_object is not a variable, the corresponding actual
6928 argument expression must be stored in e->base_expression so
6929 that the corresponding tree temporary can be used as the base
6930 object in gfc_conv_procedure_call. */
6931 if (expr
->expr_type
!= EXPR_VARIABLE
)
6933 gfc_actual_arglist
*args
;
6935 args
= code
->expr1
->value
.function
.actual
;
6936 for (; args
; args
= args
->next
)
6937 if (expr
== args
->expr
)
6941 /* Since the typebound operators are generic, we have to ensure
6942 that any delays in resolution are corrected and that the vtab
6944 declared
= expr
->ts
.u
.derived
;
6945 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6946 if (c
->ts
.u
.derived
== NULL
)
6947 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6949 if (!resolve_typebound_call (code
, &name
, NULL
))
6952 /* Use the generic name if it is there. */
6953 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6954 code
->expr1
->symtree
= expr
->symtree
;
6955 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6957 /* Trim away the extraneous references that emerge from nested
6958 use of interface.cc (extend_expr). */
6959 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6960 if (class_ref
&& class_ref
->next
)
6962 gfc_free_ref_list (class_ref
->next
);
6963 class_ref
->next
= NULL
;
6965 else if (code
->expr1
->ref
&& !class_ref
)
6967 gfc_free_ref_list (code
->expr1
->ref
);
6968 code
->expr1
->ref
= NULL
;
6971 /* Now use the procedure in the vtable. */
6972 gfc_add_vptr_component (code
->expr1
);
6973 gfc_add_component_ref (code
->expr1
, name
);
6974 code
->expr1
->value
.function
.esym
= NULL
;
6975 if (expr
->expr_type
!= EXPR_VARIABLE
)
6976 code
->expr1
->base_expr
= expr
;
6981 return resolve_typebound_call (code
, NULL
, NULL
);
6983 if (!gfc_resolve_ref (code
->expr1
))
6986 /* Get the CLASS declared type. */
6987 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6989 /* Weed out cases of the ultimate component being a derived type. */
6990 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6991 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6993 gfc_free_ref_list (new_ref
);
6994 return resolve_typebound_call (code
, NULL
, NULL
);
6997 if (!resolve_typebound_call (code
, &name
, &overridable
))
6999 gfc_free_ref_list (new_ref
);
7002 ts
= code
->expr1
->ts
;
7006 /* Convert the expression to a procedure pointer component call. */
7007 code
->expr1
->value
.function
.esym
= NULL
;
7008 code
->expr1
->symtree
= st
;
7011 code
->expr1
->ref
= new_ref
;
7013 /* '_vptr' points to the vtab, which contains the procedure pointers. */
7014 gfc_add_vptr_component (code
->expr1
);
7015 gfc_add_component_ref (code
->expr1
, name
);
7017 /* Recover the typespec for the expression. This is really only
7018 necessary for generic procedures, where the additional call
7019 to gfc_add_component_ref seems to throw the collection of the
7020 correct typespec. */
7021 code
->expr1
->ts
= ts
;
7024 gfc_free_ref_list (new_ref
);
7030 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
7033 resolve_ppc_call (gfc_code
* c
)
7035 gfc_component
*comp
;
7037 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
7038 gcc_assert (comp
!= NULL
);
7040 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
7041 c
->expr1
->expr_type
= EXPR_VARIABLE
;
7043 if (!comp
->attr
.subroutine
)
7044 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
7046 if (!gfc_resolve_ref (c
->expr1
))
7049 if (!update_ppc_arglist (c
->expr1
))
7052 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
7054 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
7055 !(comp
->ts
.interface
7056 && comp
->ts
.interface
->formal
)))
7059 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
7062 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
7068 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
7071 resolve_expr_ppc (gfc_expr
* e
)
7073 gfc_component
*comp
;
7075 comp
= gfc_get_proc_ptr_comp (e
);
7076 gcc_assert (comp
!= NULL
);
7078 /* Convert to EXPR_FUNCTION. */
7079 e
->expr_type
= EXPR_FUNCTION
;
7080 e
->value
.function
.isym
= NULL
;
7081 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
7083 if (comp
->as
!= NULL
)
7084 e
->rank
= comp
->as
->rank
;
7086 if (!comp
->attr
.function
)
7087 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
7089 if (!gfc_resolve_ref (e
))
7092 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
7093 !(comp
->ts
.interface
7094 && comp
->ts
.interface
->formal
)))
7097 if (!update_ppc_arglist (e
))
7100 if (!check_pure_function(e
))
7103 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
7110 gfc_is_expandable_expr (gfc_expr
*e
)
7112 gfc_constructor
*con
;
7114 if (e
->expr_type
== EXPR_ARRAY
)
7116 /* Traverse the constructor looking for variables that are flavor
7117 parameter. Parameters must be expanded since they are fully used at
7119 con
= gfc_constructor_first (e
->value
.constructor
);
7120 for (; con
; con
= gfc_constructor_next (con
))
7122 if (con
->expr
->expr_type
== EXPR_VARIABLE
7123 && con
->expr
->symtree
7124 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
7125 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
7127 if (con
->expr
->expr_type
== EXPR_ARRAY
7128 && gfc_is_expandable_expr (con
->expr
))
7137 /* Sometimes variables in specification expressions of the result
7138 of module procedures in submodules wind up not being the 'real'
7139 dummy. Find this, if possible, in the namespace of the first
7143 fixup_unique_dummy (gfc_expr
*e
)
7145 gfc_symtree
*st
= NULL
;
7146 gfc_symbol
*s
= NULL
;
7148 if (e
->symtree
->n
.sym
->ns
->proc_name
7149 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
7150 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
7153 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
7156 && st
->n
.sym
!= NULL
7157 && st
->n
.sym
->attr
.dummy
)
7161 /* Resolve an expression. That is, make sure that types of operands agree
7162 with their operators, intrinsic operators are converted to function calls
7163 for overloaded types and unresolved function references are resolved. */
7166 gfc_resolve_expr (gfc_expr
*e
)
7169 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
7171 if (e
== NULL
|| e
->do_not_resolve_again
)
7174 /* inquiry_argument only applies to variables. */
7175 inquiry_save
= inquiry_argument
;
7176 actual_arg_save
= actual_arg
;
7177 first_actual_arg_save
= first_actual_arg
;
7179 if (e
->expr_type
!= EXPR_VARIABLE
)
7181 inquiry_argument
= false;
7183 first_actual_arg
= false;
7185 else if (e
->symtree
!= NULL
7186 && *e
->symtree
->name
== '@'
7187 && e
->symtree
->n
.sym
->attr
.dummy
)
7189 /* Deal with submodule specification expressions that are not
7190 found to be referenced in module.cc(read_cleanup). */
7191 fixup_unique_dummy (e
);
7194 switch (e
->expr_type
)
7197 t
= resolve_operator (e
);
7203 if (check_host_association (e
))
7204 t
= resolve_function (e
);
7206 t
= resolve_variable (e
);
7208 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
7209 && e
->ref
->type
!= REF_SUBSTRING
)
7210 gfc_resolve_substring_charlen (e
);
7215 t
= resolve_typebound_function (e
);
7218 case EXPR_SUBSTRING
:
7219 t
= gfc_resolve_ref (e
);
7228 t
= resolve_expr_ppc (e
);
7233 if (!gfc_resolve_ref (e
))
7236 t
= gfc_resolve_array_constructor (e
);
7237 /* Also try to expand a constructor. */
7240 gfc_expression_rank (e
);
7241 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
7242 gfc_expand_constructor (e
, false);
7245 /* This provides the opportunity for the length of constructors with
7246 character valued function elements to propagate the string length
7247 to the expression. */
7248 if (t
&& e
->ts
.type
== BT_CHARACTER
)
7250 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
7251 here rather then add a duplicate test for it above. */
7252 gfc_expand_constructor (e
, false);
7253 t
= gfc_resolve_character_array_constructor (e
);
7258 case EXPR_STRUCTURE
:
7259 t
= gfc_resolve_ref (e
);
7263 t
= resolve_structure_cons (e
, 0);
7267 t
= gfc_simplify_expr (e
, 0);
7271 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7274 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
7277 inquiry_argument
= inquiry_save
;
7278 actual_arg
= actual_arg_save
;
7279 first_actual_arg
= first_actual_arg_save
;
7281 /* For some reason, resolving these expressions a second time mangles
7282 the typespec of the expression itself. */
7283 if (t
&& e
->expr_type
== EXPR_VARIABLE
7284 && e
->symtree
->n
.sym
->attr
.select_rank_temporary
7285 && UNLIMITED_POLY (e
->symtree
->n
.sym
))
7286 e
->do_not_resolve_again
= 1;
7292 /* Resolve an expression from an iterator. They must be scalar and have
7293 INTEGER or (optionally) REAL type. */
7296 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
7297 const char *name_msgid
)
7299 if (!gfc_resolve_expr (expr
))
7302 if (expr
->rank
!= 0)
7304 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7308 if (expr
->ts
.type
!= BT_INTEGER
)
7310 if (expr
->ts
.type
== BT_REAL
)
7313 return gfc_notify_std (GFC_STD_F95_DEL
,
7314 "%s at %L must be integer",
7315 _(name_msgid
), &expr
->where
);
7318 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7325 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7333 /* Resolve the expressions in an iterator structure. If REAL_OK is
7334 false allow only INTEGER type iterators, otherwise allow REAL types.
7335 Set own_scope to true for ac-implied-do and data-implied-do as those
7336 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7339 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7341 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7344 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7345 _("iterator variable")))
7348 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7349 "Start expression in DO loop"))
7352 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7353 "End expression in DO loop"))
7356 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7357 "Step expression in DO loop"))
7360 /* Convert start, end, and step to the same type as var. */
7361 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7362 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7363 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7365 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7366 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7367 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7369 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7370 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7371 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7373 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7375 if ((iter
->step
->ts
.type
== BT_INTEGER
7376 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7377 || (iter
->step
->ts
.type
== BT_REAL
7378 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7380 gfc_error ("Step expression in DO loop at %L cannot be zero",
7381 &iter
->step
->where
);
7386 if (iter
->start
->expr_type
== EXPR_CONSTANT
7387 && iter
->end
->expr_type
== EXPR_CONSTANT
7388 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7391 if (iter
->start
->ts
.type
== BT_INTEGER
)
7393 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7394 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7398 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7399 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7401 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7402 gfc_warning (OPT_Wzerotrip
,
7403 "DO loop at %L will be executed zero times",
7404 &iter
->step
->where
);
7407 if (iter
->end
->expr_type
== EXPR_CONSTANT
7408 && iter
->end
->ts
.type
== BT_INTEGER
7409 && iter
->step
->expr_type
== EXPR_CONSTANT
7410 && iter
->step
->ts
.type
== BT_INTEGER
7411 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7412 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7414 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7415 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7417 if (is_step_positive
7418 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7419 gfc_warning (OPT_Wundefined_do_loop
,
7420 "DO loop at %L is undefined as it overflows",
7421 &iter
->step
->where
);
7422 else if (!is_step_positive
7423 && mpz_cmp (iter
->end
->value
.integer
,
7424 gfc_integer_kinds
[k
].min_int
) == 0)
7425 gfc_warning (OPT_Wundefined_do_loop
,
7426 "DO loop at %L is undefined as it underflows",
7427 &iter
->step
->where
);
7434 /* Traversal function for find_forall_index. f == 2 signals that
7435 that variable itself is not to be checked - only the references. */
7438 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7440 if (expr
->expr_type
!= EXPR_VARIABLE
)
7443 /* A scalar assignment */
7444 if (!expr
->ref
|| *f
== 1)
7446 if (expr
->symtree
->n
.sym
== sym
)
7458 /* Check whether the FORALL index appears in the expression or not.
7459 Returns true if SYM is found in EXPR. */
7462 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7464 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7471 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7472 to be a scalar INTEGER variable. The subscripts and stride are scalar
7473 INTEGERs, and if stride is a constant it must be nonzero.
7474 Furthermore "A subscript or stride in a forall-triplet-spec shall
7475 not contain a reference to any index-name in the
7476 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7479 resolve_forall_iterators (gfc_forall_iterator
*it
)
7481 gfc_forall_iterator
*iter
, *iter2
;
7483 for (iter
= it
; iter
; iter
= iter
->next
)
7485 if (gfc_resolve_expr (iter
->var
)
7486 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7487 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7490 if (gfc_resolve_expr (iter
->start
)
7491 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7492 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7493 &iter
->start
->where
);
7494 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7495 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7497 if (gfc_resolve_expr (iter
->end
)
7498 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7499 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7501 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7502 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7504 if (gfc_resolve_expr (iter
->stride
))
7506 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7507 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7508 &iter
->stride
->where
, "INTEGER");
7510 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7511 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7512 gfc_error ("FORALL stride expression at %L cannot be zero",
7513 &iter
->stride
->where
);
7515 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7516 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7519 for (iter
= it
; iter
; iter
= iter
->next
)
7520 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7522 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7523 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7524 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7525 gfc_error ("FORALL index %qs may not appear in triplet "
7526 "specification at %L", iter
->var
->symtree
->name
,
7527 &iter2
->start
->where
);
7532 /* Given a pointer to a symbol that is a derived type, see if it's
7533 inaccessible, i.e. if it's defined in another module and the components are
7534 PRIVATE. The search is recursive if necessary. Returns zero if no
7535 inaccessible components are found, nonzero otherwise. */
7538 derived_inaccessible (gfc_symbol
*sym
)
7542 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7545 for (c
= sym
->components
; c
; c
= c
->next
)
7547 /* Prevent an infinite loop through this function. */
7548 if (c
->ts
.type
== BT_DERIVED
7549 && (c
->attr
.pointer
|| c
->attr
.allocatable
)
7550 && sym
== c
->ts
.u
.derived
)
7553 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7561 /* Resolve the argument of a deallocate expression. The expression must be
7562 a pointer or a full array. */
7565 resolve_deallocate_expr (gfc_expr
*e
)
7567 symbol_attribute attr
;
7568 int allocatable
, pointer
;
7574 if (!gfc_resolve_expr (e
))
7577 if (e
->expr_type
!= EXPR_VARIABLE
)
7580 sym
= e
->symtree
->n
.sym
;
7581 unlimited
= UNLIMITED_POLY(sym
);
7583 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
&& CLASS_DATA (sym
))
7585 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7586 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7590 allocatable
= sym
->attr
.allocatable
;
7591 pointer
= sym
->attr
.pointer
;
7593 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7598 if (ref
->u
.ar
.type
!= AR_FULL
7599 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7600 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7605 c
= ref
->u
.c
.component
;
7606 if (c
->ts
.type
== BT_CLASS
)
7608 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7609 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7613 allocatable
= c
->attr
.allocatable
;
7614 pointer
= c
->attr
.pointer
;
7625 attr
= gfc_expr_attr (e
);
7627 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7630 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7636 if (gfc_is_coindexed (e
))
7638 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7643 && !gfc_check_vardef_context (e
, true, true, false,
7644 _("DEALLOCATE object")))
7646 if (!gfc_check_vardef_context (e
, false, true, false,
7647 _("DEALLOCATE object")))
7654 /* Returns true if the expression e contains a reference to the symbol sym. */
7656 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7658 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7665 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7667 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7671 /* Given the expression node e for an allocatable/pointer of derived type to be
7672 allocated, get the expression node to be initialized afterwards (needed for
7673 derived types with default initializers, and derived types with allocatable
7674 components that need nullification.) */
7677 gfc_expr_to_initialize (gfc_expr
*e
)
7683 result
= gfc_copy_expr (e
);
7685 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7686 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7687 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7689 if (ref
->u
.ar
.dimen
== 0
7690 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->corank
)
7693 ref
->u
.ar
.type
= AR_FULL
;
7695 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7696 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7701 gfc_free_shape (&result
->shape
, result
->rank
);
7703 /* Recalculate rank, shape, etc. */
7704 gfc_resolve_expr (result
);
7709 /* If the last ref of an expression is an array ref, return a copy of the
7710 expression with that one removed. Otherwise, a copy of the original
7711 expression. This is used for allocate-expressions and pointer assignment
7712 LHS, where there may be an array specification that needs to be stripped
7713 off when using gfc_check_vardef_context. */
7716 remove_last_array_ref (gfc_expr
* e
)
7721 e2
= gfc_copy_expr (e
);
7722 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7723 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7725 gfc_free_ref_list (*r
);
7734 /* Used in resolve_allocate_expr to check that a allocation-object and
7735 a source-expr are conformable. This does not catch all possible
7736 cases; in particular a runtime checking is needed. */
7739 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7742 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7744 /* First compare rank. */
7745 if ((tail
&& (!tail
->u
.ar
.as
|| e1
->rank
!= tail
->u
.ar
.as
->rank
))
7746 || (!tail
&& e1
->rank
!= e2
->rank
))
7748 gfc_error ("Source-expr at %L must be scalar or have the "
7749 "same rank as the allocate-object at %L",
7750 &e1
->where
, &e2
->where
);
7761 for (i
= 0; i
< e1
->rank
; i
++)
7763 if (tail
->u
.ar
.start
[i
] == NULL
)
7766 if (tail
->u
.ar
.end
[i
])
7768 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7769 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7770 mpz_add_ui (s
, s
, 1);
7774 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7777 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7779 gfc_error ("Source-expr at %L and allocate-object at %L must "
7780 "have the same shape", &e1
->where
, &e2
->where
);
7793 /* Resolve the expression in an ALLOCATE statement, doing the additional
7794 checks to see whether the expression is OK or not. The expression must
7795 have a trailing array reference that gives the size of the array. */
7798 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7800 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7804 symbol_attribute attr
;
7805 gfc_ref
*ref
, *ref2
;
7808 gfc_symbol
*sym
= NULL
;
7813 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7814 checking of coarrays. */
7815 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7816 if (ref
->next
== NULL
)
7819 if (ref
&& ref
->type
== REF_ARRAY
)
7820 ref
->u
.ar
.in_allocate
= true;
7822 if (!gfc_resolve_expr (e
))
7825 /* Make sure the expression is allocatable or a pointer. If it is
7826 pointer, the next-to-last reference must be a pointer. */
7830 sym
= e
->symtree
->n
.sym
;
7832 /* Check whether ultimate component is abstract and CLASS. */
7835 /* Is the allocate-object unlimited polymorphic? */
7836 unlimited
= UNLIMITED_POLY(e
);
7838 if (e
->expr_type
!= EXPR_VARIABLE
)
7841 attr
= gfc_expr_attr (e
);
7842 pointer
= attr
.pointer
;
7843 dimension
= attr
.dimension
;
7844 codimension
= attr
.codimension
;
7848 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7850 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7851 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7852 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7853 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7854 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7858 allocatable
= sym
->attr
.allocatable
;
7859 pointer
= sym
->attr
.pointer
;
7860 dimension
= sym
->attr
.dimension
;
7861 codimension
= sym
->attr
.codimension
;
7866 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7871 if (ref
->u
.ar
.codimen
> 0)
7874 for (n
= ref
->u
.ar
.dimen
;
7875 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7876 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7883 if (ref
->next
!= NULL
)
7891 gfc_error ("Coindexed allocatable object at %L",
7896 c
= ref
->u
.c
.component
;
7897 if (c
->ts
.type
== BT_CLASS
)
7899 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7900 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7901 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7902 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7903 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7907 allocatable
= c
->attr
.allocatable
;
7908 pointer
= c
->attr
.pointer
;
7909 dimension
= c
->attr
.dimension
;
7910 codimension
= c
->attr
.codimension
;
7911 is_abstract
= c
->attr
.abstract
;
7924 /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
7925 pointer or an allocatable variable. */
7926 if (allocatable
== 0 && pointer
== 0)
7928 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7933 /* Some checks for the SOURCE tag. */
7936 /* Check F03:C631. */
7937 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7939 gfc_error ("Type of entity at %L is type incompatible with "
7940 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7944 /* Check F03:C632 and restriction following Note 6.18. */
7945 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7948 /* Check F03:C633. */
7949 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7951 gfc_error ("The allocate-object at %L and the source-expr at %L "
7952 "shall have the same kind type parameter",
7953 &e
->where
, &code
->expr3
->where
);
7957 /* Check F2008, C642. */
7958 if (code
->expr3
->ts
.type
== BT_DERIVED
7959 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7960 || (code
->expr3
->ts
.u
.derived
->from_intmod
7961 == INTMOD_ISO_FORTRAN_ENV
7962 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7963 == ISOFORTRAN_LOCK_TYPE
)))
7965 gfc_error ("The source-expr at %L shall neither be of type "
7966 "LOCK_TYPE nor have a LOCK_TYPE component if "
7967 "allocate-object at %L is a coarray",
7968 &code
->expr3
->where
, &e
->where
);
7972 /* Check TS18508, C702/C703. */
7973 if (code
->expr3
->ts
.type
== BT_DERIVED
7974 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7975 || (code
->expr3
->ts
.u
.derived
->from_intmod
7976 == INTMOD_ISO_FORTRAN_ENV
7977 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7978 == ISOFORTRAN_EVENT_TYPE
)))
7980 gfc_error ("The source-expr at %L shall neither be of type "
7981 "EVENT_TYPE nor have a EVENT_TYPE component if "
7982 "allocate-object at %L is a coarray",
7983 &code
->expr3
->where
, &e
->where
);
7988 /* Check F08:C629. */
7989 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7992 gcc_assert (e
->ts
.type
== BT_CLASS
);
7993 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7994 "type-spec or source-expr", sym
->name
, &e
->where
);
7998 /* Check F08:C632. */
7999 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
8000 && !UNLIMITED_POLY (e
))
8004 if (!e
->ts
.u
.cl
->length
)
8007 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
8008 code
->ext
.alloc
.ts
.u
.cl
->length
);
8009 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
8011 gfc_error ("Allocating %s at %L with type-spec requires the same "
8012 "character-length parameter as in the declaration",
8013 sym
->name
, &e
->where
);
8018 /* In the variable definition context checks, gfc_expr_attr is used
8019 on the expression. This is fooled by the array specification
8020 present in e, thus we have to eliminate that one temporarily. */
8021 e2
= remove_last_array_ref (e
);
8024 t
= gfc_check_vardef_context (e2
, true, true, false,
8025 _("ALLOCATE object"));
8027 t
= gfc_check_vardef_context (e2
, false, true, false,
8028 _("ALLOCATE object"));
8033 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
8034 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
8036 /* For class arrays, the initialization with SOURCE is done
8037 using _copy and trans_call. It is convenient to exploit that
8038 when the allocated type is different from the declared type but
8039 no SOURCE exists by setting expr3. */
8040 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
8042 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
8043 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
8044 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
8046 /* We have to zero initialize the integer variable. */
8047 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
8050 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
8052 /* Make sure the vtab symbol is present when
8053 the module variables are generated. */
8054 gfc_typespec ts
= e
->ts
;
8056 ts
= code
->expr3
->ts
;
8057 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
8058 ts
= code
->ext
.alloc
.ts
;
8060 /* Finding the vtab also publishes the type's symbol. Therefore this
8061 statement is necessary. */
8062 gfc_find_derived_vtab (ts
.u
.derived
);
8064 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
8066 /* Again, make sure the vtab symbol is present when
8067 the module variables are generated. */
8068 gfc_typespec
*ts
= NULL
;
8070 ts
= &code
->expr3
->ts
;
8072 ts
= &code
->ext
.alloc
.ts
;
8076 /* Finding the vtab also publishes the type's symbol. Therefore this
8077 statement is necessary. */
8081 if (dimension
== 0 && codimension
== 0)
8084 /* Make sure the last reference node is an array specification. */
8086 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
8087 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
8092 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
8093 "in ALLOCATE statement at %L", &e
->where
))
8095 if (code
->expr3
->rank
!= 0)
8096 *array_alloc_wo_spec
= true;
8099 gfc_error ("Array specification or array-valued SOURCE= "
8100 "expression required in ALLOCATE statement at %L",
8107 gfc_error ("Array specification required in ALLOCATE statement "
8108 "at %L", &e
->where
);
8113 /* Make sure that the array section reference makes sense in the
8114 context of an ALLOCATE specification. */
8119 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
8121 switch (ar
->dimen_type
[i
])
8123 case DIMEN_THIS_IMAGE
:
8124 gfc_error ("Coarray specification required in ALLOCATE statement "
8125 "at %L", &e
->where
);
8130 * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
8132 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0 || ar
->stride
[i
] != NULL
)
8134 gfc_error ("Bad coarray specification in ALLOCATE statement "
8135 "at %L", &e
->where
);
8138 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
8140 gfc_error ("Upper cobound is less than lower cobound at %L",
8141 &ar
->start
[i
]->where
);
8147 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
8149 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
8150 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
8152 gfc_error ("Upper cobound is less than lower cobound "
8153 "of 1 at %L", &ar
->start
[i
]->where
);
8163 gfc_error ("Bad array specification in ALLOCATE statement at %L",
8169 for (i
= 0; i
< ar
->dimen
; i
++)
8171 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
8174 switch (ar
->dimen_type
[i
])
8180 if (ar
->start
[i
] != NULL
8181 && ar
->end
[i
] != NULL
8182 && ar
->stride
[i
] == NULL
)
8190 case DIMEN_THIS_IMAGE
:
8191 gfc_error ("Bad array specification in ALLOCATE statement at %L",
8197 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8199 sym
= a
->expr
->symtree
->n
.sym
;
8201 /* TODO - check derived type components. */
8202 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
8205 if ((ar
->start
[i
] != NULL
8206 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
8207 || (ar
->end
[i
] != NULL
8208 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
8210 gfc_error ("%qs must not appear in the array specification at "
8211 "%L in the same ALLOCATE statement where it is "
8212 "itself allocated", sym
->name
, &ar
->where
);
8218 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
8220 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
8221 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
8223 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
8225 gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
8226 "statement at %L", &e
->where
);
8232 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
8233 && ar
->stride
[i
] == NULL
)
8236 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
8250 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
8252 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
8253 gfc_alloc
*a
, *p
, *q
;
8256 errmsg
= code
->expr2
;
8258 /* Check the stat variable. */
8261 if (!gfc_check_vardef_context (stat
, false, false, false,
8262 _("STAT variable")))
8265 if (stat
->ts
.type
!= BT_INTEGER
8267 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8268 "variable", &stat
->where
);
8270 if (stat
->expr_type
== EXPR_CONSTANT
|| stat
->symtree
== NULL
)
8273 /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
8274 * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8276 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8277 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
8279 gfc_ref
*ref1
, *ref2
;
8282 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
8283 ref1
= ref1
->next
, ref2
= ref2
->next
)
8285 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8287 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8296 gfc_error ("Stat-variable at %L shall not be %sd within "
8297 "the same %s statement", &stat
->where
, fcn
, fcn
);
8305 /* Check the errmsg variable. */
8309 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8312 if (!gfc_check_vardef_context (errmsg
, false, false, false,
8313 _("ERRMSG variable")))
8316 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8317 F18:R930 errmsg-variable is scalar-default-char-variable
8318 F18:R906 default-char-variable is variable
8319 F18:C906 default-char-variable shall be default character. */
8320 if (errmsg
->ts
.type
!= BT_CHARACTER
8322 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8323 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8324 "variable", &errmsg
->where
);
8326 if (errmsg
->expr_type
== EXPR_CONSTANT
|| errmsg
->symtree
== NULL
)
8329 /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
8330 * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8332 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8333 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8335 gfc_ref
*ref1
, *ref2
;
8338 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
8339 ref1
= ref1
->next
, ref2
= ref2
->next
)
8341 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8343 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8352 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8353 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8361 /* Check that an allocate-object appears only once in the statement. */
8363 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8366 for (q
= p
->next
; q
; q
= q
->next
)
8369 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8371 /* This is a potential collision. */
8372 gfc_ref
*pr
= pe
->ref
;
8373 gfc_ref
*qr
= qe
->ref
;
8375 /* Follow the references until
8376 a) They start to differ, in which case there is no error;
8377 you can deallocate a%b and a%c in a single statement
8378 b) Both of them stop, which is an error
8379 c) One of them stops, which is also an error. */
8382 if (pr
== NULL
&& qr
== NULL
)
8384 gfc_error ("Allocate-object at %L also appears at %L",
8385 &pe
->where
, &qe
->where
);
8388 else if (pr
!= NULL
&& qr
== NULL
)
8390 gfc_error ("Allocate-object at %L is subobject of"
8391 " object at %L", &pe
->where
, &qe
->where
);
8394 else if (pr
== NULL
&& qr
!= NULL
)
8396 gfc_error ("Allocate-object at %L is subobject of"
8397 " object at %L", &qe
->where
, &pe
->where
);
8400 /* Here, pr != NULL && qr != NULL */
8401 gcc_assert(pr
->type
== qr
->type
);
8402 if (pr
->type
== REF_ARRAY
)
8404 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8406 gcc_assert (qr
->type
== REF_ARRAY
);
8408 if (pr
->next
&& qr
->next
)
8411 gfc_array_ref
*par
= &(pr
->u
.ar
);
8412 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8414 for (i
=0; i
<par
->dimen
; i
++)
8416 if ((par
->start
[i
] != NULL
8417 || qar
->start
[i
] != NULL
)
8418 && gfc_dep_compare_expr (par
->start
[i
],
8419 qar
->start
[i
]) != 0)
8426 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8439 if (strcmp (fcn
, "ALLOCATE") == 0)
8441 bool arr_alloc_wo_spec
= false;
8443 /* Resolving the expr3 in the loop over all objects to allocate would
8444 execute loop invariant code for each loop item. Therefore do it just
8446 if (code
->expr3
&& code
->expr3
->mold
8447 && code
->expr3
->ts
.type
== BT_DERIVED
)
8449 /* Default initialization via MOLD (non-polymorphic). */
8450 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8453 gfc_resolve_expr (rhs
);
8454 gfc_free_expr (code
->expr3
);
8458 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8459 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8461 if (arr_alloc_wo_spec
&& code
->expr3
)
8463 /* Mark the allocate to have to take the array specification
8465 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8470 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8471 resolve_deallocate_expr (a
->expr
);
8476 /************ SELECT CASE resolution subroutines ************/
8478 /* Callback function for our mergesort variant. Determines interval
8479 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8480 op1 > op2. Assumes we're not dealing with the default case.
8481 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8482 There are nine situations to check. */
8485 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8489 if (op1
->low
== NULL
) /* op1 = (:L) */
8491 /* op2 = (:N), so overlap. */
8493 /* op2 = (M:) or (M:N), L < M */
8494 if (op2
->low
!= NULL
8495 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8498 else if (op1
->high
== NULL
) /* op1 = (K:) */
8500 /* op2 = (M:), so overlap. */
8502 /* op2 = (:N) or (M:N), K > N */
8503 if (op2
->high
!= NULL
8504 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8507 else /* op1 = (K:L) */
8509 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8510 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8512 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8513 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8515 else /* op2 = (M:N) */
8519 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8522 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8531 /* Merge-sort a double linked case list, detecting overlap in the
8532 process. LIST is the head of the double linked case list before it
8533 is sorted. Returns the head of the sorted list if we don't see any
8534 overlap, or NULL otherwise. */
8537 check_case_overlap (gfc_case
*list
)
8539 gfc_case
*p
, *q
, *e
, *tail
;
8540 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8542 /* If the passed list was empty, return immediately. */
8549 /* Loop unconditionally. The only exit from this loop is a return
8550 statement, when we've finished sorting the case list. */
8557 /* Count the number of merges we do in this pass. */
8560 /* Loop while there exists a merge to be done. */
8565 /* Count this merge. */
8568 /* Cut the list in two pieces by stepping INSIZE places
8569 forward in the list, starting from P. */
8572 for (i
= 0; i
< insize
; i
++)
8581 /* Now we have two lists. Merge them! */
8582 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8584 /* See from which the next case to merge comes from. */
8587 /* P is empty so the next case must come from Q. */
8592 else if (qsize
== 0 || q
== NULL
)
8601 cmp
= compare_cases (p
, q
);
8604 /* The whole case range for P is less than the
8612 /* The whole case range for Q is greater than
8613 the case range for P. */
8620 /* The cases overlap, or they are the same
8621 element in the list. Either way, we must
8622 issue an error and get the next case from P. */
8623 /* FIXME: Sort P and Q by line number. */
8624 gfc_error ("CASE label at %L overlaps with CASE "
8625 "label at %L", &p
->where
, &q
->where
);
8633 /* Add the next element to the merged list. */
8642 /* P has now stepped INSIZE places along, and so has Q. So
8643 they're the same. */
8648 /* If we have done only one merge or none at all, we've
8649 finished sorting the cases. */
8658 /* Otherwise repeat, merging lists twice the size. */
8664 /* Check to see if an expression is suitable for use in a CASE statement.
8665 Makes sure that all case expressions are scalar constants of the same
8666 type. Return false if anything is wrong. */
8669 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8671 if (e
== NULL
) return true;
8673 if (e
->ts
.type
!= case_expr
->ts
.type
)
8675 gfc_error ("Expression in CASE statement at %L must be of type %s",
8676 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8680 /* C805 (R808) For a given case-construct, each case-value shall be of
8681 the same type as case-expr. For character type, length differences
8682 are allowed, but the kind type parameters shall be the same. */
8684 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8686 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8687 &e
->where
, case_expr
->ts
.kind
);
8691 /* Convert the case value kind to that of case expression kind,
8694 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8695 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8699 gfc_error ("Expression in CASE statement at %L must be scalar",
8708 /* Given a completely parsed select statement, we:
8710 - Validate all expressions and code within the SELECT.
8711 - Make sure that the selection expression is not of the wrong type.
8712 - Make sure that no case ranges overlap.
8713 - Eliminate unreachable cases and unreachable code resulting from
8714 removing case labels.
8716 The standard does allow unreachable cases, e.g. CASE (5:3). But
8717 they are a hassle for code generation, and to prevent that, we just
8718 cut them out here. This is not necessary for overlapping cases
8719 because they are illegal and we never even try to generate code.
8721 We have the additional caveat that a SELECT construct could have
8722 been a computed GOTO in the source code. Fortunately we can fairly
8723 easily work around that here: The case_expr for a "real" SELECT CASE
8724 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8725 we have to do is make sure that the case_expr is a scalar integer
8729 resolve_select (gfc_code
*code
, bool select_type
)
8732 gfc_expr
*case_expr
;
8733 gfc_case
*cp
, *default_case
, *tail
, *head
;
8734 int seen_unreachable
;
8740 if (code
->expr1
== NULL
)
8742 /* This was actually a computed GOTO statement. */
8743 case_expr
= code
->expr2
;
8744 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8745 gfc_error ("Selection expression in computed GOTO statement "
8746 "at %L must be a scalar integer expression",
8749 /* Further checking is not necessary because this SELECT was built
8750 by the compiler, so it should always be OK. Just move the
8751 case_expr from expr2 to expr so that we can handle computed
8752 GOTOs as normal SELECTs from here on. */
8753 code
->expr1
= code
->expr2
;
8758 case_expr
= code
->expr1
;
8759 type
= case_expr
->ts
.type
;
8762 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8764 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8765 &case_expr
->where
, gfc_typename (case_expr
));
8767 /* Punt. Going on here just produce more garbage error messages. */
8772 if (!select_type
&& case_expr
->rank
!= 0)
8774 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8775 "expression", &case_expr
->where
);
8781 /* Raise a warning if an INTEGER case value exceeds the range of
8782 the case-expr. Later, all expressions will be promoted to the
8783 largest kind of all case-labels. */
8785 if (type
== BT_INTEGER
)
8786 for (body
= code
->block
; body
; body
= body
->block
)
8787 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8790 && gfc_check_integer_range (cp
->low
->value
.integer
,
8791 case_expr
->ts
.kind
) != ARITH_OK
)
8792 gfc_warning (0, "Expression in CASE statement at %L is "
8793 "not in the range of %s", &cp
->low
->where
,
8794 gfc_typename (case_expr
));
8797 && cp
->low
!= cp
->high
8798 && gfc_check_integer_range (cp
->high
->value
.integer
,
8799 case_expr
->ts
.kind
) != ARITH_OK
)
8800 gfc_warning (0, "Expression in CASE statement at %L is "
8801 "not in the range of %s", &cp
->high
->where
,
8802 gfc_typename (case_expr
));
8805 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8806 of the SELECT CASE expression and its CASE values. Walk the lists
8807 of case values, and if we find a mismatch, promote case_expr to
8808 the appropriate kind. */
8810 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8812 for (body
= code
->block
; body
; body
= body
->block
)
8814 /* Walk the case label list. */
8815 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8817 /* Intercept the DEFAULT case. It does not have a kind. */
8818 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8821 /* Unreachable case ranges are discarded, so ignore. */
8822 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8823 && cp
->low
!= cp
->high
8824 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8828 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8829 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 1, 0);
8831 if (cp
->high
!= NULL
8832 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8833 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 1, 0);
8838 /* Assume there is no DEFAULT case. */
8839 default_case
= NULL
;
8844 for (body
= code
->block
; body
; body
= body
->block
)
8846 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8848 seen_unreachable
= 0;
8850 /* Walk the case label list, making sure that all case labels
8852 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8854 /* Count the number of cases in the whole construct. */
8857 /* Intercept the DEFAULT case. */
8858 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8860 if (default_case
!= NULL
)
8862 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8863 "by a second DEFAULT CASE at %L",
8864 &default_case
->where
, &cp
->where
);
8875 /* Deal with single value cases and case ranges. Errors are
8876 issued from the validation function. */
8877 if (!validate_case_label_expr (cp
->low
, case_expr
)
8878 || !validate_case_label_expr (cp
->high
, case_expr
))
8884 if (type
== BT_LOGICAL
8885 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8886 || cp
->low
!= cp
->high
))
8888 gfc_error ("Logical range in CASE statement at %L is not "
8890 cp
->low
? &cp
->low
->where
: &cp
->high
->where
);
8895 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8898 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8899 if (value
& seen_logical
)
8901 gfc_error ("Constant logical value in CASE statement "
8902 "is repeated at %L",
8907 seen_logical
|= value
;
8910 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8911 && cp
->low
!= cp
->high
8912 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8914 if (warn_surprising
)
8915 gfc_warning (OPT_Wsurprising
,
8916 "Range specification at %L can never be matched",
8919 cp
->unreachable
= 1;
8920 seen_unreachable
= 1;
8924 /* If the case range can be matched, it can also overlap with
8925 other cases. To make sure it does not, we put it in a
8926 double linked list here. We sort that with a merge sort
8927 later on to detect any overlapping cases. */
8931 head
->right
= head
->left
= NULL
;
8936 tail
->right
->left
= tail
;
8943 /* It there was a failure in the previous case label, give up
8944 for this case label list. Continue with the next block. */
8948 /* See if any case labels that are unreachable have been seen.
8949 If so, we eliminate them. This is a bit of a kludge because
8950 the case lists for a single case statement (label) is a
8951 single forward linked lists. */
8952 if (seen_unreachable
)
8954 /* Advance until the first case in the list is reachable. */
8955 while (body
->ext
.block
.case_list
!= NULL
8956 && body
->ext
.block
.case_list
->unreachable
)
8958 gfc_case
*n
= body
->ext
.block
.case_list
;
8959 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8961 gfc_free_case_list (n
);
8964 /* Strip all other unreachable cases. */
8965 if (body
->ext
.block
.case_list
)
8967 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8969 if (cp
->next
->unreachable
)
8971 gfc_case
*n
= cp
->next
;
8972 cp
->next
= cp
->next
->next
;
8974 gfc_free_case_list (n
);
8981 /* See if there were overlapping cases. If the check returns NULL,
8982 there was overlap. In that case we don't do anything. If head
8983 is non-NULL, we prepend the DEFAULT case. The sorted list can
8984 then used during code generation for SELECT CASE constructs with
8985 a case expression of a CHARACTER type. */
8988 head
= check_case_overlap (head
);
8990 /* Prepend the default_case if it is there. */
8991 if (head
!= NULL
&& default_case
)
8993 default_case
->left
= NULL
;
8994 default_case
->right
= head
;
8995 head
->left
= default_case
;
8999 /* Eliminate dead blocks that may be the result if we've seen
9000 unreachable case labels for a block. */
9001 for (body
= code
; body
&& body
->block
; body
= body
->block
)
9003 if (body
->block
->ext
.block
.case_list
== NULL
)
9005 /* Cut the unreachable block from the code chain. */
9006 gfc_code
*c
= body
->block
;
9007 body
->block
= c
->block
;
9009 /* Kill the dead block, but not the blocks below it. */
9011 gfc_free_statements (c
);
9015 /* More than two cases is legal but insane for logical selects.
9016 Issue a warning for it. */
9017 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
9018 gfc_warning (OPT_Wsurprising
,
9019 "Logical SELECT CASE block at %L has more that two cases",
9024 /* Check if a derived type is extensible. */
9027 gfc_type_is_extensible (gfc_symbol
*sym
)
9029 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
9030 || (sym
->attr
.is_class
9031 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
9036 resolve_types (gfc_namespace
*ns
);
9038 /* Resolve an associate-name: Resolve target and ensure the type-spec is
9039 correct as well as possibly the array-spec. */
9042 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
9046 gcc_assert (sym
->assoc
);
9047 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
9049 /* If this is for SELECT TYPE, the target may not yet be set. In that
9050 case, return. Resolution will be called later manually again when
9052 target
= sym
->assoc
->target
;
9055 gcc_assert (!sym
->assoc
->dangling
);
9057 if (resolve_target
&& !gfc_resolve_expr (target
))
9060 /* For variable targets, we get some attributes from the target. */
9061 if (target
->expr_type
== EXPR_VARIABLE
)
9063 gfc_symbol
*tsym
, *dsym
;
9065 gcc_assert (target
->symtree
);
9066 tsym
= target
->symtree
->n
.sym
;
9068 if (gfc_expr_attr (target
).proc_pointer
)
9070 gfc_error ("Associating entity %qs at %L is a procedure pointer",
9071 tsym
->name
, &target
->where
);
9075 if (tsym
->attr
.flavor
== FL_PROCEDURE
&& tsym
->generic
9076 && (dsym
= gfc_find_dt_in_generic (tsym
)) != NULL
9077 && dsym
->attr
.flavor
== FL_DERIVED
)
9079 gfc_error ("Derived type %qs cannot be used as a variable at %L",
9080 tsym
->name
, &target
->where
);
9084 if (tsym
->attr
.flavor
== FL_PROCEDURE
)
9086 bool is_error
= true;
9087 if (tsym
->attr
.function
&& tsym
->result
== tsym
)
9088 for (gfc_namespace
*ns
= sym
->ns
; ns
; ns
= ns
->parent
)
9089 if (tsym
== ns
->proc_name
)
9096 gfc_error ("Associating entity %qs at %L is a procedure name",
9097 tsym
->name
, &target
->where
);
9102 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
9103 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
9105 sym
->attr
.target
= tsym
->attr
.target
9106 || gfc_expr_attr (target
).pointer
;
9107 if (is_subref_array (target
))
9108 sym
->attr
.subref_array_pointer
= 1;
9110 else if (target
->ts
.type
== BT_PROCEDURE
)
9112 gfc_error ("Associating selector-expression at %L yields a procedure",
9117 if (target
->expr_type
== EXPR_NULL
)
9119 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
9122 else if (target
->ts
.type
== BT_UNKNOWN
)
9124 gfc_error ("Selector at %L has no type", &target
->where
);
9128 /* Get type if this was not already set. Note that it can be
9129 some other type than the target in case this is a SELECT TYPE
9130 selector! So we must not update when the type is already there. */
9131 if (sym
->ts
.type
== BT_UNKNOWN
)
9132 sym
->ts
= target
->ts
;
9134 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
9136 /* See if this is a valid association-to-variable. */
9137 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
9138 && !gfc_has_vector_subscript (target
));
9140 /* Finally resolve if this is an array or not. */
9141 if (sym
->attr
.dimension
&& target
->rank
== 0)
9143 /* primary.cc makes the assumption that a reference to an associate
9144 name followed by a left parenthesis is an array reference. */
9145 if (sym
->ts
.type
!= BT_CHARACTER
)
9146 gfc_error ("Associate-name %qs at %L is used as array",
9147 sym
->name
, &sym
->declared_at
);
9148 sym
->attr
.dimension
= 0;
9153 /* We cannot deal with class selectors that need temporaries. */
9154 if (target
->ts
.type
== BT_CLASS
9155 && gfc_ref_needs_temporary_p (target
->ref
))
9157 gfc_error ("CLASS selector at %L needs a temporary which is not "
9158 "yet implemented", &target
->where
);
9162 if (target
->ts
.type
== BT_CLASS
)
9163 gfc_fix_class_refs (target
);
9165 if (target
->rank
!= 0 && !sym
->attr
.select_rank_temporary
)
9168 /* The rank may be incorrectly guessed at parsing, therefore make sure
9169 it is corrected now. */
9170 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
9173 sym
->as
= gfc_get_array_spec ();
9175 as
->rank
= target
->rank
;
9176 as
->type
= AS_DEFERRED
;
9177 as
->corank
= gfc_get_corank (target
);
9178 sym
->attr
.dimension
= 1;
9179 if (as
->corank
!= 0)
9180 sym
->attr
.codimension
= 1;
9182 else if (sym
->ts
.type
== BT_CLASS
9184 && (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
9186 if (!CLASS_DATA (sym
)->as
)
9187 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
9188 as
= CLASS_DATA (sym
)->as
;
9189 as
->rank
= target
->rank
;
9190 as
->type
= AS_DEFERRED
;
9191 as
->corank
= gfc_get_corank (target
);
9192 CLASS_DATA (sym
)->attr
.dimension
= 1;
9193 if (as
->corank
!= 0)
9194 CLASS_DATA (sym
)->attr
.codimension
= 1;
9197 else if (!sym
->attr
.select_rank_temporary
)
9199 /* target's rank is 0, but the type of the sym is still array valued,
9200 which has to be corrected. */
9201 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
9202 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
9205 symbol_attribute attr
;
9206 /* The associated variable's type is still the array type
9207 correct this now. */
9208 gfc_typespec
*ts
= &target
->ts
;
9211 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
9216 ts
= &ref
->u
.c
.component
->ts
;
9219 if (ts
->type
== BT_CLASS
)
9220 ts
= &ts
->u
.derived
->components
->ts
;
9226 /* Create a scalar instance of the current class type. Because the
9227 rank of a class array goes into its name, the type has to be
9228 rebuild. The alternative of (re-)setting just the attributes
9229 and as in the current type, destroys the type also in other
9233 sym
->ts
.type
= BT_CLASS
;
9234 attr
= CLASS_DATA (sym
) ? CLASS_DATA (sym
)->attr
: sym
->attr
;
9236 attr
.associate_var
= 1;
9237 attr
.dimension
= attr
.codimension
= 0;
9238 attr
.class_pointer
= 1;
9239 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
9241 /* Make sure the _vptr is set. */
9242 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
9243 if (c
->ts
.u
.derived
== NULL
)
9244 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
9245 CLASS_DATA (sym
)->attr
.pointer
= 1;
9246 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
9247 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
9248 gfc_commit_symbol (sym
->ts
.u
.derived
);
9249 /* _vptr now has the _vtab in it, change it to the _vtype. */
9250 if (c
->ts
.u
.derived
->attr
.vtab
)
9251 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
9252 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
9253 resolve_types (c
->ts
.u
.derived
->ns
);
9257 /* Mark this as an associate variable. */
9258 sym
->attr
.associate_var
= 1;
9260 /* Fix up the type-spec for CHARACTER types. */
9261 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
9264 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
9266 if (sym
->ts
.deferred
9267 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
9269 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
9270 sym
->ts
.deferred
= 1;
9273 if (!sym
->ts
.u
.cl
->length
9274 && !sym
->ts
.deferred
9275 && target
->expr_type
== EXPR_CONSTANT
)
9277 sym
->ts
.u
.cl
->length
=
9278 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
9279 target
->value
.character
.length
);
9281 else if ((!sym
->ts
.u
.cl
->length
9282 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9283 && target
->expr_type
!= EXPR_VARIABLE
)
9285 if (!sym
->ts
.deferred
)
9287 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
9288 sym
->ts
.deferred
= 1;
9291 /* This is reset in trans-stmt.cc after the assignment
9292 of the target expression to the associate name. */
9293 sym
->attr
.allocatable
= 1;
9297 /* If the target is a good class object, so is the associate variable. */
9298 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
9299 sym
->attr
.class_ok
= 1;
9303 /* Ensure that SELECT TYPE expressions have the correct rank and a full
9304 array reference, where necessary. The symbols are artificial and so
9305 the dimension attribute and arrayspec can also be set. In addition,
9306 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
9307 This is corrected here as well.*/
9310 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
9311 int rank
, gfc_ref
*ref
)
9313 gfc_ref
*nref
= (*expr1
)->ref
;
9314 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
9315 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
9316 (*expr1
)->rank
= rank
;
9317 if (sym1
->ts
.type
== BT_CLASS
)
9319 if ((*expr1
)->ts
.type
!= BT_CLASS
)
9320 (*expr1
)->ts
= sym1
->ts
;
9322 CLASS_DATA (sym1
)->attr
.dimension
= 1;
9323 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
9324 CLASS_DATA (sym1
)->as
9325 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
9329 sym1
->attr
.dimension
= 1;
9330 if (sym1
->as
== NULL
&& sym2
)
9331 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
9334 for (; nref
; nref
= nref
->next
)
9335 if (nref
->next
== NULL
)
9338 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
9339 nref
->next
= gfc_copy_ref (ref
);
9340 else if (ref
&& !nref
)
9341 (*expr1
)->ref
= gfc_copy_ref (ref
);
9346 build_loc_call (gfc_expr
*sym_expr
)
9349 loc_call
= gfc_get_expr ();
9350 loc_call
->expr_type
= EXPR_FUNCTION
;
9351 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
9352 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
9353 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
9354 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
9355 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
9356 loc_call
->ts
.type
= BT_INTEGER
;
9357 loc_call
->ts
.kind
= gfc_index_integer_kind
;
9358 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
9359 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
9360 loc_call
->value
.function
.actual
->expr
= sym_expr
;
9361 loc_call
->where
= sym_expr
->where
;
9365 /* Resolve a SELECT TYPE statement. */
9368 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9370 gfc_symbol
*selector_type
;
9371 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9372 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9375 char name
[GFC_MAX_SYMBOL_LEN
+ 12 + 1];
9379 gfc_ref
* ref
= NULL
;
9380 gfc_expr
*selector_expr
= NULL
;
9382 ns
= code
->ext
.block
.ns
;
9385 /* Check for F03:C813. */
9386 if (code
->expr1
->ts
.type
!= BT_CLASS
9387 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9389 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9390 "at %L", &code
->loc
);
9394 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9399 gfc_ref
*ref2
= NULL
;
9400 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9401 if (ref
->type
== REF_COMPONENT
9402 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9407 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9408 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9409 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9413 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9414 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9415 selector_type
= CLASS_DATA (code
->expr2
)
9416 ? CLASS_DATA (code
->expr2
)->ts
.u
.derived
: code
->expr2
->ts
.u
.derived
;
9419 if (code
->expr2
->rank
9420 && code
->expr1
->ts
.type
== BT_CLASS
9421 && CLASS_DATA (code
->expr1
)->as
)
9422 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9424 /* F2008: C803 The selector expression must not be coindexed. */
9425 if (gfc_is_coindexed (code
->expr2
))
9427 gfc_error ("Selector at %L must not be coindexed",
9428 &code
->expr2
->where
);
9435 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9437 if (gfc_is_coindexed (code
->expr1
))
9439 gfc_error ("Selector at %L must not be coindexed",
9440 &code
->expr1
->where
);
9445 /* Loop over TYPE IS / CLASS IS cases. */
9446 for (body
= code
->block
; body
; body
= body
->block
)
9448 c
= body
->ext
.block
.case_list
;
9452 /* Check for repeated cases. */
9453 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9455 gfc_case
*d
= tail
->ext
.block
.case_list
;
9459 if (c
->ts
.type
== d
->ts
.type
9460 && ((c
->ts
.type
== BT_DERIVED
9461 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9462 && !strcmp (c
->ts
.u
.derived
->name
,
9463 d
->ts
.u
.derived
->name
))
9464 || c
->ts
.type
== BT_UNKNOWN
9465 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9466 && c
->ts
.kind
== d
->ts
.kind
)))
9468 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9469 &c
->where
, &d
->where
);
9475 /* Check F03:C815. */
9476 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9478 && !selector_type
->attr
.unlimited_polymorphic
9479 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9481 gfc_error ("Derived type %qs at %L must be extensible",
9482 c
->ts
.u
.derived
->name
, &c
->where
);
9487 /* Check F03:C816. */
9488 if (c
->ts
.type
!= BT_UNKNOWN
9489 && selector_type
&& !selector_type
->attr
.unlimited_polymorphic
9490 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9491 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9493 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9494 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9495 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9497 gfc_error ("Unexpected intrinsic type %qs at %L",
9498 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9503 /* Check F03:C814. */
9504 if (c
->ts
.type
== BT_CHARACTER
9505 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9507 gfc_error ("The type-spec at %L shall specify that each length "
9508 "type parameter is assumed", &c
->where
);
9513 /* Intercept the DEFAULT case. */
9514 if (c
->ts
.type
== BT_UNKNOWN
)
9516 /* Check F03:C818. */
9519 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9520 "by a second DEFAULT CASE at %L",
9521 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9526 default_case
= body
;
9533 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9534 target if present. If there are any EXIT statements referring to the
9535 SELECT TYPE construct, this is no problem because the gfc_code
9536 reference stays the same and EXIT is equally possible from the BLOCK
9537 it is changed to. */
9538 code
->op
= EXEC_BLOCK
;
9541 gfc_association_list
* assoc
;
9543 assoc
= gfc_get_association_list ();
9544 assoc
->st
= code
->expr1
->symtree
;
9545 assoc
->target
= gfc_copy_expr (code
->expr2
);
9546 assoc
->target
->where
= code
->expr2
->where
;
9547 /* assoc->variable will be set by resolve_assoc_var. */
9549 code
->ext
.block
.assoc
= assoc
;
9550 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9552 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9555 code
->ext
.block
.assoc
= NULL
;
9557 /* Ensure that the selector rank and arrayspec are available to
9558 correct expressions in which they might be missing. */
9559 if (code
->expr2
&& code
->expr2
->rank
)
9561 rank
= code
->expr2
->rank
;
9562 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9563 if (ref
->next
== NULL
)
9565 if (ref
&& ref
->type
== REF_ARRAY
)
9566 ref
= gfc_copy_ref (ref
);
9568 /* Fixup expr1 if necessary. */
9570 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9572 else if (code
->expr1
->rank
)
9574 rank
= code
->expr1
->rank
;
9575 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9576 if (ref
->next
== NULL
)
9578 if (ref
&& ref
->type
== REF_ARRAY
)
9579 ref
= gfc_copy_ref (ref
);
9582 /* Add EXEC_SELECT to switch on type. */
9583 new_st
= gfc_get_code (code
->op
);
9584 new_st
->expr1
= code
->expr1
;
9585 new_st
->expr2
= code
->expr2
;
9586 new_st
->block
= code
->block
;
9587 code
->expr1
= code
->expr2
= NULL
;
9592 ns
->code
->next
= new_st
;
9594 code
->op
= EXEC_SELECT_TYPE
;
9596 /* Use the intrinsic LOC function to generate an integer expression
9597 for the vtable of the selector. Note that the rank of the selector
9598 expression has to be set to zero. */
9599 gfc_add_vptr_component (code
->expr1
);
9600 code
->expr1
->rank
= 0;
9601 code
->expr1
= build_loc_call (code
->expr1
);
9602 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9604 /* Loop over TYPE IS / CLASS IS cases. */
9605 for (body
= code
->block
; body
; body
= body
->block
)
9609 c
= body
->ext
.block
.case_list
;
9611 /* Generate an index integer expression for address of the
9612 TYPE/CLASS vtable and store it in c->low. The hash expression
9613 is stored in c->high and is used to resolve intrinsic cases. */
9614 if (c
->ts
.type
!= BT_UNKNOWN
)
9616 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9618 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9620 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9621 c
->ts
.u
.derived
->hash_value
);
9625 vtab
= gfc_find_vtab (&c
->ts
);
9626 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9627 e
= CLASS_DATA (vtab
)->initializer
;
9628 c
->high
= gfc_copy_expr (e
);
9629 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9632 ts
.kind
= gfc_integer_4_kind
;
9633 ts
.type
= BT_INTEGER
;
9634 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9638 e
= gfc_lval_expr_from_sym (vtab
);
9639 c
->low
= build_loc_call (e
);
9644 /* Associate temporary to selector. This should only be done
9645 when this case is actually true, so build a new ASSOCIATE
9646 that does precisely this here (instead of using the
9649 if (c
->ts
.type
== BT_CLASS
)
9650 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9651 else if (c
->ts
.type
== BT_DERIVED
)
9652 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9653 else if (c
->ts
.type
== BT_CHARACTER
)
9655 HOST_WIDE_INT charlen
= 0;
9656 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9657 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9658 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9659 snprintf (name
, sizeof (name
),
9660 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9661 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9664 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9667 st
= gfc_find_symtree (ns
->sym_root
, name
);
9668 gcc_assert (st
->n
.sym
->assoc
);
9669 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9670 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9671 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9673 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9674 /* Fixup the target expression if necessary. */
9676 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9679 new_st
= gfc_get_code (EXEC_BLOCK
);
9680 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9681 new_st
->ext
.block
.ns
->code
= body
->next
;
9682 body
->next
= new_st
;
9684 /* Chain in the new list only if it is marked as dangling. Otherwise
9685 there is a CASE label overlap and this is already used. Just ignore,
9686 the error is diagnosed elsewhere. */
9687 if (st
->n
.sym
->assoc
->dangling
)
9689 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9690 st
->n
.sym
->assoc
->dangling
= 0;
9693 resolve_assoc_var (st
->n
.sym
, false);
9696 /* Take out CLASS IS cases for separate treatment. */
9698 while (body
&& body
->block
)
9700 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9702 /* Add to class_is list. */
9703 if (class_is
== NULL
)
9705 class_is
= body
->block
;
9710 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9711 tail
->block
= body
->block
;
9714 /* Remove from EXEC_SELECT list. */
9715 body
->block
= body
->block
->block
;
9728 /* Add a default case to hold the CLASS IS cases. */
9729 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9730 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9732 tail
->ext
.block
.case_list
= gfc_get_case ();
9733 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9735 default_case
= tail
;
9738 /* More than one CLASS IS block? */
9739 if (class_is
->block
)
9743 /* Sort CLASS IS blocks by extension level. */
9747 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9750 /* F03:C817 (check for doubles). */
9751 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9752 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9754 gfc_error ("Double CLASS IS block in SELECT TYPE "
9756 &c2
->ext
.block
.case_list
->where
);
9759 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9760 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9763 (*c1
)->block
= c2
->block
;
9773 /* Generate IF chain. */
9774 if_st
= gfc_get_code (EXEC_IF
);
9776 for (body
= class_is
; body
; body
= body
->block
)
9778 new_st
->block
= gfc_get_code (EXEC_IF
);
9779 new_st
= new_st
->block
;
9780 /* Set up IF condition: Call _gfortran_is_extension_of. */
9781 new_st
->expr1
= gfc_get_expr ();
9782 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9783 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9784 new_st
->expr1
->ts
.kind
= 4;
9785 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9786 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9787 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9788 /* Set up arguments. */
9789 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9790 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9791 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9792 new_st
->expr1
->where
= code
->loc
;
9793 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9794 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9795 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9796 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9797 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9798 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9799 /* Set up types in formal arg list. */
9800 new_st
->expr1
->value
.function
.isym
->formal
= XCNEW (gfc_intrinsic_arg
);
9801 new_st
->expr1
->value
.function
.isym
->formal
->ts
= new_st
->expr1
->value
.function
.actual
->expr
->ts
;
9802 new_st
->expr1
->value
.function
.isym
->formal
->next
= XCNEW (gfc_intrinsic_arg
);
9803 new_st
->expr1
->value
.function
.isym
->formal
->next
->ts
= new_st
->expr1
->value
.function
.actual
->next
->expr
->ts
;
9805 new_st
->next
= body
->next
;
9807 if (default_case
->next
)
9809 new_st
->block
= gfc_get_code (EXEC_IF
);
9810 new_st
= new_st
->block
;
9811 new_st
->next
= default_case
->next
;
9814 /* Replace CLASS DEFAULT code by the IF chain. */
9815 default_case
->next
= if_st
;
9818 /* Resolve the internal code. This cannot be done earlier because
9819 it requires that the sym->assoc of selectors is set already. */
9820 gfc_current_ns
= ns
;
9821 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9822 gfc_current_ns
= old_ns
;
9829 /* Resolve a SELECT RANK statement. */
9832 resolve_select_rank (gfc_code
*code
, gfc_namespace
*old_ns
)
9835 gfc_code
*body
, *new_st
, *tail
;
9837 char tname
[GFC_MAX_SYMBOL_LEN
+ 7];
9838 char name
[2 * GFC_MAX_SYMBOL_LEN
];
9840 gfc_expr
*selector_expr
= NULL
;
9842 HOST_WIDE_INT charlen
= 0;
9844 ns
= code
->ext
.block
.ns
;
9847 code
->op
= EXEC_BLOCK
;
9850 gfc_association_list
* assoc
;
9852 assoc
= gfc_get_association_list ();
9853 assoc
->st
= code
->expr1
->symtree
;
9854 assoc
->target
= gfc_copy_expr (code
->expr2
);
9855 assoc
->target
->where
= code
->expr2
->where
;
9856 /* assoc->variable will be set by resolve_assoc_var. */
9858 code
->ext
.block
.assoc
= assoc
;
9859 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9861 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9864 code
->ext
.block
.assoc
= NULL
;
9866 /* Loop over RANK cases. Note that returning on the errors causes a
9867 cascade of further errors because the case blocks do not compile
9869 for (body
= code
->block
; body
; body
= body
->block
)
9871 c
= body
->ext
.block
.case_list
;
9873 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9877 /* Check for repeated cases. */
9878 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9880 gfc_case
*d
= tail
->ext
.block
.case_list
;
9886 /* Check F2018: C1153. */
9887 if (!c
->low
&& !d
->low
)
9888 gfc_error ("RANK DEFAULT at %L is repeated at %L",
9889 &c
->where
, &d
->where
);
9891 if (!c
->low
|| !d
->low
)
9894 /* Check F2018: C1153. */
9895 case_value2
= (int) mpz_get_si (d
->low
->value
.integer
);
9896 if ((case_value
== case_value2
) && case_value
== -1)
9897 gfc_error ("RANK (*) at %L is repeated at %L",
9898 &c
->where
, &d
->where
);
9899 else if (case_value
== case_value2
)
9900 gfc_error ("RANK (%i) at %L is repeated at %L",
9901 case_value
, &c
->where
, &d
->where
);
9907 /* Check F2018: C1155. */
9908 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9909 || gfc_expr_attr (code
->expr1
).pointer
))
9910 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9911 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9913 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9914 || gfc_expr_attr (code
->expr1
).pointer
))
9915 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9916 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9919 /* Add EXEC_SELECT to switch on rank. */
9920 new_st
= gfc_get_code (code
->op
);
9921 new_st
->expr1
= code
->expr1
;
9922 new_st
->expr2
= code
->expr2
;
9923 new_st
->block
= code
->block
;
9924 code
->expr1
= code
->expr2
= NULL
;
9929 ns
->code
->next
= new_st
;
9931 code
->op
= EXEC_SELECT_RANK
;
9933 selector_expr
= code
->expr1
;
9935 /* Loop over SELECT RANK cases. */
9936 for (body
= code
->block
; body
; body
= body
->block
)
9938 c
= body
->ext
.block
.case_list
;
9941 /* Pass on the default case. */
9945 /* Associate temporary to selector. This should only be done
9946 when this case is actually true, so build a new ASSOCIATE
9947 that does precisely this here (instead of using the
9949 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9950 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9951 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9953 if (c
->ts
.type
== BT_CLASS
)
9954 sprintf (tname
, "class_%s", c
->ts
.u
.derived
->name
);
9955 else if (c
->ts
.type
== BT_DERIVED
)
9956 sprintf (tname
, "type_%s", c
->ts
.u
.derived
->name
);
9957 else if (c
->ts
.type
!= BT_CHARACTER
)
9958 sprintf (tname
, "%s_%d", gfc_basic_typename (c
->ts
.type
), c
->ts
.kind
);
9960 sprintf (tname
, "%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9961 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9963 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9964 if (case_value
>= 0)
9965 sprintf (name
, "__tmp_%s_rank_%d", tname
, case_value
);
9967 sprintf (name
, "__tmp_%s_rank_m%d", tname
, -case_value
);
9969 st
= gfc_find_symtree (ns
->sym_root
, name
);
9970 gcc_assert (st
->n
.sym
->assoc
);
9972 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9973 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9975 new_st
= gfc_get_code (EXEC_BLOCK
);
9976 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9977 new_st
->ext
.block
.ns
->code
= body
->next
;
9978 body
->next
= new_st
;
9980 /* Chain in the new list only if it is marked as dangling. Otherwise
9981 there is a CASE label overlap and this is already used. Just ignore,
9982 the error is diagnosed elsewhere. */
9983 if (st
->n
.sym
->assoc
->dangling
)
9985 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9986 st
->n
.sym
->assoc
->dangling
= 0;
9989 resolve_assoc_var (st
->n
.sym
, false);
9992 gfc_current_ns
= ns
;
9993 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9994 gfc_current_ns
= old_ns
;
9998 /* Resolve a transfer statement. This is making sure that:
9999 -- a derived type being transferred has only non-pointer components
10000 -- a derived type being transferred doesn't have private components, unless
10001 it's being transferred from the module where the type was defined
10002 -- we're not trying to transfer a whole assumed size array. */
10005 resolve_transfer (gfc_code
*code
)
10007 gfc_symbol
*sym
, *derived
;
10010 bool write
= false;
10011 bool formatted
= false;
10012 gfc_dt
*dt
= code
->ext
.dt
;
10013 gfc_symbol
*dtio_sub
= NULL
;
10017 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
10018 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
10019 exp
= exp
->value
.op
.op1
;
10021 if (exp
&& exp
->expr_type
== EXPR_NULL
10024 gfc_error ("Invalid context for NULL () intrinsic at %L",
10029 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
10030 && exp
->expr_type
!= EXPR_FUNCTION
10031 && exp
->expr_type
!= EXPR_ARRAY
10032 && exp
->expr_type
!= EXPR_STRUCTURE
))
10035 /* If we are reading, the variable will be changed. Note that
10036 code->ext.dt may be NULL if the TRANSFER is related to
10037 an INQUIRE statement -- but in this case, we are not reading, either. */
10038 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
10039 && !gfc_check_vardef_context (exp
, false, false, false,
10040 _("item in READ")))
10043 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
10044 || exp
->expr_type
== EXPR_FUNCTION
10045 || exp
->expr_type
== EXPR_ARRAY
10046 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
10048 /* Go to actual component transferred. */
10049 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
10050 if (ref
->type
== REF_COMPONENT
)
10051 ts
= &ref
->u
.c
.component
->ts
;
10053 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
10054 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
10056 derived
= ts
->u
.derived
;
10058 /* Determine when to use the formatted DTIO procedure. */
10059 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
10062 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
10063 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
10064 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
10066 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
10069 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
10070 /* Check to see if this is a nested DTIO call, with the
10071 dummy as the io-list object. */
10072 if (sym
&& sym
== dtio_sub
&& sym
->formal
10073 && sym
->formal
->sym
== exp
->symtree
->n
.sym
10074 && exp
->ref
== NULL
)
10076 if (!sym
->attr
.recursive
)
10078 gfc_error ("DTIO %s procedure at %L must be recursive",
10079 sym
->name
, &sym
->declared_at
);
10086 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
10088 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
10089 "it is processed by a defined input/output procedure",
10094 if (ts
->type
== BT_DERIVED
)
10096 /* Check that transferred derived type doesn't contain POINTER
10097 components unless it is processed by a defined input/output
10099 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
10101 gfc_error ("Data transfer element at %L cannot have POINTER "
10102 "components unless it is processed by a defined "
10103 "input/output procedure", &code
->loc
);
10108 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
10110 gfc_error ("Data transfer element at %L cannot have "
10111 "procedure pointer components", &code
->loc
);
10115 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
10117 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
10118 "components unless it is processed by a defined "
10119 "input/output procedure", &code
->loc
);
10123 /* C_PTR and C_FUNPTR have private components which means they cannot
10124 be printed. However, if -std=gnu and not -pedantic, allow
10125 the component to be printed to help debugging. */
10126 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
10128 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
10129 "cannot have PRIVATE components", &code
->loc
))
10132 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
10134 gfc_error ("Data transfer element at %L cannot have "
10135 "PRIVATE components unless it is processed by "
10136 "a defined input/output procedure", &code
->loc
);
10141 if (exp
->expr_type
== EXPR_STRUCTURE
)
10144 if (exp
->expr_type
== EXPR_ARRAY
)
10147 sym
= exp
->symtree
->n
.sym
;
10149 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
10150 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
10152 gfc_error ("Data transfer element at %L cannot be a full reference to "
10153 "an assumed-size array", &code
->loc
);
10159 /*********** Toplevel code resolution subroutines ***********/
10161 /* Find the set of labels that are reachable from this block. We also
10162 record the last statement in each block. */
10165 find_reachable_labels (gfc_code
*block
)
10172 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
10174 /* Collect labels in this block. We don't keep those corresponding
10175 to END {IF|SELECT}, these are checked in resolve_branch by going
10176 up through the code_stack. */
10177 for (c
= block
; c
; c
= c
->next
)
10179 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
10180 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
10183 /* Merge with labels from parent block. */
10186 gcc_assert (cs_base
->prev
->reachable_labels
);
10187 bitmap_ior_into (cs_base
->reachable_labels
,
10188 cs_base
->prev
->reachable_labels
);
10194 resolve_lock_unlock_event (gfc_code
*code
)
10196 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10197 && code
->expr1
->value
.function
.isym
10198 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10199 remove_caf_get_intrinsic (code
->expr1
);
10201 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
10202 && (code
->expr1
->ts
.type
!= BT_DERIVED
10203 || code
->expr1
->expr_type
!= EXPR_VARIABLE
10204 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
10205 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
10206 || code
->expr1
->rank
!= 0
10207 || (!gfc_is_coarray (code
->expr1
) &&
10208 !gfc_is_coindexed (code
->expr1
))))
10209 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
10210 &code
->expr1
->where
);
10211 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
10212 && (code
->expr1
->ts
.type
!= BT_DERIVED
10213 || code
->expr1
->expr_type
!= EXPR_VARIABLE
10214 || code
->expr1
->ts
.u
.derived
->from_intmod
10215 != INTMOD_ISO_FORTRAN_ENV
10216 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
10217 != ISOFORTRAN_EVENT_TYPE
10218 || code
->expr1
->rank
!= 0))
10219 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
10220 &code
->expr1
->where
);
10221 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
10222 && !gfc_is_coindexed (code
->expr1
))
10223 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
10224 &code
->expr1
->where
);
10225 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
10226 gfc_error ("Event variable argument at %L must be a coarray but not "
10227 "coindexed", &code
->expr1
->where
);
10231 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
10232 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
10233 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10234 &code
->expr2
->where
);
10237 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
10238 _("STAT variable")))
10241 /* Check ERRMSG. */
10243 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
10244 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
10245 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10246 &code
->expr3
->where
);
10249 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
10250 _("ERRMSG variable")))
10253 /* Check for LOCK the ACQUIRED_LOCK. */
10254 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
10255 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
10256 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
10257 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
10258 "variable", &code
->expr4
->where
);
10260 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
10261 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
10262 _("ACQUIRED_LOCK variable")))
10265 /* Check for EVENT WAIT the UNTIL_COUNT. */
10266 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
10268 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
10269 || code
->expr4
->rank
!= 0)
10270 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
10271 "expression", &code
->expr4
->where
);
10277 resolve_critical (gfc_code
*code
)
10279 gfc_symtree
*symtree
;
10280 gfc_symbol
*lock_type
;
10281 char name
[GFC_MAX_SYMBOL_LEN
];
10282 static int serial
= 0;
10284 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
10287 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
10288 GFC_PREFIX ("lock_type"));
10290 lock_type
= symtree
->n
.sym
;
10293 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
10295 gcc_unreachable ();
10296 lock_type
= symtree
->n
.sym
;
10297 lock_type
->attr
.flavor
= FL_DERIVED
;
10298 lock_type
->attr
.zero_comp
= 1;
10299 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
10300 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
10303 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
10304 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
10305 gcc_unreachable ();
10307 code
->resolved_sym
= symtree
->n
.sym
;
10308 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10309 symtree
->n
.sym
->attr
.referenced
= 1;
10310 symtree
->n
.sym
->attr
.artificial
= 1;
10311 symtree
->n
.sym
->attr
.codimension
= 1;
10312 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
10313 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
10314 symtree
->n
.sym
->as
= gfc_get_array_spec ();
10315 symtree
->n
.sym
->as
->corank
= 1;
10316 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
10317 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
10318 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
10320 gfc_commit_symbols();
10325 resolve_sync (gfc_code
*code
)
10327 /* Check imageset. The * case matches expr1 == NULL. */
10330 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
10331 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
10332 "INTEGER expression", &code
->expr1
->where
);
10333 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
10334 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
10335 gfc_error ("Imageset argument at %L must between 1 and num_images()",
10336 &code
->expr1
->where
);
10337 else if (code
->expr1
->expr_type
== EXPR_ARRAY
10338 && gfc_simplify_expr (code
->expr1
, 0))
10340 gfc_constructor
*cons
;
10341 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
10342 for (; cons
; cons
= gfc_constructor_next (cons
))
10343 if (cons
->expr
->expr_type
== EXPR_CONSTANT
10344 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
10345 gfc_error ("Imageset argument at %L must between 1 and "
10346 "num_images()", &cons
->expr
->where
);
10351 gfc_resolve_expr (code
->expr2
);
10354 if (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0)
10355 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10356 &code
->expr2
->where
);
10358 gfc_check_vardef_context (code
->expr2
, false, false, false,
10359 _("STAT variable"));
10362 /* Check ERRMSG. */
10363 gfc_resolve_expr (code
->expr3
);
10366 if (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0)
10367 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10368 &code
->expr3
->where
);
10370 gfc_check_vardef_context (code
->expr3
, false, false, false,
10371 _("ERRMSG variable"));
10376 /* Given a branch to a label, see if the branch is conforming.
10377 The code node describes where the branch is located. */
10380 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
10387 /* Step one: is this a valid branching target? */
10389 if (label
->defined
== ST_LABEL_UNKNOWN
)
10391 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
10396 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
10398 gfc_error ("Statement at %L is not a valid branch target statement "
10399 "for the branch statement at %L", &label
->where
, &code
->loc
);
10403 /* Step two: make sure this branch is not a branch to itself ;-) */
10405 if (code
->here
== label
)
10408 "Branch at %L may result in an infinite loop", &code
->loc
);
10412 /* Step three: See if the label is in the same block as the
10413 branching statement. The hard work has been done by setting up
10414 the bitmap reachable_labels. */
10416 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
10418 /* Check now whether there is a CRITICAL construct; if so, check
10419 whether the label is still visible outside of the CRITICAL block,
10420 which is invalid. */
10421 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10423 if (stack
->current
->op
== EXEC_CRITICAL
10424 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10425 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
10426 "label at %L", &code
->loc
, &label
->where
);
10427 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
10428 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10429 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
10430 "for label at %L", &code
->loc
, &label
->where
);
10436 /* Step four: If we haven't found the label in the bitmap, it may
10437 still be the label of the END of the enclosing block, in which
10438 case we find it by going up the code_stack. */
10440 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10442 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
10444 if (stack
->current
->op
== EXEC_CRITICAL
)
10446 /* Note: A label at END CRITICAL does not leave the CRITICAL
10447 construct as END CRITICAL is still part of it. */
10448 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
10449 " at %L", &code
->loc
, &label
->where
);
10452 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
10454 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
10455 "label at %L", &code
->loc
, &label
->where
);
10462 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
10466 /* The label is not in an enclosing block, so illegal. This was
10467 allowed in Fortran 66, so we allow it as extension. No
10468 further checks are necessary in this case. */
10469 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
10470 "as the GOTO statement at %L", &label
->where
,
10476 /* Check whether EXPR1 has the same shape as EXPR2. */
10479 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
10481 mpz_t shape
[GFC_MAX_DIMENSIONS
];
10482 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
10483 bool result
= false;
10486 /* Compare the rank. */
10487 if (expr1
->rank
!= expr2
->rank
)
10490 /* Compare the size of each dimension. */
10491 for (i
=0; i
<expr1
->rank
; i
++)
10493 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
10496 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
10499 if (mpz_cmp (shape
[i
], shape2
[i
]))
10503 /* When either of the two expression is an assumed size array, we
10504 ignore the comparison of dimension sizes. */
10509 gfc_clear_shape (shape
, i
);
10510 gfc_clear_shape (shape2
, i
);
10515 /* Check whether a WHERE assignment target or a WHERE mask expression
10516 has the same shape as the outmost WHERE mask expression. */
10519 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
10523 gfc_expr
*e
= NULL
;
10525 cblock
= code
->block
;
10527 /* Store the first WHERE mask-expr of the WHERE statement or construct.
10528 In case of nested WHERE, only the outmost one is stored. */
10529 if (mask
== NULL
) /* outmost WHERE */
10531 else /* inner WHERE */
10538 /* Check if the mask-expr has a consistent shape with the
10539 outmost WHERE mask-expr. */
10540 if (!resolve_where_shape (cblock
->expr1
, e
))
10541 gfc_error ("WHERE mask at %L has inconsistent shape",
10542 &cblock
->expr1
->where
);
10545 /* the assignment statement of a WHERE statement, or the first
10546 statement in where-body-construct of a WHERE construct */
10547 cnext
= cblock
->next
;
10552 /* WHERE assignment statement */
10555 /* Check shape consistent for WHERE assignment target. */
10556 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10557 gfc_error ("WHERE assignment target at %L has "
10558 "inconsistent shape", &cnext
->expr1
->where
);
10562 case EXEC_ASSIGN_CALL
:
10563 resolve_call (cnext
);
10564 if (!cnext
->resolved_sym
->attr
.elemental
)
10565 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10566 &cnext
->ext
.actual
->expr
->where
);
10569 /* WHERE or WHERE construct is part of a where-body-construct */
10571 resolve_where (cnext
, e
);
10575 gfc_error ("Unsupported statement inside WHERE at %L",
10578 /* the next statement within the same where-body-construct */
10579 cnext
= cnext
->next
;
10581 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10582 cblock
= cblock
->block
;
10587 /* Resolve assignment in FORALL construct.
10588 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10589 FORALL index variables. */
10592 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10596 for (n
= 0; n
< nvar
; n
++)
10598 gfc_symbol
*forall_index
;
10600 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10602 /* Check whether the assignment target is one of the FORALL index
10604 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10605 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10606 gfc_error ("Assignment to a FORALL index variable at %L",
10607 &code
->expr1
->where
);
10610 /* If one of the FORALL index variables doesn't appear in the
10611 assignment variable, then there could be a many-to-one
10612 assignment. Emit a warning rather than an error because the
10613 mask could be resolving this problem. */
10614 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10615 gfc_warning (0, "The FORALL with index %qs is not used on the "
10616 "left side of the assignment at %L and so might "
10617 "cause multiple assignment to this object",
10618 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10624 /* Resolve WHERE statement in FORALL construct. */
10627 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10628 gfc_expr
**var_expr
)
10633 cblock
= code
->block
;
10636 /* the assignment statement of a WHERE statement, or the first
10637 statement in where-body-construct of a WHERE construct */
10638 cnext
= cblock
->next
;
10643 /* WHERE assignment statement */
10645 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10648 /* WHERE operator assignment statement */
10649 case EXEC_ASSIGN_CALL
:
10650 resolve_call (cnext
);
10651 if (!cnext
->resolved_sym
->attr
.elemental
)
10652 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10653 &cnext
->ext
.actual
->expr
->where
);
10656 /* WHERE or WHERE construct is part of a where-body-construct */
10658 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10662 gfc_error ("Unsupported statement inside WHERE at %L",
10665 /* the next statement within the same where-body-construct */
10666 cnext
= cnext
->next
;
10668 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10669 cblock
= cblock
->block
;
10674 /* Traverse the FORALL body to check whether the following errors exist:
10675 1. For assignment, check if a many-to-one assignment happens.
10676 2. For WHERE statement, check the WHERE body to see if there is any
10677 many-to-one assignment. */
10680 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10684 c
= code
->block
->next
;
10690 case EXEC_POINTER_ASSIGN
:
10691 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10694 case EXEC_ASSIGN_CALL
:
10698 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10699 there is no need to handle it here. */
10703 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10708 /* The next statement in the FORALL body. */
10714 /* Counts the number of iterators needed inside a forall construct, including
10715 nested forall constructs. This is used to allocate the needed memory
10716 in gfc_resolve_forall. */
10719 gfc_count_forall_iterators (gfc_code
*code
)
10721 int max_iters
, sub_iters
, current_iters
;
10722 gfc_forall_iterator
*fa
;
10724 gcc_assert(code
->op
== EXEC_FORALL
);
10728 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10731 code
= code
->block
->next
;
10735 if (code
->op
== EXEC_FORALL
)
10737 sub_iters
= gfc_count_forall_iterators (code
);
10738 if (sub_iters
> max_iters
)
10739 max_iters
= sub_iters
;
10744 return current_iters
+ max_iters
;
10748 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10749 gfc_resolve_forall_body to resolve the FORALL body. */
10752 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10754 static gfc_expr
**var_expr
;
10755 static int total_var
= 0;
10756 static int nvar
= 0;
10757 int i
, old_nvar
, tmp
;
10758 gfc_forall_iterator
*fa
;
10762 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10765 /* Start to resolve a FORALL construct */
10766 if (forall_save
== 0)
10768 /* Count the total number of FORALL indices in the nested FORALL
10769 construct in order to allocate the VAR_EXPR with proper size. */
10770 total_var
= gfc_count_forall_iterators (code
);
10772 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10773 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10776 /* The information about FORALL iterator, including FORALL indices start, end
10777 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10778 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10780 /* Fortran 20008: C738 (R753). */
10781 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10783 gfc_error ("FORALL index-name at %L must be a scalar variable "
10784 "of type integer", &fa
->var
->where
);
10788 /* Check if any outer FORALL index name is the same as the current
10790 for (i
= 0; i
< nvar
; i
++)
10792 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10793 gfc_error ("An outer FORALL construct already has an index "
10794 "with this name %L", &fa
->var
->where
);
10797 /* Record the current FORALL index. */
10798 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10802 /* No memory leak. */
10803 gcc_assert (nvar
<= total_var
);
10806 /* Resolve the FORALL body. */
10807 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10809 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10810 gfc_resolve_blocks (code
->block
, ns
);
10814 /* Free only the VAR_EXPRs allocated in this frame. */
10815 for (i
= nvar
; i
< tmp
; i
++)
10816 gfc_free_expr (var_expr
[i
]);
10820 /* We are in the outermost FORALL construct. */
10821 gcc_assert (forall_save
== 0);
10823 /* VAR_EXPR is not needed any more. */
10830 /* Resolve a BLOCK construct statement. */
10833 resolve_block_construct (gfc_code
* code
)
10835 /* Resolve the BLOCK's namespace. */
10836 gfc_resolve (code
->ext
.block
.ns
);
10838 /* For an ASSOCIATE block, the associations (and their targets) are already
10839 resolved during resolve_symbol. */
10843 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10847 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10851 for (; b
; b
= b
->block
)
10853 t
= gfc_resolve_expr (b
->expr1
);
10854 if (!gfc_resolve_expr (b
->expr2
))
10860 if (t
&& b
->expr1
!= NULL
10861 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10862 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10868 && b
->expr1
!= NULL
10869 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10870 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10875 resolve_branch (b
->label1
, b
);
10879 resolve_block_construct (b
);
10883 case EXEC_SELECT_TYPE
:
10884 case EXEC_SELECT_RANK
:
10887 case EXEC_DO_WHILE
:
10888 case EXEC_DO_CONCURRENT
:
10889 case EXEC_CRITICAL
:
10892 case EXEC_IOLENGTH
:
10896 case EXEC_OMP_ATOMIC
:
10897 case EXEC_OACC_ATOMIC
:
10899 /* Verify this before calling gfc_resolve_code, which might
10901 gcc_assert (b
->op
== EXEC_OMP_ATOMIC
10902 || (b
->next
&& b
->next
->op
== EXEC_ASSIGN
));
10906 case EXEC_OACC_PARALLEL_LOOP
:
10907 case EXEC_OACC_PARALLEL
:
10908 case EXEC_OACC_KERNELS_LOOP
:
10909 case EXEC_OACC_KERNELS
:
10910 case EXEC_OACC_SERIAL_LOOP
:
10911 case EXEC_OACC_SERIAL
:
10912 case EXEC_OACC_DATA
:
10913 case EXEC_OACC_HOST_DATA
:
10914 case EXEC_OACC_LOOP
:
10915 case EXEC_OACC_UPDATE
:
10916 case EXEC_OACC_WAIT
:
10917 case EXEC_OACC_CACHE
:
10918 case EXEC_OACC_ENTER_DATA
:
10919 case EXEC_OACC_EXIT_DATA
:
10920 case EXEC_OACC_ROUTINE
:
10921 case EXEC_OMP_ASSUME
:
10922 case EXEC_OMP_CRITICAL
:
10923 case EXEC_OMP_DISTRIBUTE
:
10924 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10925 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10926 case EXEC_OMP_DISTRIBUTE_SIMD
:
10928 case EXEC_OMP_DO_SIMD
:
10929 case EXEC_OMP_ERROR
:
10930 case EXEC_OMP_LOOP
:
10931 case EXEC_OMP_MASKED
:
10932 case EXEC_OMP_MASKED_TASKLOOP
:
10933 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
10934 case EXEC_OMP_MASTER
:
10935 case EXEC_OMP_MASTER_TASKLOOP
:
10936 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
10937 case EXEC_OMP_ORDERED
:
10938 case EXEC_OMP_PARALLEL
:
10939 case EXEC_OMP_PARALLEL_DO
:
10940 case EXEC_OMP_PARALLEL_DO_SIMD
:
10941 case EXEC_OMP_PARALLEL_LOOP
:
10942 case EXEC_OMP_PARALLEL_MASKED
:
10943 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
10944 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
10945 case EXEC_OMP_PARALLEL_MASTER
:
10946 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
10947 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
10948 case EXEC_OMP_PARALLEL_SECTIONS
:
10949 case EXEC_OMP_PARALLEL_WORKSHARE
:
10950 case EXEC_OMP_SECTIONS
:
10951 case EXEC_OMP_SIMD
:
10952 case EXEC_OMP_SCOPE
:
10953 case EXEC_OMP_SINGLE
:
10954 case EXEC_OMP_TARGET
:
10955 case EXEC_OMP_TARGET_DATA
:
10956 case EXEC_OMP_TARGET_ENTER_DATA
:
10957 case EXEC_OMP_TARGET_EXIT_DATA
:
10958 case EXEC_OMP_TARGET_PARALLEL
:
10959 case EXEC_OMP_TARGET_PARALLEL_DO
:
10960 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10961 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
10962 case EXEC_OMP_TARGET_SIMD
:
10963 case EXEC_OMP_TARGET_TEAMS
:
10964 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10965 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10966 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10967 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10968 case EXEC_OMP_TARGET_TEAMS_LOOP
:
10969 case EXEC_OMP_TARGET_UPDATE
:
10970 case EXEC_OMP_TASK
:
10971 case EXEC_OMP_TASKGROUP
:
10972 case EXEC_OMP_TASKLOOP
:
10973 case EXEC_OMP_TASKLOOP_SIMD
:
10974 case EXEC_OMP_TASKWAIT
:
10975 case EXEC_OMP_TASKYIELD
:
10976 case EXEC_OMP_TEAMS
:
10977 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10978 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10979 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10980 case EXEC_OMP_TEAMS_LOOP
:
10981 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10982 case EXEC_OMP_WORKSHARE
:
10986 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10989 gfc_resolve_code (b
->next
, ns
);
10994 /* Does everything to resolve an ordinary assignment. Returns true
10995 if this is an interface assignment. */
10997 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
11004 symbol_attribute attr
;
11006 if (gfc_extend_assign (code
, ns
))
11010 if (code
->op
== EXEC_ASSIGN_CALL
)
11012 lhs
= code
->ext
.actual
->expr
;
11013 rhsptr
= &code
->ext
.actual
->next
->expr
;
11017 gfc_actual_arglist
* args
;
11018 gfc_typebound_proc
* tbp
;
11020 gcc_assert (code
->op
== EXEC_COMPCALL
);
11022 args
= code
->expr1
->value
.compcall
.actual
;
11024 rhsptr
= &args
->next
->expr
;
11026 tbp
= code
->expr1
->value
.compcall
.tbp
;
11027 gcc_assert (!tbp
->is_generic
);
11030 /* Make a temporary rhs when there is a default initializer
11031 and rhs is the same symbol as the lhs. */
11032 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
11033 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
11034 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
11035 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
11036 *rhsptr
= gfc_get_parentheses (*rhsptr
);
11044 if ((gfc_numeric_ts (&lhs
->ts
) || lhs
->ts
.type
== BT_LOGICAL
)
11045 && rhs
->ts
.type
== BT_CHARACTER
11046 && (rhs
->expr_type
!= EXPR_CONSTANT
|| !flag_dec_char_conversions
))
11048 /* Use of -fdec-char-conversions allows assignment of character data
11049 to non-character variables. This not permited for nonconstant
11051 gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs
),
11052 gfc_typename (lhs
), &rhs
->where
);
11056 /* Handle the case of a BOZ literal on the RHS. */
11057 if (rhs
->ts
.type
== BT_BOZ
)
11059 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
11060 "statement value nor an actual argument of "
11061 "INT/REAL/DBLE/CMPLX intrinsic subprogram",
11065 switch (lhs
->ts
.type
)
11068 if (!gfc_boz2int (rhs
, lhs
->ts
.kind
))
11072 if (!gfc_boz2real (rhs
, lhs
->ts
.kind
))
11076 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs
->where
);
11081 if (lhs
->ts
.type
== BT_CHARACTER
&& warn_character_truncation
)
11083 HOST_WIDE_INT llen
= 0, rlen
= 0;
11084 if (lhs
->ts
.u
.cl
!= NULL
11085 && lhs
->ts
.u
.cl
->length
!= NULL
11086 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
11087 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
11089 if (rhs
->expr_type
== EXPR_CONSTANT
)
11090 rlen
= rhs
->value
.character
.length
;
11092 else if (rhs
->ts
.u
.cl
!= NULL
11093 && rhs
->ts
.u
.cl
->length
!= NULL
11094 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
11095 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
11097 if (rlen
&& llen
&& rlen
> llen
)
11098 gfc_warning_now (OPT_Wcharacter_truncation
,
11099 "CHARACTER expression will be truncated "
11100 "in assignment (%ld/%ld) at %L",
11101 (long) llen
, (long) rlen
, &code
->loc
);
11104 /* Ensure that a vector index expression for the lvalue is evaluated
11105 to a temporary if the lvalue symbol is referenced in it. */
11108 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
11109 if (ref
->type
== REF_ARRAY
)
11111 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
11112 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
11113 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
11114 ref
->u
.ar
.start
[n
]))
11116 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
11120 if (gfc_pure (NULL
))
11122 if (lhs
->ts
.type
== BT_DERIVED
11123 && lhs
->expr_type
== EXPR_VARIABLE
11124 && lhs
->ts
.u
.derived
->attr
.pointer_comp
11125 && rhs
->expr_type
== EXPR_VARIABLE
11126 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
11127 || gfc_is_coindexed (rhs
)))
11129 /* F2008, C1283. */
11130 if (gfc_is_coindexed (rhs
))
11131 gfc_error ("Coindexed expression at %L is assigned to "
11132 "a derived type variable with a POINTER "
11133 "component in a PURE procedure",
11136 /* F2008, C1283 (4). */
11137 gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
11138 "shall not be used as the expr at %L of an intrinsic "
11139 "assignment statement in which the variable is of a "
11140 "derived type if the derived type has a pointer "
11141 "component at any level of component selection.",
11146 /* Fortran 2008, C1283. */
11147 if (gfc_is_coindexed (lhs
))
11149 gfc_error ("Assignment to coindexed variable at %L in a PURE "
11150 "procedure", &rhs
->where
);
11155 if (gfc_implicit_pure (NULL
))
11157 if (lhs
->expr_type
== EXPR_VARIABLE
11158 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
11159 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
11160 gfc_unset_implicit_pure (NULL
);
11162 if (lhs
->ts
.type
== BT_DERIVED
11163 && lhs
->expr_type
== EXPR_VARIABLE
11164 && lhs
->ts
.u
.derived
->attr
.pointer_comp
11165 && rhs
->expr_type
== EXPR_VARIABLE
11166 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
11167 || gfc_is_coindexed (rhs
)))
11168 gfc_unset_implicit_pure (NULL
);
11170 /* Fortran 2008, C1283. */
11171 if (gfc_is_coindexed (lhs
))
11172 gfc_unset_implicit_pure (NULL
);
11175 /* F2008, 7.2.1.2. */
11176 attr
= gfc_expr_attr (lhs
);
11177 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
11179 if (attr
.codimension
)
11181 gfc_error ("Assignment to polymorphic coarray at %L is not "
11182 "permitted", &lhs
->where
);
11185 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
11186 "polymorphic variable at %L", &lhs
->where
))
11188 if (!flag_realloc_lhs
)
11190 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
11191 "requires %<-frealloc-lhs%>", &lhs
->where
);
11195 else if (lhs
->ts
.type
== BT_CLASS
)
11197 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
11198 "assignment at %L - check that there is a matching specific "
11199 "subroutine for %<=%> operator", &lhs
->where
);
11203 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
11205 /* F2008, Section 7.2.1.2. */
11206 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
11208 gfc_error ("Coindexed variable must not have an allocatable ultimate "
11209 "component in assignment at %L", &lhs
->where
);
11213 /* Assign the 'data' of a class object to a derived type. */
11214 if (lhs
->ts
.type
== BT_DERIVED
11215 && rhs
->ts
.type
== BT_CLASS
11216 && rhs
->expr_type
!= EXPR_ARRAY
)
11217 gfc_add_data_component (rhs
);
11219 /* Make sure there is a vtable and, in particular, a _copy for the
11221 if (lhs
->ts
.type
== BT_CLASS
&& rhs
->ts
.type
!= BT_CLASS
)
11222 gfc_find_vtab (&rhs
->ts
);
11224 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
11226 || (code
->expr2
->expr_type
== EXPR_FUNCTION
11227 && code
->expr2
->value
.function
.isym
11228 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
11229 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
11230 && !gfc_expr_attr (rhs
).allocatable
11231 && !gfc_has_vector_subscript (rhs
)));
11233 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
11235 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
11236 Additionally, insert this code when the RHS is a CAF as we then use the
11237 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
11238 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
11239 noncoindexed array and the RHS is a coindexed scalar, use the normal code
11241 if (caf_convert_to_send
)
11243 if (code
->expr2
->expr_type
== EXPR_FUNCTION
11244 && code
->expr2
->value
.function
.isym
11245 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11246 remove_caf_get_intrinsic (code
->expr2
);
11247 code
->op
= EXEC_CALL
;
11248 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
11249 code
->resolved_sym
= code
->symtree
->n
.sym
;
11250 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
11251 code
->resolved_sym
->attr
.intrinsic
= 1;
11252 code
->resolved_sym
->attr
.subroutine
= 1;
11253 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
11254 gfc_commit_symbol (code
->resolved_sym
);
11255 code
->ext
.actual
= gfc_get_actual_arglist ();
11256 code
->ext
.actual
->expr
= lhs
;
11257 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
11258 code
->ext
.actual
->next
->expr
= rhs
;
11259 code
->expr1
= NULL
;
11260 code
->expr2
= NULL
;
11267 /* Add a component reference onto an expression. */
11270 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
11275 ref
= &((*ref
)->next
);
11276 *ref
= gfc_get_ref ();
11277 (*ref
)->type
= REF_COMPONENT
;
11278 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
11279 (*ref
)->u
.c
.component
= c
;
11282 /* Add a full array ref, as necessary. */
11285 gfc_add_full_array_ref (e
, c
->as
);
11286 e
->rank
= c
->as
->rank
;
11291 /* Build an assignment. Keep the argument 'op' for future use, so that
11292 pointer assignments can be made. */
11295 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
11296 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
11298 gfc_code
*this_code
;
11300 this_code
= gfc_get_code (op
);
11301 this_code
->next
= NULL
;
11302 this_code
->expr1
= gfc_copy_expr (expr1
);
11303 this_code
->expr2
= gfc_copy_expr (expr2
);
11304 this_code
->loc
= loc
;
11305 if (comp1
&& comp2
)
11307 add_comp_ref (this_code
->expr1
, comp1
);
11308 add_comp_ref (this_code
->expr2
, comp2
);
11315 /* Makes a temporary variable expression based on the characteristics of
11316 a given variable expression. */
11319 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
11321 static int serial
= 0;
11322 char name
[GFC_MAX_SYMBOL_LEN
];
11324 gfc_array_spec
*as
;
11325 gfc_array_ref
*aref
;
11328 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
11329 gfc_get_sym_tree (name
, ns
, &tmp
, false);
11330 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
11332 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
11333 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
11335 e
->value
.character
.length
);
11341 /* Obtain the arrayspec for the temporary. */
11342 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
11343 && e
->expr_type
!= EXPR_FUNCTION
11344 && e
->expr_type
!= EXPR_OP
)
11346 aref
= gfc_find_array_ref (e
);
11347 if (e
->expr_type
== EXPR_VARIABLE
11348 && e
->symtree
->n
.sym
->as
== aref
->as
)
11352 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
11353 if (ref
->type
== REF_COMPONENT
11354 && ref
->u
.c
.component
->as
== aref
->as
)
11362 /* Add the attributes and the arrayspec to the temporary. */
11363 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
11364 tmp
->n
.sym
->attr
.function
= 0;
11365 tmp
->n
.sym
->attr
.proc_pointer
= 0;
11366 tmp
->n
.sym
->attr
.result
= 0;
11367 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
11368 tmp
->n
.sym
->attr
.dummy
= 0;
11369 tmp
->n
.sym
->attr
.use_assoc
= 0;
11370 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
11374 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
11377 if (as
->type
== AS_DEFERRED
)
11378 tmp
->n
.sym
->attr
.allocatable
= 1;
11380 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
11381 || e
->expr_type
== EXPR_FUNCTION
11382 || e
->expr_type
== EXPR_OP
))
11384 tmp
->n
.sym
->as
= gfc_get_array_spec ();
11385 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
11386 tmp
->n
.sym
->as
->rank
= e
->rank
;
11387 tmp
->n
.sym
->attr
.allocatable
= 1;
11388 tmp
->n
.sym
->attr
.dimension
= 1;
11391 tmp
->n
.sym
->attr
.dimension
= 0;
11393 gfc_set_sym_referenced (tmp
->n
.sym
);
11394 gfc_commit_symbol (tmp
->n
.sym
);
11395 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
11397 /* Should the lhs be a section, use its array ref for the
11398 temporary expression. */
11399 if (aref
&& aref
->type
!= AR_FULL
)
11401 gfc_free_ref_list (e
->ref
);
11402 e
->ref
= gfc_copy_ref (ref
);
11408 /* Add one line of code to the code chain, making sure that 'head' and
11409 'tail' are appropriately updated. */
11412 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
11414 gcc_assert (this_code
);
11416 *head
= *tail
= *this_code
;
11418 *tail
= gfc_append_code (*tail
, *this_code
);
11423 /* Counts the potential number of part array references that would
11424 result from resolution of typebound defined assignments. */
11427 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
11430 int c_depth
= 0, t_depth
;
11432 for (c
= derived
->components
; c
; c
= c
->next
)
11434 if ((!gfc_bt_struct (c
->ts
.type
)
11436 || c
->attr
.allocatable
11437 || c
->attr
.proc_pointer_comp
11438 || c
->attr
.class_pointer
11439 || c
->attr
.proc_pointer
)
11440 && !c
->attr
.defined_assign_comp
)
11443 if (c
->as
&& c_depth
== 0)
11446 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
11447 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
11452 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
11454 return depth
+ c_depth
;
11458 /* Implement 7.2.1.3 of the F08 standard:
11459 "An intrinsic assignment where the variable is of derived type is
11460 performed as if each component of the variable were assigned from the
11461 corresponding component of expr using pointer assignment (7.2.2) for
11462 each pointer component, defined assignment for each nonpointer
11463 nonallocatable component of a type that has a type-bound defined
11464 assignment consistent with the component, intrinsic assignment for
11465 each other nonpointer nonallocatable component, ..."
11467 The pointer assignments are taken care of by the intrinsic
11468 assignment of the structure itself. This function recursively adds
11469 defined assignments where required. The recursion is accomplished
11470 by calling gfc_resolve_code.
11472 When the lhs in a defined assignment has intent INOUT, we need a
11473 temporary for the lhs. In pseudo-code:
11475 ! Only call function lhs once.
11476 if (lhs is not a constant or an variable)
11479 ! Do the intrinsic assignment
11481 ! Now do the defined assignments
11482 do over components with typebound defined assignment [%cmp]
11483 #if one component's assignment procedure is INOUT
11485 #if expr2 non-variable
11491 t1%cmp {defined=} expr2%cmp
11497 expr1%cmp {defined=} expr2%cmp
11501 /* The temporary assignments have to be put on top of the additional
11502 code to avoid the result being changed by the intrinsic assignment.
11504 static int component_assignment_level
= 0;
11505 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
11508 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
11510 gfc_component
*comp1
, *comp2
;
11511 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
11513 int error_count
, depth
;
11515 gfc_get_errors (NULL
, &error_count
);
11517 /* Filter out continuing processing after an error. */
11519 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
11520 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
11523 /* TODO: Handle more than one part array reference in assignments. */
11524 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
11525 (*code
)->expr1
->rank
? 1 : 0);
11528 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
11529 "done because multiple part array references would "
11530 "occur in intermediate expressions.", &(*code
)->loc
);
11534 component_assignment_level
++;
11536 /* Create a temporary so that functions get called only once. */
11537 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
11538 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
11540 gfc_expr
*tmp_expr
;
11542 /* Assign the rhs to the temporary. */
11543 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11544 this_code
= build_assignment (EXEC_ASSIGN
,
11545 tmp_expr
, (*code
)->expr2
,
11546 NULL
, NULL
, (*code
)->loc
);
11547 /* Add the code and substitute the rhs expression. */
11548 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
11549 gfc_free_expr ((*code
)->expr2
);
11550 (*code
)->expr2
= tmp_expr
;
11553 /* Do the intrinsic assignment. This is not needed if the lhs is one
11554 of the temporaries generated here, since the intrinsic assignment
11555 to the final result already does this. */
11556 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
11558 this_code
= build_assignment (EXEC_ASSIGN
,
11559 (*code
)->expr1
, (*code
)->expr2
,
11560 NULL
, NULL
, (*code
)->loc
);
11561 add_code_to_chain (&this_code
, &head
, &tail
);
11564 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
11565 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
11568 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
11570 bool inout
= false;
11572 /* The intrinsic assignment does the right thing for pointers
11573 of all kinds and allocatable components. */
11574 if (!gfc_bt_struct (comp1
->ts
.type
)
11575 || comp1
->attr
.pointer
11576 || comp1
->attr
.allocatable
11577 || comp1
->attr
.proc_pointer_comp
11578 || comp1
->attr
.class_pointer
11579 || comp1
->attr
.proc_pointer
)
11582 /* Make an assignment for this component. */
11583 this_code
= build_assignment (EXEC_ASSIGN
,
11584 (*code
)->expr1
, (*code
)->expr2
,
11585 comp1
, comp2
, (*code
)->loc
);
11587 /* Convert the assignment if there is a defined assignment for
11588 this type. Otherwise, using the call from gfc_resolve_code,
11589 recurse into its components. */
11590 gfc_resolve_code (this_code
, ns
);
11592 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11594 gfc_formal_arglist
*dummy_args
;
11596 /* Check that there is a typebound defined assignment. If not,
11597 then this must be a module defined assignment. We cannot
11598 use the defined_assign_comp attribute here because it must
11599 be this derived type that has the defined assignment and not
11601 if (!(comp1
->ts
.u
.derived
->f2k_derived
11602 && comp1
->ts
.u
.derived
->f2k_derived
11603 ->tb_op
[INTRINSIC_ASSIGN
]))
11605 gfc_free_statements (this_code
);
11610 /* If the first argument of the subroutine has intent INOUT
11611 a temporary must be generated and used instead. */
11612 rsym
= this_code
->resolved_sym
;
11613 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11615 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
11617 gfc_code
*temp_code
;
11620 /* Build the temporary required for the assignment and put
11621 it at the head of the generated code. */
11624 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
11625 temp_code
= build_assignment (EXEC_ASSIGN
,
11626 t1
, (*code
)->expr1
,
11627 NULL
, NULL
, (*code
)->loc
);
11629 /* For allocatable LHS, check whether it is allocated. Note
11630 that allocatable components with defined assignment are
11631 not yet support. See PR 57696. */
11632 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11636 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11637 block
= gfc_get_code (EXEC_IF
);
11638 block
->block
= gfc_get_code (EXEC_IF
);
11639 block
->block
->expr1
11640 = gfc_build_intrinsic_call (ns
,
11641 GFC_ISYM_ALLOCATED
, "allocated",
11642 (*code
)->loc
, 1, e
);
11643 block
->block
->next
= temp_code
;
11646 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11649 /* Replace the first actual arg with the component of the
11651 gfc_free_expr (this_code
->ext
.actual
->expr
);
11652 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11653 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11655 /* If the LHS variable is allocatable and wasn't allocated and
11656 the temporary is allocatable, pointer assign the address of
11657 the freshly allocated LHS to the temporary. */
11658 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11659 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11664 cond
= gfc_get_expr ();
11665 cond
->ts
.type
= BT_LOGICAL
;
11666 cond
->ts
.kind
= gfc_default_logical_kind
;
11667 cond
->expr_type
= EXPR_OP
;
11668 cond
->where
= (*code
)->loc
;
11669 cond
->value
.op
.op
= INTRINSIC_NOT
;
11670 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11671 GFC_ISYM_ALLOCATED
, "allocated",
11672 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11673 block
= gfc_get_code (EXEC_IF
);
11674 block
->block
= gfc_get_code (EXEC_IF
);
11675 block
->block
->expr1
= cond
;
11676 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11677 t1
, (*code
)->expr1
,
11678 NULL
, NULL
, (*code
)->loc
);
11679 add_code_to_chain (&block
, &head
, &tail
);
11683 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11685 /* Don't add intrinsic assignments since they are already
11686 effected by the intrinsic assignment of the structure. */
11687 gfc_free_statements (this_code
);
11692 add_code_to_chain (&this_code
, &head
, &tail
);
11696 /* Transfer the value to the final result. */
11697 this_code
= build_assignment (EXEC_ASSIGN
,
11698 (*code
)->expr1
, t1
,
11699 comp1
, comp2
, (*code
)->loc
);
11700 add_code_to_chain (&this_code
, &head
, &tail
);
11704 /* Put the temporary assignments at the top of the generated code. */
11705 if (tmp_head
&& component_assignment_level
== 1)
11707 gfc_append_code (tmp_head
, head
);
11709 tmp_head
= tmp_tail
= NULL
;
11712 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11713 // not accidentally deallocated. Hence, nullify t1.
11714 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11715 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11721 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11722 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11723 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11724 block
= gfc_get_code (EXEC_IF
);
11725 block
->block
= gfc_get_code (EXEC_IF
);
11726 block
->block
->expr1
= cond
;
11727 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11728 t1
, gfc_get_null_expr (&(*code
)->loc
),
11729 NULL
, NULL
, (*code
)->loc
);
11730 gfc_append_code (tail
, block
);
11734 /* Now attach the remaining code chain to the input code. Step on
11735 to the end of the new code since resolution is complete. */
11736 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11737 tail
->next
= (*code
)->next
;
11738 /* Overwrite 'code' because this would place the intrinsic assignment
11739 before the temporary for the lhs is created. */
11740 gfc_free_expr ((*code
)->expr1
);
11741 gfc_free_expr ((*code
)->expr2
);
11747 component_assignment_level
--;
11751 /* F2008: Pointer function assignments are of the form:
11752 ptr_fcn (args) = expr
11753 This function breaks these assignments into two statements:
11754 temporary_pointer => ptr_fcn(args)
11755 temporary_pointer = expr */
11758 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11760 gfc_expr
*tmp_ptr_expr
;
11761 gfc_code
*this_code
;
11762 gfc_component
*comp
;
11765 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11768 /* Even if standard does not support this feature, continue to build
11769 the two statements to avoid upsetting frontend_passes.c. */
11770 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11771 "%L", &(*code
)->loc
);
11773 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11776 s
= comp
->ts
.interface
;
11778 s
= (*code
)->expr1
->symtree
->n
.sym
;
11780 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11782 gfc_error ("The function result on the lhs of the assignment at "
11783 "%L must have the pointer attribute.",
11784 &(*code
)->expr1
->where
);
11785 (*code
)->op
= EXEC_NOP
;
11789 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11791 /* get_temp_from_expression is set up for ordinary assignments. To that
11792 end, where array bounds are not known, arrays are made allocatable.
11793 Change the temporary to a pointer here. */
11794 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11795 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11796 tmp_ptr_expr
->where
= (*code
)->loc
;
11798 this_code
= build_assignment (EXEC_ASSIGN
,
11799 tmp_ptr_expr
, (*code
)->expr2
,
11800 NULL
, NULL
, (*code
)->loc
);
11801 this_code
->next
= (*code
)->next
;
11802 (*code
)->next
= this_code
;
11803 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11804 (*code
)->expr2
= (*code
)->expr1
;
11805 (*code
)->expr1
= tmp_ptr_expr
;
11811 /* Deferred character length assignments from an operator expression
11812 require a temporary because the character length of the lhs can
11813 change in the course of the assignment. */
11816 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11818 gfc_expr
*tmp_expr
;
11819 gfc_code
*this_code
;
11821 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11822 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11823 && (*code
)->expr2
->ts
.type
== BT_CHARACTER
11824 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11827 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11830 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
11833 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11834 tmp_expr
->where
= (*code
)->loc
;
11836 /* A new charlen is required to ensure that the variable string
11837 length is different to that of the original lhs. */
11838 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11839 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11840 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11841 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11843 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11845 this_code
= build_assignment (EXEC_ASSIGN
,
11847 gfc_copy_expr (tmp_expr
),
11848 NULL
, NULL
, (*code
)->loc
);
11850 (*code
)->expr1
= tmp_expr
;
11852 this_code
->next
= (*code
)->next
;
11853 (*code
)->next
= this_code
;
11860 check_team (gfc_expr
*team
, const char *intrinsic
)
11862 if (team
->rank
!= 0
11863 || team
->ts
.type
!= BT_DERIVED
11864 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
11865 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
11867 gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
11868 "of type TEAM_TYPE", intrinsic
, &team
->where
);
11876 /* Given a block of code, recursively resolve everything pointed to by this
11880 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11882 int omp_workshare_save
;
11883 int forall_save
, do_concurrent_save
;
11887 frame
.prev
= cs_base
;
11891 find_reachable_labels (code
);
11893 for (; code
; code
= code
->next
)
11895 frame
.current
= code
;
11896 forall_save
= forall_flag
;
11897 do_concurrent_save
= gfc_do_concurrent_flag
;
11899 if (code
->op
== EXEC_FORALL
)
11902 gfc_resolve_forall (code
, ns
, forall_save
);
11905 else if (code
->block
)
11907 omp_workshare_save
= -1;
11910 case EXEC_OACC_PARALLEL_LOOP
:
11911 case EXEC_OACC_PARALLEL
:
11912 case EXEC_OACC_KERNELS_LOOP
:
11913 case EXEC_OACC_KERNELS
:
11914 case EXEC_OACC_SERIAL_LOOP
:
11915 case EXEC_OACC_SERIAL
:
11916 case EXEC_OACC_DATA
:
11917 case EXEC_OACC_HOST_DATA
:
11918 case EXEC_OACC_LOOP
:
11919 gfc_resolve_oacc_blocks (code
, ns
);
11921 case EXEC_OMP_PARALLEL_WORKSHARE
:
11922 omp_workshare_save
= omp_workshare_flag
;
11923 omp_workshare_flag
= 1;
11924 gfc_resolve_omp_parallel_blocks (code
, ns
);
11926 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11927 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11928 case EXEC_OMP_MASKED_TASKLOOP
:
11929 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
11930 case EXEC_OMP_MASTER_TASKLOOP
:
11931 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
11932 case EXEC_OMP_PARALLEL
:
11933 case EXEC_OMP_PARALLEL_DO
:
11934 case EXEC_OMP_PARALLEL_DO_SIMD
:
11935 case EXEC_OMP_PARALLEL_LOOP
:
11936 case EXEC_OMP_PARALLEL_MASKED
:
11937 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
11938 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
11939 case EXEC_OMP_PARALLEL_MASTER
:
11940 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
11941 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
11942 case EXEC_OMP_PARALLEL_SECTIONS
:
11943 case EXEC_OMP_TARGET_PARALLEL
:
11944 case EXEC_OMP_TARGET_PARALLEL_DO
:
11945 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11946 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
11947 case EXEC_OMP_TARGET_TEAMS
:
11948 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11949 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11950 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11951 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11952 case EXEC_OMP_TARGET_TEAMS_LOOP
:
11953 case EXEC_OMP_TASK
:
11954 case EXEC_OMP_TASKLOOP
:
11955 case EXEC_OMP_TASKLOOP_SIMD
:
11956 case EXEC_OMP_TEAMS
:
11957 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11958 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11959 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11960 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11961 case EXEC_OMP_TEAMS_LOOP
:
11962 omp_workshare_save
= omp_workshare_flag
;
11963 omp_workshare_flag
= 0;
11964 gfc_resolve_omp_parallel_blocks (code
, ns
);
11966 case EXEC_OMP_DISTRIBUTE
:
11967 case EXEC_OMP_DISTRIBUTE_SIMD
:
11969 case EXEC_OMP_DO_SIMD
:
11970 case EXEC_OMP_LOOP
:
11971 case EXEC_OMP_SIMD
:
11972 case EXEC_OMP_TARGET_SIMD
:
11973 gfc_resolve_omp_do_blocks (code
, ns
);
11975 case EXEC_SELECT_TYPE
:
11976 case EXEC_SELECT_RANK
:
11977 /* Blocks are handled in resolve_select_type/rank because we
11978 have to transform the SELECT TYPE into ASSOCIATE first. */
11980 case EXEC_DO_CONCURRENT
:
11981 gfc_do_concurrent_flag
= 1;
11982 gfc_resolve_blocks (code
->block
, ns
);
11983 gfc_do_concurrent_flag
= 2;
11985 case EXEC_OMP_WORKSHARE
:
11986 omp_workshare_save
= omp_workshare_flag
;
11987 omp_workshare_flag
= 1;
11990 gfc_resolve_blocks (code
->block
, ns
);
11994 if (omp_workshare_save
!= -1)
11995 omp_workshare_flag
= omp_workshare_save
;
11999 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
12000 t
= gfc_resolve_expr (code
->expr1
);
12001 forall_flag
= forall_save
;
12002 gfc_do_concurrent_flag
= do_concurrent_save
;
12004 if (!gfc_resolve_expr (code
->expr2
))
12007 if (code
->op
== EXEC_ALLOCATE
12008 && !gfc_resolve_expr (code
->expr3
))
12014 case EXEC_END_BLOCK
:
12015 case EXEC_END_NESTED_BLOCK
:
12021 case EXEC_ERROR_STOP
:
12022 if (code
->expr2
!= NULL
12023 && (code
->expr2
->ts
.type
!= BT_LOGICAL
12024 || code
->expr2
->rank
!= 0))
12025 gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
12026 &code
->expr2
->where
);
12030 case EXEC_CONTINUE
:
12032 case EXEC_ASSIGN_CALL
:
12035 case EXEC_CRITICAL
:
12036 resolve_critical (code
);
12039 case EXEC_SYNC_ALL
:
12040 case EXEC_SYNC_IMAGES
:
12041 case EXEC_SYNC_MEMORY
:
12042 resolve_sync (code
);
12047 case EXEC_EVENT_POST
:
12048 case EXEC_EVENT_WAIT
:
12049 resolve_lock_unlock_event (code
);
12052 case EXEC_FAIL_IMAGE
:
12055 case EXEC_FORM_TEAM
:
12056 if (code
->expr1
!= NULL
12057 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
12058 gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
12059 "a scalar INTEGER", &code
->expr1
->where
);
12060 check_team (code
->expr2
, "FORM TEAM");
12063 case EXEC_CHANGE_TEAM
:
12064 check_team (code
->expr1
, "CHANGE TEAM");
12067 case EXEC_END_TEAM
:
12070 case EXEC_SYNC_TEAM
:
12071 check_team (code
->expr1
, "SYNC TEAM");
12075 /* Keep track of which entry we are up to. */
12076 current_entry_id
= code
->ext
.entry
->id
;
12080 resolve_where (code
, NULL
);
12084 if (code
->expr1
!= NULL
)
12086 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
12087 || code
->expr1
->ts
.type
!= BT_INTEGER
12088 || (code
->expr1
->ref
12089 && code
->expr1
->ref
->type
== REF_ARRAY
)
12090 || code
->expr1
->symtree
== NULL
12091 || (code
->expr1
->symtree
->n
.sym
12092 && (code
->expr1
->symtree
->n
.sym
->attr
.flavor
12094 gfc_error ("ASSIGNED GOTO statement at %L requires a "
12095 "scalar INTEGER variable", &code
->expr1
->where
);
12096 else if (code
->expr1
->symtree
->n
.sym
12097 && code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
12098 gfc_error ("Variable %qs has not been assigned a target "
12099 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
12100 &code
->expr1
->where
);
12103 resolve_branch (code
->label1
, code
);
12107 if (code
->expr1
!= NULL
12108 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
12109 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
12110 "INTEGER return specifier", &code
->expr1
->where
);
12113 case EXEC_INIT_ASSIGN
:
12114 case EXEC_END_PROCEDURE
:
12121 if (code
->expr1
->ts
.type
== BT_CLASS
)
12122 gfc_find_vtab (&code
->expr2
->ts
);
12124 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
12126 if (code
->expr1
->expr_type
== EXPR_FUNCTION
12127 && code
->expr1
->value
.function
.isym
12128 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
12129 remove_caf_get_intrinsic (code
->expr1
);
12131 /* If this is a pointer function in an lvalue variable context,
12132 the new code will have to be resolved afresh. This is also the
12133 case with an error, where the code is transformed into NOP to
12134 prevent ICEs downstream. */
12135 if (resolve_ptr_fcn_assign (&code
, ns
)
12136 || code
->op
== EXEC_NOP
)
12139 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
12143 if (resolve_ordinary_assign (code
, ns
))
12145 if (omp_workshare_flag
)
12147 gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
12148 "at %L", &code
->loc
);
12151 if (code
->op
== EXEC_COMPCALL
)
12157 /* Check for dependencies in deferred character length array
12158 assignments and generate a temporary, if necessary. */
12159 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
12162 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
12163 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
12164 && code
->expr1
->ts
.u
.derived
12165 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
12166 generate_component_assignments (&code
, ns
);
12170 case EXEC_LABEL_ASSIGN
:
12171 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
12172 gfc_error ("Label %d referenced at %L is never defined",
12173 code
->label1
->value
, &code
->label1
->where
);
12175 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
12176 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
12177 || code
->expr1
->symtree
->n
.sym
->ts
.kind
12178 != gfc_default_integer_kind
12179 || code
->expr1
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
12180 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
12181 gfc_error ("ASSIGN statement at %L requires a scalar "
12182 "default INTEGER variable", &code
->expr1
->where
);
12185 case EXEC_POINTER_ASSIGN
:
12192 /* This is both a variable definition and pointer assignment
12193 context, so check both of them. For rank remapping, a final
12194 array ref may be present on the LHS and fool gfc_expr_attr
12195 used in gfc_check_vardef_context. Remove it. */
12196 e
= remove_last_array_ref (code
->expr1
);
12197 t
= gfc_check_vardef_context (e
, true, false, false,
12198 _("pointer assignment"));
12200 t
= gfc_check_vardef_context (e
, false, false, false,
12201 _("pointer assignment"));
12204 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
12209 /* Assigning a class object always is a regular assign. */
12210 if (code
->expr2
->ts
.type
== BT_CLASS
12211 && code
->expr1
->ts
.type
== BT_CLASS
12212 && CLASS_DATA (code
->expr2
)
12213 && !CLASS_DATA (code
->expr2
)->attr
.dimension
12214 && !(gfc_expr_attr (code
->expr1
).proc_pointer
12215 && code
->expr2
->expr_type
== EXPR_VARIABLE
12216 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
12218 code
->op
= EXEC_ASSIGN
;
12222 case EXEC_ARITHMETIC_IF
:
12224 gfc_expr
*e
= code
->expr1
;
12226 gfc_resolve_expr (e
);
12227 if (e
->expr_type
== EXPR_NULL
)
12228 gfc_error ("Invalid NULL at %L", &e
->where
);
12230 if (t
&& (e
->rank
> 0
12231 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
12232 gfc_error ("Arithmetic IF statement at %L requires a scalar "
12233 "REAL or INTEGER expression", &e
->where
);
12235 resolve_branch (code
->label1
, code
);
12236 resolve_branch (code
->label2
, code
);
12237 resolve_branch (code
->label3
, code
);
12242 if (t
&& code
->expr1
!= NULL
12243 && (code
->expr1
->ts
.type
!= BT_LOGICAL
12244 || code
->expr1
->rank
!= 0))
12245 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12246 &code
->expr1
->where
);
12251 resolve_call (code
);
12254 case EXEC_COMPCALL
:
12256 resolve_typebound_subroutine (code
);
12259 case EXEC_CALL_PPC
:
12260 resolve_ppc_call (code
);
12264 /* Select is complicated. Also, a SELECT construct could be
12265 a transformed computed GOTO. */
12266 resolve_select (code
, false);
12269 case EXEC_SELECT_TYPE
:
12270 resolve_select_type (code
, ns
);
12273 case EXEC_SELECT_RANK
:
12274 resolve_select_rank (code
, ns
);
12278 resolve_block_construct (code
);
12282 if (code
->ext
.iterator
!= NULL
)
12284 gfc_iterator
*iter
= code
->ext
.iterator
;
12285 if (gfc_resolve_iterator (iter
, true, false))
12286 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
12291 case EXEC_DO_WHILE
:
12292 if (code
->expr1
== NULL
)
12293 gfc_internal_error ("gfc_resolve_code(): No expression on "
12296 && (code
->expr1
->rank
!= 0
12297 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
12298 gfc_error ("Exit condition of DO WHILE loop at %L must be "
12299 "a scalar LOGICAL expression", &code
->expr1
->where
);
12302 case EXEC_ALLOCATE
:
12304 resolve_allocate_deallocate (code
, "ALLOCATE");
12308 case EXEC_DEALLOCATE
:
12310 resolve_allocate_deallocate (code
, "DEALLOCATE");
12315 if (!gfc_resolve_open (code
->ext
.open
, &code
->loc
))
12318 resolve_branch (code
->ext
.open
->err
, code
);
12322 if (!gfc_resolve_close (code
->ext
.close
, &code
->loc
))
12325 resolve_branch (code
->ext
.close
->err
, code
);
12328 case EXEC_BACKSPACE
:
12332 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
12335 resolve_branch (code
->ext
.filepos
->err
, code
);
12339 if (!gfc_resolve_inquire (code
->ext
.inquire
))
12342 resolve_branch (code
->ext
.inquire
->err
, code
);
12345 case EXEC_IOLENGTH
:
12346 gcc_assert (code
->ext
.inquire
!= NULL
);
12347 if (!gfc_resolve_inquire (code
->ext
.inquire
))
12350 resolve_branch (code
->ext
.inquire
->err
, code
);
12354 if (!gfc_resolve_wait (code
->ext
.wait
))
12357 resolve_branch (code
->ext
.wait
->err
, code
);
12358 resolve_branch (code
->ext
.wait
->end
, code
);
12359 resolve_branch (code
->ext
.wait
->eor
, code
);
12364 if (!gfc_resolve_dt (code
, code
->ext
.dt
, &code
->loc
))
12367 resolve_branch (code
->ext
.dt
->err
, code
);
12368 resolve_branch (code
->ext
.dt
->end
, code
);
12369 resolve_branch (code
->ext
.dt
->eor
, code
);
12372 case EXEC_TRANSFER
:
12373 resolve_transfer (code
);
12376 case EXEC_DO_CONCURRENT
:
12378 resolve_forall_iterators (code
->ext
.forall_iterator
);
12380 if (code
->expr1
!= NULL
12381 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
12382 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
12383 "expression", &code
->expr1
->where
);
12386 case EXEC_OACC_PARALLEL_LOOP
:
12387 case EXEC_OACC_PARALLEL
:
12388 case EXEC_OACC_KERNELS_LOOP
:
12389 case EXEC_OACC_KERNELS
:
12390 case EXEC_OACC_SERIAL_LOOP
:
12391 case EXEC_OACC_SERIAL
:
12392 case EXEC_OACC_DATA
:
12393 case EXEC_OACC_HOST_DATA
:
12394 case EXEC_OACC_LOOP
:
12395 case EXEC_OACC_UPDATE
:
12396 case EXEC_OACC_WAIT
:
12397 case EXEC_OACC_CACHE
:
12398 case EXEC_OACC_ENTER_DATA
:
12399 case EXEC_OACC_EXIT_DATA
:
12400 case EXEC_OACC_ATOMIC
:
12401 case EXEC_OACC_DECLARE
:
12402 gfc_resolve_oacc_directive (code
, ns
);
12405 case EXEC_OMP_ASSUME
:
12406 case EXEC_OMP_ATOMIC
:
12407 case EXEC_OMP_BARRIER
:
12408 case EXEC_OMP_CANCEL
:
12409 case EXEC_OMP_CANCELLATION_POINT
:
12410 case EXEC_OMP_CRITICAL
:
12411 case EXEC_OMP_FLUSH
:
12412 case EXEC_OMP_DEPOBJ
:
12413 case EXEC_OMP_DISTRIBUTE
:
12414 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
12415 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
12416 case EXEC_OMP_DISTRIBUTE_SIMD
:
12418 case EXEC_OMP_DO_SIMD
:
12419 case EXEC_OMP_ERROR
:
12420 case EXEC_OMP_LOOP
:
12421 case EXEC_OMP_MASTER
:
12422 case EXEC_OMP_MASTER_TASKLOOP
:
12423 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
12424 case EXEC_OMP_MASKED
:
12425 case EXEC_OMP_MASKED_TASKLOOP
:
12426 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
12427 case EXEC_OMP_ORDERED
:
12428 case EXEC_OMP_SCAN
:
12429 case EXEC_OMP_SCOPE
:
12430 case EXEC_OMP_SECTIONS
:
12431 case EXEC_OMP_SIMD
:
12432 case EXEC_OMP_SINGLE
:
12433 case EXEC_OMP_TARGET
:
12434 case EXEC_OMP_TARGET_DATA
:
12435 case EXEC_OMP_TARGET_ENTER_DATA
:
12436 case EXEC_OMP_TARGET_EXIT_DATA
:
12437 case EXEC_OMP_TARGET_PARALLEL
:
12438 case EXEC_OMP_TARGET_PARALLEL_DO
:
12439 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
12440 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
12441 case EXEC_OMP_TARGET_SIMD
:
12442 case EXEC_OMP_TARGET_TEAMS
:
12443 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
12444 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12445 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12446 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
12447 case EXEC_OMP_TARGET_TEAMS_LOOP
:
12448 case EXEC_OMP_TARGET_UPDATE
:
12449 case EXEC_OMP_TASK
:
12450 case EXEC_OMP_TASKGROUP
:
12451 case EXEC_OMP_TASKLOOP
:
12452 case EXEC_OMP_TASKLOOP_SIMD
:
12453 case EXEC_OMP_TASKWAIT
:
12454 case EXEC_OMP_TASKYIELD
:
12455 case EXEC_OMP_TEAMS
:
12456 case EXEC_OMP_TEAMS_DISTRIBUTE
:
12457 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12458 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12459 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
12460 case EXEC_OMP_TEAMS_LOOP
:
12461 case EXEC_OMP_WORKSHARE
:
12462 gfc_resolve_omp_directive (code
, ns
);
12465 case EXEC_OMP_PARALLEL
:
12466 case EXEC_OMP_PARALLEL_DO
:
12467 case EXEC_OMP_PARALLEL_DO_SIMD
:
12468 case EXEC_OMP_PARALLEL_LOOP
:
12469 case EXEC_OMP_PARALLEL_MASKED
:
12470 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
12471 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
12472 case EXEC_OMP_PARALLEL_MASTER
:
12473 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
12474 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
12475 case EXEC_OMP_PARALLEL_SECTIONS
:
12476 case EXEC_OMP_PARALLEL_WORKSHARE
:
12477 omp_workshare_save
= omp_workshare_flag
;
12478 omp_workshare_flag
= 0;
12479 gfc_resolve_omp_directive (code
, ns
);
12480 omp_workshare_flag
= omp_workshare_save
;
12484 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
12488 cs_base
= frame
.prev
;
12492 /* Resolve initial values and make sure they are compatible with
12496 resolve_values (gfc_symbol
*sym
)
12500 if (sym
->value
== NULL
)
12503 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
) && sym
->attr
.referenced
)
12504 gfc_warning (OPT_Wdeprecated_declarations
,
12505 "Using parameter %qs declared at %L is deprecated",
12506 sym
->name
, &sym
->declared_at
);
12508 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
12509 t
= resolve_structure_cons (sym
->value
, 1);
12511 t
= gfc_resolve_expr (sym
->value
);
12516 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
12520 /* Verify any BIND(C) derived types in the namespace so we can report errors
12521 for them once, rather than for each variable declared of that type. */
12524 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
12526 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
12527 && derived_sym
->attr
.is_bind_c
== 1)
12528 verify_bind_c_derived_type (derived_sym
);
12534 /* Check the interfaces of DTIO procedures associated with derived
12535 type 'sym'. These procedures can either have typebound bindings or
12536 can appear in DTIO generic interfaces. */
12539 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
12541 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
12544 gfc_check_dtio_interfaces (sym
);
12549 /* Verify that any binding labels used in a given namespace do not collide
12550 with the names or binding labels of any global symbols. Multiple INTERFACE
12551 for the same procedure are permitted. */
12554 gfc_verify_binding_labels (gfc_symbol
*sym
)
12557 const char *module
;
12559 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
12560 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
12563 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
12566 module
= sym
->module
;
12567 else if (sym
->ns
&& sym
->ns
->proc_name
12568 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
12569 module
= sym
->ns
->proc_name
->name
;
12570 else if (sym
->ns
&& sym
->ns
->parent
12571 && sym
->ns
&& sym
->ns
->parent
->proc_name
12572 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12573 module
= sym
->ns
->parent
->proc_name
->name
;
12579 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
12582 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
12583 gsym
->where
= sym
->declared_at
;
12584 gsym
->sym_name
= sym
->name
;
12585 gsym
->binding_label
= sym
->binding_label
;
12586 gsym
->ns
= sym
->ns
;
12587 gsym
->mod_name
= module
;
12588 if (sym
->attr
.function
)
12589 gsym
->type
= GSYM_FUNCTION
;
12590 else if (sym
->attr
.subroutine
)
12591 gsym
->type
= GSYM_SUBROUTINE
;
12592 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
12593 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
12597 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
12599 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
12600 "identifier as entity at %L", sym
->name
,
12601 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12602 /* Clear the binding label to prevent checking multiple times. */
12603 sym
->binding_label
= NULL
;
12607 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
12608 && (strcmp (module
, gsym
->mod_name
) != 0
12609 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
12611 /* This can only happen if the variable is defined in a module - if it
12612 isn't the same module, reject it. */
12613 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
12614 "uses the same global identifier as entity at %L from module %qs",
12615 sym
->name
, module
, sym
->binding_label
,
12616 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
12617 sym
->binding_label
= NULL
;
12621 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
12622 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
12623 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
12624 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
12625 && (module
!= gsym
->mod_name
12626 || strcmp (gsym
->sym_name
, sym
->name
) != 0
12627 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
12629 /* Print an error if the procedure is defined multiple times; we have to
12630 exclude references to the same procedure via module association or
12631 multiple checks for the same procedure. */
12632 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
12633 "global identifier as entity at %L", sym
->name
,
12634 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12635 sym
->binding_label
= NULL
;
12640 /* Resolve an index expression. */
12643 resolve_index_expr (gfc_expr
*e
)
12645 if (!gfc_resolve_expr (e
))
12648 if (!gfc_simplify_expr (e
, 0))
12651 if (!gfc_specification_expr (e
))
12658 /* Resolve a charlen structure. */
12661 resolve_charlen (gfc_charlen
*cl
)
12664 bool saved_specification_expr
;
12670 saved_specification_expr
= specification_expr
;
12671 specification_expr
= true;
12673 if (cl
->length_from_typespec
)
12675 if (!gfc_resolve_expr (cl
->length
))
12677 specification_expr
= saved_specification_expr
;
12681 if (!gfc_simplify_expr (cl
->length
, 0))
12683 specification_expr
= saved_specification_expr
;
12687 /* cl->length has been resolved. It should have an integer type. */
12689 && (cl
->length
->ts
.type
!= BT_INTEGER
|| cl
->length
->rank
!= 0))
12691 gfc_error ("Scalar INTEGER expression expected at %L",
12692 &cl
->length
->where
);
12698 if (!resolve_index_expr (cl
->length
))
12700 specification_expr
= saved_specification_expr
;
12705 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12706 a negative value, the length of character entities declared is zero. */
12707 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12708 && mpz_sgn (cl
->length
->value
.integer
) < 0)
12709 gfc_replace_expr (cl
->length
,
12710 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
12712 /* Check that the character length is not too large. */
12713 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
12714 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12715 && cl
->length
->ts
.type
== BT_INTEGER
12716 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
12718 gfc_error ("String length at %L is too large", &cl
->length
->where
);
12719 specification_expr
= saved_specification_expr
;
12723 specification_expr
= saved_specification_expr
;
12728 /* Test for non-constant shape arrays. */
12731 is_non_constant_shape_array (gfc_symbol
*sym
)
12737 not_constant
= false;
12738 if (sym
->as
!= NULL
)
12740 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12741 has not been simplified; parameter array references. Do the
12742 simplification now. */
12743 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12745 if (i
== GFC_MAX_DIMENSIONS
)
12748 e
= sym
->as
->lower
[i
];
12749 if (e
&& (!resolve_index_expr(e
)
12750 || !gfc_is_constant_expr (e
)))
12751 not_constant
= true;
12752 e
= sym
->as
->upper
[i
];
12753 if (e
&& (!resolve_index_expr(e
)
12754 || !gfc_is_constant_expr (e
)))
12755 not_constant
= true;
12758 return not_constant
;
12761 /* Given a symbol and an initialization expression, add code to initialize
12762 the symbol to the function entry. */
12764 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12768 gfc_namespace
*ns
= sym
->ns
;
12770 /* Search for the function namespace if this is a contained
12771 function without an explicit result. */
12772 if (sym
->attr
.function
&& sym
== sym
->result
12773 && sym
->name
!= sym
->ns
->proc_name
->name
)
12775 ns
= ns
->contained
;
12776 for (;ns
; ns
= ns
->sibling
)
12777 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12783 gfc_free_expr (init
);
12787 /* Build an l-value expression for the result. */
12788 lval
= gfc_lval_expr_from_sym (sym
);
12790 /* Add the code at scope entry. */
12791 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
12792 init_st
->next
= ns
->code
;
12793 ns
->code
= init_st
;
12795 /* Assign the default initializer to the l-value. */
12796 init_st
->loc
= sym
->declared_at
;
12797 init_st
->expr1
= lval
;
12798 init_st
->expr2
= init
;
12802 /* Whether or not we can generate a default initializer for a symbol. */
12805 can_generate_init (gfc_symbol
*sym
)
12807 symbol_attribute
*a
;
12812 /* These symbols should never have a default initialization. */
12817 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
12818 && (CLASS_DATA (sym
)->attr
.class_pointer
12819 || CLASS_DATA (sym
)->attr
.proc_pointer
))
12820 || a
->in_equivalence
12827 || (!a
->referenced
&& !a
->result
)
12828 || (a
->dummy
&& (a
->intent
!= INTENT_OUT
12829 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
))
12830 || (a
->function
&& sym
!= sym
->result
)
12835 /* Assign the default initializer to a derived type variable or result. */
12838 apply_default_init (gfc_symbol
*sym
)
12840 gfc_expr
*init
= NULL
;
12842 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12845 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12846 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12848 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12851 build_init_assign (sym
, init
);
12852 sym
->attr
.referenced
= 1;
12856 /* Build an initializer for a local. Returns null if the symbol should not have
12857 a default initialization. */
12860 build_default_init_expr (gfc_symbol
*sym
)
12862 /* These symbols should never have a default initialization. */
12863 if (sym
->attr
.allocatable
12864 || sym
->attr
.external
12866 || sym
->attr
.pointer
12867 || sym
->attr
.in_equivalence
12868 || sym
->attr
.in_common
12871 || sym
->attr
.cray_pointee
12872 || sym
->attr
.cray_pointer
12876 /* Get the appropriate init expression. */
12877 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12880 /* Add an initialization expression to a local variable. */
12882 apply_default_init_local (gfc_symbol
*sym
)
12884 gfc_expr
*init
= NULL
;
12886 /* The symbol should be a variable or a function return value. */
12887 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12888 || (sym
->attr
.function
&& sym
->result
!= sym
))
12891 /* Try to build the initializer expression. If we can't initialize
12892 this symbol, then init will be NULL. */
12893 init
= build_default_init_expr (sym
);
12897 /* For saved variables, we don't want to add an initializer at function
12898 entry, so we just add a static initializer. Note that automatic variables
12899 are stack allocated even with -fno-automatic; we have also to exclude
12900 result variable, which are also nonstatic. */
12901 if (!sym
->attr
.automatic
12902 && (sym
->attr
.save
|| sym
->ns
->save_all
12903 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12904 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12905 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12907 /* Don't clobber an existing initializer! */
12908 gcc_assert (sym
->value
== NULL
);
12913 build_init_assign (sym
, init
);
12917 /* Resolution of common features of flavors variable and procedure. */
12920 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12922 gfc_array_spec
*as
;
12924 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12925 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
))
12926 as
= CLASS_DATA (sym
)->as
;
12930 /* Constraints on deferred shape variable. */
12931 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12933 bool pointer
, allocatable
, dimension
;
12935 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12936 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
))
12938 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12939 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12940 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12944 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12945 allocatable
= sym
->attr
.allocatable
;
12946 dimension
= sym
->attr
.dimension
;
12951 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12953 gfc_error ("Allocatable array %qs at %L must have a deferred "
12954 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12957 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12958 "%qs at %L may not be ALLOCATABLE",
12959 sym
->name
, &sym
->declared_at
))
12963 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12965 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12966 "assumed rank", sym
->name
, &sym
->declared_at
);
12973 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12974 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12976 gfc_error ("Array %qs at %L cannot have a deferred shape",
12977 sym
->name
, &sym
->declared_at
);
12982 /* Constraints on polymorphic variables. */
12983 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12986 if (sym
->attr
.class_ok
12987 && sym
->ts
.u
.derived
12988 && !sym
->attr
.select_type_temporary
12989 && !UNLIMITED_POLY (sym
)
12990 && CLASS_DATA (sym
)->ts
.u
.derived
12991 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12993 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12994 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12995 &sym
->declared_at
);
13000 /* Assume that use associated symbols were checked in the module ns.
13001 Class-variables that are associate-names are also something special
13002 and excepted from the test. */
13003 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
13005 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
13006 "or pointer", sym
->name
, &sym
->declared_at
);
13015 /* Additional checks for symbols with flavor variable and derived
13016 type. To be called from resolve_fl_variable. */
13019 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
13021 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
13023 /* Check to see if a derived type is blocked from being host
13024 associated by the presence of another class I symbol in the same
13025 namespace. 14.6.1.3 of the standard and the discussion on
13026 comp.lang.fortran. */
13027 if (sym
->ts
.u
.derived
13028 && sym
->ns
!= sym
->ts
.u
.derived
->ns
13029 && !sym
->ts
.u
.derived
->attr
.use_assoc
13030 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
13033 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
13034 if (s
&& s
->attr
.generic
)
13035 s
= gfc_find_dt_in_generic (s
);
13036 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
13038 gfc_error ("The type %qs cannot be host associated at %L "
13039 "because it is blocked by an incompatible object "
13040 "of the same name declared at %L",
13041 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
13047 /* 4th constraint in section 11.3: "If an object of a type for which
13048 component-initialization is specified (R429) appears in the
13049 specification-part of a module and does not have the ALLOCATABLE
13050 or POINTER attribute, the object shall have the SAVE attribute."
13052 The check for initializers is performed with
13053 gfc_has_default_initializer because gfc_default_initializer generates
13054 a hidden default for allocatable components. */
13055 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
13056 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13057 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
13058 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
13059 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
13060 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
13061 "%qs at %L, needed due to the default "
13062 "initialization", sym
->name
, &sym
->declared_at
))
13065 /* Assign default initializer. */
13066 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
13068 || (sym
->attr
.intent
== INTENT_OUT
13069 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)))
13070 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
13076 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
13077 except in the declaration of an entity or component that has the POINTER
13078 or ALLOCATABLE attribute. */
13081 deferred_requirements (gfc_symbol
*sym
)
13083 if (sym
->ts
.deferred
13084 && !(sym
->attr
.pointer
13085 || sym
->attr
.allocatable
13086 || sym
->attr
.associate_var
13087 || sym
->attr
.omp_udr_artificial_var
))
13089 /* If a function has a result variable, only check the variable. */
13090 if (sym
->result
&& sym
->name
!= sym
->result
->name
)
13093 gfc_error ("Entity %qs at %L has a deferred type parameter and "
13094 "requires either the POINTER or ALLOCATABLE attribute",
13095 sym
->name
, &sym
->declared_at
);
13102 /* Resolve symbols with flavor variable. */
13105 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
13107 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
13110 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
13113 /* Set this flag to check that variables are parameters of all entries.
13114 This check is effected by the call to gfc_resolve_expr through
13115 is_non_constant_shape_array. */
13116 bool saved_specification_expr
= specification_expr
;
13117 specification_expr
= true;
13119 if (sym
->ns
->proc_name
13120 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13121 || sym
->ns
->proc_name
->attr
.is_main_program
)
13122 && !sym
->attr
.use_assoc
13123 && !sym
->attr
.allocatable
13124 && !sym
->attr
.pointer
13125 && is_non_constant_shape_array (sym
))
13127 /* F08:C541. The shape of an array defined in a main program or module
13128 * needs to be constant. */
13129 gfc_error ("The module or main program array %qs at %L must "
13130 "have constant shape", sym
->name
, &sym
->declared_at
);
13131 specification_expr
= saved_specification_expr
;
13135 /* Constraints on deferred type parameter. */
13136 if (!deferred_requirements (sym
))
13139 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
13141 /* Make sure that character string variables with assumed length are
13142 dummy arguments. */
13143 gfc_expr
*e
= NULL
;
13146 e
= sym
->ts
.u
.cl
->length
;
13150 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
13151 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
13152 && !sym
->attr
.omp_udr_artificial_var
)
13154 gfc_error ("Entity with assumed character length at %L must be a "
13155 "dummy argument or a PARAMETER", &sym
->declared_at
);
13156 specification_expr
= saved_specification_expr
;
13160 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
13162 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
13163 specification_expr
= saved_specification_expr
;
13167 if (!gfc_is_constant_expr (e
)
13168 && !(e
->expr_type
== EXPR_VARIABLE
13169 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
13171 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
13172 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13173 || sym
->ns
->proc_name
->attr
.is_main_program
))
13175 gfc_error ("%qs at %L must have constant character length "
13176 "in this context", sym
->name
, &sym
->declared_at
);
13177 specification_expr
= saved_specification_expr
;
13180 if (sym
->attr
.in_common
)
13182 gfc_error ("COMMON variable %qs at %L must have constant "
13183 "character length", sym
->name
, &sym
->declared_at
);
13184 specification_expr
= saved_specification_expr
;
13190 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
13191 apply_default_init_local (sym
); /* Try to apply a default initialization. */
13193 /* Determine if the symbol may not have an initializer. */
13194 int no_init_flag
= 0, automatic_flag
= 0;
13195 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
13196 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
13198 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
13199 && is_non_constant_shape_array (sym
))
13201 no_init_flag
= automatic_flag
= 1;
13203 /* Also, they must not have the SAVE attribute.
13204 SAVE_IMPLICIT is checked below. */
13205 if (sym
->as
&& sym
->attr
.codimension
)
13207 int corank
= sym
->as
->corank
;
13208 sym
->as
->corank
= 0;
13209 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
13210 sym
->as
->corank
= corank
;
13212 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
13214 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
13215 specification_expr
= saved_specification_expr
;
13220 /* Ensure that any initializer is simplified. */
13222 gfc_simplify_expr (sym
->value
, 1);
13224 /* Reject illegal initializers. */
13225 if (!sym
->mark
&& sym
->value
)
13227 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
13228 && CLASS_DATA (sym
)->attr
.allocatable
))
13229 gfc_error ("Allocatable %qs at %L cannot have an initializer",
13230 sym
->name
, &sym
->declared_at
);
13231 else if (sym
->attr
.external
)
13232 gfc_error ("External %qs at %L cannot have an initializer",
13233 sym
->name
, &sym
->declared_at
);
13234 else if (sym
->attr
.dummy
)
13235 gfc_error ("Dummy %qs at %L cannot have an initializer",
13236 sym
->name
, &sym
->declared_at
);
13237 else if (sym
->attr
.intrinsic
)
13238 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
13239 sym
->name
, &sym
->declared_at
);
13240 else if (sym
->attr
.result
)
13241 gfc_error ("Function result %qs at %L cannot have an initializer",
13242 sym
->name
, &sym
->declared_at
);
13243 else if (automatic_flag
)
13244 gfc_error ("Automatic array %qs at %L cannot have an initializer",
13245 sym
->name
, &sym
->declared_at
);
13247 goto no_init_error
;
13248 specification_expr
= saved_specification_expr
;
13253 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
13255 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
13256 specification_expr
= saved_specification_expr
;
13260 specification_expr
= saved_specification_expr
;
13265 /* Compare the dummy characteristics of a module procedure interface
13266 declaration with the corresponding declaration in a submodule. */
13267 static gfc_formal_arglist
*new_formal
;
13268 static char errmsg
[200];
13271 compare_fsyms (gfc_symbol
*sym
)
13275 if (sym
== NULL
|| new_formal
== NULL
)
13278 fsym
= new_formal
->sym
;
13283 if (strcmp (sym
->name
, fsym
->name
) == 0)
13285 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
13286 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
13291 /* Resolve a procedure. */
13294 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
13296 gfc_formal_arglist
*arg
;
13297 bool allocatable_or_pointer
= false;
13299 if (sym
->attr
.function
13300 && !resolve_fl_var_and_proc (sym
, mp_flag
))
13303 /* Constraints on deferred type parameter. */
13304 if (!deferred_requirements (sym
))
13307 if (sym
->ts
.type
== BT_CHARACTER
)
13309 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13311 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
13312 && !resolve_charlen (cl
))
13315 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13316 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
13318 gfc_error ("Character-valued statement function %qs at %L must "
13319 "have constant length", sym
->name
, &sym
->declared_at
);
13324 /* Ensure that derived type for are not of a private type. Internal
13325 module procedures are excluded by 2.2.3.3 - i.e., they are not
13326 externally accessible and can access all the objects accessible in
13328 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
13329 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
13330 && gfc_check_symbol_access (sym
))
13332 gfc_interface
*iface
;
13334 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
13337 && arg
->sym
->ts
.type
== BT_DERIVED
13338 && arg
->sym
->ts
.u
.derived
13339 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
13340 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
13341 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
13342 "and cannot be a dummy argument"
13343 " of %qs, which is PUBLIC at %L",
13344 arg
->sym
->name
, sym
->name
,
13345 &sym
->declared_at
))
13347 /* Stop this message from recurring. */
13348 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
13353 /* PUBLIC interfaces may expose PRIVATE procedures that take types
13354 PRIVATE to the containing module. */
13355 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
13357 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
13360 && arg
->sym
->ts
.type
== BT_DERIVED
13361 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
13362 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
13363 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
13364 "PUBLIC interface %qs at %L "
13365 "takes dummy arguments of %qs which "
13366 "is PRIVATE", iface
->sym
->name
,
13367 sym
->name
, &iface
->sym
->declared_at
,
13368 gfc_typename(&arg
->sym
->ts
)))
13370 /* Stop this message from recurring. */
13371 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
13378 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
13379 && !sym
->attr
.proc_pointer
)
13381 gfc_error ("Function %qs at %L cannot have an initializer",
13382 sym
->name
, &sym
->declared_at
);
13384 /* Make sure no second error is issued for this. */
13385 sym
->value
->error
= 1;
13389 /* An external symbol may not have an initializer because it is taken to be
13390 a procedure. Exception: Procedure Pointers. */
13391 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
13393 gfc_error ("External object %qs at %L may not have an initializer",
13394 sym
->name
, &sym
->declared_at
);
13398 /* An elemental function is required to return a scalar 12.7.1 */
13399 if (sym
->attr
.elemental
&& sym
->attr
.function
13400 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13401 && CLASS_DATA (sym
)->as
)))
13403 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
13404 "result", sym
->name
, &sym
->declared_at
);
13405 /* Reset so that the error only occurs once. */
13406 sym
->attr
.elemental
= 0;
13410 if (sym
->attr
.proc
== PROC_ST_FUNCTION
13411 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
13413 gfc_error ("Statement function %qs at %L may not have pointer or "
13414 "allocatable attribute", sym
->name
, &sym
->declared_at
);
13418 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
13419 char-len-param shall not be array-valued, pointer-valued, recursive
13420 or pure. ....snip... A character value of * may only be used in the
13421 following ways: (i) Dummy arg of procedure - dummy associates with
13422 actual length; (ii) To declare a named constant; or (iii) External
13423 function - but length must be declared in calling scoping unit. */
13424 if (sym
->attr
.function
13425 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
13426 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
13428 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
13429 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
13431 if (sym
->as
&& sym
->as
->rank
)
13432 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13433 "array-valued", sym
->name
, &sym
->declared_at
);
13435 if (sym
->attr
.pointer
)
13436 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13437 "pointer-valued", sym
->name
, &sym
->declared_at
);
13439 if (sym
->attr
.pure
)
13440 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13441 "pure", sym
->name
, &sym
->declared_at
);
13443 if (sym
->attr
.recursive
)
13444 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13445 "recursive", sym
->name
, &sym
->declared_at
);
13450 /* Appendix B.2 of the standard. Contained functions give an
13451 error anyway. Deferred character length is an F2003 feature.
13452 Don't warn on intrinsic conversion functions, which start
13453 with two underscores. */
13454 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
13455 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
13456 gfc_notify_std (GFC_STD_F95_OBS
,
13457 "CHARACTER(*) function %qs at %L",
13458 sym
->name
, &sym
->declared_at
);
13461 /* F2008, C1218. */
13462 if (sym
->attr
.elemental
)
13464 if (sym
->attr
.proc_pointer
)
13466 const char* name
= (sym
->attr
.result
? sym
->ns
->proc_name
->name
13468 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
13469 name
, &sym
->declared_at
);
13472 if (sym
->attr
.dummy
)
13474 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
13475 sym
->name
, &sym
->declared_at
);
13480 /* F2018, C15100: "The result of an elemental function shall be scalar,
13481 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
13482 pointer is tested and caught elsewhere. */
13484 allocatable_or_pointer
= sym
->result
->ts
.type
== BT_CLASS
13485 && CLASS_DATA (sym
->result
) ?
13486 (CLASS_DATA (sym
->result
)->attr
.allocatable
13487 || CLASS_DATA (sym
->result
)->attr
.pointer
) :
13488 (sym
->result
->attr
.allocatable
13489 || sym
->result
->attr
.pointer
);
13491 if (sym
->attr
.elemental
&& sym
->result
13492 && allocatable_or_pointer
)
13494 gfc_error ("Function result variable %qs at %L of elemental "
13495 "function %qs shall not have an ALLOCATABLE or POINTER "
13496 "attribute", sym
->result
->name
,
13497 &sym
->result
->declared_at
, sym
->name
);
13501 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
13503 gfc_formal_arglist
*curr_arg
;
13504 int has_non_interop_arg
= 0;
13506 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13507 sym
->common_block
))
13509 /* Clear these to prevent looking at them again if there was an
13511 sym
->attr
.is_bind_c
= 0;
13512 sym
->attr
.is_c_interop
= 0;
13513 sym
->ts
.is_c_interop
= 0;
13517 /* So far, no errors have been found. */
13518 sym
->attr
.is_c_interop
= 1;
13519 sym
->ts
.is_c_interop
= 1;
13522 curr_arg
= gfc_sym_get_dummy_args (sym
);
13523 while (curr_arg
!= NULL
)
13525 /* Skip implicitly typed dummy args here. */
13526 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
13527 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
13528 /* If something is found to fail, record the fact so we
13529 can mark the symbol for the procedure as not being
13530 BIND(C) to try and prevent multiple errors being
13532 has_non_interop_arg
= 1;
13534 curr_arg
= curr_arg
->next
;
13537 /* See if any of the arguments were not interoperable and if so, clear
13538 the procedure symbol to prevent duplicate error messages. */
13539 if (has_non_interop_arg
!= 0)
13541 sym
->attr
.is_c_interop
= 0;
13542 sym
->ts
.is_c_interop
= 0;
13543 sym
->attr
.is_bind_c
= 0;
13547 if (!sym
->attr
.proc_pointer
)
13549 if (sym
->attr
.save
== SAVE_EXPLICIT
)
13551 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
13552 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13555 if (sym
->attr
.intent
)
13557 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
13558 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13561 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
13563 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
13564 "in %qs at %L", sym
->ns
->proc_name
->name
, &sym
->declared_at
);
13567 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
13568 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
13569 || sym
->attr
.contained
))
13571 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
13572 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13575 if (strcmp ("ppr@", sym
->name
) == 0)
13577 gfc_error ("Procedure pointer result %qs at %L "
13578 "is missing the pointer attribute",
13579 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
13584 /* Assume that a procedure whose body is not known has references
13585 to external arrays. */
13586 if (sym
->attr
.if_source
!= IFSRC_DECL
)
13587 sym
->attr
.array_outer_dependency
= 1;
13589 /* Compare the characteristics of a module procedure with the
13590 interface declaration. Ideally this would be done with
13591 gfc_compare_interfaces but, at present, the formal interface
13592 cannot be copied to the ts.interface. */
13593 if (sym
->attr
.module_procedure
13594 && sym
->attr
.if_source
== IFSRC_DECL
)
13597 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
13599 char *submodule_name
;
13600 strcpy (name
, sym
->ns
->proc_name
->name
);
13601 module_name
= strtok (name
, ".");
13602 submodule_name
= strtok (NULL
, ".");
13604 iface
= sym
->tlink
;
13607 /* Make sure that the result uses the correct charlen for deferred
13609 if (iface
&& sym
->result
13610 && iface
->ts
.type
== BT_CHARACTER
13611 && iface
->ts
.deferred
)
13612 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
13617 /* Check the procedure characteristics. */
13618 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
13620 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
13621 "PROCEDURE at %L and its interface in %s",
13622 &sym
->declared_at
, module_name
);
13626 if (sym
->attr
.pure
!= iface
->attr
.pure
)
13628 gfc_error ("Mismatch in PURE attribute between MODULE "
13629 "PROCEDURE at %L and its interface in %s",
13630 &sym
->declared_at
, module_name
);
13634 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
13636 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
13637 "PROCEDURE at %L and its interface in %s",
13638 &sym
->declared_at
, module_name
);
13642 /* Check the result characteristics. */
13643 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
13645 gfc_error ("%s between the MODULE PROCEDURE declaration "
13646 "in MODULE %qs and the declaration at %L in "
13648 errmsg
, module_name
, &sym
->declared_at
,
13649 submodule_name
? submodule_name
: module_name
);
13654 /* Check the characteristics of the formal arguments. */
13655 if (sym
->formal
&& sym
->formal_ns
)
13657 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
13660 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
13668 /* Resolve a list of finalizer procedures. That is, after they have hopefully
13669 been defined and we now know their defined arguments, check that they fulfill
13670 the requirements of the standard for procedures used as finalizers. */
13673 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
13675 gfc_finalizer
* list
;
13676 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
13677 bool result
= true;
13678 bool seen_scalar
= false;
13681 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
13684 gfc_resolve_finalizers (parent
, finalizable
);
13686 /* Ensure that derived-type components have a their finalizers resolved. */
13687 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
13688 for (c
= derived
->components
; c
; c
= c
->next
)
13689 if (c
->ts
.type
== BT_DERIVED
13690 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
13692 bool has_final2
= false;
13693 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
13694 return false; /* Error. */
13695 has_final
= has_final
|| has_final2
;
13697 /* Return early if not finalizable. */
13701 *finalizable
= false;
13705 /* Walk over the list of finalizer-procedures, check them, and if any one
13706 does not fit in with the standard's definition, print an error and remove
13707 it from the list. */
13708 prev_link
= &derived
->f2k_derived
->finalizers
;
13709 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
13711 gfc_formal_arglist
*dummy_args
;
13716 /* Skip this finalizer if we already resolved it. */
13717 if (list
->proc_tree
)
13719 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
13720 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
13721 seen_scalar
= true;
13722 prev_link
= &(list
->next
);
13726 /* Check this exists and is a SUBROUTINE. */
13727 if (!list
->proc_sym
->attr
.subroutine
)
13729 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
13730 list
->proc_sym
->name
, &list
->where
);
13734 /* We should have exactly one argument. */
13735 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
13736 if (!dummy_args
|| dummy_args
->next
)
13738 gfc_error ("FINAL procedure at %L must have exactly one argument",
13742 arg
= dummy_args
->sym
;
13744 /* This argument must be of our type. */
13745 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
13747 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
13748 &arg
->declared_at
, derived
->name
);
13752 /* It must neither be a pointer nor allocatable nor optional. */
13753 if (arg
->attr
.pointer
)
13755 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13756 &arg
->declared_at
);
13759 if (arg
->attr
.allocatable
)
13761 gfc_error ("Argument of FINAL procedure at %L must not be"
13762 " ALLOCATABLE", &arg
->declared_at
);
13765 if (arg
->attr
.optional
)
13767 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13768 &arg
->declared_at
);
13772 /* It must not be INTENT(OUT). */
13773 if (arg
->attr
.intent
== INTENT_OUT
)
13775 gfc_error ("Argument of FINAL procedure at %L must not be"
13776 " INTENT(OUT)", &arg
->declared_at
);
13780 /* Warn if the procedure is non-scalar and not assumed shape. */
13781 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
13782 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
13783 gfc_warning (OPT_Wsurprising
,
13784 "Non-scalar FINAL procedure at %L should have assumed"
13785 " shape argument", &arg
->declared_at
);
13787 /* Check that it does not match in kind and rank with a FINAL procedure
13788 defined earlier. To really loop over the *earlier* declarations,
13789 we need to walk the tail of the list as new ones were pushed at the
13791 /* TODO: Handle kind parameters once they are implemented. */
13792 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
13793 for (i
= list
->next
; i
; i
= i
->next
)
13795 gfc_formal_arglist
*dummy_args
;
13797 /* Argument list might be empty; that is an error signalled earlier,
13798 but we nevertheless continued resolving. */
13799 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
13802 gfc_symbol
* i_arg
= dummy_args
->sym
;
13803 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
13804 if (i_rank
== my_rank
)
13806 gfc_error ("FINAL procedure %qs declared at %L has the same"
13807 " rank (%d) as %qs",
13808 list
->proc_sym
->name
, &list
->where
, my_rank
,
13809 i
->proc_sym
->name
);
13815 /* Is this the/a scalar finalizer procedure? */
13817 seen_scalar
= true;
13819 /* Find the symtree for this procedure. */
13820 gcc_assert (!list
->proc_tree
);
13821 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
13823 prev_link
= &list
->next
;
13826 /* Remove wrong nodes immediately from the list so we don't risk any
13827 troubles in the future when they might fail later expectations. */
13830 *prev_link
= list
->next
;
13831 gfc_free_finalizer (i
);
13835 if (result
== false)
13838 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13839 were nodes in the list, must have been for arrays. It is surely a good
13840 idea to have a scalar version there if there's something to finalize. */
13841 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
13842 gfc_warning (OPT_Wsurprising
,
13843 "Only array FINAL procedures declared for derived type %qs"
13844 " defined at %L, suggest also scalar one",
13845 derived
->name
, &derived
->declared_at
);
13847 vtab
= gfc_find_derived_vtab (derived
);
13848 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
13849 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
13852 *finalizable
= true;
13858 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13861 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13862 const char* generic_name
, locus where
)
13864 gfc_symbol
*sym1
, *sym2
;
13865 const char *pass1
, *pass2
;
13866 gfc_formal_arglist
*dummy_args
;
13868 gcc_assert (t1
->specific
&& t2
->specific
);
13869 gcc_assert (!t1
->specific
->is_generic
);
13870 gcc_assert (!t2
->specific
->is_generic
);
13871 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13873 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13874 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13879 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13880 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13881 || sym1
->attr
.function
!= sym2
->attr
.function
)
13883 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
13884 " GENERIC %qs at %L",
13885 sym1
->name
, sym2
->name
, generic_name
, &where
);
13889 /* Determine PASS arguments. */
13890 if (t1
->specific
->nopass
)
13892 else if (t1
->specific
->pass_arg
)
13893 pass1
= t1
->specific
->pass_arg
;
13896 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13898 pass1
= dummy_args
->sym
->name
;
13902 if (t2
->specific
->nopass
)
13904 else if (t2
->specific
->pass_arg
)
13905 pass2
= t2
->specific
->pass_arg
;
13908 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13910 pass2
= dummy_args
->sym
->name
;
13915 /* Compare the interfaces. */
13916 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13917 NULL
, 0, pass1
, pass2
))
13919 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13920 sym1
->name
, sym2
->name
, generic_name
, &where
);
13928 /* Worker function for resolving a generic procedure binding; this is used to
13929 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13931 The difference between those cases is finding possible inherited bindings
13932 that are overridden, as one has to look for them in tb_sym_root,
13933 tb_uop_root or tb_op, respectively. Thus the caller must already find
13934 the super-type and set p->overridden correctly. */
13937 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13938 gfc_typebound_proc
* p
, const char* name
)
13940 gfc_tbp_generic
* target
;
13941 gfc_symtree
* first_target
;
13942 gfc_symtree
* inherited
;
13944 gcc_assert (p
&& p
->is_generic
);
13946 /* Try to find the specific bindings for the symtrees in our target-list. */
13947 gcc_assert (p
->u
.generic
);
13948 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13949 if (!target
->specific
)
13951 gfc_typebound_proc
* overridden_tbp
;
13952 gfc_tbp_generic
* g
;
13953 const char* target_name
;
13955 target_name
= target
->specific_st
->name
;
13957 /* Defined for this type directly. */
13958 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13960 target
->specific
= target
->specific_st
->n
.tb
;
13961 goto specific_found
;
13964 /* Look for an inherited specific binding. */
13967 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13972 gcc_assert (inherited
->n
.tb
);
13973 target
->specific
= inherited
->n
.tb
;
13974 goto specific_found
;
13978 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13979 " at %L", target_name
, name
, &p
->where
);
13982 /* Once we've found the specific binding, check it is not ambiguous with
13983 other specifics already found or inherited for the same GENERIC. */
13985 gcc_assert (target
->specific
);
13987 /* This must really be a specific binding! */
13988 if (target
->specific
->is_generic
)
13990 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13991 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13995 /* Check those already resolved on this type directly. */
13996 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13997 if (g
!= target
&& g
->specific
13998 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
14001 /* Check for ambiguity with inherited specific targets. */
14002 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
14003 overridden_tbp
= overridden_tbp
->overridden
)
14004 if (overridden_tbp
->is_generic
)
14006 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
14008 gcc_assert (g
->specific
);
14009 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
14015 /* If we attempt to "overwrite" a specific binding, this is an error. */
14016 if (p
->overridden
&& !p
->overridden
->is_generic
)
14018 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
14019 " the same name", name
, &p
->where
);
14023 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
14024 all must have the same attributes here. */
14025 first_target
= p
->u
.generic
->specific
->u
.specific
;
14026 gcc_assert (first_target
);
14027 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
14028 p
->function
= first_target
->n
.sym
->attr
.function
;
14034 /* Resolve a GENERIC procedure binding for a derived type. */
14037 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
14039 gfc_symbol
* super_type
;
14041 /* Find the overridden binding if any. */
14042 st
->n
.tb
->overridden
= NULL
;
14043 super_type
= gfc_get_derived_super_type (derived
);
14046 gfc_symtree
* overridden
;
14047 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
14050 if (overridden
&& overridden
->n
.tb
)
14051 st
->n
.tb
->overridden
= overridden
->n
.tb
;
14054 /* Resolve using worker function. */
14055 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
14059 /* Retrieve the target-procedure of an operator binding and do some checks in
14060 common for intrinsic and user-defined type-bound operators. */
14063 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
14065 gfc_symbol
* target_proc
;
14067 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
14068 target_proc
= target
->specific
->u
.specific
->n
.sym
;
14069 gcc_assert (target_proc
);
14071 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
14072 if (target
->specific
->nopass
)
14074 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
14078 return target_proc
;
14082 /* Resolve a type-bound intrinsic operator. */
14085 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
14086 gfc_typebound_proc
* p
)
14088 gfc_symbol
* super_type
;
14089 gfc_tbp_generic
* target
;
14091 /* If there's already an error here, do nothing (but don't fail again). */
14095 /* Operators should always be GENERIC bindings. */
14096 gcc_assert (p
->is_generic
);
14098 /* Look for an overridden binding. */
14099 super_type
= gfc_get_derived_super_type (derived
);
14100 if (super_type
&& super_type
->f2k_derived
)
14101 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
14104 p
->overridden
= NULL
;
14106 /* Resolve general GENERIC properties using worker function. */
14107 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
14110 /* Check the targets to be procedures of correct interface. */
14111 for (target
= p
->u
.generic
; target
; target
= target
->next
)
14113 gfc_symbol
* target_proc
;
14115 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
14119 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
14122 /* Add target to non-typebound operator list. */
14123 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
14124 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
14126 gfc_interface
*head
, *intr
;
14128 /* Preempt 'gfc_check_new_interface' for submodules, where the
14129 mechanism for handling module procedures winds up resolving
14130 operator interfaces twice and would otherwise cause an error. */
14131 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
14132 if (intr
->sym
== target_proc
14133 && target_proc
->attr
.used_in_submodule
)
14136 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
14137 target_proc
, p
->where
))
14139 head
= derived
->ns
->op
[op
];
14140 intr
= gfc_get_interface ();
14141 intr
->sym
= target_proc
;
14142 intr
->where
= p
->where
;
14144 derived
->ns
->op
[op
] = intr
;
14156 /* Resolve a type-bound user operator (tree-walker callback). */
14158 static gfc_symbol
* resolve_bindings_derived
;
14159 static bool resolve_bindings_result
;
14161 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
14164 resolve_typebound_user_op (gfc_symtree
* stree
)
14166 gfc_symbol
* super_type
;
14167 gfc_tbp_generic
* target
;
14169 gcc_assert (stree
&& stree
->n
.tb
);
14171 if (stree
->n
.tb
->error
)
14174 /* Operators should always be GENERIC bindings. */
14175 gcc_assert (stree
->n
.tb
->is_generic
);
14177 /* Find overridden procedure, if any. */
14178 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
14179 if (super_type
&& super_type
->f2k_derived
)
14181 gfc_symtree
* overridden
;
14182 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
14183 stree
->name
, true, NULL
);
14185 if (overridden
&& overridden
->n
.tb
)
14186 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
14189 stree
->n
.tb
->overridden
= NULL
;
14191 /* Resolve basically using worker function. */
14192 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
14195 /* Check the targets to be functions of correct interface. */
14196 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
14198 gfc_symbol
* target_proc
;
14200 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
14204 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
14211 resolve_bindings_result
= false;
14212 stree
->n
.tb
->error
= 1;
14216 /* Resolve the type-bound procedures for a derived type. */
14219 resolve_typebound_procedure (gfc_symtree
* stree
)
14223 gfc_symbol
* me_arg
;
14224 gfc_symbol
* super_type
;
14225 gfc_component
* comp
;
14227 gcc_assert (stree
);
14229 /* Undefined specific symbol from GENERIC target definition. */
14233 if (stree
->n
.tb
->error
)
14236 /* If this is a GENERIC binding, use that routine. */
14237 if (stree
->n
.tb
->is_generic
)
14239 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
14244 /* Get the target-procedure to check it. */
14245 gcc_assert (!stree
->n
.tb
->is_generic
);
14246 gcc_assert (stree
->n
.tb
->u
.specific
);
14247 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
14248 where
= stree
->n
.tb
->where
;
14250 /* Default access should already be resolved from the parser. */
14251 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
14253 if (stree
->n
.tb
->deferred
)
14255 if (!check_proc_interface (proc
, &where
))
14260 /* If proc has not been resolved at this point, proc->name may
14261 actually be a USE associated entity. See PR fortran/89647. */
14262 if (!proc
->resolve_symbol_called
14263 && proc
->attr
.function
== 0 && proc
->attr
.subroutine
== 0)
14266 gfc_find_symbol (proc
->name
, gfc_current_ns
->parent
, 1, &tmp
);
14267 if (tmp
&& tmp
->attr
.use_assoc
)
14269 proc
->module
= tmp
->module
;
14270 proc
->attr
.proc
= tmp
->attr
.proc
;
14271 proc
->attr
.function
= tmp
->attr
.function
;
14272 proc
->attr
.subroutine
= tmp
->attr
.subroutine
;
14273 proc
->attr
.use_assoc
= tmp
->attr
.use_assoc
;
14274 proc
->ts
= tmp
->ts
;
14275 proc
->result
= tmp
->result
;
14279 /* Check for F08:C465. */
14280 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
14281 || (proc
->attr
.proc
!= PROC_MODULE
14282 && proc
->attr
.if_source
!= IFSRC_IFBODY
14283 && !proc
->attr
.module_procedure
)
14284 || proc
->attr
.abstract
)
14286 gfc_error ("%qs must be a module procedure or an external "
14287 "procedure with an explicit interface at %L",
14288 proc
->name
, &where
);
14293 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
14294 stree
->n
.tb
->function
= proc
->attr
.function
;
14296 /* Find the super-type of the current derived type. We could do this once and
14297 store in a global if speed is needed, but as long as not I believe this is
14298 more readable and clearer. */
14299 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
14301 /* If PASS, resolve and check arguments if not already resolved / loaded
14302 from a .mod file. */
14303 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
14305 gfc_formal_arglist
*dummy_args
;
14307 dummy_args
= gfc_sym_get_dummy_args (proc
);
14308 if (stree
->n
.tb
->pass_arg
)
14310 gfc_formal_arglist
*i
;
14312 /* If an explicit passing argument name is given, walk the arg-list
14313 and look for it. */
14316 stree
->n
.tb
->pass_arg_num
= 1;
14317 for (i
= dummy_args
; i
; i
= i
->next
)
14319 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
14324 ++stree
->n
.tb
->pass_arg_num
;
14329 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
14331 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
14332 stree
->n
.tb
->pass_arg
);
14338 /* Otherwise, take the first one; there should in fact be at least
14340 stree
->n
.tb
->pass_arg_num
= 1;
14343 gfc_error ("Procedure %qs with PASS at %L must have at"
14344 " least one argument", proc
->name
, &where
);
14347 me_arg
= dummy_args
->sym
;
14350 /* Now check that the argument-type matches and the passed-object
14351 dummy argument is generally fine. */
14353 gcc_assert (me_arg
);
14355 if (me_arg
->ts
.type
!= BT_CLASS
)
14357 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14358 " at %L", proc
->name
, &where
);
14362 if (CLASS_DATA (me_arg
)->ts
.u
.derived
14363 != resolve_bindings_derived
)
14365 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14366 " the derived-type %qs", me_arg
->name
, proc
->name
,
14367 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
14371 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
14372 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
14374 gfc_error ("Passed-object dummy argument of %qs at %L must be"
14375 " scalar", proc
->name
, &where
);
14378 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14380 gfc_error ("Passed-object dummy argument of %qs at %L must not"
14381 " be ALLOCATABLE", proc
->name
, &where
);
14384 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14386 gfc_error ("Passed-object dummy argument of %qs at %L must not"
14387 " be POINTER", proc
->name
, &where
);
14392 /* If we are extending some type, check that we don't override a procedure
14393 flagged NON_OVERRIDABLE. */
14394 stree
->n
.tb
->overridden
= NULL
;
14397 gfc_symtree
* overridden
;
14398 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
14399 stree
->name
, true, NULL
);
14403 if (overridden
->n
.tb
)
14404 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
14406 if (!gfc_check_typebound_override (stree
, overridden
))
14411 /* See if there's a name collision with a component directly in this type. */
14412 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
14413 if (!strcmp (comp
->name
, stree
->name
))
14415 gfc_error ("Procedure %qs at %L has the same name as a component of"
14417 stree
->name
, &where
, resolve_bindings_derived
->name
);
14421 /* Try to find a name collision with an inherited component. */
14422 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
14425 gfc_error ("Procedure %qs at %L has the same name as an inherited"
14426 " component of %qs",
14427 stree
->name
, &where
, resolve_bindings_derived
->name
);
14431 stree
->n
.tb
->error
= 0;
14435 resolve_bindings_result
= false;
14436 stree
->n
.tb
->error
= 1;
14441 resolve_typebound_procedures (gfc_symbol
* derived
)
14444 gfc_symbol
* super_type
;
14446 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
14449 super_type
= gfc_get_derived_super_type (derived
);
14451 resolve_symbol (super_type
);
14453 resolve_bindings_derived
= derived
;
14454 resolve_bindings_result
= true;
14456 if (derived
->f2k_derived
->tb_sym_root
)
14457 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
14458 &resolve_typebound_procedure
);
14460 if (derived
->f2k_derived
->tb_uop_root
)
14461 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
14462 &resolve_typebound_user_op
);
14464 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
14466 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
14467 if (p
&& !resolve_typebound_intrinsic_op (derived
,
14468 (gfc_intrinsic_op
)op
, p
))
14469 resolve_bindings_result
= false;
14472 return resolve_bindings_result
;
14476 /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
14477 to give all identical derived types the same backend_decl. */
14479 add_dt_to_dt_list (gfc_symbol
*derived
)
14481 if (!derived
->dt_next
)
14483 if (gfc_derived_types
)
14485 derived
->dt_next
= gfc_derived_types
->dt_next
;
14486 gfc_derived_types
->dt_next
= derived
;
14490 derived
->dt_next
= derived
;
14492 gfc_derived_types
= derived
;
14497 /* Ensure that a derived-type is really not abstract, meaning that every
14498 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
14501 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
14506 if (!ensure_not_abstract_walker (sub
, st
->left
))
14508 if (!ensure_not_abstract_walker (sub
, st
->right
))
14511 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
14513 gfc_symtree
* overriding
;
14514 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
14517 gcc_assert (overriding
->n
.tb
);
14518 if (overriding
->n
.tb
->deferred
)
14520 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
14521 " %qs is DEFERRED and not overridden",
14522 sub
->name
, &sub
->declared_at
, st
->name
);
14531 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
14533 /* The algorithm used here is to recursively travel up the ancestry of sub
14534 and for each ancestor-type, check all bindings. If any of them is
14535 DEFERRED, look it up starting from sub and see if the found (overriding)
14536 binding is not DEFERRED.
14537 This is not the most efficient way to do this, but it should be ok and is
14538 clearer than something sophisticated. */
14540 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
14542 if (!ancestor
->attr
.abstract
)
14545 /* Walk bindings of this ancestor. */
14546 if (ancestor
->f2k_derived
)
14549 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
14554 /* Find next ancestor type and recurse on it. */
14555 ancestor
= gfc_get_derived_super_type (ancestor
);
14557 return ensure_not_abstract (sub
, ancestor
);
14563 /* This check for typebound defined assignments is done recursively
14564 since the order in which derived types are resolved is not always in
14565 order of the declarations. */
14568 check_defined_assignments (gfc_symbol
*derived
)
14572 for (c
= derived
->components
; c
; c
= c
->next
)
14574 if (!gfc_bt_struct (c
->ts
.type
)
14576 || c
->attr
.allocatable
14577 || c
->attr
.proc_pointer_comp
14578 || c
->attr
.class_pointer
14579 || c
->attr
.proc_pointer
)
14582 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
14583 || (c
->ts
.u
.derived
->f2k_derived
14584 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
14586 derived
->attr
.defined_assign_comp
= 1;
14590 check_defined_assignments (c
->ts
.u
.derived
);
14591 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
14593 derived
->attr
.defined_assign_comp
= 1;
14600 /* Resolve a single component of a derived type or structure. */
14603 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
14605 gfc_symbol
*super_type
;
14606 symbol_attribute
*attr
;
14608 if (c
->attr
.artificial
)
14611 /* Do not allow vtype components to be resolved in nameless namespaces
14612 such as block data because the procedure pointers will cause ICEs
14613 and vtables are not needed in these contexts. */
14614 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
14615 && sym
->ns
->proc_name
== NULL
)
14619 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
14620 && c
->attr
.codimension
14621 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
14623 gfc_error ("Coarray component %qs at %L must be allocatable with "
14624 "deferred shape", c
->name
, &c
->loc
);
14629 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
14630 && c
->ts
.u
.derived
->ts
.is_iso_c
)
14632 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14633 "shall not be a coarray", c
->name
, &c
->loc
);
14638 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
14639 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
14640 || c
->attr
.allocatable
))
14642 gfc_error ("Component %qs at %L with coarray component "
14643 "shall be a nonpointer, nonallocatable scalar",
14649 if (c
->ts
.type
== BT_CLASS
)
14651 if (c
->attr
.class_ok
&& CLASS_DATA (c
))
14653 attr
= &(CLASS_DATA (c
)->attr
);
14655 /* Fix up contiguous attribute. */
14656 if (c
->attr
.contiguous
)
14657 attr
->contiguous
= 1;
14665 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
14667 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
14668 "is not an array pointer", c
->name
, &c
->loc
);
14672 /* F2003, 15.2.1 - length has to be one. */
14673 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
14674 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
14675 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
14676 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
14678 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
14683 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
14685 gfc_symbol
*ifc
= c
->ts
.interface
;
14687 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
14693 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
14695 /* Resolve interface and copy attributes. */
14696 if (ifc
->formal
&& !ifc
->formal_ns
)
14697 resolve_symbol (ifc
);
14698 if (ifc
->attr
.intrinsic
)
14699 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
14703 c
->ts
= ifc
->result
->ts
;
14704 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
14705 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
14706 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
14707 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
14708 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
14713 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
14714 c
->attr
.pointer
= ifc
->attr
.pointer
;
14715 c
->attr
.dimension
= ifc
->attr
.dimension
;
14716 c
->as
= gfc_copy_array_spec (ifc
->as
);
14717 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
14719 c
->ts
.interface
= ifc
;
14720 c
->attr
.function
= ifc
->attr
.function
;
14721 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
14723 c
->attr
.pure
= ifc
->attr
.pure
;
14724 c
->attr
.elemental
= ifc
->attr
.elemental
;
14725 c
->attr
.recursive
= ifc
->attr
.recursive
;
14726 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
14727 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
14728 /* Copy char length. */
14729 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
14731 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
14732 if (cl
->length
&& !cl
->resolved
14733 && !gfc_resolve_expr (cl
->length
))
14742 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
14744 /* Since PPCs are not implicitly typed, a PPC without an explicit
14745 interface must be a subroutine. */
14746 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
14749 /* Procedure pointer components: Check PASS arg. */
14750 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
14751 && !sym
->attr
.vtype
)
14753 gfc_symbol
* me_arg
;
14755 if (c
->tb
->pass_arg
)
14757 gfc_formal_arglist
* i
;
14759 /* If an explicit passing argument name is given, walk the arg-list
14760 and look for it. */
14763 c
->tb
->pass_arg_num
= 1;
14764 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
14766 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
14771 c
->tb
->pass_arg_num
++;
14776 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14777 "at %L has no argument %qs", c
->name
,
14778 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
14785 /* Otherwise, take the first one; there should in fact be at least
14787 c
->tb
->pass_arg_num
= 1;
14788 if (!c
->ts
.interface
->formal
)
14790 gfc_error ("Procedure pointer component %qs with PASS at %L "
14791 "must have at least one argument",
14796 me_arg
= c
->ts
.interface
->formal
->sym
;
14799 /* Now check that the argument-type matches. */
14800 gcc_assert (me_arg
);
14801 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
14802 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
14803 || (me_arg
->ts
.type
== BT_CLASS
14804 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
14806 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14807 " the derived type %qs", me_arg
->name
, c
->name
,
14808 me_arg
->name
, &c
->loc
, sym
->name
);
14813 /* Check for F03:C453. */
14814 if (CLASS_DATA (me_arg
)->attr
.dimension
)
14816 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14817 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
14823 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14825 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14826 "may not have the POINTER attribute", me_arg
->name
,
14827 c
->name
, me_arg
->name
, &c
->loc
);
14832 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14834 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14835 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
14836 me_arg
->name
, &c
->loc
);
14841 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
14843 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14844 " at %L", c
->name
, &c
->loc
);
14850 /* Check type-spec if this is not the parent-type component. */
14851 if (((sym
->attr
.is_class
14852 && (!sym
->components
->ts
.u
.derived
->attr
.extension
14853 || c
!= sym
->components
->ts
.u
.derived
->components
))
14854 || (!sym
->attr
.is_class
14855 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
14856 && !sym
->attr
.vtype
14857 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
14860 super_type
= gfc_get_derived_super_type (sym
);
14862 /* If this type is an extension, set the accessibility of the parent
14865 && ((sym
->attr
.is_class
14866 && c
== sym
->components
->ts
.u
.derived
->components
)
14867 || (!sym
->attr
.is_class
&& c
== sym
->components
))
14868 && strcmp (super_type
->name
, c
->name
) == 0)
14869 c
->attr
.access
= super_type
->attr
.access
;
14871 /* If this type is an extension, see if this component has the same name
14872 as an inherited type-bound procedure. */
14873 if (super_type
&& !sym
->attr
.is_class
14874 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
14876 gfc_error ("Component %qs of %qs at %L has the same name as an"
14877 " inherited type-bound procedure",
14878 c
->name
, sym
->name
, &c
->loc
);
14882 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
14883 && !c
->ts
.deferred
)
14885 if (c
->ts
.u
.cl
->length
== NULL
14886 || (!resolve_charlen(c
->ts
.u
.cl
))
14887 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
14889 gfc_error ("Character length of component %qs needs to "
14890 "be a constant specification expression at %L",
14892 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14896 if (c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
14898 if (!c
->ts
.u
.cl
->length
->error
)
14900 gfc_error ("Character length expression of component %qs at %L "
14901 "must be of INTEGER type, found %s",
14902 c
->name
, &c
->ts
.u
.cl
->length
->where
,
14903 gfc_basic_typename (c
->ts
.u
.cl
->length
->ts
.type
));
14904 c
->ts
.u
.cl
->length
->error
= 1;
14910 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14911 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14913 gfc_error ("Character component %qs of %qs at %L with deferred "
14914 "length must be a POINTER or ALLOCATABLE",
14915 c
->name
, sym
->name
, &c
->loc
);
14919 /* Add the hidden deferred length field. */
14920 if (c
->ts
.type
== BT_CHARACTER
14921 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14922 && !c
->attr
.function
14923 && !sym
->attr
.is_class
)
14925 char name
[GFC_MAX_SYMBOL_LEN
+9];
14926 gfc_component
*strlen
;
14927 sprintf (name
, "_%s_length", c
->name
);
14928 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14929 if (strlen
== NULL
)
14931 if (!gfc_add_component (sym
, name
, &strlen
))
14933 strlen
->ts
.type
= BT_INTEGER
;
14934 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14935 strlen
->attr
.access
= ACCESS_PRIVATE
;
14936 strlen
->attr
.artificial
= 1;
14940 if (c
->ts
.type
== BT_DERIVED
14941 && sym
->component_access
!= ACCESS_PRIVATE
14942 && gfc_check_symbol_access (sym
)
14943 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14944 && !c
->ts
.u
.derived
->attr
.use_assoc
14945 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14946 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14947 "PRIVATE type and cannot be a component of "
14948 "%qs, which is PUBLIC at %L", c
->name
,
14949 sym
->name
, &sym
->declared_at
))
14952 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14954 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14955 "type %s", c
->name
, &c
->loc
, sym
->name
);
14959 if (sym
->attr
.sequence
)
14961 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14963 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14964 "not have the SEQUENCE attribute",
14965 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14970 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14971 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14972 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14973 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14974 CLASS_DATA (c
)->ts
.u
.derived
14975 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14977 /* If an allocatable component derived type is of the same type as
14978 the enclosing derived type, we need a vtable generating so that
14979 the __deallocate procedure is created. */
14980 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14981 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14982 gfc_find_vtab (&c
->ts
);
14984 /* Ensure that all the derived type components are put on the
14985 derived type list; even in formal namespaces, where derived type
14986 pointer components might not have been declared. */
14987 if (c
->ts
.type
== BT_DERIVED
14989 && c
->ts
.u
.derived
->components
14991 && sym
!= c
->ts
.u
.derived
)
14992 add_dt_to_dt_list (c
->ts
.u
.derived
);
14994 if (c
->as
&& c
->as
->type
!= AS_DEFERRED
14995 && (c
->attr
.pointer
|| c
->attr
.allocatable
))
14998 if (!gfc_resolve_array_spec (c
->as
,
14999 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
15000 || c
->attr
.allocatable
)))
15003 if (c
->initializer
&& !sym
->attr
.vtype
15004 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
15005 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
15012 /* Be nice about the locus for a structure expression - show the locus of the
15013 first non-null sub-expression if we can. */
15016 cons_where (gfc_expr
*struct_expr
)
15018 gfc_constructor
*cons
;
15020 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
15022 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
15023 for (; cons
; cons
= gfc_constructor_next (cons
))
15025 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
15026 return &cons
->expr
->where
;
15029 return &struct_expr
->where
;
15032 /* Resolve the components of a structure type. Much less work than derived
15036 resolve_fl_struct (gfc_symbol
*sym
)
15039 gfc_expr
*init
= NULL
;
15042 /* Make sure UNIONs do not have overlapping initializers. */
15043 if (sym
->attr
.flavor
== FL_UNION
)
15045 for (c
= sym
->components
; c
; c
= c
->next
)
15047 if (init
&& c
->initializer
)
15049 gfc_error ("Conflicting initializers in union at %L and %L",
15050 cons_where (init
), cons_where (c
->initializer
));
15051 gfc_free_expr (c
->initializer
);
15052 c
->initializer
= NULL
;
15055 init
= c
->initializer
;
15060 for (c
= sym
->components
; c
; c
= c
->next
)
15061 if (!resolve_component (c
, sym
))
15067 if (sym
->components
)
15068 add_dt_to_dt_list (sym
);
15074 /* Resolve the components of a derived type. This does not have to wait until
15075 resolution stage, but can be done as soon as the dt declaration has been
15079 resolve_fl_derived0 (gfc_symbol
*sym
)
15081 gfc_symbol
* super_type
;
15083 gfc_formal_arglist
*f
;
15086 if (sym
->attr
.unlimited_polymorphic
)
15089 super_type
= gfc_get_derived_super_type (sym
);
15092 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
15094 gfc_error ("As extending type %qs at %L has a coarray component, "
15095 "parent type %qs shall also have one", sym
->name
,
15096 &sym
->declared_at
, super_type
->name
);
15100 /* Ensure the extended type gets resolved before we do. */
15101 if (super_type
&& !resolve_fl_derived0 (super_type
))
15104 /* An ABSTRACT type must be extensible. */
15105 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
15107 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
15108 sym
->name
, &sym
->declared_at
);
15112 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
15116 for ( ; c
!= NULL
; c
= c
->next
)
15117 if (!resolve_component (c
, sym
))
15123 /* Now add the caf token field, where needed. */
15124 if (flag_coarray
!= GFC_FCOARRAY_NONE
15125 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
15127 for (c
= sym
->components
; c
; c
= c
->next
)
15128 if (!c
->attr
.dimension
&& !c
->attr
.codimension
15129 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
15131 char name
[GFC_MAX_SYMBOL_LEN
+9];
15132 gfc_component
*token
;
15133 sprintf (name
, "_caf_%s", c
->name
);
15134 token
= gfc_find_component (sym
, name
, true, true, NULL
);
15137 if (!gfc_add_component (sym
, name
, &token
))
15139 token
->ts
.type
= BT_VOID
;
15140 token
->ts
.kind
= gfc_default_integer_kind
;
15141 token
->attr
.access
= ACCESS_PRIVATE
;
15142 token
->attr
.artificial
= 1;
15143 token
->attr
.caf_token
= 1;
15148 check_defined_assignments (sym
);
15150 if (!sym
->attr
.defined_assign_comp
&& super_type
)
15151 sym
->attr
.defined_assign_comp
15152 = super_type
->attr
.defined_assign_comp
;
15154 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
15155 all DEFERRED bindings are overridden. */
15156 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
15157 && !sym
->attr
.is_class
15158 && !ensure_not_abstract (sym
, super_type
))
15161 /* Check that there is a component for every PDT parameter. */
15162 if (sym
->attr
.pdt_template
)
15164 for (f
= sym
->formal
; f
; f
= f
->next
)
15168 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
15171 gfc_error ("Parameterized type %qs does not have a component "
15172 "corresponding to parameter %qs at %L", sym
->name
,
15173 f
->sym
->name
, &sym
->declared_at
);
15179 /* Add derived type to the derived type list. */
15180 add_dt_to_dt_list (sym
);
15186 /* The following procedure does the full resolution of a derived type,
15187 including resolution of all type-bound procedures (if present). In contrast
15188 to 'resolve_fl_derived0' this can only be done after the module has been
15189 parsed completely. */
15192 resolve_fl_derived (gfc_symbol
*sym
)
15194 gfc_symbol
*gen_dt
= NULL
;
15196 if (sym
->attr
.unlimited_polymorphic
)
15199 if (!sym
->attr
.is_class
)
15200 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
15201 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
15202 && (!gen_dt
->generic
->sym
->attr
.use_assoc
15203 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
15204 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
15205 "%qs at %L being the same name as derived "
15206 "type at %L", sym
->name
,
15207 gen_dt
->generic
->sym
== sym
15208 ? gen_dt
->generic
->next
->sym
->name
15209 : gen_dt
->generic
->sym
->name
,
15210 gen_dt
->generic
->sym
== sym
15211 ? &gen_dt
->generic
->next
->sym
->declared_at
15212 : &gen_dt
->generic
->sym
->declared_at
,
15213 &sym
->declared_at
))
15216 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
15218 gfc_error ("Derived type %qs at %L has not been declared",
15219 sym
->name
, &sym
->declared_at
);
15223 /* Resolve the finalizer procedures. */
15224 if (!gfc_resolve_finalizers (sym
, NULL
))
15227 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
15229 /* Fix up incomplete CLASS symbols. */
15230 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
15231 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
15233 /* Nothing more to do for unlimited polymorphic entities. */
15234 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
15236 add_dt_to_dt_list (sym
);
15239 else if (vptr
->ts
.u
.derived
== NULL
)
15241 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
15243 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
15244 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
15249 if (!resolve_fl_derived0 (sym
))
15252 /* Resolve the type-bound procedures. */
15253 if (!resolve_typebound_procedures (sym
))
15256 /* Generate module vtables subject to their accessibility and their not
15257 being vtables or pdt templates. If this is not done class declarations
15258 in external procedures wind up with their own version and so SELECT TYPE
15259 fails because the vptrs do not have the same address. */
15260 if (gfc_option
.allow_std
& GFC_STD_F2003
15261 && sym
->ns
->proc_name
15262 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15263 && sym
->attr
.access
!= ACCESS_PRIVATE
15264 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
15266 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
15267 gfc_set_sym_referenced (vtab
);
15275 resolve_fl_namelist (gfc_symbol
*sym
)
15280 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
15282 /* Check again, the check in match only works if NAMELIST comes
15284 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
15286 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
15287 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15291 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
15292 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
15293 "with assumed shape in namelist %qs at %L",
15294 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
15297 if (is_non_constant_shape_array (nl
->sym
)
15298 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
15299 "with nonconstant shape in namelist %qs at %L",
15300 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
15303 if (nl
->sym
->ts
.type
== BT_CHARACTER
15304 && (nl
->sym
->ts
.u
.cl
->length
== NULL
15305 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
15306 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
15307 "nonconstant character length in "
15308 "namelist %qs at %L", nl
->sym
->name
,
15309 sym
->name
, &sym
->declared_at
))
15314 /* Reject PRIVATE objects in a PUBLIC namelist. */
15315 if (gfc_check_symbol_access (sym
))
15317 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
15319 if (!nl
->sym
->attr
.use_assoc
15320 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
15321 && !gfc_check_symbol_access (nl
->sym
))
15323 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
15324 "cannot be member of PUBLIC namelist %qs at %L",
15325 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15329 if (nl
->sym
->ts
.type
== BT_DERIVED
15330 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
15331 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
15333 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
15334 "namelist %qs at %L with ALLOCATABLE "
15335 "or POINTER components", nl
->sym
->name
,
15336 sym
->name
, &sym
->declared_at
))
15341 /* Types with private components that came here by USE-association. */
15342 if (nl
->sym
->ts
.type
== BT_DERIVED
15343 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
15345 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
15346 "components and cannot be member of namelist %qs at %L",
15347 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15351 /* Types with private components that are defined in the same module. */
15352 if (nl
->sym
->ts
.type
== BT_DERIVED
15353 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
15354 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
15356 gfc_error ("NAMELIST object %qs has PRIVATE components and "
15357 "cannot be a member of PUBLIC namelist %qs at %L",
15358 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15365 /* 14.1.2 A module or internal procedure represent local entities
15366 of the same type as a namelist member and so are not allowed. */
15367 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
15369 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
15372 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
15373 if ((nl
->sym
== sym
->ns
->proc_name
)
15375 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
15380 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
15381 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
15383 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
15384 "attribute in %qs at %L", nlsym
->name
,
15385 &sym
->declared_at
);
15395 resolve_fl_parameter (gfc_symbol
*sym
)
15397 /* A parameter array's shape needs to be constant. */
15398 if (sym
->as
!= NULL
15399 && (sym
->as
->type
== AS_DEFERRED
15400 || is_non_constant_shape_array (sym
)))
15402 gfc_error ("Parameter array %qs at %L cannot be automatic "
15403 "or of deferred shape", sym
->name
, &sym
->declared_at
);
15407 /* Constraints on deferred type parameter. */
15408 if (!deferred_requirements (sym
))
15411 /* Make sure a parameter that has been implicitly typed still
15412 matches the implicit type, since PARAMETER statements can precede
15413 IMPLICIT statements. */
15414 if (sym
->attr
.implicit_type
15415 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
15418 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
15419 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
15423 /* Make sure the types of derived parameters are consistent. This
15424 type checking is deferred until resolution because the type may
15425 refer to a derived type from the host. */
15426 if (sym
->ts
.type
== BT_DERIVED
15427 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
15429 gfc_error ("Incompatible derived type in PARAMETER at %L",
15430 &sym
->value
->where
);
15434 /* F03:C509,C514. */
15435 if (sym
->ts
.type
== BT_CLASS
)
15437 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
15438 sym
->name
, &sym
->declared_at
);
15446 /* Called by resolve_symbol to check PDTs. */
15449 resolve_pdt (gfc_symbol
* sym
)
15451 gfc_symbol
*derived
= NULL
;
15452 gfc_actual_arglist
*param
;
15454 bool const_len_exprs
= true;
15455 bool assumed_len_exprs
= false;
15456 symbol_attribute
*attr
;
15458 if (sym
->ts
.type
== BT_DERIVED
)
15460 derived
= sym
->ts
.u
.derived
;
15461 attr
= &(sym
->attr
);
15463 else if (sym
->ts
.type
== BT_CLASS
)
15465 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
15466 attr
= &(CLASS_DATA (sym
)->attr
);
15469 gcc_unreachable ();
15471 gcc_assert (derived
->attr
.pdt_type
);
15473 for (param
= sym
->param_list
; param
; param
= param
->next
)
15475 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
15477 if (c
->attr
.pdt_kind
)
15480 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
15481 && c
->attr
.pdt_len
)
15482 const_len_exprs
= false;
15483 else if (param
->spec_type
== SPEC_ASSUMED
)
15484 assumed_len_exprs
= true;
15486 if (param
->spec_type
== SPEC_DEFERRED
15487 && !attr
->allocatable
&& !attr
->pointer
)
15488 gfc_error ("The object %qs at %L has a deferred LEN "
15489 "parameter %qs and is neither allocatable "
15490 "nor a pointer", sym
->name
, &sym
->declared_at
,
15495 if (!const_len_exprs
15496 && (sym
->ns
->proc_name
->attr
.is_main_program
15497 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15498 || sym
->attr
.save
!= SAVE_NONE
))
15499 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
15500 "SAVE attribute or be a variable declared in the "
15501 "main program, a module or a submodule(F08/C513)",
15502 sym
->name
, &sym
->declared_at
);
15504 if (assumed_len_exprs
&& !(sym
->attr
.dummy
15505 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
15506 gfc_error ("The object %qs at %L with ASSUMED type parameters "
15507 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
15508 sym
->name
, &sym
->declared_at
);
15512 /* Do anything necessary to resolve a symbol. Right now, we just
15513 assume that an otherwise unknown symbol is a variable. This sort
15514 of thing commonly happens for symbols in module. */
15517 resolve_symbol (gfc_symbol
*sym
)
15519 int check_constant
, mp_flag
;
15520 gfc_symtree
*symtree
;
15521 gfc_symtree
*this_symtree
;
15524 symbol_attribute class_attr
;
15525 gfc_array_spec
*as
;
15526 bool saved_specification_expr
;
15528 if (sym
->resolve_symbol_called
>= 1)
15530 sym
->resolve_symbol_called
= 1;
15532 /* No symbol will ever have union type; only components can be unions.
15533 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
15534 (just like derived type declaration symbols have flavor FL_DERIVED). */
15535 gcc_assert (sym
->ts
.type
!= BT_UNION
);
15537 /* Coarrayed polymorphic objects with allocatable or pointer components are
15538 yet unsupported for -fcoarray=lib. */
15539 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
15540 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
15541 && CLASS_DATA (sym
)->attr
.codimension
15542 && CLASS_DATA (sym
)->ts
.u
.derived
15543 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
15544 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
15546 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
15547 "type coarrays at %L are unsupported", &sym
->declared_at
);
15551 if (sym
->attr
.artificial
)
15554 if (sym
->attr
.unlimited_polymorphic
)
15557 if (UNLIKELY (flag_openmp
&& strcmp (sym
->name
, "omp_all_memory") == 0))
15559 gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
15560 "the OpenMP DEPEND clause", &sym
->declared_at
);
15564 if (sym
->attr
.flavor
== FL_UNKNOWN
15565 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
15566 && !sym
->attr
.generic
&& !sym
->attr
.external
15567 && sym
->attr
.if_source
== IFSRC_UNKNOWN
15568 && sym
->ts
.type
== BT_UNKNOWN
))
15571 /* If we find that a flavorless symbol is an interface in one of the
15572 parent namespaces, find its symtree in this namespace, free the
15573 symbol and set the symtree to point to the interface symbol. */
15574 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
15576 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
15577 if (symtree
&& (symtree
->n
.sym
->generic
||
15578 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
15579 && sym
->ns
->construct_entities
)))
15581 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
15583 if (this_symtree
->n
.sym
== sym
)
15585 symtree
->n
.sym
->refs
++;
15586 gfc_release_symbol (sym
);
15587 this_symtree
->n
.sym
= symtree
->n
.sym
;
15593 /* Otherwise give it a flavor according to such attributes as
15595 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
15596 && sym
->attr
.intrinsic
== 0)
15597 sym
->attr
.flavor
= FL_VARIABLE
;
15598 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
15600 sym
->attr
.flavor
= FL_PROCEDURE
;
15601 if (sym
->attr
.dimension
)
15602 sym
->attr
.function
= 1;
15606 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
15607 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15609 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
15610 && !resolve_procedure_interface (sym
))
15613 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
15614 && (sym
->attr
.procedure
|| sym
->attr
.external
))
15616 if (sym
->attr
.external
)
15617 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
15618 "at %L", &sym
->declared_at
);
15620 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
15621 "at %L", &sym
->declared_at
);
15626 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
15629 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
15630 && !resolve_fl_struct (sym
))
15633 /* Symbols that are module procedures with results (functions) have
15634 the types and array specification copied for type checking in
15635 procedures that call them, as well as for saving to a module
15636 file. These symbols can't stand the scrutiny that their results
15638 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
15640 /* Make sure that the intrinsic is consistent with its internal
15641 representation. This needs to be done before assigning a default
15642 type to avoid spurious warnings. */
15643 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
15644 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
15647 /* Resolve associate names. */
15649 resolve_assoc_var (sym
, true);
15651 /* Assign default type to symbols that need one and don't have one. */
15652 if (sym
->ts
.type
== BT_UNKNOWN
)
15654 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
15656 gfc_set_default_type (sym
, 1, NULL
);
15659 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
15660 && !sym
->attr
.function
&& !sym
->attr
.subroutine
15661 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
15662 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15664 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15666 /* The specific case of an external procedure should emit an error
15667 in the case that there is no implicit type. */
15670 if (!sym
->attr
.mixed_entry_master
)
15671 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
15675 /* Result may be in another namespace. */
15676 resolve_symbol (sym
->result
);
15678 if (!sym
->result
->attr
.proc_pointer
)
15680 sym
->ts
= sym
->result
->ts
;
15681 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
15682 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
15683 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
15684 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
15685 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
15690 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15692 bool saved_specification_expr
= specification_expr
;
15693 bool saved_formal_arg_flag
= formal_arg_flag
;
15695 specification_expr
= true;
15696 formal_arg_flag
= true;
15697 gfc_resolve_array_spec (sym
->result
->as
, false);
15698 formal_arg_flag
= saved_formal_arg_flag
;
15699 specification_expr
= saved_specification_expr
;
15702 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
&& sym
->ts
.u
.derived
)
15704 as
= CLASS_DATA (sym
)->as
;
15705 class_attr
= CLASS_DATA (sym
)->attr
;
15706 class_attr
.pointer
= class_attr
.class_pointer
;
15710 class_attr
= sym
->attr
;
15715 if (sym
->attr
.contiguous
15716 && (!class_attr
.dimension
15717 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
15718 && !class_attr
.pointer
)))
15720 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
15721 "array pointer or an assumed-shape or assumed-rank array",
15722 sym
->name
, &sym
->declared_at
);
15726 /* Assumed size arrays and assumed shape arrays must be dummy
15727 arguments. Array-spec's of implied-shape should have been resolved to
15728 AS_EXPLICIT already. */
15732 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
15733 specification expression. */
15734 if (as
->type
== AS_IMPLIED_SHAPE
)
15737 for (i
=0; i
<as
->rank
; i
++)
15739 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
15741 gfc_error ("Bad specification for assumed size array at %L",
15742 &as
->lower
[i
]->where
);
15749 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
15750 || as
->type
== AS_ASSUMED_SHAPE
)
15751 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
15753 if (as
->type
== AS_ASSUMED_SIZE
)
15754 gfc_error ("Assumed size array at %L must be a dummy argument",
15755 &sym
->declared_at
);
15757 gfc_error ("Assumed shape array at %L must be a dummy argument",
15758 &sym
->declared_at
);
15761 /* TS 29113, C535a. */
15762 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
15763 && !sym
->attr
.select_type_temporary
15764 && !(cs_base
&& cs_base
->current
15765 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
15767 gfc_error ("Assumed-rank array at %L must be a dummy argument",
15768 &sym
->declared_at
);
15771 if (as
->type
== AS_ASSUMED_RANK
15772 && (sym
->attr
.codimension
|| sym
->attr
.value
))
15774 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15775 "CODIMENSION attribute", &sym
->declared_at
);
15780 /* Make sure symbols with known intent or optional are really dummy
15781 variable. Because of ENTRY statement, this has to be deferred
15782 until resolution time. */
15784 if (!sym
->attr
.dummy
15785 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
15787 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
15791 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
15793 gfc_error ("%qs at %L cannot have the VALUE attribute because "
15794 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
15798 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
15800 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
15801 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
15803 gfc_error ("Character dummy variable %qs at %L with VALUE "
15804 "attribute must have constant length",
15805 sym
->name
, &sym
->declared_at
);
15809 if (sym
->ts
.is_c_interop
15810 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
15812 gfc_error ("C interoperable character dummy variable %qs at %L "
15813 "with VALUE attribute must have length one",
15814 sym
->name
, &sym
->declared_at
);
15819 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15820 && sym
->ts
.u
.derived
->attr
.generic
)
15822 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
15823 if (!sym
->ts
.u
.derived
)
15825 gfc_error ("The derived type %qs at %L is of type %qs, "
15826 "which has not been defined", sym
->name
,
15827 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15828 sym
->ts
.type
= BT_UNKNOWN
;
15833 /* Use the same constraints as TYPE(*), except for the type check
15834 and that only scalars and assumed-size arrays are permitted. */
15835 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
15837 if (!sym
->attr
.dummy
)
15839 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15840 "a dummy argument", sym
->name
, &sym
->declared_at
);
15844 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
15845 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
15846 && sym
->ts
.type
!= BT_COMPLEX
)
15848 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15849 "of type TYPE(*) or of an numeric intrinsic type",
15850 sym
->name
, &sym
->declared_at
);
15854 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15855 || sym
->attr
.pointer
|| sym
->attr
.value
)
15857 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15858 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15859 "attribute", sym
->name
, &sym
->declared_at
);
15863 if (sym
->attr
.intent
== INTENT_OUT
)
15865 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15866 "have the INTENT(OUT) attribute",
15867 sym
->name
, &sym
->declared_at
);
15870 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
15872 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15873 "either be a scalar or an assumed-size array",
15874 sym
->name
, &sym
->declared_at
);
15878 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15879 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15881 sym
->ts
.type
= BT_ASSUMED
;
15882 sym
->as
= gfc_get_array_spec ();
15883 sym
->as
->type
= AS_ASSUMED_SIZE
;
15885 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
15887 else if (sym
->ts
.type
== BT_ASSUMED
)
15889 /* TS 29113, C407a. */
15890 if (!sym
->attr
.dummy
)
15892 gfc_error ("Assumed type of variable %s at %L is only permitted "
15893 "for dummy variables", sym
->name
, &sym
->declared_at
);
15896 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15897 || sym
->attr
.pointer
|| sym
->attr
.value
)
15899 gfc_error ("Assumed-type variable %s at %L may not have the "
15900 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15901 sym
->name
, &sym
->declared_at
);
15904 if (sym
->attr
.intent
== INTENT_OUT
)
15906 gfc_error ("Assumed-type variable %s at %L may not have the "
15907 "INTENT(OUT) attribute",
15908 sym
->name
, &sym
->declared_at
);
15911 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
15913 gfc_error ("Assumed-type variable %s at %L shall not be an "
15914 "explicit-shape array", sym
->name
, &sym
->declared_at
);
15919 /* If the symbol is marked as bind(c), that it is declared at module level
15920 scope and verify its type and kind. Do not do the latter for symbols
15921 that are implicitly typed because that is handled in
15922 gfc_set_default_type. Handle dummy arguments and procedure definitions
15923 separately. Also, anything that is use associated is not handled here
15924 but instead is handled in the module it is declared in. Finally, derived
15925 type definitions are allowed to be BIND(C) since that only implies that
15926 they're interoperable, and they are checked fully for interoperability
15927 when a variable is declared of that type. */
15928 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15929 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15930 && sym
->attr
.flavor
!= FL_DERIVED
)
15934 /* First, make sure the variable is declared at the
15935 module-level scope (J3/04-007, Section 15.3). */
15936 if (!(sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
15937 && !sym
->attr
.in_common
)
15939 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15940 "is neither a COMMON block nor declared at the "
15941 "module level scope", sym
->name
, &(sym
->declared_at
));
15944 else if (sym
->ts
.type
== BT_CHARACTER
15945 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15946 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15947 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15949 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15950 sym
->name
, &sym
->declared_at
);
15953 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15955 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15957 else if (sym
->attr
.implicit_type
== 0)
15959 /* If type() declaration, we need to verify that the components
15960 of the given type are all C interoperable, etc. */
15961 if (sym
->ts
.type
== BT_DERIVED
&&
15962 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15964 /* Make sure the user marked the derived type as BIND(C). If
15965 not, call the verify routine. This could print an error
15966 for the derived type more than once if multiple variables
15967 of that type are declared. */
15968 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15969 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15973 /* Verify the variable itself as C interoperable if it
15974 is BIND(C). It is not possible for this to succeed if
15975 the verify_bind_c_derived_type failed, so don't have to handle
15976 any error returned by verify_bind_c_derived_type. */
15977 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15978 sym
->common_block
);
15983 /* clear the is_bind_c flag to prevent reporting errors more than
15984 once if something failed. */
15985 sym
->attr
.is_bind_c
= 0;
15990 /* If a derived type symbol has reached this point, without its
15991 type being declared, we have an error. Notice that most
15992 conditions that produce undefined derived types have already
15993 been dealt with. However, the likes of:
15994 implicit type(t) (t) ..... call foo (t) will get us here if
15995 the type is not declared in the scope of the implicit
15996 statement. Change the type to BT_UNKNOWN, both because it is so
15997 and to prevent an ICE. */
15998 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15999 && sym
->ts
.u
.derived
->components
== NULL
16000 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
16002 gfc_error ("The derived type %qs at %L is of type %qs, "
16003 "which has not been defined", sym
->name
,
16004 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16005 sym
->ts
.type
= BT_UNKNOWN
;
16009 /* Make sure that the derived type has been resolved and that the
16010 derived type is visible in the symbol's namespace, if it is a
16011 module function and is not PRIVATE. */
16012 if (sym
->ts
.type
== BT_DERIVED
16013 && sym
->ts
.u
.derived
->attr
.use_assoc
16014 && sym
->ns
->proc_name
16015 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
16016 && !resolve_fl_derived (sym
->ts
.u
.derived
))
16019 /* Unless the derived-type declaration is use associated, Fortran 95
16020 does not allow public entries of private derived types.
16021 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
16022 161 in 95-006r3. */
16023 if (sym
->ts
.type
== BT_DERIVED
16024 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
16025 && !sym
->ts
.u
.derived
->attr
.use_assoc
16026 && gfc_check_symbol_access (sym
)
16027 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16028 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
16029 "derived type %qs",
16030 (sym
->attr
.flavor
== FL_PARAMETER
)
16031 ? "parameter" : "variable",
16032 sym
->name
, &sym
->declared_at
,
16033 sym
->ts
.u
.derived
->name
))
16036 /* F2008, C1302. */
16037 if (sym
->ts
.type
== BT_DERIVED
16038 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
16039 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
16040 || sym
->ts
.u
.derived
->attr
.lock_comp
)
16041 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
16043 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
16044 "type LOCK_TYPE must be a coarray", sym
->name
,
16045 &sym
->declared_at
);
16049 /* TS18508, C702/C703. */
16050 if (sym
->ts
.type
== BT_DERIVED
16051 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
16052 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
16053 || sym
->ts
.u
.derived
->attr
.event_comp
)
16054 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
16056 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
16057 "type EVENT_TYPE must be a coarray", sym
->name
,
16058 &sym
->declared_at
);
16062 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
16063 default initialization is defined (5.1.2.4.4). */
16064 if (sym
->ts
.type
== BT_DERIVED
16066 && sym
->attr
.intent
== INTENT_OUT
16068 && sym
->as
->type
== AS_ASSUMED_SIZE
)
16070 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
16072 if (c
->initializer
)
16074 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
16075 "ASSUMED SIZE and so cannot have a default initializer",
16076 sym
->name
, &sym
->declared_at
);
16083 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
16084 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
16086 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
16087 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
16092 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
16093 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
16095 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
16096 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
16101 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
16102 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
16103 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
16104 && CLASS_DATA (sym
)->attr
.coarray_comp
))
16105 || class_attr
.codimension
)
16106 && (sym
->attr
.result
|| sym
->result
== sym
))
16108 gfc_error ("Function result %qs at %L shall not be a coarray or have "
16109 "a coarray component", sym
->name
, &sym
->declared_at
);
16114 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
16115 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
16117 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
16118 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
16123 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
16124 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
16125 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
16126 && CLASS_DATA (sym
)->attr
.coarray_comp
))
16127 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
16128 || class_attr
.allocatable
))
16130 gfc_error ("Variable %qs at %L with coarray component shall be a "
16131 "nonpointer, nonallocatable scalar, which is not a coarray",
16132 sym
->name
, &sym
->declared_at
);
16136 /* F2008, C526. The function-result case was handled above. */
16137 if (class_attr
.codimension
16138 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
16139 || sym
->attr
.select_type_temporary
16140 || sym
->attr
.associate_var
16141 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
16142 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
16143 || sym
->ns
->proc_name
->attr
.is_main_program
16144 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
16146 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
16147 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
16151 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
16152 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
16154 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
16155 "deferred shape", sym
->name
, &sym
->declared_at
);
16158 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
16159 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
16161 gfc_error ("Allocatable coarray variable %qs at %L must have "
16162 "deferred shape", sym
->name
, &sym
->declared_at
);
16167 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
16168 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
16169 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
16170 && CLASS_DATA (sym
)->attr
.coarray_comp
))
16171 || (class_attr
.codimension
&& class_attr
.allocatable
))
16172 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
16174 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
16175 "allocatable coarray or have coarray components",
16176 sym
->name
, &sym
->declared_at
);
16180 if (class_attr
.codimension
&& sym
->attr
.dummy
16181 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
16183 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
16184 "procedure %qs", sym
->name
, &sym
->declared_at
,
16185 sym
->ns
->proc_name
->name
);
16189 if (sym
->ts
.type
== BT_LOGICAL
16190 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
16191 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
16192 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
16195 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
16196 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
16198 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
16199 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
16200 "%L with non-C_Bool kind in BIND(C) procedure "
16201 "%qs", sym
->name
, &sym
->declared_at
,
16202 sym
->ns
->proc_name
->name
))
16204 else if (!gfc_logical_kinds
[i
].c_bool
16205 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
16206 "%qs at %L with non-C_Bool kind in "
16207 "BIND(C) procedure %qs", sym
->name
,
16209 sym
->attr
.function
? sym
->name
16210 : sym
->ns
->proc_name
->name
))
16214 switch (sym
->attr
.flavor
)
16217 if (!resolve_fl_variable (sym
, mp_flag
))
16222 if (sym
->formal
&& !sym
->formal_ns
)
16224 /* Check that none of the arguments are a namelist. */
16225 gfc_formal_arglist
*formal
= sym
->formal
;
16227 for (; formal
; formal
= formal
->next
)
16228 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
16230 gfc_error ("Namelist %qs cannot be an argument to "
16231 "subroutine or function at %L",
16232 formal
->sym
->name
, &sym
->declared_at
);
16237 if (!resolve_fl_procedure (sym
, mp_flag
))
16242 if (!resolve_fl_namelist (sym
))
16247 if (!resolve_fl_parameter (sym
))
16255 /* Resolve array specifier. Check as well some constraints
16256 on COMMON blocks. */
16258 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
16260 /* Set the formal_arg_flag so that check_conflict will not throw
16261 an error for host associated variables in the specification
16262 expression for an array_valued function. */
16263 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
16264 formal_arg_flag
= true;
16266 saved_specification_expr
= specification_expr
;
16267 specification_expr
= true;
16268 gfc_resolve_array_spec (sym
->as
, check_constant
);
16269 specification_expr
= saved_specification_expr
;
16271 formal_arg_flag
= false;
16273 /* Resolve formal namespaces. */
16274 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
16275 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
16276 gfc_resolve (sym
->formal_ns
);
16278 /* Make sure the formal namespace is present. */
16279 if (sym
->formal
&& !sym
->formal_ns
)
16281 gfc_formal_arglist
*formal
= sym
->formal
;
16282 while (formal
&& !formal
->sym
)
16283 formal
= formal
->next
;
16287 sym
->formal_ns
= formal
->sym
->ns
;
16288 if (sym
->formal_ns
&& sym
->ns
!= formal
->sym
->ns
)
16289 sym
->formal_ns
->refs
++;
16293 /* Check threadprivate restrictions. */
16294 if (sym
->attr
.threadprivate
16295 && !(sym
->attr
.save
|| sym
->attr
.data
|| sym
->attr
.in_common
)
16296 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
16297 && sym
->module
== NULL
16298 && (sym
->ns
->proc_name
== NULL
16299 || (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
16300 && !sym
->ns
->proc_name
->attr
.is_main_program
)))
16301 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
16303 /* Check omp declare target restrictions. */
16304 if (sym
->attr
.omp_declare_target
16305 && sym
->attr
.flavor
== FL_VARIABLE
16307 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
16308 && (!sym
->attr
.in_common
16309 && sym
->module
== NULL
16310 && (sym
->ns
->proc_name
== NULL
16311 || (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
16312 && !sym
->ns
->proc_name
->attr
.is_main_program
))))
16313 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
16314 sym
->name
, &sym
->declared_at
);
16316 /* If we have come this far we can apply default-initializers, as
16317 described in 14.7.5, to those variables that have not already
16318 been assigned one. */
16319 if (sym
->ts
.type
== BT_DERIVED
16321 && !sym
->attr
.allocatable
16322 && !sym
->attr
.alloc_comp
)
16324 symbol_attribute
*a
= &sym
->attr
;
16326 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
16327 && !a
->in_common
&& !a
->use_assoc
16329 && !((a
->function
|| a
->result
)
16331 || sym
->ts
.u
.derived
->attr
.alloc_comp
16332 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
16333 && !(a
->function
&& sym
!= sym
->result
))
16334 || (a
->dummy
&& !a
->pointer
&& a
->intent
== INTENT_OUT
16335 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
))
16336 apply_default_init (sym
);
16337 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
16338 && (sym
->ts
.u
.derived
->attr
.alloc_comp
16339 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
16340 /* Mark the result symbol to be referenced, when it has allocatable
16342 sym
->result
->attr
.referenced
= 1;
16345 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
16346 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
16347 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
16348 && !CLASS_DATA (sym
)->attr
.class_pointer
16349 && !CLASS_DATA (sym
)->attr
.allocatable
)
16350 apply_default_init (sym
);
16352 /* If this symbol has a type-spec, check it. */
16353 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
16354 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
16355 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
16358 if (sym
->param_list
)
16363 /************* Resolve DATA statements *************/
16367 gfc_data_value
*vnode
;
16373 /* Advance the values structure to point to the next value in the data list. */
16376 next_data_value (void)
16378 while (mpz_cmp_ui (values
.left
, 0) == 0)
16381 if (values
.vnode
->next
== NULL
)
16384 values
.vnode
= values
.vnode
->next
;
16385 mpz_set (values
.left
, values
.vnode
->repeat
);
16393 check_data_variable (gfc_data_variable
*var
, locus
*where
)
16399 ar_type mark
= AR_UNKNOWN
;
16401 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
16407 if (!gfc_resolve_expr (var
->expr
))
16411 mpz_init_set_si (offset
, 0);
16414 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
16415 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
16416 e
= e
->value
.function
.actual
->expr
;
16418 if (e
->expr_type
!= EXPR_VARIABLE
)
16420 gfc_error ("Expecting definable entity near %L", where
);
16424 sym
= e
->symtree
->n
.sym
;
16426 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
16428 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
16429 sym
->name
, &sym
->declared_at
);
16433 if (e
->ref
== NULL
&& sym
->as
)
16435 gfc_error ("DATA array %qs at %L must be specified in a previous"
16436 " declaration", sym
->name
, where
);
16440 if (gfc_is_coindexed (e
))
16442 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
16447 has_pointer
= sym
->attr
.pointer
;
16449 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
16451 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
16456 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_FULL
)
16458 gfc_error ("DATA element %qs at %L is a pointer and so must "
16459 "be a full array", sym
->name
, where
);
16463 if (values
.vnode
->expr
->expr_type
== EXPR_CONSTANT
)
16465 gfc_error ("DATA object near %L has the pointer attribute "
16466 "and the corresponding DATA value is not a valid "
16467 "initial-data-target", where
);
16472 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.allocatable
)
16474 gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
16475 "attribute", ref
->u
.c
.component
->name
, &e
->where
);
16480 if (e
->rank
== 0 || has_pointer
)
16482 mpz_init_set_ui (size
, 1);
16489 /* Find the array section reference. */
16490 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
16492 if (ref
->type
!= REF_ARRAY
)
16494 if (ref
->u
.ar
.type
== AR_ELEMENT
)
16500 /* Set marks according to the reference pattern. */
16501 switch (ref
->u
.ar
.type
)
16509 /* Get the start position of array section. */
16510 gfc_get_section_index (ar
, section_index
, &offset
);
16515 gcc_unreachable ();
16518 if (!gfc_array_size (e
, &size
))
16520 gfc_error ("Nonconstant array section at %L in DATA statement",
16522 mpz_clear (offset
);
16529 while (mpz_cmp_ui (size
, 0) > 0)
16531 if (!next_data_value ())
16533 gfc_error ("DATA statement at %L has more variables than values",
16539 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
16543 /* If we have more than one element left in the repeat count,
16544 and we have more than one element left in the target variable,
16545 then create a range assignment. */
16546 /* FIXME: Only done for full arrays for now, since array sections
16548 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
16549 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
16553 if (mpz_cmp (size
, values
.left
) >= 0)
16555 mpz_init_set (range
, values
.left
);
16556 mpz_sub (size
, size
, values
.left
);
16557 mpz_set_ui (values
.left
, 0);
16561 mpz_init_set (range
, size
);
16562 mpz_sub (values
.left
, values
.left
, size
);
16563 mpz_set_ui (size
, 0);
16566 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16569 mpz_add (offset
, offset
, range
);
16576 /* Assign initial value to symbol. */
16579 mpz_sub_ui (values
.left
, values
.left
, 1);
16580 mpz_sub_ui (size
, size
, 1);
16582 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16587 if (mark
== AR_FULL
)
16588 mpz_add_ui (offset
, offset
, 1);
16590 /* Modify the array section indexes and recalculate the offset
16591 for next element. */
16592 else if (mark
== AR_SECTION
)
16593 gfc_advance_section (section_index
, ar
, &offset
);
16597 if (mark
== AR_SECTION
)
16599 for (i
= 0; i
< ar
->dimen
; i
++)
16600 mpz_clear (section_index
[i
]);
16604 mpz_clear (offset
);
16610 static bool traverse_data_var (gfc_data_variable
*, locus
*);
16612 /* Iterate over a list of elements in a DATA statement. */
16615 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
16618 iterator_stack frame
;
16619 gfc_expr
*e
, *start
, *end
, *step
;
16620 bool retval
= true;
16622 mpz_init (frame
.value
);
16625 start
= gfc_copy_expr (var
->iter
.start
);
16626 end
= gfc_copy_expr (var
->iter
.end
);
16627 step
= gfc_copy_expr (var
->iter
.step
);
16629 if (!gfc_simplify_expr (start
, 1)
16630 || start
->expr_type
!= EXPR_CONSTANT
)
16632 gfc_error ("start of implied-do loop at %L could not be "
16633 "simplified to a constant value", &start
->where
);
16637 if (!gfc_simplify_expr (end
, 1)
16638 || end
->expr_type
!= EXPR_CONSTANT
)
16640 gfc_error ("end of implied-do loop at %L could not be "
16641 "simplified to a constant value", &end
->where
);
16645 if (!gfc_simplify_expr (step
, 1)
16646 || step
->expr_type
!= EXPR_CONSTANT
)
16648 gfc_error ("step of implied-do loop at %L could not be "
16649 "simplified to a constant value", &step
->where
);
16653 if (mpz_cmp_si (step
->value
.integer
, 0) == 0)
16655 gfc_error ("step of implied-do loop at %L shall not be zero",
16661 mpz_set (trip
, end
->value
.integer
);
16662 mpz_sub (trip
, trip
, start
->value
.integer
);
16663 mpz_add (trip
, trip
, step
->value
.integer
);
16665 mpz_div (trip
, trip
, step
->value
.integer
);
16667 mpz_set (frame
.value
, start
->value
.integer
);
16669 frame
.prev
= iter_stack
;
16670 frame
.variable
= var
->iter
.var
->symtree
;
16671 iter_stack
= &frame
;
16673 while (mpz_cmp_ui (trip
, 0) > 0)
16675 if (!traverse_data_var (var
->list
, where
))
16681 e
= gfc_copy_expr (var
->expr
);
16682 if (!gfc_simplify_expr (e
, 1))
16689 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
16691 mpz_sub_ui (trip
, trip
, 1);
16695 mpz_clear (frame
.value
);
16698 gfc_free_expr (start
);
16699 gfc_free_expr (end
);
16700 gfc_free_expr (step
);
16702 iter_stack
= frame
.prev
;
16707 /* Type resolve variables in the variable list of a DATA statement. */
16710 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
16714 for (; var
; var
= var
->next
)
16716 if (var
->expr
== NULL
)
16717 t
= traverse_data_list (var
, where
);
16719 t
= check_data_variable (var
, where
);
16729 /* Resolve the expressions and iterators associated with a data statement.
16730 This is separate from the assignment checking because data lists should
16731 only be resolved once. */
16734 resolve_data_variables (gfc_data_variable
*d
)
16736 for (; d
; d
= d
->next
)
16738 if (d
->list
== NULL
)
16740 if (!gfc_resolve_expr (d
->expr
))
16745 if (!gfc_resolve_iterator (&d
->iter
, false, true))
16748 if (!resolve_data_variables (d
->list
))
16757 /* Resolve a single DATA statement. We implement this by storing a pointer to
16758 the value list into static variables, and then recursively traversing the
16759 variables list, expanding iterators and such. */
16762 resolve_data (gfc_data
*d
)
16765 if (!resolve_data_variables (d
->var
))
16768 values
.vnode
= d
->value
;
16769 if (d
->value
== NULL
)
16770 mpz_set_ui (values
.left
, 0);
16772 mpz_set (values
.left
, d
->value
->repeat
);
16774 if (!traverse_data_var (d
->var
, &d
->where
))
16777 /* At this point, we better not have any values left. */
16779 if (next_data_value ())
16780 gfc_error ("DATA statement at %L has more values than variables",
16785 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
16786 accessed by host or use association, is a dummy argument to a pure function,
16787 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
16788 is storage associated with any such variable, shall not be used in the
16789 following contexts: (clients of this function). */
16791 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
16792 procedure. Returns zero if assignment is OK, nonzero if there is a
16795 gfc_impure_variable (gfc_symbol
*sym
)
16800 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
16803 /* Check if the symbol's ns is inside the pure procedure. */
16804 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16808 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
16812 proc
= sym
->ns
->proc_name
;
16813 if (sym
->attr
.dummy
16814 && !sym
->attr
.value
16815 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
16816 || proc
->attr
.function
))
16819 /* TODO: Sort out what can be storage associated, if anything, and include
16820 it here. In principle equivalences should be scanned but it does not
16821 seem to be possible to storage associate an impure variable this way. */
16826 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
16827 current namespace is inside a pure procedure. */
16830 gfc_pure (gfc_symbol
*sym
)
16832 symbol_attribute attr
;
16837 /* Check if the current namespace or one of its parents
16838 belongs to a pure procedure. */
16839 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16841 sym
= ns
->proc_name
;
16845 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
16853 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
16857 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16858 checks if the current namespace is implicitly pure. Note that this
16859 function returns false for a PURE procedure. */
16862 gfc_implicit_pure (gfc_symbol
*sym
)
16868 /* Check if the current procedure is implicit_pure. Walk up
16869 the procedure list until we find a procedure. */
16870 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16872 sym
= ns
->proc_name
;
16876 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16881 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
16882 && !sym
->attr
.pure
;
16887 gfc_unset_implicit_pure (gfc_symbol
*sym
)
16893 /* Check if the current procedure is implicit_pure. Walk up
16894 the procedure list until we find a procedure. */
16895 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16897 sym
= ns
->proc_name
;
16901 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16906 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16907 sym
->attr
.implicit_pure
= 0;
16909 sym
->attr
.pure
= 0;
16913 /* Test whether the current procedure is elemental or not. */
16916 gfc_elemental (gfc_symbol
*sym
)
16918 symbol_attribute attr
;
16921 sym
= gfc_current_ns
->proc_name
;
16926 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
16930 /* Warn about unused labels. */
16933 warn_unused_fortran_label (gfc_st_label
*label
)
16938 warn_unused_fortran_label (label
->left
);
16940 if (label
->defined
== ST_LABEL_UNKNOWN
)
16943 switch (label
->referenced
)
16945 case ST_LABEL_UNKNOWN
:
16946 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
16947 label
->value
, &label
->where
);
16950 case ST_LABEL_BAD_TARGET
:
16951 gfc_warning (OPT_Wunused_label
,
16952 "Label %d at %L defined but cannot be used",
16953 label
->value
, &label
->where
);
16960 warn_unused_fortran_label (label
->right
);
16964 /* Returns the sequence type of a symbol or sequence. */
16967 sequence_type (gfc_typespec ts
)
16976 if (ts
.u
.derived
->components
== NULL
)
16977 return SEQ_NONDEFAULT
;
16979 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16980 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16981 if (sequence_type (c
->ts
) != result
)
16987 if (ts
.kind
!= gfc_default_character_kind
)
16988 return SEQ_NONDEFAULT
;
16990 return SEQ_CHARACTER
;
16993 if (ts
.kind
!= gfc_default_integer_kind
)
16994 return SEQ_NONDEFAULT
;
16996 return SEQ_NUMERIC
;
16999 if (!(ts
.kind
== gfc_default_real_kind
17000 || ts
.kind
== gfc_default_double_kind
))
17001 return SEQ_NONDEFAULT
;
17003 return SEQ_NUMERIC
;
17006 if (ts
.kind
!= gfc_default_complex_kind
)
17007 return SEQ_NONDEFAULT
;
17009 return SEQ_NUMERIC
;
17012 if (ts
.kind
!= gfc_default_logical_kind
)
17013 return SEQ_NONDEFAULT
;
17015 return SEQ_NUMERIC
;
17018 return SEQ_NONDEFAULT
;
17023 /* Resolve derived type EQUIVALENCE object. */
17026 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
17028 gfc_component
*c
= derived
->components
;
17033 /* Shall not be an object of nonsequence derived type. */
17034 if (!derived
->attr
.sequence
)
17036 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
17037 "attribute to be an EQUIVALENCE object", sym
->name
,
17042 /* Shall not have allocatable components. */
17043 if (derived
->attr
.alloc_comp
)
17045 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
17046 "components to be an EQUIVALENCE object",sym
->name
,
17051 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
17053 gfc_error ("Derived type variable %qs at %L with default "
17054 "initialization cannot be in EQUIVALENCE with a variable "
17055 "in COMMON", sym
->name
, &e
->where
);
17059 for (; c
; c
= c
->next
)
17061 if (gfc_bt_struct (c
->ts
.type
)
17062 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
17065 /* Shall not be an object of sequence derived type containing a pointer
17066 in the structure. */
17067 if (c
->attr
.pointer
)
17069 gfc_error ("Derived type variable %qs at %L with pointer "
17070 "component(s) cannot be an EQUIVALENCE object",
17071 sym
->name
, &e
->where
);
17079 /* Resolve equivalence object.
17080 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
17081 an allocatable array, an object of nonsequence derived type, an object of
17082 sequence derived type containing a pointer at any level of component
17083 selection, an automatic object, a function name, an entry name, a result
17084 name, a named constant, a structure component, or a subobject of any of
17085 the preceding objects. A substring shall not have length zero. A
17086 derived type shall not have components with default initialization nor
17087 shall two objects of an equivalence group be initialized.
17088 Either all or none of the objects shall have an protected attribute.
17089 The simple constraints are done in symbol.cc(check_conflict) and the rest
17090 are implemented here. */
17093 resolve_equivalence (gfc_equiv
*eq
)
17096 gfc_symbol
*first_sym
;
17099 locus
*last_where
= NULL
;
17100 seq_type eq_type
, last_eq_type
;
17101 gfc_typespec
*last_ts
;
17102 int object
, cnt_protected
;
17105 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
17107 first_sym
= eq
->expr
->symtree
->n
.sym
;
17111 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
17115 e
->ts
= e
->symtree
->n
.sym
->ts
;
17116 /* match_varspec might not know yet if it is seeing
17117 array reference or substring reference, as it doesn't
17119 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
17121 gfc_ref
*ref
= e
->ref
;
17122 sym
= e
->symtree
->n
.sym
;
17124 if (sym
->attr
.dimension
)
17126 ref
->u
.ar
.as
= sym
->as
;
17130 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
17131 if (e
->ts
.type
== BT_CHARACTER
17133 && ref
->type
== REF_ARRAY
17134 && ref
->u
.ar
.dimen
== 1
17135 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
17136 && ref
->u
.ar
.stride
[0] == NULL
)
17138 gfc_expr
*start
= ref
->u
.ar
.start
[0];
17139 gfc_expr
*end
= ref
->u
.ar
.end
[0];
17142 /* Optimize away the (:) reference. */
17143 if (start
== NULL
&& end
== NULL
)
17146 e
->ref
= ref
->next
;
17148 e
->ref
->next
= ref
->next
;
17153 ref
->type
= REF_SUBSTRING
;
17155 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
17157 ref
->u
.ss
.start
= start
;
17158 if (end
== NULL
&& e
->ts
.u
.cl
)
17159 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
17160 ref
->u
.ss
.end
= end
;
17161 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
17168 /* Any further ref is an error. */
17171 gcc_assert (ref
->type
== REF_ARRAY
);
17172 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
17178 if (!gfc_resolve_expr (e
))
17181 sym
= e
->symtree
->n
.sym
;
17183 if (sym
->attr
.is_protected
)
17185 if (cnt_protected
> 0 && cnt_protected
!= object
)
17187 gfc_error ("Either all or none of the objects in the "
17188 "EQUIVALENCE set at %L shall have the "
17189 "PROTECTED attribute",
17194 /* Shall not equivalence common block variables in a PURE procedure. */
17195 if (sym
->ns
->proc_name
17196 && sym
->ns
->proc_name
->attr
.pure
17197 && sym
->attr
.in_common
)
17199 /* Need to check for symbols that may have entered the pure
17200 procedure via a USE statement. */
17201 bool saw_sym
= false;
17202 if (sym
->ns
->use_stmts
)
17205 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
17206 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
17212 gfc_error ("COMMON block member %qs at %L cannot be an "
17213 "EQUIVALENCE object in the pure procedure %qs",
17214 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
17218 /* Shall not be a named constant. */
17219 if (e
->expr_type
== EXPR_CONSTANT
)
17221 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
17222 "object", sym
->name
, &e
->where
);
17226 if (e
->ts
.type
== BT_DERIVED
17227 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
17230 /* Check that the types correspond correctly:
17232 A numeric sequence structure may be equivalenced to another sequence
17233 structure, an object of default integer type, default real type, double
17234 precision real type, default logical type such that components of the
17235 structure ultimately only become associated to objects of the same
17236 kind. A character sequence structure may be equivalenced to an object
17237 of default character kind or another character sequence structure.
17238 Other objects may be equivalenced only to objects of the same type and
17239 kind parameters. */
17241 /* Identical types are unconditionally OK. */
17242 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
17243 goto identical_types
;
17245 last_eq_type
= sequence_type (*last_ts
);
17246 eq_type
= sequence_type (sym
->ts
);
17248 /* Since the pair of objects is not of the same type, mixed or
17249 non-default sequences can be rejected. */
17251 msg
= "Sequence %s with mixed components in EQUIVALENCE "
17252 "statement at %L with different type objects";
17254 && last_eq_type
== SEQ_MIXED
17256 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
17257 || (eq_type
== SEQ_MIXED
17258 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
17261 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
17262 "statement at %L with objects of different type";
17264 && last_eq_type
== SEQ_NONDEFAULT
17266 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
17267 || (eq_type
== SEQ_NONDEFAULT
17268 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
17271 msg
="Non-CHARACTER object %qs in default CHARACTER "
17272 "EQUIVALENCE statement at %L";
17273 if (last_eq_type
== SEQ_CHARACTER
17274 && eq_type
!= SEQ_CHARACTER
17275 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
17278 msg
="Non-NUMERIC object %qs in default NUMERIC "
17279 "EQUIVALENCE statement at %L";
17280 if (last_eq_type
== SEQ_NUMERIC
17281 && eq_type
!= SEQ_NUMERIC
17282 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
17288 last_where
= &e
->where
;
17293 /* Shall not be an automatic array. */
17294 if (e
->ref
->type
== REF_ARRAY
&& is_non_constant_shape_array (sym
))
17296 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
17297 "an EQUIVALENCE object", sym
->name
, &e
->where
);
17304 /* Shall not be a structure component. */
17305 if (r
->type
== REF_COMPONENT
)
17307 gfc_error ("Structure component %qs at %L cannot be an "
17308 "EQUIVALENCE object",
17309 r
->u
.c
.component
->name
, &e
->where
);
17313 /* A substring shall not have length zero. */
17314 if (r
->type
== REF_SUBSTRING
)
17316 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
17318 gfc_error ("Substring at %L has length zero",
17319 &r
->u
.ss
.start
->where
);
17329 /* Function called by resolve_fntype to flag other symbols used in the
17330 length type parameter specification of function results. */
17333 flag_fn_result_spec (gfc_expr
*expr
,
17335 int *f ATTRIBUTE_UNUSED
)
17340 if (expr
->expr_type
== EXPR_VARIABLE
)
17342 s
= expr
->symtree
->n
.sym
;
17343 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
17349 gfc_error ("Self reference in character length expression "
17350 "for %qs at %L", sym
->name
, &expr
->where
);
17354 if (!s
->fn_result_spec
17355 && s
->attr
.flavor
== FL_PARAMETER
)
17357 /* Function contained in a module.... */
17358 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
17361 s
->fn_result_spec
= 1;
17362 /* Make sure that this symbol is translated as a module
17364 st
= gfc_get_unique_symtree (ns
);
17368 /* ... which is use associated and called. */
17369 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
17371 /* External function matched with an interface. */
17374 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
17375 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
17376 && s
->ns
->proc_name
->attr
.function
))
17377 s
->fn_result_spec
= 1;
17384 /* Resolve function and ENTRY types, issue diagnostics if needed. */
17387 resolve_fntype (gfc_namespace
*ns
)
17389 gfc_entry_list
*el
;
17392 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
17395 /* If there are any entries, ns->proc_name is the entry master
17396 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
17398 sym
= ns
->entries
->sym
;
17400 sym
= ns
->proc_name
;
17401 if (sym
->result
== sym
17402 && sym
->ts
.type
== BT_UNKNOWN
17403 && !gfc_set_default_type (sym
, 0, NULL
)
17404 && !sym
->attr
.untyped
)
17406 gfc_error ("Function %qs at %L has no IMPLICIT type",
17407 sym
->name
, &sym
->declared_at
);
17408 sym
->attr
.untyped
= 1;
17411 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
17412 && !sym
->attr
.contained
17413 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
17414 && gfc_check_symbol_access (sym
))
17416 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
17417 "%L of PRIVATE type %qs", sym
->name
,
17418 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
17422 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
17424 if (el
->sym
->result
== el
->sym
17425 && el
->sym
->ts
.type
== BT_UNKNOWN
17426 && !gfc_set_default_type (el
->sym
, 0, NULL
)
17427 && !el
->sym
->attr
.untyped
)
17429 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
17430 el
->sym
->name
, &el
->sym
->declared_at
);
17431 el
->sym
->attr
.untyped
= 1;
17435 if (sym
->ts
.type
== BT_CHARACTER
17436 && sym
->ts
.u
.cl
->length
17437 && sym
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
17438 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
17442 /* 12.3.2.1.1 Defined operators. */
17445 check_uop_procedure (gfc_symbol
*sym
, locus where
)
17447 gfc_formal_arglist
*formal
;
17449 if (!sym
->attr
.function
)
17451 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
17452 sym
->name
, &where
);
17456 if (sym
->ts
.type
== BT_CHARACTER
17457 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
17458 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
17459 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
17461 gfc_error ("User operator procedure %qs at %L cannot be assumed "
17462 "character length", sym
->name
, &where
);
17466 formal
= gfc_sym_get_dummy_args (sym
);
17467 if (!formal
|| !formal
->sym
)
17469 gfc_error ("User operator procedure %qs at %L must have at least "
17470 "one argument", sym
->name
, &where
);
17474 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
17476 gfc_error ("First argument of operator interface at %L must be "
17477 "INTENT(IN)", &where
);
17481 if (formal
->sym
->attr
.optional
)
17483 gfc_error ("First argument of operator interface at %L cannot be "
17484 "optional", &where
);
17488 formal
= formal
->next
;
17489 if (!formal
|| !formal
->sym
)
17492 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
17494 gfc_error ("Second argument of operator interface at %L must be "
17495 "INTENT(IN)", &where
);
17499 if (formal
->sym
->attr
.optional
)
17501 gfc_error ("Second argument of operator interface at %L cannot be "
17502 "optional", &where
);
17508 gfc_error ("Operator interface at %L must have, at most, two "
17509 "arguments", &where
);
17517 gfc_resolve_uops (gfc_symtree
*symtree
)
17519 gfc_interface
*itr
;
17521 if (symtree
== NULL
)
17524 gfc_resolve_uops (symtree
->left
);
17525 gfc_resolve_uops (symtree
->right
);
17527 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
17528 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
17532 /* Examine all of the expressions associated with a program unit,
17533 assign types to all intermediate expressions, make sure that all
17534 assignments are to compatible types and figure out which names
17535 refer to which functions or subroutines. It doesn't check code
17536 block, which is handled by gfc_resolve_code. */
17539 resolve_types (gfc_namespace
*ns
)
17545 gfc_namespace
* old_ns
= gfc_current_ns
;
17546 bool recursive
= ns
->proc_name
&& ns
->proc_name
->attr
.recursive
;
17548 if (ns
->types_resolved
)
17551 /* Check that all IMPLICIT types are ok. */
17552 if (!ns
->seen_implicit_none
)
17555 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
17556 if (ns
->set_flag
[letter
]
17557 && !resolve_typespec_used (&ns
->default_type
[letter
],
17558 &ns
->implicit_loc
[letter
], NULL
))
17562 gfc_current_ns
= ns
;
17564 resolve_entries (ns
);
17566 resolve_common_vars (&ns
->blank_common
, false);
17567 resolve_common_blocks (ns
->common_root
);
17569 resolve_contained_functions (ns
);
17571 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
17572 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
17573 gfc_resolve_formal_arglist (ns
->proc_name
);
17575 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
17577 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
17578 resolve_charlen (cl
);
17580 gfc_traverse_ns (ns
, resolve_symbol
);
17582 resolve_fntype (ns
);
17584 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17586 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
17587 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
17588 "also be PURE", n
->proc_name
->name
,
17589 &n
->proc_name
->declared_at
);
17595 gfc_do_concurrent_flag
= 0;
17596 gfc_check_interfaces (ns
);
17598 gfc_traverse_ns (ns
, resolve_values
);
17600 if (ns
->save_all
|| (!flag_automatic
&& !recursive
))
17604 for (d
= ns
->data
; d
; d
= d
->next
)
17608 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
17610 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
17612 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
17613 resolve_equivalence (eq
);
17615 /* Warn about unused labels. */
17616 if (warn_unused_label
)
17617 warn_unused_fortran_label (ns
->st_labels
);
17619 gfc_resolve_uops (ns
->uop_root
);
17621 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
17623 gfc_resolve_omp_declare_simd (ns
);
17625 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
17627 ns
->types_resolved
= 1;
17629 gfc_current_ns
= old_ns
;
17633 /* Call gfc_resolve_code recursively. */
17636 resolve_codes (gfc_namespace
*ns
)
17639 bitmap_obstack old_obstack
;
17641 if (ns
->resolved
== 1)
17644 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17647 gfc_current_ns
= ns
;
17649 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
17650 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
17653 /* Set to an out of range value. */
17654 current_entry_id
= -1;
17656 old_obstack
= labels_obstack
;
17657 bitmap_obstack_initialize (&labels_obstack
);
17659 gfc_resolve_oacc_declare (ns
);
17660 gfc_resolve_oacc_routines (ns
);
17661 gfc_resolve_omp_local_vars (ns
);
17662 gfc_resolve_code (ns
->code
, ns
);
17664 bitmap_obstack_release (&labels_obstack
);
17665 labels_obstack
= old_obstack
;
17669 /* This function is called after a complete program unit has been compiled.
17670 Its purpose is to examine all of the expressions associated with a program
17671 unit, assign types to all intermediate expressions, make sure that all
17672 assignments are to compatible types and figure out which names refer to
17673 which functions or subroutines. */
17676 gfc_resolve (gfc_namespace
*ns
)
17678 gfc_namespace
*old_ns
;
17679 code_stack
*old_cs_base
;
17680 struct gfc_omp_saved_state old_omp_state
;
17686 old_ns
= gfc_current_ns
;
17687 old_cs_base
= cs_base
;
17689 /* As gfc_resolve can be called during resolution of an OpenMP construct
17690 body, we should clear any state associated to it, so that say NS's
17691 DO loops are not interpreted as OpenMP loops. */
17692 if (!ns
->construct_entities
)
17693 gfc_omp_save_and_clear_state (&old_omp_state
);
17695 resolve_types (ns
);
17696 component_assignment_level
= 0;
17697 resolve_codes (ns
);
17699 if (ns
->omp_assumes
)
17700 gfc_resolve_omp_assumptions (ns
->omp_assumes
);
17702 gfc_current_ns
= old_ns
;
17703 cs_base
= old_cs_base
;
17706 gfc_run_passes (ns
);
17708 if (!ns
->construct_entities
)
17709 gfc_omp_restore_state (&old_omp_state
);