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 /* These derived types with an incomplete namespace, arising from use
3482 association, cause gfc_get_derived_vtab to segfault. If the function
3483 namespace does not suffice, something is badly wrong. */
3484 if (expr
->ts
.type
== BT_DERIVED
3485 && !expr
->ts
.u
.derived
->ns
->proc_name
)
3488 gfc_find_symbol (expr
->ts
.u
.derived
->name
, expr
->symtree
->n
.sym
->ns
, 1, &der
);
3491 expr
->ts
.u
.derived
->refs
--;
3492 expr
->ts
.u
.derived
= der
;
3496 expr
->ts
.u
.derived
->ns
= expr
->symtree
->n
.sym
->ns
;
3499 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3501 if (expr
->value
.function
.esym
)
3502 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3504 update_current_proc_array_outer_dependency (sym
);
3507 /* typebound procedure: Assume the worst. */
3508 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3510 if (expr
->value
.function
.esym
3511 && expr
->value
.function
.esym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
))
3512 gfc_warning (OPT_Wdeprecated_declarations
,
3513 "Using function %qs at %L is deprecated",
3514 sym
->name
, &expr
->where
);
3519 /************* Subroutine resolution *************/
3522 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3529 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3533 else if (gfc_do_concurrent_flag
)
3535 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3539 else if (gfc_pure (NULL
))
3541 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3545 gfc_unset_implicit_pure (NULL
);
3551 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3555 if (sym
->attr
.generic
)
3557 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3560 c
->resolved_sym
= s
;
3561 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3566 /* TODO: Need to search for elemental references in generic interface. */
3569 if (sym
->attr
.intrinsic
)
3570 return gfc_intrinsic_sub_interface (c
, 0);
3577 resolve_generic_s (gfc_code
*c
)
3582 sym
= c
->symtree
->n
.sym
;
3586 m
= resolve_generic_s0 (c
, sym
);
3589 else if (m
== MATCH_ERROR
)
3593 if (sym
->ns
->parent
== NULL
)
3595 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3599 if (!generic_sym (sym
))
3603 /* Last ditch attempt. See if the reference is to an intrinsic
3604 that possesses a matching interface. 14.1.2.4 */
3605 sym
= c
->symtree
->n
.sym
;
3607 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3609 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3610 sym
->name
, &c
->loc
);
3614 m
= gfc_intrinsic_sub_interface (c
, 0);
3618 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3619 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3625 /* Resolve a subroutine call known to be specific. */
3628 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3632 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3634 if (sym
->attr
.dummy
)
3636 sym
->attr
.proc
= PROC_DUMMY
;
3640 sym
->attr
.proc
= PROC_EXTERNAL
;
3644 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3647 if (sym
->attr
.intrinsic
)
3649 m
= gfc_intrinsic_sub_interface (c
, 1);
3653 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3654 "with an intrinsic", sym
->name
, &c
->loc
);
3662 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3664 c
->resolved_sym
= sym
;
3665 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3673 resolve_specific_s (gfc_code
*c
)
3678 sym
= c
->symtree
->n
.sym
;
3682 m
= resolve_specific_s0 (c
, sym
);
3685 if (m
== MATCH_ERROR
)
3688 if (sym
->ns
->parent
== NULL
)
3691 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3697 sym
= c
->symtree
->n
.sym
;
3698 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3699 sym
->name
, &c
->loc
);
3705 /* Resolve a subroutine call not known to be generic nor specific. */
3708 resolve_unknown_s (gfc_code
*c
)
3712 sym
= c
->symtree
->n
.sym
;
3714 if (sym
->attr
.dummy
)
3716 sym
->attr
.proc
= PROC_DUMMY
;
3720 /* See if we have an intrinsic function reference. */
3722 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3724 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3729 /* The reference is to an external name. */
3732 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3734 c
->resolved_sym
= sym
;
3736 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3740 /* Resolve a subroutine call. Although it was tempting to use the same code
3741 for functions, subroutines and functions are stored differently and this
3742 makes things awkward. */
3745 resolve_call (gfc_code
*c
)
3748 procedure_type ptype
= PROC_INTRINSIC
;
3749 gfc_symbol
*csym
, *sym
;
3750 bool no_formal_args
;
3752 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3754 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3756 gfc_error ("%qs at %L has a type, which is not consistent with "
3757 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3761 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3764 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3765 sym
= st
? st
->n
.sym
: NULL
;
3766 if (sym
&& csym
!= sym
3767 && sym
->ns
== gfc_current_ns
3768 && sym
->attr
.flavor
== FL_PROCEDURE
3769 && sym
->attr
.contained
)
3772 if (csym
->attr
.generic
)
3773 c
->symtree
->n
.sym
= sym
;
3776 csym
= c
->symtree
->n
.sym
;
3780 /* If this ia a deferred TBP, c->expr1 will be set. */
3781 if (!c
->expr1
&& csym
)
3783 if (csym
->attr
.abstract
)
3785 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3786 csym
->name
, &c
->loc
);
3790 /* Subroutines without the RECURSIVE attribution are not allowed to
3792 if (is_illegal_recursion (csym
, gfc_current_ns
))
3794 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3795 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3796 "as subroutine %qs is not RECURSIVE",
3797 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3799 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3800 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3806 /* Switch off assumed size checking and do this again for certain kinds
3807 of procedure, once the procedure itself is resolved. */
3808 need_full_assumed_size
++;
3811 ptype
= csym
->attr
.proc
;
3813 no_formal_args
= csym
&& is_external_proc (csym
)
3814 && gfc_sym_get_dummy_args (csym
) == NULL
;
3815 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3818 /* Resume assumed_size checking. */
3819 need_full_assumed_size
--;
3821 /* If external, check for usage. */
3822 if (csym
&& is_external_proc (csym
))
3823 resolve_global_procedure (csym
, &c
->loc
, 1);
3826 if (c
->resolved_sym
== NULL
)
3828 c
->resolved_isym
= NULL
;
3829 switch (procedure_kind (csym
))
3832 t
= resolve_generic_s (c
);
3835 case PTYPE_SPECIFIC
:
3836 t
= resolve_specific_s (c
);
3840 t
= resolve_unknown_s (c
);
3844 gfc_internal_error ("resolve_subroutine(): bad function type");
3848 /* Some checks of elemental subroutine actual arguments. */
3849 if (!resolve_elemental_actual (NULL
, c
))
3853 update_current_proc_array_outer_dependency (csym
);
3855 /* Typebound procedure: Assume the worst. */
3856 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3859 && c
->resolved_sym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
))
3860 gfc_warning (OPT_Wdeprecated_declarations
,
3861 "Using subroutine %qs at %L is deprecated",
3862 c
->resolved_sym
->name
, &c
->loc
);
3868 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3869 op1->shape and op2->shape are non-NULL return true if their shapes
3870 match. If both op1->shape and op2->shape are non-NULL return false
3871 if their shapes do not match. If either op1->shape or op2->shape is
3872 NULL, return true. */
3875 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3882 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3884 for (i
= 0; i
< op1
->rank
; i
++)
3886 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3888 gfc_error ("Shapes for operands at %L and %L are not conformable",
3889 &op1
->where
, &op2
->where
);
3899 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3900 For example A .AND. B becomes IAND(A, B). */
3902 logical_to_bitwise (gfc_expr
*e
)
3904 gfc_expr
*tmp
, *op1
, *op2
;
3906 gfc_actual_arglist
*args
= NULL
;
3908 gcc_assert (e
->expr_type
== EXPR_OP
);
3910 isym
= GFC_ISYM_NONE
;
3911 op1
= e
->value
.op
.op1
;
3912 op2
= e
->value
.op
.op2
;
3914 switch (e
->value
.op
.op
)
3917 isym
= GFC_ISYM_NOT
;
3920 isym
= GFC_ISYM_IAND
;
3923 isym
= GFC_ISYM_IOR
;
3925 case INTRINSIC_NEQV
:
3926 isym
= GFC_ISYM_IEOR
;
3929 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3930 Change the old expression to NEQV, which will get replaced by IEOR,
3931 and wrap it in NOT. */
3932 tmp
= gfc_copy_expr (e
);
3933 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3934 tmp
= logical_to_bitwise (tmp
);
3935 isym
= GFC_ISYM_NOT
;
3940 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3943 /* Inherit the original operation's operands as arguments. */
3944 args
= gfc_get_actual_arglist ();
3948 args
->next
= gfc_get_actual_arglist ();
3949 args
->next
->expr
= op2
;
3952 /* Convert the expression to a function call. */
3953 e
->expr_type
= EXPR_FUNCTION
;
3954 e
->value
.function
.actual
= args
;
3955 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3956 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3957 e
->value
.function
.esym
= NULL
;
3959 /* Make up a pre-resolved function call symtree if we need to. */
3960 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3963 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3964 sym
= e
->symtree
->n
.sym
;
3966 sym
->attr
.flavor
= FL_PROCEDURE
;
3967 sym
->attr
.function
= 1;
3968 sym
->attr
.elemental
= 1;
3970 sym
->attr
.referenced
= 1;
3971 gfc_intrinsic_symbol (sym
);
3972 gfc_commit_symbol (sym
);
3975 args
->name
= e
->value
.function
.isym
->formal
->name
;
3976 if (e
->value
.function
.isym
->formal
->next
)
3977 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3982 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3983 candidates in CANDIDATES_LEN. */
3985 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3987 size_t &candidates_len
)
3994 /* Not sure how to properly filter here. Use all for a start.
3995 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3996 these as i suppose they don't make terribly sense. */
3998 if (uop
->n
.uop
->op
!= NULL
)
3999 vec_push (candidates
, candidates_len
, uop
->name
);
4003 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
4007 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
4010 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4013 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
4015 char **candidates
= NULL
;
4016 size_t candidates_len
= 0;
4017 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
4018 return gfc_closest_fuzzy_match (op
, candidates
);
4022 /* Callback finding an impure function as an operand to an .and. or
4023 .or. expression. Remember the last function warned about to
4024 avoid double warnings when recursing. */
4027 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4032 static gfc_expr
*last
= NULL
;
4033 bool *found
= (bool *) data
;
4035 if (f
->expr_type
== EXPR_FUNCTION
)
4038 if (f
!= last
&& !gfc_pure_function (f
, &name
)
4039 && !gfc_implicit_pure_function (f
))
4042 gfc_warning (OPT_Wfunction_elimination
,
4043 "Impure function %qs at %L might not be evaluated",
4046 gfc_warning (OPT_Wfunction_elimination
,
4047 "Impure function at %L might not be evaluated",
4056 /* Return true if TYPE is character based, false otherwise. */
4059 is_character_based (bt type
)
4061 return type
== BT_CHARACTER
|| type
== BT_HOLLERITH
;
4065 /* If expression is a hollerith, convert it to character and issue a warning
4066 for the conversion. */
4069 convert_hollerith_to_character (gfc_expr
*e
)
4071 if (e
->ts
.type
== BT_HOLLERITH
)
4075 t
.type
= BT_CHARACTER
;
4076 t
.kind
= e
->ts
.kind
;
4077 gfc_convert_type_warn (e
, &t
, 2, 1);
4081 /* Convert to numeric and issue a warning for the conversion. */
4084 convert_to_numeric (gfc_expr
*a
, gfc_expr
*b
)
4088 t
.type
= b
->ts
.type
;
4089 t
.kind
= b
->ts
.kind
;
4090 gfc_convert_type_warn (a
, &t
, 2, 1);
4093 /* Resolve an operator expression node. This can involve replacing the
4094 operation with a user defined function call. */
4097 resolve_operator (gfc_expr
*e
)
4099 gfc_expr
*op1
, *op2
;
4100 /* One error uses 3 names; additional space for wording (also via gettext). */
4101 char msg
[3*GFC_MAX_SYMBOL_LEN
+ 1 + 50];
4102 bool dual_locus_error
;
4105 /* Resolve all subnodes-- give them types. */
4107 switch (e
->value
.op
.op
)
4110 if (!gfc_resolve_expr (e
->value
.op
.op2
))
4116 case INTRINSIC_UPLUS
:
4117 case INTRINSIC_UMINUS
:
4118 case INTRINSIC_PARENTHESES
:
4119 if (!gfc_resolve_expr (e
->value
.op
.op1
))
4122 && e
->value
.op
.op1
->ts
.type
== BT_BOZ
&& !e
->value
.op
.op2
)
4124 gfc_error ("BOZ literal constant at %L cannot be an operand of "
4125 "unary operator %qs", &e
->value
.op
.op1
->where
,
4126 gfc_op2string (e
->value
.op
.op
));
4132 /* Typecheck the new node. */
4134 op1
= e
->value
.op
.op1
;
4135 op2
= e
->value
.op
.op2
;
4136 if (op1
== NULL
&& op2
== NULL
)
4138 /* Error out if op2 did not resolve. We already diagnosed op1. */
4142 dual_locus_error
= false;
4144 /* op1 and op2 cannot both be BOZ. */
4145 if (op1
&& op1
->ts
.type
== BT_BOZ
4146 && op2
&& op2
->ts
.type
== BT_BOZ
)
4148 gfc_error ("Operands at %L and %L cannot appear as operands of "
4149 "binary operator %qs", &op1
->where
, &op2
->where
,
4150 gfc_op2string (e
->value
.op
.op
));
4154 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
4155 || (op2
&& op2
->expr_type
== EXPR_NULL
))
4157 snprintf (msg
, sizeof (msg
),
4158 _("Invalid context for NULL() pointer at %%L"));
4162 switch (e
->value
.op
.op
)
4164 case INTRINSIC_UPLUS
:
4165 case INTRINSIC_UMINUS
:
4166 if (op1
->ts
.type
== BT_INTEGER
4167 || op1
->ts
.type
== BT_REAL
4168 || op1
->ts
.type
== BT_COMPLEX
)
4174 snprintf (msg
, sizeof (msg
),
4175 _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
4176 gfc_op2string (e
->value
.op
.op
), gfc_typename (e
));
4179 case INTRINSIC_PLUS
:
4180 case INTRINSIC_MINUS
:
4181 case INTRINSIC_TIMES
:
4182 case INTRINSIC_DIVIDE
:
4183 case INTRINSIC_POWER
:
4184 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4186 gfc_type_convert_binary (e
, 1);
4190 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
4191 snprintf (msg
, sizeof (msg
),
4192 _("Unexpected derived-type entities in binary intrinsic "
4193 "numeric operator %%<%s%%> at %%L"),
4194 gfc_op2string (e
->value
.op
.op
));
4196 snprintf (msg
, sizeof(msg
),
4197 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
4198 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4199 gfc_typename (op2
));
4202 case INTRINSIC_CONCAT
:
4203 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4204 && op1
->ts
.kind
== op2
->ts
.kind
)
4206 e
->ts
.type
= BT_CHARACTER
;
4207 e
->ts
.kind
= op1
->ts
.kind
;
4211 snprintf (msg
, sizeof (msg
),
4212 _("Operands of string concatenation operator at %%L are %s/%s"),
4213 gfc_typename (op1
), gfc_typename (op2
));
4219 case INTRINSIC_NEQV
:
4220 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4222 e
->ts
.type
= BT_LOGICAL
;
4223 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4224 if (op1
->ts
.kind
< e
->ts
.kind
)
4225 gfc_convert_type (op1
, &e
->ts
, 2);
4226 else if (op2
->ts
.kind
< e
->ts
.kind
)
4227 gfc_convert_type (op2
, &e
->ts
, 2);
4229 if (flag_frontend_optimize
&&
4230 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4232 /* Warn about short-circuiting
4233 with impure function as second operand. */
4235 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4240 /* Logical ops on integers become bitwise ops with -fdec. */
4242 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4244 e
->ts
.type
= BT_INTEGER
;
4245 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4246 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4247 gfc_convert_type (op1
, &e
->ts
, 1);
4248 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4249 gfc_convert_type (op2
, &e
->ts
, 1);
4250 e
= logical_to_bitwise (e
);
4254 snprintf (msg
, sizeof (msg
),
4255 _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4256 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4257 gfc_typename (op2
));
4262 /* Logical ops on integers become bitwise ops with -fdec. */
4263 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4265 e
->ts
.type
= BT_INTEGER
;
4266 e
->ts
.kind
= op1
->ts
.kind
;
4267 e
= logical_to_bitwise (e
);
4271 if (op1
->ts
.type
== BT_LOGICAL
)
4273 e
->ts
.type
= BT_LOGICAL
;
4274 e
->ts
.kind
= op1
->ts
.kind
;
4278 snprintf (msg
, sizeof (msg
), _("Operand of .not. operator at %%L is %s"),
4279 gfc_typename (op1
));
4283 case INTRINSIC_GT_OS
:
4285 case INTRINSIC_GE_OS
:
4287 case INTRINSIC_LT_OS
:
4289 case INTRINSIC_LE_OS
:
4290 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4292 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4299 case INTRINSIC_EQ_OS
:
4301 case INTRINSIC_NE_OS
:
4304 && is_character_based (op1
->ts
.type
)
4305 && is_character_based (op2
->ts
.type
))
4307 convert_hollerith_to_character (op1
);
4308 convert_hollerith_to_character (op2
);
4311 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4312 && op1
->ts
.kind
== op2
->ts
.kind
)
4314 e
->ts
.type
= BT_LOGICAL
;
4315 e
->ts
.kind
= gfc_default_logical_kind
;
4319 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4320 if (op1
->ts
.type
== BT_BOZ
)
4322 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4323 "as an operand of a relational operator"),
4327 if (op2
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op1
, op2
->ts
.kind
))
4330 if (op2
->ts
.type
== BT_REAL
&& !gfc_boz2real (op1
, op2
->ts
.kind
))
4334 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4335 if (op2
->ts
.type
== BT_BOZ
)
4337 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4338 " as an operand of a relational operator"),
4342 if (op1
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op2
, op1
->ts
.kind
))
4345 if (op1
->ts
.type
== BT_REAL
&& !gfc_boz2real (op2
, op1
->ts
.kind
))
4349 && op1
->ts
.type
== BT_HOLLERITH
&& gfc_numeric_ts (&op2
->ts
))
4350 convert_to_numeric (op1
, op2
);
4353 && gfc_numeric_ts (&op1
->ts
) && op2
->ts
.type
== BT_HOLLERITH
)
4354 convert_to_numeric (op2
, op1
);
4356 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4358 gfc_type_convert_binary (e
, 1);
4360 e
->ts
.type
= BT_LOGICAL
;
4361 e
->ts
.kind
= gfc_default_logical_kind
;
4363 if (warn_compare_reals
)
4365 gfc_intrinsic_op op
= e
->value
.op
.op
;
4367 /* Type conversion has made sure that the types of op1 and op2
4368 agree, so it is only necessary to check the first one. */
4369 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4370 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4371 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4375 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4376 msg
= G_("Equality comparison for %s at %L");
4378 msg
= G_("Inequality comparison for %s at %L");
4380 gfc_warning (OPT_Wcompare_reals
, msg
,
4381 gfc_typename (op1
), &op1
->where
);
4388 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4389 snprintf (msg
, sizeof (msg
),
4390 _("Logicals at %%L must be compared with %s instead of %s"),
4391 (e
->value
.op
.op
== INTRINSIC_EQ
4392 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4393 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4395 snprintf (msg
, sizeof (msg
),
4396 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4397 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4398 gfc_typename (op2
));
4402 case INTRINSIC_USER
:
4403 if (e
->value
.op
.uop
->op
== NULL
)
4405 const char *name
= e
->value
.op
.uop
->name
;
4406 const char *guessed
;
4407 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4409 snprintf (msg
, sizeof (msg
),
4410 _("Unknown operator %%<%s%%> at %%L; did you mean "
4411 "%%<%s%%>?"), name
, guessed
);
4413 snprintf (msg
, sizeof (msg
), _("Unknown operator %%<%s%%> at %%L"),
4416 else if (op2
== NULL
)
4417 snprintf (msg
, sizeof (msg
),
4418 _("Operand of user operator %%<%s%%> at %%L is %s"),
4419 e
->value
.op
.uop
->name
, gfc_typename (op1
));
4422 snprintf (msg
, sizeof (msg
),
4423 _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4424 e
->value
.op
.uop
->name
, gfc_typename (op1
),
4425 gfc_typename (op2
));
4426 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4431 case INTRINSIC_PARENTHESES
:
4433 if (e
->ts
.type
== BT_CHARACTER
)
4434 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4438 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4441 /* Deal with arrayness of an operand through an operator. */
4443 switch (e
->value
.op
.op
)
4445 case INTRINSIC_PLUS
:
4446 case INTRINSIC_MINUS
:
4447 case INTRINSIC_TIMES
:
4448 case INTRINSIC_DIVIDE
:
4449 case INTRINSIC_POWER
:
4450 case INTRINSIC_CONCAT
:
4454 case INTRINSIC_NEQV
:
4456 case INTRINSIC_EQ_OS
:
4458 case INTRINSIC_NE_OS
:
4460 case INTRINSIC_GT_OS
:
4462 case INTRINSIC_GE_OS
:
4464 case INTRINSIC_LT_OS
:
4466 case INTRINSIC_LE_OS
:
4468 if (op1
->rank
== 0 && op2
->rank
== 0)
4471 if (op1
->rank
== 0 && op2
->rank
!= 0)
4473 e
->rank
= op2
->rank
;
4475 if (e
->shape
== NULL
)
4476 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4479 if (op1
->rank
!= 0 && op2
->rank
== 0)
4481 e
->rank
= op1
->rank
;
4483 if (e
->shape
== NULL
)
4484 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4487 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4489 if (op1
->rank
== op2
->rank
)
4491 e
->rank
= op1
->rank
;
4492 if (e
->shape
== NULL
)
4494 t
= compare_shapes (op1
, op2
);
4498 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4503 /* Allow higher level expressions to work. */
4506 /* Try user-defined operators, and otherwise throw an error. */
4507 dual_locus_error
= true;
4508 snprintf (msg
, sizeof (msg
),
4509 _("Inconsistent ranks for operator at %%L and %%L"));
4516 case INTRINSIC_PARENTHESES
:
4518 case INTRINSIC_UPLUS
:
4519 case INTRINSIC_UMINUS
:
4520 /* Simply copy arrayness attribute */
4521 e
->rank
= op1
->rank
;
4523 if (e
->shape
== NULL
)
4524 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4534 /* Attempt to simplify the expression. */
4537 t
= gfc_simplify_expr (e
, 0);
4538 /* Some calls do not succeed in simplification and return false
4539 even though there is no error; e.g. variable references to
4540 PARAMETER arrays. */
4541 if (!gfc_is_constant_expr (e
))
4549 match m
= gfc_extend_expr (e
);
4552 if (m
== MATCH_ERROR
)
4556 if (dual_locus_error
)
4557 gfc_error (msg
, &op1
->where
, &op2
->where
);
4559 gfc_error (msg
, &e
->where
);
4565 /************** Array resolution subroutines **************/
4568 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4570 /* Compare two integer expressions. */
4572 static compare_result
4573 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4577 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4578 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4581 /* If either of the types isn't INTEGER, we must have
4582 raised an error earlier. */
4584 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4587 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4597 /* Compare an integer expression with an integer. */
4599 static compare_result
4600 compare_bound_int (gfc_expr
*a
, int b
)
4605 || a
->expr_type
!= EXPR_CONSTANT
4606 || a
->ts
.type
!= BT_INTEGER
)
4609 i
= mpz_cmp_si (a
->value
.integer
, b
);
4619 /* Compare an integer expression with a mpz_t. */
4621 static compare_result
4622 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4627 || a
->expr_type
!= EXPR_CONSTANT
4628 || a
->ts
.type
!= BT_INTEGER
)
4631 i
= mpz_cmp (a
->value
.integer
, b
);
4641 /* Compute the last value of a sequence given by a triplet.
4642 Return 0 if it wasn't able to compute the last value, or if the
4643 sequence if empty, and 1 otherwise. */
4646 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4647 gfc_expr
*stride
, mpz_t last
)
4651 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4652 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4653 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4656 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4657 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4660 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4662 if (compare_bound (start
, end
) == CMP_GT
)
4664 mpz_set (last
, end
->value
.integer
);
4668 if (compare_bound_int (stride
, 0) == CMP_GT
)
4670 /* Stride is positive */
4671 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4676 /* Stride is negative */
4677 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4682 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4683 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4684 mpz_sub (last
, end
->value
.integer
, rem
);
4691 /* Compare a single dimension of an array reference to the array
4695 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4699 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4701 gcc_assert (ar
->stride
[i
] == NULL
);
4702 /* This implies [*] as [*:] and [*:3] are not possible. */
4703 if (ar
->start
[i
] == NULL
)
4705 gcc_assert (ar
->end
[i
] == NULL
);
4710 /* Given start, end and stride values, calculate the minimum and
4711 maximum referenced indexes. */
4713 switch (ar
->dimen_type
[i
])
4716 case DIMEN_THIS_IMAGE
:
4721 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4724 gfc_warning (0, "Array reference at %L is out of bounds "
4725 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4726 mpz_get_si (ar
->start
[i
]->value
.integer
),
4727 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4729 gfc_warning (0, "Array reference at %L is out of bounds "
4730 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4731 mpz_get_si (ar
->start
[i
]->value
.integer
),
4732 mpz_get_si (as
->lower
[i
]->value
.integer
),
4736 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4739 gfc_warning (0, "Array reference at %L is out of bounds "
4740 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4741 mpz_get_si (ar
->start
[i
]->value
.integer
),
4742 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4744 gfc_warning (0, "Array reference at %L is out of bounds "
4745 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4746 mpz_get_si (ar
->start
[i
]->value
.integer
),
4747 mpz_get_si (as
->upper
[i
]->value
.integer
),
4756 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4757 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4759 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4760 compare_result comp_stride_zero
= compare_bound_int (ar
->stride
[i
], 0);
4762 /* Check for zero stride, which is not allowed. */
4763 if (comp_stride_zero
== CMP_EQ
)
4765 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4769 /* if start == end || (stride > 0 && start < end)
4770 || (stride < 0 && start > end),
4771 then the array section contains at least one element. In this
4772 case, there is an out-of-bounds access if
4773 (start < lower || start > upper). */
4774 if (comp_start_end
== CMP_EQ
4775 || ((comp_stride_zero
== CMP_GT
|| ar
->stride
[i
] == NULL
)
4776 && comp_start_end
== CMP_LT
)
4777 || (comp_stride_zero
== CMP_LT
4778 && comp_start_end
== CMP_GT
))
4780 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4782 gfc_warning (0, "Lower array reference at %L is out of bounds "
4783 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4784 mpz_get_si (AR_START
->value
.integer
),
4785 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4788 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4790 gfc_warning (0, "Lower array reference at %L is out of bounds "
4791 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4792 mpz_get_si (AR_START
->value
.integer
),
4793 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4798 /* If we can compute the highest index of the array section,
4799 then it also has to be between lower and upper. */
4800 mpz_init (last_value
);
4801 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4804 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4806 gfc_warning (0, "Upper array reference at %L is out of bounds "
4807 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4808 mpz_get_si (last_value
),
4809 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4810 mpz_clear (last_value
);
4813 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4815 gfc_warning (0, "Upper array reference at %L is out of bounds "
4816 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4817 mpz_get_si (last_value
),
4818 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4819 mpz_clear (last_value
);
4823 mpz_clear (last_value
);
4831 gfc_internal_error ("check_dimension(): Bad array reference");
4838 /* Compare an array reference with an array specification. */
4841 compare_spec_to_ref (gfc_array_ref
*ar
)
4848 /* TODO: Full array sections are only allowed as actual parameters. */
4849 if (as
->type
== AS_ASSUMED_SIZE
4850 && (/*ar->type == AR_FULL
4851 ||*/ (ar
->type
== AR_SECTION
4852 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4854 gfc_error ("Rightmost upper bound of assumed size array section "
4855 "not specified at %L", &ar
->where
);
4859 if (ar
->type
== AR_FULL
)
4862 if (as
->rank
!= ar
->dimen
)
4864 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4865 &ar
->where
, ar
->dimen
, as
->rank
);
4869 /* ar->codimen == 0 is a local array. */
4870 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4872 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4873 &ar
->where
, ar
->codimen
, as
->corank
);
4877 for (i
= 0; i
< as
->rank
; i
++)
4878 if (!check_dimension (i
, ar
, as
))
4881 /* Local access has no coarray spec. */
4882 if (ar
->codimen
!= 0)
4883 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4885 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4886 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4888 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4889 i
+ 1 - as
->rank
, &ar
->where
);
4892 if (!check_dimension (i
, ar
, as
))
4900 /* Resolve one part of an array index. */
4903 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4904 int force_index_integer_kind
)
4911 if (!gfc_resolve_expr (index
))
4914 if (check_scalar
&& index
->rank
!= 0)
4916 gfc_error ("Array index at %L must be scalar", &index
->where
);
4920 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4922 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4923 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4927 if (index
->ts
.type
== BT_REAL
)
4928 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4932 if ((index
->ts
.kind
!= gfc_index_integer_kind
4933 && force_index_integer_kind
)
4934 || index
->ts
.type
!= BT_INTEGER
)
4937 ts
.type
= BT_INTEGER
;
4938 ts
.kind
= gfc_index_integer_kind
;
4940 gfc_convert_type_warn (index
, &ts
, 2, 0);
4946 /* Resolve one part of an array index. */
4949 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4951 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4954 /* Resolve a dim argument to an intrinsic function. */
4957 gfc_resolve_dim_arg (gfc_expr
*dim
)
4962 if (!gfc_resolve_expr (dim
))
4967 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4972 if (dim
->ts
.type
!= BT_INTEGER
)
4974 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4978 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4983 ts
.type
= BT_INTEGER
;
4984 ts
.kind
= gfc_index_integer_kind
;
4986 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4992 /* Given an expression that contains array references, update those array
4993 references to point to the right array specifications. While this is
4994 filled in during matching, this information is difficult to save and load
4995 in a module, so we take care of it here.
4997 The idea here is that the original array reference comes from the
4998 base symbol. We traverse the list of reference structures, setting
4999 the stored reference to references. Component references can
5000 provide an additional array specification. */
5002 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
);
5005 find_array_spec (gfc_expr
*e
)
5010 bool class_as
= false;
5012 if (e
->symtree
->n
.sym
->assoc
)
5014 if (e
->symtree
->n
.sym
->assoc
->target
)
5015 gfc_resolve_expr (e
->symtree
->n
.sym
->assoc
->target
);
5016 resolve_assoc_var (e
->symtree
->n
.sym
, false);
5019 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
5021 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
5025 as
= e
->symtree
->n
.sym
->as
;
5027 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5033 locus loc
= ref
->u
.ar
.where
.lb
? ref
->u
.ar
.where
: e
->where
;
5034 gfc_error ("Invalid array reference of a non-array entity at %L",
5044 c
= ref
->u
.c
.component
;
5045 if (c
->attr
.dimension
)
5047 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
5048 gfc_internal_error ("find_array_spec(): unused as(1)");
5060 gfc_internal_error ("find_array_spec(): unused as(2)");
5066 /* Resolve an array reference. */
5069 resolve_array_ref (gfc_array_ref
*ar
)
5071 int i
, check_scalar
;
5074 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
5076 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
5078 /* Do not force gfc_index_integer_kind for the start. We can
5079 do fine with any integer kind. This avoids temporary arrays
5080 created for indexing with a vector. */
5081 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
5083 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
5085 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
5090 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
5094 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
5098 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
5099 if (e
->expr_type
== EXPR_VARIABLE
5100 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
5101 ar
->start
[i
] = gfc_get_parentheses (e
);
5105 gfc_error ("Array index at %L is an array of rank %d",
5106 &ar
->c_where
[i
], e
->rank
);
5110 /* Fill in the upper bound, which may be lower than the
5111 specified one for something like a(2:10:5), which is
5112 identical to a(2:7:5). Only relevant for strides not equal
5113 to one. Don't try a division by zero. */
5114 if (ar
->dimen_type
[i
] == DIMEN_RANGE
5115 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
5116 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
5117 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
5121 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
5123 if (ar
->end
[i
] == NULL
)
5126 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
5128 mpz_set (ar
->end
[i
]->value
.integer
, end
);
5130 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
5131 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
5133 mpz_set (ar
->end
[i
]->value
.integer
, end
);
5144 if (ar
->type
== AR_FULL
)
5146 if (ar
->as
->rank
== 0)
5147 ar
->type
= AR_ELEMENT
;
5149 /* Make sure array is the same as array(:,:), this way
5150 we don't need to special case all the time. */
5151 ar
->dimen
= ar
->as
->rank
;
5152 for (i
= 0; i
< ar
->dimen
; i
++)
5154 ar
->dimen_type
[i
] = DIMEN_RANGE
;
5156 gcc_assert (ar
->start
[i
] == NULL
);
5157 gcc_assert (ar
->end
[i
] == NULL
);
5158 gcc_assert (ar
->stride
[i
] == NULL
);
5162 /* If the reference type is unknown, figure out what kind it is. */
5164 if (ar
->type
== AR_UNKNOWN
)
5166 ar
->type
= AR_ELEMENT
;
5167 for (i
= 0; i
< ar
->dimen
; i
++)
5168 if (ar
->dimen_type
[i
] == DIMEN_RANGE
5169 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5171 ar
->type
= AR_SECTION
;
5176 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
5179 if (ar
->as
->corank
&& ar
->codimen
== 0)
5182 ar
->codimen
= ar
->as
->corank
;
5183 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
5184 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
5192 gfc_resolve_substring (gfc_ref
*ref
, bool *equal_length
)
5194 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5196 if (ref
->u
.ss
.start
!= NULL
)
5198 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
5201 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
5203 gfc_error ("Substring start index at %L must be of type INTEGER",
5204 &ref
->u
.ss
.start
->where
);
5208 if (ref
->u
.ss
.start
->rank
!= 0)
5210 gfc_error ("Substring start index at %L must be scalar",
5211 &ref
->u
.ss
.start
->where
);
5215 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
5216 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5217 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5219 gfc_error ("Substring start index at %L is less than one",
5220 &ref
->u
.ss
.start
->where
);
5225 if (ref
->u
.ss
.end
!= NULL
)
5227 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
5230 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
5232 gfc_error ("Substring end index at %L must be of type INTEGER",
5233 &ref
->u
.ss
.end
->where
);
5237 if (ref
->u
.ss
.end
->rank
!= 0)
5239 gfc_error ("Substring end index at %L must be scalar",
5240 &ref
->u
.ss
.end
->where
);
5244 if (ref
->u
.ss
.length
!= NULL
5245 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
5246 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5247 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5249 gfc_error ("Substring end index at %L exceeds the string length",
5250 &ref
->u
.ss
.start
->where
);
5254 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
5255 gfc_integer_kinds
[k
].huge
) == CMP_GT
5256 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5257 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5259 gfc_error ("Substring end index at %L is too large",
5260 &ref
->u
.ss
.end
->where
);
5263 /* If the substring has the same length as the original
5264 variable, the reference itself can be deleted. */
5266 if (ref
->u
.ss
.length
!= NULL
5267 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
5268 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
5269 *equal_length
= true;
5276 /* This function supplies missing substring charlens. */
5279 gfc_resolve_substring_charlen (gfc_expr
*e
)
5282 gfc_expr
*start
, *end
;
5283 gfc_typespec
*ts
= NULL
;
5286 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5288 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5290 if (char_ref
->type
== REF_COMPONENT
)
5291 ts
= &char_ref
->u
.c
.component
->ts
;
5294 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5297 gcc_assert (char_ref
->next
== NULL
);
5301 if (e
->ts
.u
.cl
->length
)
5302 gfc_free_expr (e
->ts
.u
.cl
->length
);
5303 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5308 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5310 if (char_ref
->u
.ss
.start
)
5311 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5313 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5315 if (char_ref
->u
.ss
.end
)
5316 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5317 else if (e
->expr_type
== EXPR_VARIABLE
)
5320 ts
= &e
->symtree
->n
.sym
->ts
;
5321 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5328 gfc_free_expr (start
);
5329 gfc_free_expr (end
);
5333 /* Length = (end - start + 1).
5334 Check first whether it has a constant length. */
5335 if (gfc_dep_difference (end
, start
, &diff
))
5337 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5340 mpz_add_ui (len
->value
.integer
, diff
, 1);
5342 e
->ts
.u
.cl
->length
= len
;
5343 /* The check for length < 0 is handled below */
5347 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5348 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5349 gfc_get_int_expr (gfc_charlen_int_kind
,
5353 /* F2008, 6.4.1: Both the starting point and the ending point shall
5354 be within the range 1, 2, ..., n unless the starting point exceeds
5355 the ending point, in which case the substring has length zero. */
5357 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5358 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5360 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5361 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5363 /* Make sure that the length is simplified. */
5364 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5365 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5369 /* Resolve subtype references. */
5372 gfc_resolve_ref (gfc_expr
*expr
)
5374 int current_part_dimension
, n_components
, seen_part_dimension
, dim
;
5375 gfc_ref
*ref
, **prev
, *array_ref
;
5378 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5379 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5381 if (!find_array_spec (expr
))
5386 for (prev
= &expr
->ref
; *prev
!= NULL
;
5387 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5388 switch ((*prev
)->type
)
5391 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5400 equal_length
= false;
5401 if (!gfc_resolve_substring (*prev
, &equal_length
))
5404 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5406 /* Remove the reference and move the charlen, if any. */
5410 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5411 ref
->u
.ss
.length
= NULL
;
5412 gfc_free_ref_list (ref
);
5417 /* Check constraints on part references. */
5419 current_part_dimension
= 0;
5420 seen_part_dimension
= 0;
5424 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5430 switch (ref
->u
.ar
.type
)
5433 /* Coarray scalar. */
5434 if (ref
->u
.ar
.as
->rank
== 0)
5436 current_part_dimension
= 0;
5441 current_part_dimension
= 1;
5446 current_part_dimension
= 0;
5450 gfc_internal_error ("resolve_ref(): Bad array reference");
5456 if (current_part_dimension
|| seen_part_dimension
)
5459 if (ref
->u
.c
.component
->attr
.pointer
5460 || ref
->u
.c
.component
->attr
.proc_pointer
5461 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5462 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5464 gfc_error ("Component to the right of a part reference "
5465 "with nonzero rank must not have the POINTER "
5466 "attribute at %L", &expr
->where
);
5469 else if (ref
->u
.c
.component
->attr
.allocatable
5470 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5471 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5474 gfc_error ("Component to the right of a part reference "
5475 "with nonzero rank must not have the ALLOCATABLE "
5476 "attribute at %L", &expr
->where
);
5488 /* Implement requirement in note 9.7 of F2018 that the result of the
5489 LEN inquiry be a scalar. */
5490 if (ref
->u
.i
== INQUIRY_LEN
&& array_ref
&& expr
->ts
.deferred
)
5492 array_ref
->u
.ar
.type
= AR_ELEMENT
;
5494 /* INQUIRY_LEN is not evaluated from the rest of the expr
5495 but directly from the string length. This means that setting
5496 the array indices to one does not matter but might trigger
5497 a runtime bounds error. Suppress the check. */
5498 expr
->no_bounds_check
= 1;
5499 for (dim
= 0; dim
< array_ref
->u
.ar
.dimen
; dim
++)
5501 array_ref
->u
.ar
.dimen_type
[dim
] = DIMEN_ELEMENT
;
5502 if (array_ref
->u
.ar
.start
[dim
])
5503 gfc_free_expr (array_ref
->u
.ar
.start
[dim
]);
5504 array_ref
->u
.ar
.start
[dim
]
5505 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
5506 if (array_ref
->u
.ar
.end
[dim
])
5507 gfc_free_expr (array_ref
->u
.ar
.end
[dim
]);
5508 if (array_ref
->u
.ar
.stride
[dim
])
5509 gfc_free_expr (array_ref
->u
.ar
.stride
[dim
]);
5515 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5516 || ref
->next
== NULL
)
5517 && current_part_dimension
5518 && seen_part_dimension
)
5520 gfc_error ("Two or more part references with nonzero rank must "
5521 "not be specified at %L", &expr
->where
);
5525 if (ref
->type
== REF_COMPONENT
)
5527 if (current_part_dimension
)
5528 seen_part_dimension
= 1;
5530 /* reset to make sure */
5531 current_part_dimension
= 0;
5539 /* Given an expression, determine its shape. This is easier than it sounds.
5540 Leaves the shape array NULL if it is not possible to determine the shape. */
5543 expression_shape (gfc_expr
*e
)
5545 mpz_t array
[GFC_MAX_DIMENSIONS
];
5548 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5551 for (i
= 0; i
< e
->rank
; i
++)
5552 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5555 e
->shape
= gfc_get_shape (e
->rank
);
5557 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5562 for (i
--; i
>= 0; i
--)
5563 mpz_clear (array
[i
]);
5567 /* Given a variable expression node, compute the rank of the expression by
5568 examining the base symbol and any reference structures it may have. */
5571 gfc_expression_rank (gfc_expr
*e
)
5576 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5577 could lead to serious confusion... */
5578 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5582 if (e
->expr_type
== EXPR_ARRAY
)
5584 /* Constructors can have a rank different from one via RESHAPE(). */
5586 e
->rank
= ((e
->symtree
== NULL
|| e
->symtree
->n
.sym
->as
== NULL
)
5587 ? 0 : e
->symtree
->n
.sym
->as
->rank
);
5593 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5595 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5596 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5597 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5599 if (ref
->type
!= REF_ARRAY
)
5602 if (ref
->u
.ar
.type
== AR_FULL
)
5604 rank
= ref
->u
.ar
.as
->rank
;
5608 if (ref
->u
.ar
.type
== AR_SECTION
)
5610 /* Figure out the rank of the section. */
5612 gfc_internal_error ("gfc_expression_rank(): Two array specs");
5614 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5615 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5616 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5626 expression_shape (e
);
5631 add_caf_get_intrinsic (gfc_expr
*e
)
5633 gfc_expr
*wrapper
, *tmp_expr
;
5637 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5638 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5643 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5644 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5647 tmp_expr
= XCNEW (gfc_expr
);
5649 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5650 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5651 wrapper
->ts
= e
->ts
;
5652 wrapper
->rank
= e
->rank
;
5654 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5661 remove_caf_get_intrinsic (gfc_expr
*e
)
5663 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5664 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5665 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5666 e
->value
.function
.actual
->expr
= NULL
;
5667 gfc_free_actual_arglist (e
->value
.function
.actual
);
5668 gfc_free_shape (&e
->shape
, e
->rank
);
5674 /* Resolve a variable expression. */
5677 resolve_variable (gfc_expr
*e
)
5684 if (e
->symtree
== NULL
)
5686 sym
= e
->symtree
->n
.sym
;
5688 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5689 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5690 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5692 if (!actual_arg
|| inquiry_argument
)
5694 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5695 "be used as actual argument", sym
->name
, &e
->where
);
5699 /* TS 29113, 407b. */
5700 else if (e
->ts
.type
== BT_ASSUMED
)
5704 gfc_error ("Assumed-type variable %s at %L may only be used "
5705 "as actual argument", sym
->name
, &e
->where
);
5708 else if (inquiry_argument
&& !first_actual_arg
)
5710 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5711 for all inquiry functions in resolve_function; the reason is
5712 that the function-name resolution happens too late in that
5714 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5715 "an inquiry function shall be the first argument",
5716 sym
->name
, &e
->where
);
5720 /* TS 29113, C535b. */
5721 else if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5722 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
5723 && CLASS_DATA (sym
)->as
5724 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5725 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5726 && sym
->as
->type
== AS_ASSUMED_RANK
))
5727 && !sym
->attr
.select_rank_temporary
)
5730 && !(cs_base
&& cs_base
->current
5731 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
5733 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5734 "actual argument", sym
->name
, &e
->where
);
5737 else if (inquiry_argument
&& !first_actual_arg
)
5739 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5740 for all inquiry functions in resolve_function; the reason is
5741 that the function-name resolution happens too late in that
5743 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5744 "to an inquiry function shall be the first argument",
5745 sym
->name
, &e
->where
);
5750 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5751 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5752 && e
->ref
->next
== NULL
))
5754 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5755 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5758 /* TS 29113, 407b. */
5759 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5760 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5761 && e
->ref
->next
== NULL
))
5763 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5764 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5768 /* TS 29113, C535b. */
5769 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5770 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
5771 && CLASS_DATA (sym
)->as
5772 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5773 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5774 && sym
->as
->type
== AS_ASSUMED_RANK
))
5776 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5777 && e
->ref
->next
== NULL
))
5779 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5780 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5784 /* For variables that are used in an associate (target => object) where
5785 the object's basetype is array valued while the target is scalar,
5786 the ts' type of the component refs is still array valued, which
5787 can't be translated that way. */
5788 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5789 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5790 && sym
->assoc
->target
->ts
.u
.derived
5791 && CLASS_DATA (sym
->assoc
->target
)
5792 && CLASS_DATA (sym
->assoc
->target
)->as
)
5794 gfc_ref
*ref
= e
->ref
;
5800 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5801 /* Stop the loop. */
5811 /* If this is an associate-name, it may be parsed with an array reference
5812 in error even though the target is scalar. Fail directly in this case.
5813 TODO Understand why class scalar expressions must be excluded. */
5814 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5816 if (sym
->ts
.type
== BT_CLASS
)
5817 gfc_fix_class_refs (e
);
5818 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5820 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5822 /* This can happen because the parser did not detect that the
5823 associate name is an array and the expression had no array
5825 gfc_ref
*ref
= gfc_get_ref ();
5826 ref
->type
= REF_ARRAY
;
5827 ref
->u
.ar
.type
= AR_FULL
;
5830 ref
->u
.ar
.as
= sym
->as
;
5831 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5839 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5840 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5842 /* On the other hand, the parser may not have known this is an array;
5843 in this case, we have to add a FULL reference. */
5844 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5846 e
->ref
= gfc_get_ref ();
5847 e
->ref
->type
= REF_ARRAY
;
5848 e
->ref
->u
.ar
.type
= AR_FULL
;
5849 e
->ref
->u
.ar
.dimen
= 0;
5852 /* Like above, but for class types, where the checking whether an array
5853 ref is present is more complicated. Furthermore make sure not to add
5854 the full array ref to _vptr or _len refs. */
5855 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5857 && CLASS_DATA (sym
)->attr
.dimension
5858 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5860 gfc_ref
*ref
, *newref
;
5862 newref
= gfc_get_ref ();
5863 newref
->type
= REF_ARRAY
;
5864 newref
->u
.ar
.type
= AR_FULL
;
5865 newref
->u
.ar
.dimen
= 0;
5866 /* Because this is an associate var and the first ref either is a ref to
5867 the _data component or not, no traversal of the ref chain is
5868 needed. The array ref needs to be inserted after the _data ref,
5869 or when that is not present, which may happend for polymorphic
5870 types, then at the first position. */
5874 else if (ref
->type
== REF_COMPONENT
5875 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5877 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5879 newref
->next
= ref
->next
;
5883 /* Array ref present already. */
5884 gfc_free_ref_list (newref
);
5886 else if (ref
->type
== REF_ARRAY
)
5887 /* Array ref present already. */
5888 gfc_free_ref_list (newref
);
5896 if (e
->ref
&& !gfc_resolve_ref (e
))
5899 if (sym
->attr
.flavor
== FL_PROCEDURE
5900 && (!sym
->attr
.function
5901 || (sym
->attr
.function
&& sym
->result
5902 && sym
->result
->attr
.proc_pointer
5903 && !sym
->result
->attr
.function
)))
5905 e
->ts
.type
= BT_PROCEDURE
;
5906 goto resolve_procedure
;
5909 if (sym
->ts
.type
!= BT_UNKNOWN
)
5910 gfc_variable_attr (e
, &e
->ts
);
5911 else if (sym
->attr
.flavor
== FL_PROCEDURE
5912 && sym
->attr
.function
&& sym
->result
5913 && sym
->result
->ts
.type
!= BT_UNKNOWN
5914 && sym
->result
->attr
.proc_pointer
)
5915 e
->ts
= sym
->result
->ts
;
5918 /* Must be a simple variable reference. */
5919 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5924 if (check_assumed_size_reference (sym
, e
))
5927 /* Deal with forward references to entries during gfc_resolve_code, to
5928 satisfy, at least partially, 12.5.2.5. */
5929 if (gfc_current_ns
->entries
5930 && current_entry_id
== sym
->entry_id
5933 && cs_base
->current
->op
!= EXEC_ENTRY
)
5935 gfc_entry_list
*entry
;
5936 gfc_formal_arglist
*formal
;
5938 bool seen
, saved_specification_expr
;
5940 /* If the symbol is a dummy... */
5941 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5943 entry
= gfc_current_ns
->entries
;
5946 /* ...test if the symbol is a parameter of previous entries. */
5947 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5948 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5950 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5957 /* If it has not been seen as a dummy, this is an error. */
5960 if (specification_expr
)
5961 gfc_error ("Variable %qs, used in a specification expression"
5962 ", is referenced at %L before the ENTRY statement "
5963 "in which it is a parameter",
5964 sym
->name
, &cs_base
->current
->loc
);
5966 gfc_error ("Variable %qs is used at %L before the ENTRY "
5967 "statement in which it is a parameter",
5968 sym
->name
, &cs_base
->current
->loc
);
5973 /* Now do the same check on the specification expressions. */
5974 saved_specification_expr
= specification_expr
;
5975 specification_expr
= true;
5976 if (sym
->ts
.type
== BT_CHARACTER
5977 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5981 for (n
= 0; n
< sym
->as
->rank
; n
++)
5983 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5985 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5988 specification_expr
= saved_specification_expr
;
5991 /* Update the symbol's entry level. */
5992 sym
->entry_id
= current_entry_id
+ 1;
5995 /* If a symbol has been host_associated mark it. This is used latter,
5996 to identify if aliasing is possible via host association. */
5997 if (sym
->attr
.flavor
== FL_VARIABLE
5998 && gfc_current_ns
->parent
5999 && (gfc_current_ns
->parent
== sym
->ns
6000 || (gfc_current_ns
->parent
->parent
6001 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
6002 sym
->attr
.host_assoc
= 1;
6004 if (gfc_current_ns
->proc_name
6005 && sym
->attr
.dimension
6006 && (sym
->ns
!= gfc_current_ns
6007 || sym
->attr
.use_assoc
6008 || sym
->attr
.in_common
))
6009 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
6012 if (t
&& !resolve_procedure_expression (e
))
6015 /* F2008, C617 and C1229. */
6016 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
6017 && gfc_is_coindexed (e
))
6019 gfc_ref
*ref
, *ref2
= NULL
;
6021 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6023 if (ref
->type
== REF_COMPONENT
)
6025 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
6029 for ( ; ref
; ref
= ref
->next
)
6030 if (ref
->type
== REF_COMPONENT
)
6033 /* Expression itself is not coindexed object. */
6034 if (ref
&& e
->ts
.type
== BT_CLASS
)
6036 gfc_error ("Polymorphic subobject of coindexed object at %L",
6041 /* Expression itself is coindexed object. */
6045 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
6046 for ( ; c
; c
= c
->next
)
6047 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
6049 gfc_error ("Coindexed object with polymorphic allocatable "
6050 "subcomponent at %L", &e
->where
);
6058 gfc_expression_rank (e
);
6060 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
6061 add_caf_get_intrinsic (e
);
6063 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
) && sym
!= sym
->result
)
6064 gfc_warning (OPT_Wdeprecated_declarations
,
6065 "Using variable %qs at %L is deprecated",
6066 sym
->name
, &e
->where
);
6067 /* Simplify cases where access to a parameter array results in a
6068 single constant. Suppress errors since those will have been
6069 issued before, as warnings. */
6070 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
6072 gfc_push_suppress_errors ();
6073 gfc_simplify_expr (e
, 1);
6074 gfc_pop_suppress_errors ();
6081 /* Checks to see that the correct symbol has been host associated.
6082 The only situation where this arises is that in which a twice
6083 contained function is parsed after the host association is made.
6084 Therefore, on detecting this, change the symbol in the expression
6085 and convert the array reference into an actual arglist if the old
6086 symbol is a variable. */
6088 check_host_association (gfc_expr
*e
)
6090 gfc_symbol
*sym
, *old_sym
;
6094 gfc_actual_arglist
*arg
, *tail
= NULL
;
6095 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
6097 /* If the expression is the result of substitution in
6098 interface.cc(gfc_extend_expr) because there is no way in
6099 which the host association can be wrong. */
6100 if (e
->symtree
== NULL
6101 || e
->symtree
->n
.sym
== NULL
6102 || e
->user_operator
)
6105 old_sym
= e
->symtree
->n
.sym
;
6107 if (gfc_current_ns
->parent
6108 && old_sym
->ns
!= gfc_current_ns
)
6110 /* Use the 'USE' name so that renamed module symbols are
6111 correctly handled. */
6112 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
6114 if (sym
&& old_sym
!= sym
6115 && sym
->attr
.flavor
== FL_PROCEDURE
6116 && sym
->attr
.contained
)
6118 /* Clear the shape, since it might not be valid. */
6119 gfc_free_shape (&e
->shape
, e
->rank
);
6121 /* Give the expression the right symtree! */
6122 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
6123 gcc_assert (st
!= NULL
);
6125 if (old_sym
->attr
.flavor
== FL_PROCEDURE
6126 || e
->expr_type
== EXPR_FUNCTION
)
6128 /* Original was function so point to the new symbol, since
6129 the actual argument list is already attached to the
6131 e
->value
.function
.esym
= NULL
;
6136 /* Original was variable so convert array references into
6137 an actual arglist. This does not need any checking now
6138 since resolve_function will take care of it. */
6139 e
->value
.function
.actual
= NULL
;
6140 e
->expr_type
= EXPR_FUNCTION
;
6143 /* Ambiguity will not arise if the array reference is not
6144 the last reference. */
6145 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6146 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6149 if ((ref
== NULL
|| ref
->type
!= REF_ARRAY
)
6150 && sym
->attr
.proc
== PROC_INTERNAL
)
6152 gfc_error ("%qs at %L is host associated at %L into "
6153 "a contained procedure with an internal "
6154 "procedure of the same name", sym
->name
,
6155 &old_sym
->declared_at
, &e
->where
);
6162 gcc_assert (ref
->type
== REF_ARRAY
);
6164 /* Grab the start expressions from the array ref and
6165 copy them into actual arguments. */
6166 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6168 arg
= gfc_get_actual_arglist ();
6169 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
6170 if (e
->value
.function
.actual
== NULL
)
6171 tail
= e
->value
.function
.actual
= arg
;
6179 /* Dump the reference list and set the rank. */
6180 gfc_free_ref_list (e
->ref
);
6182 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
6185 gfc_resolve_expr (e
);
6189 /* This might have changed! */
6190 return e
->expr_type
== EXPR_FUNCTION
;
6195 gfc_resolve_character_operator (gfc_expr
*e
)
6197 gfc_expr
*op1
= e
->value
.op
.op1
;
6198 gfc_expr
*op2
= e
->value
.op
.op2
;
6199 gfc_expr
*e1
= NULL
;
6200 gfc_expr
*e2
= NULL
;
6202 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
6204 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
6205 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
6206 else if (op1
->expr_type
== EXPR_CONSTANT
)
6207 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
6208 op1
->value
.character
.length
);
6210 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
6211 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
6212 else if (op2
->expr_type
== EXPR_CONSTANT
)
6213 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
6214 op2
->value
.character
.length
);
6216 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6226 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
6227 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
6228 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
6229 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
6230 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
6236 /* Ensure that an character expression has a charlen and, if possible, a
6237 length expression. */
6240 fixup_charlen (gfc_expr
*e
)
6242 /* The cases fall through so that changes in expression type and the need
6243 for multiple fixes are picked up. In all circumstances, a charlen should
6244 be available for the middle end to hang a backend_decl on. */
6245 switch (e
->expr_type
)
6248 gfc_resolve_character_operator (e
);
6252 if (e
->expr_type
== EXPR_ARRAY
)
6253 gfc_resolve_character_array_constructor (e
);
6256 case EXPR_SUBSTRING
:
6257 if (!e
->ts
.u
.cl
&& e
->ref
)
6258 gfc_resolve_substring_charlen (e
);
6263 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6270 /* Update an actual argument to include the passed-object for type-bound
6271 procedures at the right position. */
6273 static gfc_actual_arglist
*
6274 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
6277 gcc_assert (argpos
> 0);
6281 gfc_actual_arglist
* result
;
6283 result
= gfc_get_actual_arglist ();
6287 result
->name
= name
;
6293 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
6295 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
6300 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6303 extract_compcall_passed_object (gfc_expr
* e
)
6307 if (e
->expr_type
== EXPR_UNKNOWN
)
6309 gfc_error ("Error in typebound call at %L",
6314 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6316 if (e
->value
.compcall
.base_object
)
6317 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
6320 po
= gfc_get_expr ();
6321 po
->expr_type
= EXPR_VARIABLE
;
6322 po
->symtree
= e
->symtree
;
6323 po
->ref
= gfc_copy_ref (e
->ref
);
6324 po
->where
= e
->where
;
6327 if (!gfc_resolve_expr (po
))
6334 /* Update the arglist of an EXPR_COMPCALL expression to include the
6338 update_compcall_arglist (gfc_expr
* e
)
6341 gfc_typebound_proc
* tbp
;
6343 tbp
= e
->value
.compcall
.tbp
;
6348 po
= extract_compcall_passed_object (e
);
6352 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6358 if (tbp
->pass_arg_num
<= 0)
6361 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6369 /* Extract the passed object from a PPC call (a copy of it). */
6372 extract_ppc_passed_object (gfc_expr
*e
)
6377 po
= gfc_get_expr ();
6378 po
->expr_type
= EXPR_VARIABLE
;
6379 po
->symtree
= e
->symtree
;
6380 po
->ref
= gfc_copy_ref (e
->ref
);
6381 po
->where
= e
->where
;
6383 /* Remove PPC reference. */
6385 while ((*ref
)->next
)
6386 ref
= &(*ref
)->next
;
6387 gfc_free_ref_list (*ref
);
6390 if (!gfc_resolve_expr (po
))
6397 /* Update the actual arglist of a procedure pointer component to include the
6401 update_ppc_arglist (gfc_expr
* e
)
6405 gfc_typebound_proc
* tb
;
6407 ppc
= gfc_get_proc_ptr_comp (e
);
6415 else if (tb
->nopass
)
6418 po
= extract_ppc_passed_object (e
);
6425 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6430 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6432 gfc_error ("Base object for procedure-pointer component call at %L is of"
6433 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6437 gcc_assert (tb
->pass_arg_num
> 0);
6438 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6446 /* Check that the object a TBP is called on is valid, i.e. it must not be
6447 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6450 check_typebound_baseobject (gfc_expr
* e
)
6453 bool return_value
= false;
6455 base
= extract_compcall_passed_object (e
);
6459 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6461 gfc_error ("Error in typebound call at %L", &e
->where
);
6465 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6469 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6471 gfc_error ("Base object for type-bound procedure call at %L is of"
6472 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6476 /* F08:C1230. If the procedure called is NOPASS,
6477 the base object must be scalar. */
6478 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6480 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6481 " be scalar", &e
->where
);
6485 return_value
= true;
6488 gfc_free_expr (base
);
6489 return return_value
;
6493 /* Resolve a call to a type-bound procedure, either function or subroutine,
6494 statically from the data in an EXPR_COMPCALL expression. The adapted
6495 arglist and the target-procedure symtree are returned. */
6498 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6499 gfc_actual_arglist
** actual
)
6501 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6502 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6504 /* Update the actual arglist for PASS. */
6505 if (!update_compcall_arglist (e
))
6508 *actual
= e
->value
.compcall
.actual
;
6509 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6511 gfc_free_ref_list (e
->ref
);
6513 e
->value
.compcall
.actual
= NULL
;
6515 /* If we find a deferred typebound procedure, check for derived types
6516 that an overriding typebound procedure has not been missed. */
6517 if (e
->value
.compcall
.name
6518 && !e
->value
.compcall
.tbp
->non_overridable
6519 && e
->value
.compcall
.base_object
6520 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6523 gfc_symbol
*derived
;
6525 /* Use the derived type of the base_object. */
6526 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6529 /* If necessary, go through the inheritance chain. */
6530 while (!st
&& derived
)
6532 /* Look for the typebound procedure 'name'. */
6533 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6534 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6535 e
->value
.compcall
.name
);
6537 derived
= gfc_get_derived_super_type (derived
);
6540 /* Now find the specific name in the derived type namespace. */
6541 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6542 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6543 derived
->ns
, 1, &st
);
6551 /* Get the ultimate declared type from an expression. In addition,
6552 return the last class/derived type reference and the copy of the
6553 reference list. If check_types is set true, derived types are
6554 identified as well as class references. */
6556 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6557 gfc_expr
*e
, bool check_types
)
6559 gfc_symbol
*declared
;
6566 *new_ref
= gfc_copy_ref (e
->ref
);
6568 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6570 if (ref
->type
!= REF_COMPONENT
)
6573 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6574 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6575 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6577 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6583 if (declared
== NULL
)
6584 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6590 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6591 which of the specific bindings (if any) matches the arglist and transform
6592 the expression into a call of that binding. */
6595 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6597 gfc_typebound_proc
* genproc
;
6598 const char* genname
;
6600 gfc_symbol
*derived
;
6602 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6603 genname
= e
->value
.compcall
.name
;
6604 genproc
= e
->value
.compcall
.tbp
;
6606 if (!genproc
->is_generic
)
6609 /* Try the bindings on this type and in the inheritance hierarchy. */
6610 for (; genproc
; genproc
= genproc
->overridden
)
6614 gcc_assert (genproc
->is_generic
);
6615 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6618 gfc_actual_arglist
* args
;
6621 gcc_assert (g
->specific
);
6623 if (g
->specific
->error
)
6626 target
= g
->specific
->u
.specific
->n
.sym
;
6628 /* Get the right arglist by handling PASS/NOPASS. */
6629 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6630 if (!g
->specific
->nopass
)
6633 po
= extract_compcall_passed_object (e
);
6636 gfc_free_actual_arglist (args
);
6640 gcc_assert (g
->specific
->pass_arg_num
> 0);
6641 gcc_assert (!g
->specific
->error
);
6642 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6643 g
->specific
->pass_arg
);
6645 resolve_actual_arglist (args
, target
->attr
.proc
,
6646 is_external_proc (target
)
6647 && gfc_sym_get_dummy_args (target
) == NULL
);
6649 /* Check if this arglist matches the formal. */
6650 matches
= gfc_arglist_matches_symbol (&args
, target
);
6652 /* Clean up and break out of the loop if we've found it. */
6653 gfc_free_actual_arglist (args
);
6656 e
->value
.compcall
.tbp
= g
->specific
;
6657 genname
= g
->specific_st
->name
;
6658 /* Pass along the name for CLASS methods, where the vtab
6659 procedure pointer component has to be referenced. */
6667 /* Nothing matching found! */
6668 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6669 " %qs at %L", genname
, &e
->where
);
6673 /* Make sure that we have the right specific instance for the name. */
6674 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6676 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6678 e
->value
.compcall
.tbp
= st
->n
.tb
;
6684 /* Resolve a call to a type-bound subroutine. */
6687 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6689 gfc_actual_arglist
* newactual
;
6690 gfc_symtree
* target
;
6692 /* Check that's really a SUBROUTINE. */
6693 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6695 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6696 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6697 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6698 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6699 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6702 gfc_error ("%qs at %L should be a SUBROUTINE",
6703 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6708 if (!check_typebound_baseobject (c
->expr1
))
6711 /* Pass along the name for CLASS methods, where the vtab
6712 procedure pointer component has to be referenced. */
6714 *name
= c
->expr1
->value
.compcall
.name
;
6716 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6719 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6721 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6723 /* Transform into an ordinary EXEC_CALL for now. */
6725 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6728 c
->ext
.actual
= newactual
;
6729 c
->symtree
= target
;
6730 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6732 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6734 gfc_free_expr (c
->expr1
);
6735 c
->expr1
= gfc_get_expr ();
6736 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6737 c
->expr1
->symtree
= target
;
6738 c
->expr1
->where
= c
->loc
;
6740 return resolve_call (c
);
6744 /* Resolve a component-call expression. */
6746 resolve_compcall (gfc_expr
* e
, const char **name
)
6748 gfc_actual_arglist
* newactual
;
6749 gfc_symtree
* target
;
6751 /* Check that's really a FUNCTION. */
6752 if (!e
->value
.compcall
.tbp
->function
)
6754 gfc_error ("%qs at %L should be a FUNCTION",
6755 e
->value
.compcall
.name
, &e
->where
);
6760 /* These must not be assign-calls! */
6761 gcc_assert (!e
->value
.compcall
.assign
);
6763 if (!check_typebound_baseobject (e
))
6766 /* Pass along the name for CLASS methods, where the vtab
6767 procedure pointer component has to be referenced. */
6769 *name
= e
->value
.compcall
.name
;
6771 if (!resolve_typebound_generic_call (e
, name
))
6773 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6775 /* Take the rank from the function's symbol. */
6776 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6777 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6779 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6780 arglist to the TBP's binding target. */
6782 if (!resolve_typebound_static (e
, &target
, &newactual
))
6785 e
->value
.function
.actual
= newactual
;
6786 e
->value
.function
.name
= NULL
;
6787 e
->value
.function
.esym
= target
->n
.sym
;
6788 e
->value
.function
.isym
= NULL
;
6789 e
->symtree
= target
;
6790 e
->ts
= target
->n
.sym
->ts
;
6791 e
->expr_type
= EXPR_FUNCTION
;
6793 /* Resolution is not necessary if this is a class subroutine; this
6794 function only has to identify the specific proc. Resolution of
6795 the call will be done next in resolve_typebound_call. */
6796 return gfc_resolve_expr (e
);
6800 static bool resolve_fl_derived (gfc_symbol
*sym
);
6803 /* Resolve a typebound function, or 'method'. First separate all
6804 the non-CLASS references by calling resolve_compcall directly. */
6807 resolve_typebound_function (gfc_expr
* e
)
6809 gfc_symbol
*declared
;
6821 /* Deal with typebound operators for CLASS objects. */
6822 expr
= e
->value
.compcall
.base_object
;
6823 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6824 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6826 /* Since the typebound operators are generic, we have to ensure
6827 that any delays in resolution are corrected and that the vtab
6830 declared
= ts
.u
.derived
;
6831 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6832 if (c
->ts
.u
.derived
== NULL
)
6833 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6835 if (!resolve_compcall (e
, &name
))
6838 /* Use the generic name if it is there. */
6839 name
= name
? name
: e
->value
.function
.esym
->name
;
6840 e
->symtree
= expr
->symtree
;
6841 e
->ref
= gfc_copy_ref (expr
->ref
);
6842 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6844 /* Trim away the extraneous references that emerge from nested
6845 use of interface.cc (extend_expr). */
6846 if (class_ref
&& class_ref
->next
)
6848 gfc_free_ref_list (class_ref
->next
);
6849 class_ref
->next
= NULL
;
6851 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6853 gfc_free_ref_list (e
->ref
);
6857 gfc_add_vptr_component (e
);
6858 gfc_add_component_ref (e
, name
);
6859 e
->value
.function
.esym
= NULL
;
6860 if (expr
->expr_type
!= EXPR_VARIABLE
)
6861 e
->base_expr
= expr
;
6866 return resolve_compcall (e
, NULL
);
6868 if (!gfc_resolve_ref (e
))
6871 /* Get the CLASS declared type. */
6872 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6874 if (!resolve_fl_derived (declared
))
6877 /* Weed out cases of the ultimate component being a derived type. */
6878 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6879 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6881 gfc_free_ref_list (new_ref
);
6882 return resolve_compcall (e
, NULL
);
6885 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6887 /* Treat the call as if it is a typebound procedure, in order to roll
6888 out the correct name for the specific function. */
6889 if (!resolve_compcall (e
, &name
))
6891 gfc_free_ref_list (new_ref
);
6898 /* Convert the expression to a procedure pointer component call. */
6899 e
->value
.function
.esym
= NULL
;
6905 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6906 gfc_add_vptr_component (e
);
6907 gfc_add_component_ref (e
, name
);
6909 /* Recover the typespec for the expression. This is really only
6910 necessary for generic procedures, where the additional call
6911 to gfc_add_component_ref seems to throw the collection of the
6912 correct typespec. */
6916 gfc_free_ref_list (new_ref
);
6921 /* Resolve a typebound subroutine, or 'method'. First separate all
6922 the non-CLASS references by calling resolve_typebound_call
6926 resolve_typebound_subroutine (gfc_code
*code
)
6928 gfc_symbol
*declared
;
6938 st
= code
->expr1
->symtree
;
6940 /* Deal with typebound operators for CLASS objects. */
6941 expr
= code
->expr1
->value
.compcall
.base_object
;
6942 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6943 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6945 /* If the base_object is not a variable, the corresponding actual
6946 argument expression must be stored in e->base_expression so
6947 that the corresponding tree temporary can be used as the base
6948 object in gfc_conv_procedure_call. */
6949 if (expr
->expr_type
!= EXPR_VARIABLE
)
6951 gfc_actual_arglist
*args
;
6953 args
= code
->expr1
->value
.function
.actual
;
6954 for (; args
; args
= args
->next
)
6955 if (expr
== args
->expr
)
6959 /* Since the typebound operators are generic, we have to ensure
6960 that any delays in resolution are corrected and that the vtab
6962 declared
= expr
->ts
.u
.derived
;
6963 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6964 if (c
->ts
.u
.derived
== NULL
)
6965 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6967 if (!resolve_typebound_call (code
, &name
, NULL
))
6970 /* Use the generic name if it is there. */
6971 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6972 code
->expr1
->symtree
= expr
->symtree
;
6973 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6975 /* Trim away the extraneous references that emerge from nested
6976 use of interface.cc (extend_expr). */
6977 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6978 if (class_ref
&& class_ref
->next
)
6980 gfc_free_ref_list (class_ref
->next
);
6981 class_ref
->next
= NULL
;
6983 else if (code
->expr1
->ref
&& !class_ref
)
6985 gfc_free_ref_list (code
->expr1
->ref
);
6986 code
->expr1
->ref
= NULL
;
6989 /* Now use the procedure in the vtable. */
6990 gfc_add_vptr_component (code
->expr1
);
6991 gfc_add_component_ref (code
->expr1
, name
);
6992 code
->expr1
->value
.function
.esym
= NULL
;
6993 if (expr
->expr_type
!= EXPR_VARIABLE
)
6994 code
->expr1
->base_expr
= expr
;
6999 return resolve_typebound_call (code
, NULL
, NULL
);
7001 if (!gfc_resolve_ref (code
->expr1
))
7004 /* Get the CLASS declared type. */
7005 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
7007 /* Weed out cases of the ultimate component being a derived type. */
7008 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
7009 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
7011 gfc_free_ref_list (new_ref
);
7012 return resolve_typebound_call (code
, NULL
, NULL
);
7015 if (!resolve_typebound_call (code
, &name
, &overridable
))
7017 gfc_free_ref_list (new_ref
);
7020 ts
= code
->expr1
->ts
;
7024 /* Convert the expression to a procedure pointer component call. */
7025 code
->expr1
->value
.function
.esym
= NULL
;
7026 code
->expr1
->symtree
= st
;
7029 code
->expr1
->ref
= new_ref
;
7031 /* '_vptr' points to the vtab, which contains the procedure pointers. */
7032 gfc_add_vptr_component (code
->expr1
);
7033 gfc_add_component_ref (code
->expr1
, name
);
7035 /* Recover the typespec for the expression. This is really only
7036 necessary for generic procedures, where the additional call
7037 to gfc_add_component_ref seems to throw the collection of the
7038 correct typespec. */
7039 code
->expr1
->ts
= ts
;
7042 gfc_free_ref_list (new_ref
);
7048 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
7051 resolve_ppc_call (gfc_code
* c
)
7053 gfc_component
*comp
;
7055 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
7056 gcc_assert (comp
!= NULL
);
7058 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
7059 c
->expr1
->expr_type
= EXPR_VARIABLE
;
7061 if (!comp
->attr
.subroutine
)
7062 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
7064 if (!gfc_resolve_ref (c
->expr1
))
7067 if (!update_ppc_arglist (c
->expr1
))
7070 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
7072 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
7073 !(comp
->ts
.interface
7074 && comp
->ts
.interface
->formal
)))
7077 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
7080 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
7086 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
7089 resolve_expr_ppc (gfc_expr
* e
)
7091 gfc_component
*comp
;
7093 comp
= gfc_get_proc_ptr_comp (e
);
7094 gcc_assert (comp
!= NULL
);
7096 /* Convert to EXPR_FUNCTION. */
7097 e
->expr_type
= EXPR_FUNCTION
;
7098 e
->value
.function
.isym
= NULL
;
7099 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
7101 if (comp
->as
!= NULL
)
7102 e
->rank
= comp
->as
->rank
;
7104 if (!comp
->attr
.function
)
7105 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
7107 if (!gfc_resolve_ref (e
))
7110 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
7111 !(comp
->ts
.interface
7112 && comp
->ts
.interface
->formal
)))
7115 if (!update_ppc_arglist (e
))
7118 if (!check_pure_function(e
))
7121 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
7128 gfc_is_expandable_expr (gfc_expr
*e
)
7130 gfc_constructor
*con
;
7132 if (e
->expr_type
== EXPR_ARRAY
)
7134 /* Traverse the constructor looking for variables that are flavor
7135 parameter. Parameters must be expanded since they are fully used at
7137 con
= gfc_constructor_first (e
->value
.constructor
);
7138 for (; con
; con
= gfc_constructor_next (con
))
7140 if (con
->expr
->expr_type
== EXPR_VARIABLE
7141 && con
->expr
->symtree
7142 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
7143 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
7145 if (con
->expr
->expr_type
== EXPR_ARRAY
7146 && gfc_is_expandable_expr (con
->expr
))
7155 /* Sometimes variables in specification expressions of the result
7156 of module procedures in submodules wind up not being the 'real'
7157 dummy. Find this, if possible, in the namespace of the first
7161 fixup_unique_dummy (gfc_expr
*e
)
7163 gfc_symtree
*st
= NULL
;
7164 gfc_symbol
*s
= NULL
;
7166 if (e
->symtree
->n
.sym
->ns
->proc_name
7167 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
7168 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
7171 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
7174 && st
->n
.sym
!= NULL
7175 && st
->n
.sym
->attr
.dummy
)
7179 /* Resolve an expression. That is, make sure that types of operands agree
7180 with their operators, intrinsic operators are converted to function calls
7181 for overloaded types and unresolved function references are resolved. */
7184 gfc_resolve_expr (gfc_expr
*e
)
7187 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
7189 if (e
== NULL
|| e
->do_not_resolve_again
)
7192 /* inquiry_argument only applies to variables. */
7193 inquiry_save
= inquiry_argument
;
7194 actual_arg_save
= actual_arg
;
7195 first_actual_arg_save
= first_actual_arg
;
7197 if (e
->expr_type
!= EXPR_VARIABLE
)
7199 inquiry_argument
= false;
7201 first_actual_arg
= false;
7203 else if (e
->symtree
!= NULL
7204 && *e
->symtree
->name
== '@'
7205 && e
->symtree
->n
.sym
->attr
.dummy
)
7207 /* Deal with submodule specification expressions that are not
7208 found to be referenced in module.cc(read_cleanup). */
7209 fixup_unique_dummy (e
);
7212 switch (e
->expr_type
)
7215 t
= resolve_operator (e
);
7221 if (check_host_association (e
))
7222 t
= resolve_function (e
);
7224 t
= resolve_variable (e
);
7226 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
7227 && e
->ref
->type
!= REF_SUBSTRING
)
7228 gfc_resolve_substring_charlen (e
);
7233 t
= resolve_typebound_function (e
);
7236 case EXPR_SUBSTRING
:
7237 t
= gfc_resolve_ref (e
);
7246 t
= resolve_expr_ppc (e
);
7251 if (!gfc_resolve_ref (e
))
7254 t
= gfc_resolve_array_constructor (e
);
7255 /* Also try to expand a constructor. */
7258 gfc_expression_rank (e
);
7259 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
7260 gfc_expand_constructor (e
, false);
7263 /* This provides the opportunity for the length of constructors with
7264 character valued function elements to propagate the string length
7265 to the expression. */
7266 if (t
&& e
->ts
.type
== BT_CHARACTER
)
7268 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
7269 here rather then add a duplicate test for it above. */
7270 gfc_expand_constructor (e
, false);
7271 t
= gfc_resolve_character_array_constructor (e
);
7276 case EXPR_STRUCTURE
:
7277 t
= gfc_resolve_ref (e
);
7281 t
= resolve_structure_cons (e
, 0);
7285 t
= gfc_simplify_expr (e
, 0);
7289 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7292 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
7295 inquiry_argument
= inquiry_save
;
7296 actual_arg
= actual_arg_save
;
7297 first_actual_arg
= first_actual_arg_save
;
7299 /* For some reason, resolving these expressions a second time mangles
7300 the typespec of the expression itself. */
7301 if (t
&& e
->expr_type
== EXPR_VARIABLE
7302 && e
->symtree
->n
.sym
->attr
.select_rank_temporary
7303 && UNLIMITED_POLY (e
->symtree
->n
.sym
))
7304 e
->do_not_resolve_again
= 1;
7310 /* Resolve an expression from an iterator. They must be scalar and have
7311 INTEGER or (optionally) REAL type. */
7314 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
7315 const char *name_msgid
)
7317 if (!gfc_resolve_expr (expr
))
7320 if (expr
->rank
!= 0)
7322 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7326 if (expr
->ts
.type
!= BT_INTEGER
)
7328 if (expr
->ts
.type
== BT_REAL
)
7331 return gfc_notify_std (GFC_STD_F95_DEL
,
7332 "%s at %L must be integer",
7333 _(name_msgid
), &expr
->where
);
7336 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7343 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7351 /* Resolve the expressions in an iterator structure. If REAL_OK is
7352 false allow only INTEGER type iterators, otherwise allow REAL types.
7353 Set own_scope to true for ac-implied-do and data-implied-do as those
7354 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7357 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7359 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7362 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7363 _("iterator variable")))
7366 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7367 "Start expression in DO loop"))
7370 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7371 "End expression in DO loop"))
7374 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7375 "Step expression in DO loop"))
7378 /* Convert start, end, and step to the same type as var. */
7379 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7380 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7381 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7383 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7384 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7385 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7387 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7388 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7389 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7391 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7393 if ((iter
->step
->ts
.type
== BT_INTEGER
7394 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7395 || (iter
->step
->ts
.type
== BT_REAL
7396 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7398 gfc_error ("Step expression in DO loop at %L cannot be zero",
7399 &iter
->step
->where
);
7404 if (iter
->start
->expr_type
== EXPR_CONSTANT
7405 && iter
->end
->expr_type
== EXPR_CONSTANT
7406 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7409 if (iter
->start
->ts
.type
== BT_INTEGER
)
7411 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7412 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7416 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7417 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7419 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7420 gfc_warning (OPT_Wzerotrip
,
7421 "DO loop at %L will be executed zero times",
7422 &iter
->step
->where
);
7425 if (iter
->end
->expr_type
== EXPR_CONSTANT
7426 && iter
->end
->ts
.type
== BT_INTEGER
7427 && iter
->step
->expr_type
== EXPR_CONSTANT
7428 && iter
->step
->ts
.type
== BT_INTEGER
7429 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7430 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7432 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7433 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7435 if (is_step_positive
7436 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7437 gfc_warning (OPT_Wundefined_do_loop
,
7438 "DO loop at %L is undefined as it overflows",
7439 &iter
->step
->where
);
7440 else if (!is_step_positive
7441 && mpz_cmp (iter
->end
->value
.integer
,
7442 gfc_integer_kinds
[k
].min_int
) == 0)
7443 gfc_warning (OPT_Wundefined_do_loop
,
7444 "DO loop at %L is undefined as it underflows",
7445 &iter
->step
->where
);
7452 /* Traversal function for find_forall_index. f == 2 signals that
7453 that variable itself is not to be checked - only the references. */
7456 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7458 if (expr
->expr_type
!= EXPR_VARIABLE
)
7461 /* A scalar assignment */
7462 if (!expr
->ref
|| *f
== 1)
7464 if (expr
->symtree
->n
.sym
== sym
)
7476 /* Check whether the FORALL index appears in the expression or not.
7477 Returns true if SYM is found in EXPR. */
7480 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7482 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7489 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7490 to be a scalar INTEGER variable. The subscripts and stride are scalar
7491 INTEGERs, and if stride is a constant it must be nonzero.
7492 Furthermore "A subscript or stride in a forall-triplet-spec shall
7493 not contain a reference to any index-name in the
7494 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7497 resolve_forall_iterators (gfc_forall_iterator
*it
)
7499 gfc_forall_iterator
*iter
, *iter2
;
7501 for (iter
= it
; iter
; iter
= iter
->next
)
7503 if (gfc_resolve_expr (iter
->var
)
7504 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7505 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7508 if (gfc_resolve_expr (iter
->start
)
7509 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7510 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7511 &iter
->start
->where
);
7512 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7513 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7515 if (gfc_resolve_expr (iter
->end
)
7516 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7517 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7519 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7520 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7522 if (gfc_resolve_expr (iter
->stride
))
7524 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7525 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7526 &iter
->stride
->where
, "INTEGER");
7528 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7529 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7530 gfc_error ("FORALL stride expression at %L cannot be zero",
7531 &iter
->stride
->where
);
7533 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7534 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7537 for (iter
= it
; iter
; iter
= iter
->next
)
7538 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7540 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7541 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7542 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7543 gfc_error ("FORALL index %qs may not appear in triplet "
7544 "specification at %L", iter
->var
->symtree
->name
,
7545 &iter2
->start
->where
);
7550 /* Given a pointer to a symbol that is a derived type, see if it's
7551 inaccessible, i.e. if it's defined in another module and the components are
7552 PRIVATE. The search is recursive if necessary. Returns zero if no
7553 inaccessible components are found, nonzero otherwise. */
7556 derived_inaccessible (gfc_symbol
*sym
)
7560 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7563 for (c
= sym
->components
; c
; c
= c
->next
)
7565 /* Prevent an infinite loop through this function. */
7566 if (c
->ts
.type
== BT_DERIVED
7567 && (c
->attr
.pointer
|| c
->attr
.allocatable
)
7568 && sym
== c
->ts
.u
.derived
)
7571 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7579 /* Resolve the argument of a deallocate expression. The expression must be
7580 a pointer or a full array. */
7583 resolve_deallocate_expr (gfc_expr
*e
)
7585 symbol_attribute attr
;
7586 int allocatable
, pointer
;
7592 if (!gfc_resolve_expr (e
))
7595 if (e
->expr_type
!= EXPR_VARIABLE
)
7598 sym
= e
->symtree
->n
.sym
;
7599 unlimited
= UNLIMITED_POLY(sym
);
7601 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
&& CLASS_DATA (sym
))
7603 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7604 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7608 allocatable
= sym
->attr
.allocatable
;
7609 pointer
= sym
->attr
.pointer
;
7611 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7616 if (ref
->u
.ar
.type
!= AR_FULL
7617 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7618 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7623 c
= ref
->u
.c
.component
;
7624 if (c
->ts
.type
== BT_CLASS
)
7626 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7627 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7631 allocatable
= c
->attr
.allocatable
;
7632 pointer
= c
->attr
.pointer
;
7643 attr
= gfc_expr_attr (e
);
7645 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7648 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7654 if (gfc_is_coindexed (e
))
7656 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7661 && !gfc_check_vardef_context (e
, true, true, false,
7662 _("DEALLOCATE object")))
7664 if (!gfc_check_vardef_context (e
, false, true, false,
7665 _("DEALLOCATE object")))
7672 /* Returns true if the expression e contains a reference to the symbol sym. */
7674 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7676 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7683 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7685 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7689 /* Given the expression node e for an allocatable/pointer of derived type to be
7690 allocated, get the expression node to be initialized afterwards (needed for
7691 derived types with default initializers, and derived types with allocatable
7692 components that need nullification.) */
7695 gfc_expr_to_initialize (gfc_expr
*e
)
7701 result
= gfc_copy_expr (e
);
7703 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7704 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7705 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7707 if (ref
->u
.ar
.dimen
== 0
7708 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->corank
)
7711 ref
->u
.ar
.type
= AR_FULL
;
7713 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7714 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7719 gfc_free_shape (&result
->shape
, result
->rank
);
7721 /* Recalculate rank, shape, etc. */
7722 gfc_resolve_expr (result
);
7727 /* If the last ref of an expression is an array ref, return a copy of the
7728 expression with that one removed. Otherwise, a copy of the original
7729 expression. This is used for allocate-expressions and pointer assignment
7730 LHS, where there may be an array specification that needs to be stripped
7731 off when using gfc_check_vardef_context. */
7734 remove_last_array_ref (gfc_expr
* e
)
7739 e2
= gfc_copy_expr (e
);
7740 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7741 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7743 gfc_free_ref_list (*r
);
7752 /* Used in resolve_allocate_expr to check that a allocation-object and
7753 a source-expr are conformable. This does not catch all possible
7754 cases; in particular a runtime checking is needed. */
7757 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7760 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7762 /* First compare rank. */
7763 if ((tail
&& (!tail
->u
.ar
.as
|| e1
->rank
!= tail
->u
.ar
.as
->rank
))
7764 || (!tail
&& e1
->rank
!= e2
->rank
))
7766 gfc_error ("Source-expr at %L must be scalar or have the "
7767 "same rank as the allocate-object at %L",
7768 &e1
->where
, &e2
->where
);
7779 for (i
= 0; i
< e1
->rank
; i
++)
7781 if (tail
->u
.ar
.start
[i
] == NULL
)
7784 if (tail
->u
.ar
.end
[i
])
7786 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7787 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7788 mpz_add_ui (s
, s
, 1);
7792 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7795 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7797 gfc_error ("Source-expr at %L and allocate-object at %L must "
7798 "have the same shape", &e1
->where
, &e2
->where
);
7811 /* Resolve the expression in an ALLOCATE statement, doing the additional
7812 checks to see whether the expression is OK or not. The expression must
7813 have a trailing array reference that gives the size of the array. */
7816 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7818 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7822 symbol_attribute attr
;
7823 gfc_ref
*ref
, *ref2
;
7826 gfc_symbol
*sym
= NULL
;
7831 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7832 checking of coarrays. */
7833 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7834 if (ref
->next
== NULL
)
7837 if (ref
&& ref
->type
== REF_ARRAY
)
7838 ref
->u
.ar
.in_allocate
= true;
7840 if (!gfc_resolve_expr (e
))
7843 /* Make sure the expression is allocatable or a pointer. If it is
7844 pointer, the next-to-last reference must be a pointer. */
7848 sym
= e
->symtree
->n
.sym
;
7850 /* Check whether ultimate component is abstract and CLASS. */
7853 /* Is the allocate-object unlimited polymorphic? */
7854 unlimited
= UNLIMITED_POLY(e
);
7856 if (e
->expr_type
!= EXPR_VARIABLE
)
7859 attr
= gfc_expr_attr (e
);
7860 pointer
= attr
.pointer
;
7861 dimension
= attr
.dimension
;
7862 codimension
= attr
.codimension
;
7866 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7868 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7869 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7870 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7871 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7872 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7876 allocatable
= sym
->attr
.allocatable
;
7877 pointer
= sym
->attr
.pointer
;
7878 dimension
= sym
->attr
.dimension
;
7879 codimension
= sym
->attr
.codimension
;
7884 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7889 if (ref
->u
.ar
.codimen
> 0)
7892 for (n
= ref
->u
.ar
.dimen
;
7893 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7894 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7901 if (ref
->next
!= NULL
)
7909 gfc_error ("Coindexed allocatable object at %L",
7914 c
= ref
->u
.c
.component
;
7915 if (c
->ts
.type
== BT_CLASS
)
7917 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7918 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7919 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7920 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7921 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7925 allocatable
= c
->attr
.allocatable
;
7926 pointer
= c
->attr
.pointer
;
7927 dimension
= c
->attr
.dimension
;
7928 codimension
= c
->attr
.codimension
;
7929 is_abstract
= c
->attr
.abstract
;
7942 /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
7943 pointer or an allocatable variable. */
7944 if (allocatable
== 0 && pointer
== 0)
7946 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7951 /* Some checks for the SOURCE tag. */
7954 /* Check F03:C631. */
7955 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7957 gfc_error ("Type of entity at %L is type incompatible with "
7958 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7962 /* Check F03:C632 and restriction following Note 6.18. */
7963 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7966 /* Check F03:C633. */
7967 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7969 gfc_error ("The allocate-object at %L and the source-expr at %L "
7970 "shall have the same kind type parameter",
7971 &e
->where
, &code
->expr3
->where
);
7975 /* Check F2008, C642. */
7976 if (code
->expr3
->ts
.type
== BT_DERIVED
7977 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7978 || (code
->expr3
->ts
.u
.derived
->from_intmod
7979 == INTMOD_ISO_FORTRAN_ENV
7980 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7981 == ISOFORTRAN_LOCK_TYPE
)))
7983 gfc_error ("The source-expr at %L shall neither be of type "
7984 "LOCK_TYPE nor have a LOCK_TYPE component if "
7985 "allocate-object at %L is a coarray",
7986 &code
->expr3
->where
, &e
->where
);
7990 /* Check TS18508, C702/C703. */
7991 if (code
->expr3
->ts
.type
== BT_DERIVED
7992 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7993 || (code
->expr3
->ts
.u
.derived
->from_intmod
7994 == INTMOD_ISO_FORTRAN_ENV
7995 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7996 == ISOFORTRAN_EVENT_TYPE
)))
7998 gfc_error ("The source-expr at %L shall neither be of type "
7999 "EVENT_TYPE nor have a EVENT_TYPE component if "
8000 "allocate-object at %L is a coarray",
8001 &code
->expr3
->where
, &e
->where
);
8006 /* Check F08:C629. */
8007 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
8010 gcc_assert (e
->ts
.type
== BT_CLASS
);
8011 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
8012 "type-spec or source-expr", sym
->name
, &e
->where
);
8016 /* Check F08:C632. */
8017 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
8018 && !UNLIMITED_POLY (e
))
8022 if (!e
->ts
.u
.cl
->length
)
8025 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
8026 code
->ext
.alloc
.ts
.u
.cl
->length
);
8027 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
8029 gfc_error ("Allocating %s at %L with type-spec requires the same "
8030 "character-length parameter as in the declaration",
8031 sym
->name
, &e
->where
);
8036 /* In the variable definition context checks, gfc_expr_attr is used
8037 on the expression. This is fooled by the array specification
8038 present in e, thus we have to eliminate that one temporarily. */
8039 e2
= remove_last_array_ref (e
);
8042 t
= gfc_check_vardef_context (e2
, true, true, false,
8043 _("ALLOCATE object"));
8045 t
= gfc_check_vardef_context (e2
, false, true, false,
8046 _("ALLOCATE object"));
8051 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
8052 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
8054 /* For class arrays, the initialization with SOURCE is done
8055 using _copy and trans_call. It is convenient to exploit that
8056 when the allocated type is different from the declared type but
8057 no SOURCE exists by setting expr3. */
8058 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
8060 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
8061 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
8062 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
8064 /* We have to zero initialize the integer variable. */
8065 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
8068 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
8070 /* Make sure the vtab symbol is present when
8071 the module variables are generated. */
8072 gfc_typespec ts
= e
->ts
;
8074 ts
= code
->expr3
->ts
;
8075 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
8076 ts
= code
->ext
.alloc
.ts
;
8078 /* Finding the vtab also publishes the type's symbol. Therefore this
8079 statement is necessary. */
8080 gfc_find_derived_vtab (ts
.u
.derived
);
8082 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
8084 /* Again, make sure the vtab symbol is present when
8085 the module variables are generated. */
8086 gfc_typespec
*ts
= NULL
;
8088 ts
= &code
->expr3
->ts
;
8090 ts
= &code
->ext
.alloc
.ts
;
8094 /* Finding the vtab also publishes the type's symbol. Therefore this
8095 statement is necessary. */
8099 if (dimension
== 0 && codimension
== 0)
8102 /* Make sure the last reference node is an array specification. */
8104 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
8105 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
8110 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
8111 "in ALLOCATE statement at %L", &e
->where
))
8113 if (code
->expr3
->rank
!= 0)
8114 *array_alloc_wo_spec
= true;
8117 gfc_error ("Array specification or array-valued SOURCE= "
8118 "expression required in ALLOCATE statement at %L",
8125 gfc_error ("Array specification required in ALLOCATE statement "
8126 "at %L", &e
->where
);
8131 /* Make sure that the array section reference makes sense in the
8132 context of an ALLOCATE specification. */
8137 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
8139 switch (ar
->dimen_type
[i
])
8141 case DIMEN_THIS_IMAGE
:
8142 gfc_error ("Coarray specification required in ALLOCATE statement "
8143 "at %L", &e
->where
);
8148 * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
8150 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0 || ar
->stride
[i
] != NULL
)
8152 gfc_error ("Bad coarray specification in ALLOCATE statement "
8153 "at %L", &e
->where
);
8156 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
8158 gfc_error ("Upper cobound is less than lower cobound at %L",
8159 &ar
->start
[i
]->where
);
8165 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
8167 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
8168 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
8170 gfc_error ("Upper cobound is less than lower cobound "
8171 "of 1 at %L", &ar
->start
[i
]->where
);
8181 gfc_error ("Bad array specification in ALLOCATE statement at %L",
8187 for (i
= 0; i
< ar
->dimen
; i
++)
8189 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
8192 switch (ar
->dimen_type
[i
])
8198 if (ar
->start
[i
] != NULL
8199 && ar
->end
[i
] != NULL
8200 && ar
->stride
[i
] == NULL
)
8208 case DIMEN_THIS_IMAGE
:
8209 gfc_error ("Bad array specification in ALLOCATE statement at %L",
8215 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8217 sym
= a
->expr
->symtree
->n
.sym
;
8219 /* TODO - check derived type components. */
8220 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
8223 if ((ar
->start
[i
] != NULL
8224 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
8225 || (ar
->end
[i
] != NULL
8226 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
8228 gfc_error ("%qs must not appear in the array specification at "
8229 "%L in the same ALLOCATE statement where it is "
8230 "itself allocated", sym
->name
, &ar
->where
);
8236 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
8238 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
8239 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
8241 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
8243 gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
8244 "statement at %L", &e
->where
);
8250 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
8251 && ar
->stride
[i
] == NULL
)
8254 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
8268 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
8270 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
8271 gfc_alloc
*a
, *p
, *q
;
8274 errmsg
= code
->expr2
;
8276 /* Check the stat variable. */
8279 if (!gfc_check_vardef_context (stat
, false, false, false,
8280 _("STAT variable")))
8283 if (stat
->ts
.type
!= BT_INTEGER
8285 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8286 "variable", &stat
->where
);
8288 if (stat
->expr_type
== EXPR_CONSTANT
|| stat
->symtree
== NULL
)
8291 /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
8292 * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8294 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8295 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
8297 gfc_ref
*ref1
, *ref2
;
8300 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
8301 ref1
= ref1
->next
, ref2
= ref2
->next
)
8303 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8305 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8314 gfc_error ("Stat-variable at %L shall not be %sd within "
8315 "the same %s statement", &stat
->where
, fcn
, fcn
);
8323 /* Check the errmsg variable. */
8327 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8330 if (!gfc_check_vardef_context (errmsg
, false, false, false,
8331 _("ERRMSG variable")))
8334 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8335 F18:R930 errmsg-variable is scalar-default-char-variable
8336 F18:R906 default-char-variable is variable
8337 F18:C906 default-char-variable shall be default character. */
8338 if (errmsg
->ts
.type
!= BT_CHARACTER
8340 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8341 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8342 "variable", &errmsg
->where
);
8344 if (errmsg
->expr_type
== EXPR_CONSTANT
|| errmsg
->symtree
== NULL
)
8347 /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
8348 * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8350 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8351 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8353 gfc_ref
*ref1
, *ref2
;
8356 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
8357 ref1
= ref1
->next
, ref2
= ref2
->next
)
8359 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8361 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8370 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8371 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8379 /* Check that an allocate-object appears only once in the statement. */
8381 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8384 for (q
= p
->next
; q
; q
= q
->next
)
8387 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8389 /* This is a potential collision. */
8390 gfc_ref
*pr
= pe
->ref
;
8391 gfc_ref
*qr
= qe
->ref
;
8393 /* Follow the references until
8394 a) They start to differ, in which case there is no error;
8395 you can deallocate a%b and a%c in a single statement
8396 b) Both of them stop, which is an error
8397 c) One of them stops, which is also an error. */
8400 if (pr
== NULL
&& qr
== NULL
)
8402 gfc_error ("Allocate-object at %L also appears at %L",
8403 &pe
->where
, &qe
->where
);
8406 else if (pr
!= NULL
&& qr
== NULL
)
8408 gfc_error ("Allocate-object at %L is subobject of"
8409 " object at %L", &pe
->where
, &qe
->where
);
8412 else if (pr
== NULL
&& qr
!= NULL
)
8414 gfc_error ("Allocate-object at %L is subobject of"
8415 " object at %L", &qe
->where
, &pe
->where
);
8418 /* Here, pr != NULL && qr != NULL */
8419 gcc_assert(pr
->type
== qr
->type
);
8420 if (pr
->type
== REF_ARRAY
)
8422 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8424 gcc_assert (qr
->type
== REF_ARRAY
);
8426 if (pr
->next
&& qr
->next
)
8429 gfc_array_ref
*par
= &(pr
->u
.ar
);
8430 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8432 for (i
=0; i
<par
->dimen
; i
++)
8434 if ((par
->start
[i
] != NULL
8435 || qar
->start
[i
] != NULL
)
8436 && gfc_dep_compare_expr (par
->start
[i
],
8437 qar
->start
[i
]) != 0)
8444 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8457 if (strcmp (fcn
, "ALLOCATE") == 0)
8459 bool arr_alloc_wo_spec
= false;
8461 /* Resolving the expr3 in the loop over all objects to allocate would
8462 execute loop invariant code for each loop item. Therefore do it just
8464 if (code
->expr3
&& code
->expr3
->mold
8465 && code
->expr3
->ts
.type
== BT_DERIVED
)
8467 /* Default initialization via MOLD (non-polymorphic). */
8468 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8471 gfc_resolve_expr (rhs
);
8472 gfc_free_expr (code
->expr3
);
8476 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8477 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8479 if (arr_alloc_wo_spec
&& code
->expr3
)
8481 /* Mark the allocate to have to take the array specification
8483 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8488 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8489 resolve_deallocate_expr (a
->expr
);
8494 /************ SELECT CASE resolution subroutines ************/
8496 /* Callback function for our mergesort variant. Determines interval
8497 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8498 op1 > op2. Assumes we're not dealing with the default case.
8499 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8500 There are nine situations to check. */
8503 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8507 if (op1
->low
== NULL
) /* op1 = (:L) */
8509 /* op2 = (:N), so overlap. */
8511 /* op2 = (M:) or (M:N), L < M */
8512 if (op2
->low
!= NULL
8513 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8516 else if (op1
->high
== NULL
) /* op1 = (K:) */
8518 /* op2 = (M:), so overlap. */
8520 /* op2 = (:N) or (M:N), K > N */
8521 if (op2
->high
!= NULL
8522 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8525 else /* op1 = (K:L) */
8527 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8528 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8530 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8531 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8533 else /* op2 = (M:N) */
8537 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8540 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8549 /* Merge-sort a double linked case list, detecting overlap in the
8550 process. LIST is the head of the double linked case list before it
8551 is sorted. Returns the head of the sorted list if we don't see any
8552 overlap, or NULL otherwise. */
8555 check_case_overlap (gfc_case
*list
)
8557 gfc_case
*p
, *q
, *e
, *tail
;
8558 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8560 /* If the passed list was empty, return immediately. */
8567 /* Loop unconditionally. The only exit from this loop is a return
8568 statement, when we've finished sorting the case list. */
8575 /* Count the number of merges we do in this pass. */
8578 /* Loop while there exists a merge to be done. */
8583 /* Count this merge. */
8586 /* Cut the list in two pieces by stepping INSIZE places
8587 forward in the list, starting from P. */
8590 for (i
= 0; i
< insize
; i
++)
8599 /* Now we have two lists. Merge them! */
8600 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8602 /* See from which the next case to merge comes from. */
8605 /* P is empty so the next case must come from Q. */
8610 else if (qsize
== 0 || q
== NULL
)
8619 cmp
= compare_cases (p
, q
);
8622 /* The whole case range for P is less than the
8630 /* The whole case range for Q is greater than
8631 the case range for P. */
8638 /* The cases overlap, or they are the same
8639 element in the list. Either way, we must
8640 issue an error and get the next case from P. */
8641 /* FIXME: Sort P and Q by line number. */
8642 gfc_error ("CASE label at %L overlaps with CASE "
8643 "label at %L", &p
->where
, &q
->where
);
8651 /* Add the next element to the merged list. */
8660 /* P has now stepped INSIZE places along, and so has Q. So
8661 they're the same. */
8666 /* If we have done only one merge or none at all, we've
8667 finished sorting the cases. */
8676 /* Otherwise repeat, merging lists twice the size. */
8682 /* Check to see if an expression is suitable for use in a CASE statement.
8683 Makes sure that all case expressions are scalar constants of the same
8684 type. Return false if anything is wrong. */
8687 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8689 if (e
== NULL
) return true;
8691 if (e
->ts
.type
!= case_expr
->ts
.type
)
8693 gfc_error ("Expression in CASE statement at %L must be of type %s",
8694 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8698 /* C805 (R808) For a given case-construct, each case-value shall be of
8699 the same type as case-expr. For character type, length differences
8700 are allowed, but the kind type parameters shall be the same. */
8702 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8704 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8705 &e
->where
, case_expr
->ts
.kind
);
8709 /* Convert the case value kind to that of case expression kind,
8712 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8713 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8717 gfc_error ("Expression in CASE statement at %L must be scalar",
8726 /* Given a completely parsed select statement, we:
8728 - Validate all expressions and code within the SELECT.
8729 - Make sure that the selection expression is not of the wrong type.
8730 - Make sure that no case ranges overlap.
8731 - Eliminate unreachable cases and unreachable code resulting from
8732 removing case labels.
8734 The standard does allow unreachable cases, e.g. CASE (5:3). But
8735 they are a hassle for code generation, and to prevent that, we just
8736 cut them out here. This is not necessary for overlapping cases
8737 because they are illegal and we never even try to generate code.
8739 We have the additional caveat that a SELECT construct could have
8740 been a computed GOTO in the source code. Fortunately we can fairly
8741 easily work around that here: The case_expr for a "real" SELECT CASE
8742 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8743 we have to do is make sure that the case_expr is a scalar integer
8747 resolve_select (gfc_code
*code
, bool select_type
)
8750 gfc_expr
*case_expr
;
8751 gfc_case
*cp
, *default_case
, *tail
, *head
;
8752 int seen_unreachable
;
8758 if (code
->expr1
== NULL
)
8760 /* This was actually a computed GOTO statement. */
8761 case_expr
= code
->expr2
;
8762 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8763 gfc_error ("Selection expression in computed GOTO statement "
8764 "at %L must be a scalar integer expression",
8767 /* Further checking is not necessary because this SELECT was built
8768 by the compiler, so it should always be OK. Just move the
8769 case_expr from expr2 to expr so that we can handle computed
8770 GOTOs as normal SELECTs from here on. */
8771 code
->expr1
= code
->expr2
;
8776 case_expr
= code
->expr1
;
8777 type
= case_expr
->ts
.type
;
8780 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8782 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8783 &case_expr
->where
, gfc_typename (case_expr
));
8785 /* Punt. Going on here just produce more garbage error messages. */
8790 if (!select_type
&& case_expr
->rank
!= 0)
8792 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8793 "expression", &case_expr
->where
);
8799 /* Raise a warning if an INTEGER case value exceeds the range of
8800 the case-expr. Later, all expressions will be promoted to the
8801 largest kind of all case-labels. */
8803 if (type
== BT_INTEGER
)
8804 for (body
= code
->block
; body
; body
= body
->block
)
8805 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8808 && gfc_check_integer_range (cp
->low
->value
.integer
,
8809 case_expr
->ts
.kind
) != ARITH_OK
)
8810 gfc_warning (0, "Expression in CASE statement at %L is "
8811 "not in the range of %s", &cp
->low
->where
,
8812 gfc_typename (case_expr
));
8815 && cp
->low
!= cp
->high
8816 && gfc_check_integer_range (cp
->high
->value
.integer
,
8817 case_expr
->ts
.kind
) != ARITH_OK
)
8818 gfc_warning (0, "Expression in CASE statement at %L is "
8819 "not in the range of %s", &cp
->high
->where
,
8820 gfc_typename (case_expr
));
8823 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8824 of the SELECT CASE expression and its CASE values. Walk the lists
8825 of case values, and if we find a mismatch, promote case_expr to
8826 the appropriate kind. */
8828 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8830 for (body
= code
->block
; body
; body
= body
->block
)
8832 /* Walk the case label list. */
8833 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8835 /* Intercept the DEFAULT case. It does not have a kind. */
8836 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8839 /* Unreachable case ranges are discarded, so ignore. */
8840 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8841 && cp
->low
!= cp
->high
8842 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8846 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8847 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 1, 0);
8849 if (cp
->high
!= NULL
8850 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8851 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 1, 0);
8856 /* Assume there is no DEFAULT case. */
8857 default_case
= NULL
;
8862 for (body
= code
->block
; body
; body
= body
->block
)
8864 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8866 seen_unreachable
= 0;
8868 /* Walk the case label list, making sure that all case labels
8870 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8872 /* Count the number of cases in the whole construct. */
8875 /* Intercept the DEFAULT case. */
8876 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8878 if (default_case
!= NULL
)
8880 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8881 "by a second DEFAULT CASE at %L",
8882 &default_case
->where
, &cp
->where
);
8893 /* Deal with single value cases and case ranges. Errors are
8894 issued from the validation function. */
8895 if (!validate_case_label_expr (cp
->low
, case_expr
)
8896 || !validate_case_label_expr (cp
->high
, case_expr
))
8902 if (type
== BT_LOGICAL
8903 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8904 || cp
->low
!= cp
->high
))
8906 gfc_error ("Logical range in CASE statement at %L is not "
8908 cp
->low
? &cp
->low
->where
: &cp
->high
->where
);
8913 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8916 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8917 if (value
& seen_logical
)
8919 gfc_error ("Constant logical value in CASE statement "
8920 "is repeated at %L",
8925 seen_logical
|= value
;
8928 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8929 && cp
->low
!= cp
->high
8930 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8932 if (warn_surprising
)
8933 gfc_warning (OPT_Wsurprising
,
8934 "Range specification at %L can never be matched",
8937 cp
->unreachable
= 1;
8938 seen_unreachable
= 1;
8942 /* If the case range can be matched, it can also overlap with
8943 other cases. To make sure it does not, we put it in a
8944 double linked list here. We sort that with a merge sort
8945 later on to detect any overlapping cases. */
8949 head
->right
= head
->left
= NULL
;
8954 tail
->right
->left
= tail
;
8961 /* It there was a failure in the previous case label, give up
8962 for this case label list. Continue with the next block. */
8966 /* See if any case labels that are unreachable have been seen.
8967 If so, we eliminate them. This is a bit of a kludge because
8968 the case lists for a single case statement (label) is a
8969 single forward linked lists. */
8970 if (seen_unreachable
)
8972 /* Advance until the first case in the list is reachable. */
8973 while (body
->ext
.block
.case_list
!= NULL
8974 && body
->ext
.block
.case_list
->unreachable
)
8976 gfc_case
*n
= body
->ext
.block
.case_list
;
8977 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8979 gfc_free_case_list (n
);
8982 /* Strip all other unreachable cases. */
8983 if (body
->ext
.block
.case_list
)
8985 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8987 if (cp
->next
->unreachable
)
8989 gfc_case
*n
= cp
->next
;
8990 cp
->next
= cp
->next
->next
;
8992 gfc_free_case_list (n
);
8999 /* See if there were overlapping cases. If the check returns NULL,
9000 there was overlap. In that case we don't do anything. If head
9001 is non-NULL, we prepend the DEFAULT case. The sorted list can
9002 then used during code generation for SELECT CASE constructs with
9003 a case expression of a CHARACTER type. */
9006 head
= check_case_overlap (head
);
9008 /* Prepend the default_case if it is there. */
9009 if (head
!= NULL
&& default_case
)
9011 default_case
->left
= NULL
;
9012 default_case
->right
= head
;
9013 head
->left
= default_case
;
9017 /* Eliminate dead blocks that may be the result if we've seen
9018 unreachable case labels for a block. */
9019 for (body
= code
; body
&& body
->block
; body
= body
->block
)
9021 if (body
->block
->ext
.block
.case_list
== NULL
)
9023 /* Cut the unreachable block from the code chain. */
9024 gfc_code
*c
= body
->block
;
9025 body
->block
= c
->block
;
9027 /* Kill the dead block, but not the blocks below it. */
9029 gfc_free_statements (c
);
9033 /* More than two cases is legal but insane for logical selects.
9034 Issue a warning for it. */
9035 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
9036 gfc_warning (OPT_Wsurprising
,
9037 "Logical SELECT CASE block at %L has more that two cases",
9042 /* Check if a derived type is extensible. */
9045 gfc_type_is_extensible (gfc_symbol
*sym
)
9047 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
9048 || (sym
->attr
.is_class
9049 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
9054 resolve_types (gfc_namespace
*ns
);
9056 /* Resolve an associate-name: Resolve target and ensure the type-spec is
9057 correct as well as possibly the array-spec. */
9060 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
9064 gcc_assert (sym
->assoc
);
9065 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
9067 /* If this is for SELECT TYPE, the target may not yet be set. In that
9068 case, return. Resolution will be called later manually again when
9070 target
= sym
->assoc
->target
;
9073 gcc_assert (!sym
->assoc
->dangling
);
9075 if (resolve_target
&& !gfc_resolve_expr (target
))
9078 /* For variable targets, we get some attributes from the target. */
9079 if (target
->expr_type
== EXPR_VARIABLE
)
9081 gfc_symbol
*tsym
, *dsym
;
9083 gcc_assert (target
->symtree
);
9084 tsym
= target
->symtree
->n
.sym
;
9086 if (gfc_expr_attr (target
).proc_pointer
)
9088 gfc_error ("Associating entity %qs at %L is a procedure pointer",
9089 tsym
->name
, &target
->where
);
9093 if (tsym
->attr
.flavor
== FL_PROCEDURE
&& tsym
->generic
9094 && (dsym
= gfc_find_dt_in_generic (tsym
)) != NULL
9095 && dsym
->attr
.flavor
== FL_DERIVED
)
9097 gfc_error ("Derived type %qs cannot be used as a variable at %L",
9098 tsym
->name
, &target
->where
);
9102 if (tsym
->attr
.flavor
== FL_PROCEDURE
)
9104 bool is_error
= true;
9105 if (tsym
->attr
.function
&& tsym
->result
== tsym
)
9106 for (gfc_namespace
*ns
= sym
->ns
; ns
; ns
= ns
->parent
)
9107 if (tsym
== ns
->proc_name
)
9114 gfc_error ("Associating entity %qs at %L is a procedure name",
9115 tsym
->name
, &target
->where
);
9120 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
9121 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
9123 sym
->attr
.target
= tsym
->attr
.target
9124 || gfc_expr_attr (target
).pointer
;
9125 if (is_subref_array (target
))
9126 sym
->attr
.subref_array_pointer
= 1;
9128 else if (target
->ts
.type
== BT_PROCEDURE
)
9130 gfc_error ("Associating selector-expression at %L yields a procedure",
9135 if (target
->expr_type
== EXPR_NULL
)
9137 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
9140 else if (target
->ts
.type
== BT_UNKNOWN
)
9142 gfc_error ("Selector at %L has no type", &target
->where
);
9146 /* Get type if this was not already set. Note that it can be
9147 some other type than the target in case this is a SELECT TYPE
9148 selector! So we must not update when the type is already there. */
9149 if (sym
->ts
.type
== BT_UNKNOWN
)
9150 sym
->ts
= target
->ts
;
9152 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
9154 /* See if this is a valid association-to-variable. */
9155 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
9156 && !gfc_has_vector_subscript (target
));
9158 /* Finally resolve if this is an array or not. */
9159 if (sym
->attr
.dimension
&& target
->rank
== 0)
9161 /* primary.cc makes the assumption that a reference to an associate
9162 name followed by a left parenthesis is an array reference. */
9163 if (sym
->ts
.type
!= BT_CHARACTER
)
9164 gfc_error ("Associate-name %qs at %L is used as array",
9165 sym
->name
, &sym
->declared_at
);
9166 sym
->attr
.dimension
= 0;
9171 /* We cannot deal with class selectors that need temporaries. */
9172 if (target
->ts
.type
== BT_CLASS
9173 && gfc_ref_needs_temporary_p (target
->ref
))
9175 gfc_error ("CLASS selector at %L needs a temporary which is not "
9176 "yet implemented", &target
->where
);
9180 if (target
->ts
.type
== BT_CLASS
)
9181 gfc_fix_class_refs (target
);
9183 if (target
->rank
!= 0 && !sym
->attr
.select_rank_temporary
)
9186 /* The rank may be incorrectly guessed at parsing, therefore make sure
9187 it is corrected now. */
9188 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
9191 sym
->as
= gfc_get_array_spec ();
9193 as
->rank
= target
->rank
;
9194 as
->type
= AS_DEFERRED
;
9195 as
->corank
= gfc_get_corank (target
);
9196 sym
->attr
.dimension
= 1;
9197 if (as
->corank
!= 0)
9198 sym
->attr
.codimension
= 1;
9200 else if (sym
->ts
.type
== BT_CLASS
9202 && (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
9204 if (!CLASS_DATA (sym
)->as
)
9205 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
9206 as
= CLASS_DATA (sym
)->as
;
9207 as
->rank
= target
->rank
;
9208 as
->type
= AS_DEFERRED
;
9209 as
->corank
= gfc_get_corank (target
);
9210 CLASS_DATA (sym
)->attr
.dimension
= 1;
9211 if (as
->corank
!= 0)
9212 CLASS_DATA (sym
)->attr
.codimension
= 1;
9215 else if (!sym
->attr
.select_rank_temporary
)
9217 /* target's rank is 0, but the type of the sym is still array valued,
9218 which has to be corrected. */
9219 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
9220 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
9223 symbol_attribute attr
;
9224 /* The associated variable's type is still the array type
9225 correct this now. */
9226 gfc_typespec
*ts
= &target
->ts
;
9229 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
9234 ts
= &ref
->u
.c
.component
->ts
;
9237 if (ts
->type
== BT_CLASS
)
9238 ts
= &ts
->u
.derived
->components
->ts
;
9244 /* Create a scalar instance of the current class type. Because the
9245 rank of a class array goes into its name, the type has to be
9246 rebuild. The alternative of (re-)setting just the attributes
9247 and as in the current type, destroys the type also in other
9251 sym
->ts
.type
= BT_CLASS
;
9252 attr
= CLASS_DATA (sym
) ? CLASS_DATA (sym
)->attr
: sym
->attr
;
9254 attr
.associate_var
= 1;
9255 attr
.dimension
= attr
.codimension
= 0;
9256 attr
.class_pointer
= 1;
9257 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
9259 /* Make sure the _vptr is set. */
9260 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
9261 if (c
->ts
.u
.derived
== NULL
)
9262 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
9263 CLASS_DATA (sym
)->attr
.pointer
= 1;
9264 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
9265 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
9266 gfc_commit_symbol (sym
->ts
.u
.derived
);
9267 /* _vptr now has the _vtab in it, change it to the _vtype. */
9268 if (c
->ts
.u
.derived
->attr
.vtab
)
9269 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
9270 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
9271 resolve_types (c
->ts
.u
.derived
->ns
);
9275 /* Mark this as an associate variable. */
9276 sym
->attr
.associate_var
= 1;
9278 /* Fix up the type-spec for CHARACTER types. */
9279 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
9282 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
9284 if (sym
->ts
.deferred
9285 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
9287 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
9288 sym
->ts
.deferred
= 1;
9291 if (!sym
->ts
.u
.cl
->length
9292 && !sym
->ts
.deferred
9293 && target
->expr_type
== EXPR_CONSTANT
)
9295 sym
->ts
.u
.cl
->length
=
9296 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
9297 target
->value
.character
.length
);
9299 else if ((!sym
->ts
.u
.cl
->length
9300 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9301 && target
->expr_type
!= EXPR_VARIABLE
)
9303 if (!sym
->ts
.deferred
)
9305 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
9306 sym
->ts
.deferred
= 1;
9309 /* This is reset in trans-stmt.cc after the assignment
9310 of the target expression to the associate name. */
9311 sym
->attr
.allocatable
= 1;
9315 /* If the target is a good class object, so is the associate variable. */
9316 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
9317 sym
->attr
.class_ok
= 1;
9321 /* Ensure that SELECT TYPE expressions have the correct rank and a full
9322 array reference, where necessary. The symbols are artificial and so
9323 the dimension attribute and arrayspec can also be set. In addition,
9324 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
9325 This is corrected here as well.*/
9328 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
9329 int rank
, gfc_ref
*ref
)
9331 gfc_ref
*nref
= (*expr1
)->ref
;
9332 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
9333 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
9334 (*expr1
)->rank
= rank
;
9335 if (sym1
->ts
.type
== BT_CLASS
)
9337 if ((*expr1
)->ts
.type
!= BT_CLASS
)
9338 (*expr1
)->ts
= sym1
->ts
;
9340 CLASS_DATA (sym1
)->attr
.dimension
= 1;
9341 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
9342 CLASS_DATA (sym1
)->as
9343 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
9347 sym1
->attr
.dimension
= 1;
9348 if (sym1
->as
== NULL
&& sym2
)
9349 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
9352 for (; nref
; nref
= nref
->next
)
9353 if (nref
->next
== NULL
)
9356 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
9357 nref
->next
= gfc_copy_ref (ref
);
9358 else if (ref
&& !nref
)
9359 (*expr1
)->ref
= gfc_copy_ref (ref
);
9364 build_loc_call (gfc_expr
*sym_expr
)
9367 loc_call
= gfc_get_expr ();
9368 loc_call
->expr_type
= EXPR_FUNCTION
;
9369 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
9370 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
9371 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
9372 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
9373 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
9374 loc_call
->ts
.type
= BT_INTEGER
;
9375 loc_call
->ts
.kind
= gfc_index_integer_kind
;
9376 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
9377 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
9378 loc_call
->value
.function
.actual
->expr
= sym_expr
;
9379 loc_call
->where
= sym_expr
->where
;
9383 /* Resolve a SELECT TYPE statement. */
9386 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9388 gfc_symbol
*selector_type
;
9389 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9390 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9393 char name
[GFC_MAX_SYMBOL_LEN
+ 12 + 1];
9397 gfc_ref
* ref
= NULL
;
9398 gfc_expr
*selector_expr
= NULL
;
9400 ns
= code
->ext
.block
.ns
;
9403 /* Check for F03:C813. */
9404 if (code
->expr1
->ts
.type
!= BT_CLASS
9405 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9407 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9408 "at %L", &code
->loc
);
9412 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9417 gfc_ref
*ref2
= NULL
;
9418 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9419 if (ref
->type
== REF_COMPONENT
9420 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9425 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9426 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9427 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9431 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9432 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9433 selector_type
= CLASS_DATA (code
->expr2
)
9434 ? CLASS_DATA (code
->expr2
)->ts
.u
.derived
: code
->expr2
->ts
.u
.derived
;
9437 if (code
->expr2
->rank
9438 && code
->expr1
->ts
.type
== BT_CLASS
9439 && CLASS_DATA (code
->expr1
)->as
)
9440 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9442 /* F2008: C803 The selector expression must not be coindexed. */
9443 if (gfc_is_coindexed (code
->expr2
))
9445 gfc_error ("Selector at %L must not be coindexed",
9446 &code
->expr2
->where
);
9453 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9455 if (gfc_is_coindexed (code
->expr1
))
9457 gfc_error ("Selector at %L must not be coindexed",
9458 &code
->expr1
->where
);
9463 /* Loop over TYPE IS / CLASS IS cases. */
9464 for (body
= code
->block
; body
; body
= body
->block
)
9466 c
= body
->ext
.block
.case_list
;
9470 /* Check for repeated cases. */
9471 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9473 gfc_case
*d
= tail
->ext
.block
.case_list
;
9477 if (c
->ts
.type
== d
->ts
.type
9478 && ((c
->ts
.type
== BT_DERIVED
9479 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9480 && !strcmp (c
->ts
.u
.derived
->name
,
9481 d
->ts
.u
.derived
->name
))
9482 || c
->ts
.type
== BT_UNKNOWN
9483 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9484 && c
->ts
.kind
== d
->ts
.kind
)))
9486 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9487 &c
->where
, &d
->where
);
9493 /* Check F03:C815. */
9494 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9496 && !selector_type
->attr
.unlimited_polymorphic
9497 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9499 gfc_error ("Derived type %qs at %L must be extensible",
9500 c
->ts
.u
.derived
->name
, &c
->where
);
9505 /* Check F03:C816. */
9506 if (c
->ts
.type
!= BT_UNKNOWN
9507 && selector_type
&& !selector_type
->attr
.unlimited_polymorphic
9508 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9509 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9511 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9512 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9513 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9515 gfc_error ("Unexpected intrinsic type %qs at %L",
9516 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9521 /* Check F03:C814. */
9522 if (c
->ts
.type
== BT_CHARACTER
9523 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9525 gfc_error ("The type-spec at %L shall specify that each length "
9526 "type parameter is assumed", &c
->where
);
9531 /* Intercept the DEFAULT case. */
9532 if (c
->ts
.type
== BT_UNKNOWN
)
9534 /* Check F03:C818. */
9537 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9538 "by a second DEFAULT CASE at %L",
9539 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9544 default_case
= body
;
9551 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9552 target if present. If there are any EXIT statements referring to the
9553 SELECT TYPE construct, this is no problem because the gfc_code
9554 reference stays the same and EXIT is equally possible from the BLOCK
9555 it is changed to. */
9556 code
->op
= EXEC_BLOCK
;
9559 gfc_association_list
* assoc
;
9561 assoc
= gfc_get_association_list ();
9562 assoc
->st
= code
->expr1
->symtree
;
9563 assoc
->target
= gfc_copy_expr (code
->expr2
);
9564 assoc
->target
->where
= code
->expr2
->where
;
9565 /* assoc->variable will be set by resolve_assoc_var. */
9567 code
->ext
.block
.assoc
= assoc
;
9568 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9570 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9573 code
->ext
.block
.assoc
= NULL
;
9575 /* Ensure that the selector rank and arrayspec are available to
9576 correct expressions in which they might be missing. */
9577 if (code
->expr2
&& code
->expr2
->rank
)
9579 rank
= code
->expr2
->rank
;
9580 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9581 if (ref
->next
== NULL
)
9583 if (ref
&& ref
->type
== REF_ARRAY
)
9584 ref
= gfc_copy_ref (ref
);
9586 /* Fixup expr1 if necessary. */
9588 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9590 else if (code
->expr1
->rank
)
9592 rank
= code
->expr1
->rank
;
9593 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9594 if (ref
->next
== NULL
)
9596 if (ref
&& ref
->type
== REF_ARRAY
)
9597 ref
= gfc_copy_ref (ref
);
9600 /* Add EXEC_SELECT to switch on type. */
9601 new_st
= gfc_get_code (code
->op
);
9602 new_st
->expr1
= code
->expr1
;
9603 new_st
->expr2
= code
->expr2
;
9604 new_st
->block
= code
->block
;
9605 code
->expr1
= code
->expr2
= NULL
;
9610 ns
->code
->next
= new_st
;
9612 code
->op
= EXEC_SELECT_TYPE
;
9614 /* Use the intrinsic LOC function to generate an integer expression
9615 for the vtable of the selector. Note that the rank of the selector
9616 expression has to be set to zero. */
9617 gfc_add_vptr_component (code
->expr1
);
9618 code
->expr1
->rank
= 0;
9619 code
->expr1
= build_loc_call (code
->expr1
);
9620 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9622 /* Loop over TYPE IS / CLASS IS cases. */
9623 for (body
= code
->block
; body
; body
= body
->block
)
9627 c
= body
->ext
.block
.case_list
;
9629 /* Generate an index integer expression for address of the
9630 TYPE/CLASS vtable and store it in c->low. The hash expression
9631 is stored in c->high and is used to resolve intrinsic cases. */
9632 if (c
->ts
.type
!= BT_UNKNOWN
)
9634 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9636 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9638 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9639 c
->ts
.u
.derived
->hash_value
);
9643 vtab
= gfc_find_vtab (&c
->ts
);
9644 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9645 e
= CLASS_DATA (vtab
)->initializer
;
9646 c
->high
= gfc_copy_expr (e
);
9647 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9650 ts
.kind
= gfc_integer_4_kind
;
9651 ts
.type
= BT_INTEGER
;
9652 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9656 e
= gfc_lval_expr_from_sym (vtab
);
9657 c
->low
= build_loc_call (e
);
9662 /* Associate temporary to selector. This should only be done
9663 when this case is actually true, so build a new ASSOCIATE
9664 that does precisely this here (instead of using the
9667 if (c
->ts
.type
== BT_CLASS
)
9668 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9669 else if (c
->ts
.type
== BT_DERIVED
)
9670 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9671 else if (c
->ts
.type
== BT_CHARACTER
)
9673 HOST_WIDE_INT charlen
= 0;
9674 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9675 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9676 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9677 snprintf (name
, sizeof (name
),
9678 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9679 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9682 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9685 st
= gfc_find_symtree (ns
->sym_root
, name
);
9686 gcc_assert (st
->n
.sym
->assoc
);
9687 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9688 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9689 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9691 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9692 /* Fixup the target expression if necessary. */
9694 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9697 new_st
= gfc_get_code (EXEC_BLOCK
);
9698 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9699 new_st
->ext
.block
.ns
->code
= body
->next
;
9700 body
->next
= new_st
;
9702 /* Chain in the new list only if it is marked as dangling. Otherwise
9703 there is a CASE label overlap and this is already used. Just ignore,
9704 the error is diagnosed elsewhere. */
9705 if (st
->n
.sym
->assoc
->dangling
)
9707 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9708 st
->n
.sym
->assoc
->dangling
= 0;
9711 resolve_assoc_var (st
->n
.sym
, false);
9714 /* Take out CLASS IS cases for separate treatment. */
9716 while (body
&& body
->block
)
9718 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9720 /* Add to class_is list. */
9721 if (class_is
== NULL
)
9723 class_is
= body
->block
;
9728 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9729 tail
->block
= body
->block
;
9732 /* Remove from EXEC_SELECT list. */
9733 body
->block
= body
->block
->block
;
9746 /* Add a default case to hold the CLASS IS cases. */
9747 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9748 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9750 tail
->ext
.block
.case_list
= gfc_get_case ();
9751 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9753 default_case
= tail
;
9756 /* More than one CLASS IS block? */
9757 if (class_is
->block
)
9761 /* Sort CLASS IS blocks by extension level. */
9765 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9768 /* F03:C817 (check for doubles). */
9769 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9770 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9772 gfc_error ("Double CLASS IS block in SELECT TYPE "
9774 &c2
->ext
.block
.case_list
->where
);
9777 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9778 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9781 (*c1
)->block
= c2
->block
;
9791 /* Generate IF chain. */
9792 if_st
= gfc_get_code (EXEC_IF
);
9794 for (body
= class_is
; body
; body
= body
->block
)
9796 new_st
->block
= gfc_get_code (EXEC_IF
);
9797 new_st
= new_st
->block
;
9798 /* Set up IF condition: Call _gfortran_is_extension_of. */
9799 new_st
->expr1
= gfc_get_expr ();
9800 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9801 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9802 new_st
->expr1
->ts
.kind
= 4;
9803 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9804 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9805 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9806 /* Set up arguments. */
9807 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9808 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9809 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9810 new_st
->expr1
->where
= code
->loc
;
9811 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9812 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9813 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9814 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9815 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9816 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9817 /* Set up types in formal arg list. */
9818 new_st
->expr1
->value
.function
.isym
->formal
= XCNEW (gfc_intrinsic_arg
);
9819 new_st
->expr1
->value
.function
.isym
->formal
->ts
= new_st
->expr1
->value
.function
.actual
->expr
->ts
;
9820 new_st
->expr1
->value
.function
.isym
->formal
->next
= XCNEW (gfc_intrinsic_arg
);
9821 new_st
->expr1
->value
.function
.isym
->formal
->next
->ts
= new_st
->expr1
->value
.function
.actual
->next
->expr
->ts
;
9823 new_st
->next
= body
->next
;
9825 if (default_case
->next
)
9827 new_st
->block
= gfc_get_code (EXEC_IF
);
9828 new_st
= new_st
->block
;
9829 new_st
->next
= default_case
->next
;
9832 /* Replace CLASS DEFAULT code by the IF chain. */
9833 default_case
->next
= if_st
;
9836 /* Resolve the internal code. This cannot be done earlier because
9837 it requires that the sym->assoc of selectors is set already. */
9838 gfc_current_ns
= ns
;
9839 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9840 gfc_current_ns
= old_ns
;
9847 /* Resolve a SELECT RANK statement. */
9850 resolve_select_rank (gfc_code
*code
, gfc_namespace
*old_ns
)
9853 gfc_code
*body
, *new_st
, *tail
;
9855 char tname
[GFC_MAX_SYMBOL_LEN
+ 7];
9856 char name
[2 * GFC_MAX_SYMBOL_LEN
];
9858 gfc_expr
*selector_expr
= NULL
;
9860 HOST_WIDE_INT charlen
= 0;
9862 ns
= code
->ext
.block
.ns
;
9865 code
->op
= EXEC_BLOCK
;
9868 gfc_association_list
* assoc
;
9870 assoc
= gfc_get_association_list ();
9871 assoc
->st
= code
->expr1
->symtree
;
9872 assoc
->target
= gfc_copy_expr (code
->expr2
);
9873 assoc
->target
->where
= code
->expr2
->where
;
9874 /* assoc->variable will be set by resolve_assoc_var. */
9876 code
->ext
.block
.assoc
= assoc
;
9877 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9879 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9882 code
->ext
.block
.assoc
= NULL
;
9884 /* Loop over RANK cases. Note that returning on the errors causes a
9885 cascade of further errors because the case blocks do not compile
9887 for (body
= code
->block
; body
; body
= body
->block
)
9889 c
= body
->ext
.block
.case_list
;
9891 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9895 /* Check for repeated cases. */
9896 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9898 gfc_case
*d
= tail
->ext
.block
.case_list
;
9904 /* Check F2018: C1153. */
9905 if (!c
->low
&& !d
->low
)
9906 gfc_error ("RANK DEFAULT at %L is repeated at %L",
9907 &c
->where
, &d
->where
);
9909 if (!c
->low
|| !d
->low
)
9912 /* Check F2018: C1153. */
9913 case_value2
= (int) mpz_get_si (d
->low
->value
.integer
);
9914 if ((case_value
== case_value2
) && case_value
== -1)
9915 gfc_error ("RANK (*) at %L is repeated at %L",
9916 &c
->where
, &d
->where
);
9917 else if (case_value
== case_value2
)
9918 gfc_error ("RANK (%i) at %L is repeated at %L",
9919 case_value
, &c
->where
, &d
->where
);
9925 /* Check F2018: C1155. */
9926 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9927 || gfc_expr_attr (code
->expr1
).pointer
))
9928 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9929 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9931 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9932 || gfc_expr_attr (code
->expr1
).pointer
))
9933 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9934 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9937 /* Add EXEC_SELECT to switch on rank. */
9938 new_st
= gfc_get_code (code
->op
);
9939 new_st
->expr1
= code
->expr1
;
9940 new_st
->expr2
= code
->expr2
;
9941 new_st
->block
= code
->block
;
9942 code
->expr1
= code
->expr2
= NULL
;
9947 ns
->code
->next
= new_st
;
9949 code
->op
= EXEC_SELECT_RANK
;
9951 selector_expr
= code
->expr1
;
9953 /* Loop over SELECT RANK cases. */
9954 for (body
= code
->block
; body
; body
= body
->block
)
9956 c
= body
->ext
.block
.case_list
;
9959 /* Pass on the default case. */
9963 /* Associate temporary to selector. This should only be done
9964 when this case is actually true, so build a new ASSOCIATE
9965 that does precisely this here (instead of using the
9967 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9968 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9969 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9971 if (c
->ts
.type
== BT_CLASS
)
9972 sprintf (tname
, "class_%s", c
->ts
.u
.derived
->name
);
9973 else if (c
->ts
.type
== BT_DERIVED
)
9974 sprintf (tname
, "type_%s", c
->ts
.u
.derived
->name
);
9975 else if (c
->ts
.type
!= BT_CHARACTER
)
9976 sprintf (tname
, "%s_%d", gfc_basic_typename (c
->ts
.type
), c
->ts
.kind
);
9978 sprintf (tname
, "%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9979 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9981 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9982 if (case_value
>= 0)
9983 sprintf (name
, "__tmp_%s_rank_%d", tname
, case_value
);
9985 sprintf (name
, "__tmp_%s_rank_m%d", tname
, -case_value
);
9987 st
= gfc_find_symtree (ns
->sym_root
, name
);
9988 gcc_assert (st
->n
.sym
->assoc
);
9990 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9991 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9993 new_st
= gfc_get_code (EXEC_BLOCK
);
9994 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9995 new_st
->ext
.block
.ns
->code
= body
->next
;
9996 body
->next
= new_st
;
9998 /* Chain in the new list only if it is marked as dangling. Otherwise
9999 there is a CASE label overlap and this is already used. Just ignore,
10000 the error is diagnosed elsewhere. */
10001 if (st
->n
.sym
->assoc
->dangling
)
10003 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
10004 st
->n
.sym
->assoc
->dangling
= 0;
10007 resolve_assoc_var (st
->n
.sym
, false);
10010 gfc_current_ns
= ns
;
10011 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
10012 gfc_current_ns
= old_ns
;
10016 /* Resolve a transfer statement. This is making sure that:
10017 -- a derived type being transferred has only non-pointer components
10018 -- a derived type being transferred doesn't have private components, unless
10019 it's being transferred from the module where the type was defined
10020 -- we're not trying to transfer a whole assumed size array. */
10023 resolve_transfer (gfc_code
*code
)
10025 gfc_symbol
*sym
, *derived
;
10028 bool write
= false;
10029 bool formatted
= false;
10030 gfc_dt
*dt
= code
->ext
.dt
;
10031 gfc_symbol
*dtio_sub
= NULL
;
10035 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
10036 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
10037 exp
= exp
->value
.op
.op1
;
10039 if (exp
&& exp
->expr_type
== EXPR_NULL
10042 gfc_error ("Invalid context for NULL () intrinsic at %L",
10047 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
10048 && exp
->expr_type
!= EXPR_FUNCTION
10049 && exp
->expr_type
!= EXPR_ARRAY
10050 && exp
->expr_type
!= EXPR_STRUCTURE
))
10053 /* If we are reading, the variable will be changed. Note that
10054 code->ext.dt may be NULL if the TRANSFER is related to
10055 an INQUIRE statement -- but in this case, we are not reading, either. */
10056 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
10057 && !gfc_check_vardef_context (exp
, false, false, false,
10058 _("item in READ")))
10061 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
10062 || exp
->expr_type
== EXPR_FUNCTION
10063 || exp
->expr_type
== EXPR_ARRAY
10064 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
10066 /* Go to actual component transferred. */
10067 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
10068 if (ref
->type
== REF_COMPONENT
)
10069 ts
= &ref
->u
.c
.component
->ts
;
10071 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
10072 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
10074 derived
= ts
->u
.derived
;
10076 /* Determine when to use the formatted DTIO procedure. */
10077 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
10080 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
10081 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
10082 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
10084 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
10087 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
10088 /* Check to see if this is a nested DTIO call, with the
10089 dummy as the io-list object. */
10090 if (sym
&& sym
== dtio_sub
&& sym
->formal
10091 && sym
->formal
->sym
== exp
->symtree
->n
.sym
10092 && exp
->ref
== NULL
)
10094 if (!sym
->attr
.recursive
)
10096 gfc_error ("DTIO %s procedure at %L must be recursive",
10097 sym
->name
, &sym
->declared_at
);
10104 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
10106 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
10107 "it is processed by a defined input/output procedure",
10112 if (ts
->type
== BT_DERIVED
)
10114 /* Check that transferred derived type doesn't contain POINTER
10115 components unless it is processed by a defined input/output
10117 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
10119 gfc_error ("Data transfer element at %L cannot have POINTER "
10120 "components unless it is processed by a defined "
10121 "input/output procedure", &code
->loc
);
10126 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
10128 gfc_error ("Data transfer element at %L cannot have "
10129 "procedure pointer components", &code
->loc
);
10133 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
10135 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
10136 "components unless it is processed by a defined "
10137 "input/output procedure", &code
->loc
);
10141 /* C_PTR and C_FUNPTR have private components which means they cannot
10142 be printed. However, if -std=gnu and not -pedantic, allow
10143 the component to be printed to help debugging. */
10144 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
10146 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
10147 "cannot have PRIVATE components", &code
->loc
))
10150 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
10152 gfc_error ("Data transfer element at %L cannot have "
10153 "PRIVATE components unless it is processed by "
10154 "a defined input/output procedure", &code
->loc
);
10159 if (exp
->expr_type
== EXPR_STRUCTURE
)
10162 if (exp
->expr_type
== EXPR_ARRAY
)
10165 sym
= exp
->symtree
->n
.sym
;
10167 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
10168 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
10170 gfc_error ("Data transfer element at %L cannot be a full reference to "
10171 "an assumed-size array", &code
->loc
);
10177 /*********** Toplevel code resolution subroutines ***********/
10179 /* Find the set of labels that are reachable from this block. We also
10180 record the last statement in each block. */
10183 find_reachable_labels (gfc_code
*block
)
10190 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
10192 /* Collect labels in this block. We don't keep those corresponding
10193 to END {IF|SELECT}, these are checked in resolve_branch by going
10194 up through the code_stack. */
10195 for (c
= block
; c
; c
= c
->next
)
10197 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
10198 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
10201 /* Merge with labels from parent block. */
10204 gcc_assert (cs_base
->prev
->reachable_labels
);
10205 bitmap_ior_into (cs_base
->reachable_labels
,
10206 cs_base
->prev
->reachable_labels
);
10212 resolve_lock_unlock_event (gfc_code
*code
)
10214 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10215 && code
->expr1
->value
.function
.isym
10216 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10217 remove_caf_get_intrinsic (code
->expr1
);
10219 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
10220 && (code
->expr1
->ts
.type
!= BT_DERIVED
10221 || code
->expr1
->expr_type
!= EXPR_VARIABLE
10222 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
10223 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
10224 || code
->expr1
->rank
!= 0
10225 || (!gfc_is_coarray (code
->expr1
) &&
10226 !gfc_is_coindexed (code
->expr1
))))
10227 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
10228 &code
->expr1
->where
);
10229 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
10230 && (code
->expr1
->ts
.type
!= BT_DERIVED
10231 || code
->expr1
->expr_type
!= EXPR_VARIABLE
10232 || code
->expr1
->ts
.u
.derived
->from_intmod
10233 != INTMOD_ISO_FORTRAN_ENV
10234 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
10235 != ISOFORTRAN_EVENT_TYPE
10236 || code
->expr1
->rank
!= 0))
10237 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
10238 &code
->expr1
->where
);
10239 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
10240 && !gfc_is_coindexed (code
->expr1
))
10241 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
10242 &code
->expr1
->where
);
10243 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
10244 gfc_error ("Event variable argument at %L must be a coarray but not "
10245 "coindexed", &code
->expr1
->where
);
10249 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
10250 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
10251 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10252 &code
->expr2
->where
);
10255 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
10256 _("STAT variable")))
10259 /* Check ERRMSG. */
10261 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
10262 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
10263 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10264 &code
->expr3
->where
);
10267 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
10268 _("ERRMSG variable")))
10271 /* Check for LOCK the ACQUIRED_LOCK. */
10272 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
10273 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
10274 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
10275 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
10276 "variable", &code
->expr4
->where
);
10278 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
10279 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
10280 _("ACQUIRED_LOCK variable")))
10283 /* Check for EVENT WAIT the UNTIL_COUNT. */
10284 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
10286 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
10287 || code
->expr4
->rank
!= 0)
10288 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
10289 "expression", &code
->expr4
->where
);
10295 resolve_critical (gfc_code
*code
)
10297 gfc_symtree
*symtree
;
10298 gfc_symbol
*lock_type
;
10299 char name
[GFC_MAX_SYMBOL_LEN
];
10300 static int serial
= 0;
10302 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
10305 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
10306 GFC_PREFIX ("lock_type"));
10308 lock_type
= symtree
->n
.sym
;
10311 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
10313 gcc_unreachable ();
10314 lock_type
= symtree
->n
.sym
;
10315 lock_type
->attr
.flavor
= FL_DERIVED
;
10316 lock_type
->attr
.zero_comp
= 1;
10317 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
10318 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
10321 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
10322 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
10323 gcc_unreachable ();
10325 code
->resolved_sym
= symtree
->n
.sym
;
10326 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10327 symtree
->n
.sym
->attr
.referenced
= 1;
10328 symtree
->n
.sym
->attr
.artificial
= 1;
10329 symtree
->n
.sym
->attr
.codimension
= 1;
10330 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
10331 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
10332 symtree
->n
.sym
->as
= gfc_get_array_spec ();
10333 symtree
->n
.sym
->as
->corank
= 1;
10334 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
10335 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
10336 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
10338 gfc_commit_symbols();
10343 resolve_sync (gfc_code
*code
)
10345 /* Check imageset. The * case matches expr1 == NULL. */
10348 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
10349 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
10350 "INTEGER expression", &code
->expr1
->where
);
10351 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
10352 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
10353 gfc_error ("Imageset argument at %L must between 1 and num_images()",
10354 &code
->expr1
->where
);
10355 else if (code
->expr1
->expr_type
== EXPR_ARRAY
10356 && gfc_simplify_expr (code
->expr1
, 0))
10358 gfc_constructor
*cons
;
10359 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
10360 for (; cons
; cons
= gfc_constructor_next (cons
))
10361 if (cons
->expr
->expr_type
== EXPR_CONSTANT
10362 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
10363 gfc_error ("Imageset argument at %L must between 1 and "
10364 "num_images()", &cons
->expr
->where
);
10369 gfc_resolve_expr (code
->expr2
);
10372 if (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0)
10373 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10374 &code
->expr2
->where
);
10376 gfc_check_vardef_context (code
->expr2
, false, false, false,
10377 _("STAT variable"));
10380 /* Check ERRMSG. */
10381 gfc_resolve_expr (code
->expr3
);
10384 if (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0)
10385 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10386 &code
->expr3
->where
);
10388 gfc_check_vardef_context (code
->expr3
, false, false, false,
10389 _("ERRMSG variable"));
10394 /* Given a branch to a label, see if the branch is conforming.
10395 The code node describes where the branch is located. */
10398 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
10405 /* Step one: is this a valid branching target? */
10407 if (label
->defined
== ST_LABEL_UNKNOWN
)
10409 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
10414 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
10416 gfc_error ("Statement at %L is not a valid branch target statement "
10417 "for the branch statement at %L", &label
->where
, &code
->loc
);
10421 /* Step two: make sure this branch is not a branch to itself ;-) */
10423 if (code
->here
== label
)
10426 "Branch at %L may result in an infinite loop", &code
->loc
);
10430 /* Step three: See if the label is in the same block as the
10431 branching statement. The hard work has been done by setting up
10432 the bitmap reachable_labels. */
10434 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
10436 /* Check now whether there is a CRITICAL construct; if so, check
10437 whether the label is still visible outside of the CRITICAL block,
10438 which is invalid. */
10439 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10441 if (stack
->current
->op
== EXEC_CRITICAL
10442 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10443 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
10444 "label at %L", &code
->loc
, &label
->where
);
10445 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
10446 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10447 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
10448 "for label at %L", &code
->loc
, &label
->where
);
10454 /* Step four: If we haven't found the label in the bitmap, it may
10455 still be the label of the END of the enclosing block, in which
10456 case we find it by going up the code_stack. */
10458 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10460 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
10462 if (stack
->current
->op
== EXEC_CRITICAL
)
10464 /* Note: A label at END CRITICAL does not leave the CRITICAL
10465 construct as END CRITICAL is still part of it. */
10466 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
10467 " at %L", &code
->loc
, &label
->where
);
10470 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
10472 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
10473 "label at %L", &code
->loc
, &label
->where
);
10480 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
10484 /* The label is not in an enclosing block, so illegal. This was
10485 allowed in Fortran 66, so we allow it as extension. No
10486 further checks are necessary in this case. */
10487 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
10488 "as the GOTO statement at %L", &label
->where
,
10494 /* Check whether EXPR1 has the same shape as EXPR2. */
10497 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
10499 mpz_t shape
[GFC_MAX_DIMENSIONS
];
10500 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
10501 bool result
= false;
10504 /* Compare the rank. */
10505 if (expr1
->rank
!= expr2
->rank
)
10508 /* Compare the size of each dimension. */
10509 for (i
=0; i
<expr1
->rank
; i
++)
10511 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
10514 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
10517 if (mpz_cmp (shape
[i
], shape2
[i
]))
10521 /* When either of the two expression is an assumed size array, we
10522 ignore the comparison of dimension sizes. */
10527 gfc_clear_shape (shape
, i
);
10528 gfc_clear_shape (shape2
, i
);
10533 /* Check whether a WHERE assignment target or a WHERE mask expression
10534 has the same shape as the outmost WHERE mask expression. */
10537 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
10541 gfc_expr
*e
= NULL
;
10543 cblock
= code
->block
;
10545 /* Store the first WHERE mask-expr of the WHERE statement or construct.
10546 In case of nested WHERE, only the outmost one is stored. */
10547 if (mask
== NULL
) /* outmost WHERE */
10549 else /* inner WHERE */
10556 /* Check if the mask-expr has a consistent shape with the
10557 outmost WHERE mask-expr. */
10558 if (!resolve_where_shape (cblock
->expr1
, e
))
10559 gfc_error ("WHERE mask at %L has inconsistent shape",
10560 &cblock
->expr1
->where
);
10563 /* the assignment statement of a WHERE statement, or the first
10564 statement in where-body-construct of a WHERE construct */
10565 cnext
= cblock
->next
;
10570 /* WHERE assignment statement */
10573 /* Check shape consistent for WHERE assignment target. */
10574 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10575 gfc_error ("WHERE assignment target at %L has "
10576 "inconsistent shape", &cnext
->expr1
->where
);
10578 if (cnext
->op
== EXEC_ASSIGN
10579 && gfc_may_be_finalized (cnext
->expr1
->ts
))
10580 cnext
->expr1
->must_finalize
= 1;
10585 case EXEC_ASSIGN_CALL
:
10586 resolve_call (cnext
);
10587 if (!cnext
->resolved_sym
->attr
.elemental
)
10588 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10589 &cnext
->ext
.actual
->expr
->where
);
10592 /* WHERE or WHERE construct is part of a where-body-construct */
10594 resolve_where (cnext
, e
);
10598 gfc_error ("Unsupported statement inside WHERE at %L",
10601 /* the next statement within the same where-body-construct */
10602 cnext
= cnext
->next
;
10604 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10605 cblock
= cblock
->block
;
10610 /* Resolve assignment in FORALL construct.
10611 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10612 FORALL index variables. */
10615 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10619 for (n
= 0; n
< nvar
; n
++)
10621 gfc_symbol
*forall_index
;
10623 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10625 /* Check whether the assignment target is one of the FORALL index
10627 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10628 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10629 gfc_error ("Assignment to a FORALL index variable at %L",
10630 &code
->expr1
->where
);
10633 /* If one of the FORALL index variables doesn't appear in the
10634 assignment variable, then there could be a many-to-one
10635 assignment. Emit a warning rather than an error because the
10636 mask could be resolving this problem. */
10637 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10638 gfc_warning (0, "The FORALL with index %qs is not used on the "
10639 "left side of the assignment at %L and so might "
10640 "cause multiple assignment to this object",
10641 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10647 /* Resolve WHERE statement in FORALL construct. */
10650 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10651 gfc_expr
**var_expr
)
10656 cblock
= code
->block
;
10659 /* the assignment statement of a WHERE statement, or the first
10660 statement in where-body-construct of a WHERE construct */
10661 cnext
= cblock
->next
;
10666 /* WHERE assignment statement */
10668 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10670 if (cnext
->op
== EXEC_ASSIGN
10671 && gfc_may_be_finalized (cnext
->expr1
->ts
))
10672 cnext
->expr1
->must_finalize
= 1;
10676 /* WHERE operator assignment statement */
10677 case EXEC_ASSIGN_CALL
:
10678 resolve_call (cnext
);
10679 if (!cnext
->resolved_sym
->attr
.elemental
)
10680 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10681 &cnext
->ext
.actual
->expr
->where
);
10684 /* WHERE or WHERE construct is part of a where-body-construct */
10686 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10690 gfc_error ("Unsupported statement inside WHERE at %L",
10693 /* the next statement within the same where-body-construct */
10694 cnext
= cnext
->next
;
10696 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10697 cblock
= cblock
->block
;
10702 /* Traverse the FORALL body to check whether the following errors exist:
10703 1. For assignment, check if a many-to-one assignment happens.
10704 2. For WHERE statement, check the WHERE body to see if there is any
10705 many-to-one assignment. */
10708 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10712 c
= code
->block
->next
;
10718 case EXEC_POINTER_ASSIGN
:
10719 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10721 if (c
->op
== EXEC_ASSIGN
10722 && gfc_may_be_finalized (c
->expr1
->ts
))
10723 c
->expr1
->must_finalize
= 1;
10727 case EXEC_ASSIGN_CALL
:
10731 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10732 there is no need to handle it here. */
10736 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10741 /* The next statement in the FORALL body. */
10747 /* Counts the number of iterators needed inside a forall construct, including
10748 nested forall constructs. This is used to allocate the needed memory
10749 in gfc_resolve_forall. */
10752 gfc_count_forall_iterators (gfc_code
*code
)
10754 int max_iters
, sub_iters
, current_iters
;
10755 gfc_forall_iterator
*fa
;
10757 gcc_assert(code
->op
== EXEC_FORALL
);
10761 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10764 code
= code
->block
->next
;
10768 if (code
->op
== EXEC_FORALL
)
10770 sub_iters
= gfc_count_forall_iterators (code
);
10771 if (sub_iters
> max_iters
)
10772 max_iters
= sub_iters
;
10777 return current_iters
+ max_iters
;
10781 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10782 gfc_resolve_forall_body to resolve the FORALL body. */
10785 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10787 static gfc_expr
**var_expr
;
10788 static int total_var
= 0;
10789 static int nvar
= 0;
10790 int i
, old_nvar
, tmp
;
10791 gfc_forall_iterator
*fa
;
10795 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10798 /* Start to resolve a FORALL construct */
10799 if (forall_save
== 0)
10801 /* Count the total number of FORALL indices in the nested FORALL
10802 construct in order to allocate the VAR_EXPR with proper size. */
10803 total_var
= gfc_count_forall_iterators (code
);
10805 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10806 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10809 /* The information about FORALL iterator, including FORALL indices start, end
10810 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10811 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10813 /* Fortran 20008: C738 (R753). */
10814 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10816 gfc_error ("FORALL index-name at %L must be a scalar variable "
10817 "of type integer", &fa
->var
->where
);
10821 /* Check if any outer FORALL index name is the same as the current
10823 for (i
= 0; i
< nvar
; i
++)
10825 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10826 gfc_error ("An outer FORALL construct already has an index "
10827 "with this name %L", &fa
->var
->where
);
10830 /* Record the current FORALL index. */
10831 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10835 /* No memory leak. */
10836 gcc_assert (nvar
<= total_var
);
10839 /* Resolve the FORALL body. */
10840 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10842 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10843 gfc_resolve_blocks (code
->block
, ns
);
10847 /* Free only the VAR_EXPRs allocated in this frame. */
10848 for (i
= nvar
; i
< tmp
; i
++)
10849 gfc_free_expr (var_expr
[i
]);
10853 /* We are in the outermost FORALL construct. */
10854 gcc_assert (forall_save
== 0);
10856 /* VAR_EXPR is not needed any more. */
10863 /* Resolve a BLOCK construct statement. */
10865 get_temp_from_expr (gfc_expr
*, gfc_namespace
*);
10867 build_assignment (gfc_exec_op
, gfc_expr
*, gfc_expr
*,
10868 gfc_component
*, gfc_component
*, locus
);
10871 resolve_block_construct (gfc_code
* code
)
10873 gfc_namespace
*ns
= code
->ext
.block
.ns
;
10875 /* For an ASSOCIATE block, the associations (and their targets) are already
10876 resolved during resolve_symbol. Resolve the BLOCK's namespace. */
10881 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10885 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10889 for (; b
; b
= b
->block
)
10891 t
= gfc_resolve_expr (b
->expr1
);
10892 if (!gfc_resolve_expr (b
->expr2
))
10898 if (t
&& b
->expr1
!= NULL
10899 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10900 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10906 && b
->expr1
!= NULL
10907 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10908 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10913 resolve_branch (b
->label1
, b
);
10917 resolve_block_construct (b
);
10921 case EXEC_SELECT_TYPE
:
10922 case EXEC_SELECT_RANK
:
10925 case EXEC_DO_WHILE
:
10926 case EXEC_DO_CONCURRENT
:
10927 case EXEC_CRITICAL
:
10930 case EXEC_IOLENGTH
:
10934 case EXEC_OMP_ATOMIC
:
10935 case EXEC_OACC_ATOMIC
:
10937 /* Verify this before calling gfc_resolve_code, which might
10939 gcc_assert (b
->op
== EXEC_OMP_ATOMIC
10940 || (b
->next
&& b
->next
->op
== EXEC_ASSIGN
));
10944 case EXEC_OACC_PARALLEL_LOOP
:
10945 case EXEC_OACC_PARALLEL
:
10946 case EXEC_OACC_KERNELS_LOOP
:
10947 case EXEC_OACC_KERNELS
:
10948 case EXEC_OACC_SERIAL_LOOP
:
10949 case EXEC_OACC_SERIAL
:
10950 case EXEC_OACC_DATA
:
10951 case EXEC_OACC_HOST_DATA
:
10952 case EXEC_OACC_LOOP
:
10953 case EXEC_OACC_UPDATE
:
10954 case EXEC_OACC_WAIT
:
10955 case EXEC_OACC_CACHE
:
10956 case EXEC_OACC_ENTER_DATA
:
10957 case EXEC_OACC_EXIT_DATA
:
10958 case EXEC_OACC_ROUTINE
:
10959 case EXEC_OMP_ASSUME
:
10960 case EXEC_OMP_CRITICAL
:
10961 case EXEC_OMP_DISTRIBUTE
:
10962 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10963 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10964 case EXEC_OMP_DISTRIBUTE_SIMD
:
10966 case EXEC_OMP_DO_SIMD
:
10967 case EXEC_OMP_ERROR
:
10968 case EXEC_OMP_LOOP
:
10969 case EXEC_OMP_MASKED
:
10970 case EXEC_OMP_MASKED_TASKLOOP
:
10971 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
10972 case EXEC_OMP_MASTER
:
10973 case EXEC_OMP_MASTER_TASKLOOP
:
10974 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
10975 case EXEC_OMP_ORDERED
:
10976 case EXEC_OMP_PARALLEL
:
10977 case EXEC_OMP_PARALLEL_DO
:
10978 case EXEC_OMP_PARALLEL_DO_SIMD
:
10979 case EXEC_OMP_PARALLEL_LOOP
:
10980 case EXEC_OMP_PARALLEL_MASKED
:
10981 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
10982 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
10983 case EXEC_OMP_PARALLEL_MASTER
:
10984 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
10985 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
10986 case EXEC_OMP_PARALLEL_SECTIONS
:
10987 case EXEC_OMP_PARALLEL_WORKSHARE
:
10988 case EXEC_OMP_SECTIONS
:
10989 case EXEC_OMP_SIMD
:
10990 case EXEC_OMP_SCOPE
:
10991 case EXEC_OMP_SINGLE
:
10992 case EXEC_OMP_TARGET
:
10993 case EXEC_OMP_TARGET_DATA
:
10994 case EXEC_OMP_TARGET_ENTER_DATA
:
10995 case EXEC_OMP_TARGET_EXIT_DATA
:
10996 case EXEC_OMP_TARGET_PARALLEL
:
10997 case EXEC_OMP_TARGET_PARALLEL_DO
:
10998 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10999 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
11000 case EXEC_OMP_TARGET_SIMD
:
11001 case EXEC_OMP_TARGET_TEAMS
:
11002 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11003 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11004 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11005 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11006 case EXEC_OMP_TARGET_TEAMS_LOOP
:
11007 case EXEC_OMP_TARGET_UPDATE
:
11008 case EXEC_OMP_TASK
:
11009 case EXEC_OMP_TASKGROUP
:
11010 case EXEC_OMP_TASKLOOP
:
11011 case EXEC_OMP_TASKLOOP_SIMD
:
11012 case EXEC_OMP_TASKWAIT
:
11013 case EXEC_OMP_TASKYIELD
:
11014 case EXEC_OMP_TEAMS
:
11015 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11016 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11017 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11018 case EXEC_OMP_TEAMS_LOOP
:
11019 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11020 case EXEC_OMP_WORKSHARE
:
11024 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
11027 gfc_resolve_code (b
->next
, ns
);
11032 /* Does everything to resolve an ordinary assignment. Returns true
11033 if this is an interface assignment. */
11035 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
11042 symbol_attribute attr
;
11044 if (gfc_extend_assign (code
, ns
))
11048 if (code
->op
== EXEC_ASSIGN_CALL
)
11050 lhs
= code
->ext
.actual
->expr
;
11051 rhsptr
= &code
->ext
.actual
->next
->expr
;
11055 gfc_actual_arglist
* args
;
11056 gfc_typebound_proc
* tbp
;
11058 gcc_assert (code
->op
== EXEC_COMPCALL
);
11060 args
= code
->expr1
->value
.compcall
.actual
;
11062 rhsptr
= &args
->next
->expr
;
11064 tbp
= code
->expr1
->value
.compcall
.tbp
;
11065 gcc_assert (!tbp
->is_generic
);
11068 /* Make a temporary rhs when there is a default initializer
11069 and rhs is the same symbol as the lhs. */
11070 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
11071 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
11072 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
11073 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
11074 *rhsptr
= gfc_get_parentheses (*rhsptr
);
11082 if ((gfc_numeric_ts (&lhs
->ts
) || lhs
->ts
.type
== BT_LOGICAL
)
11083 && rhs
->ts
.type
== BT_CHARACTER
11084 && (rhs
->expr_type
!= EXPR_CONSTANT
|| !flag_dec_char_conversions
))
11086 /* Use of -fdec-char-conversions allows assignment of character data
11087 to non-character variables. This not permited for nonconstant
11089 gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs
),
11090 gfc_typename (lhs
), &rhs
->where
);
11094 /* Handle the case of a BOZ literal on the RHS. */
11095 if (rhs
->ts
.type
== BT_BOZ
)
11097 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
11098 "statement value nor an actual argument of "
11099 "INT/REAL/DBLE/CMPLX intrinsic subprogram",
11103 switch (lhs
->ts
.type
)
11106 if (!gfc_boz2int (rhs
, lhs
->ts
.kind
))
11110 if (!gfc_boz2real (rhs
, lhs
->ts
.kind
))
11114 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs
->where
);
11119 if (lhs
->ts
.type
== BT_CHARACTER
&& warn_character_truncation
)
11121 HOST_WIDE_INT llen
= 0, rlen
= 0;
11122 if (lhs
->ts
.u
.cl
!= NULL
11123 && lhs
->ts
.u
.cl
->length
!= NULL
11124 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
11125 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
11127 if (rhs
->expr_type
== EXPR_CONSTANT
)
11128 rlen
= rhs
->value
.character
.length
;
11130 else if (rhs
->ts
.u
.cl
!= NULL
11131 && rhs
->ts
.u
.cl
->length
!= NULL
11132 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
11133 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
11135 if (rlen
&& llen
&& rlen
> llen
)
11136 gfc_warning_now (OPT_Wcharacter_truncation
,
11137 "CHARACTER expression will be truncated "
11138 "in assignment (%ld/%ld) at %L",
11139 (long) llen
, (long) rlen
, &code
->loc
);
11142 /* Ensure that a vector index expression for the lvalue is evaluated
11143 to a temporary if the lvalue symbol is referenced in it. */
11146 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
11147 if (ref
->type
== REF_ARRAY
)
11149 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
11150 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
11151 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
11152 ref
->u
.ar
.start
[n
]))
11154 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
11158 if (gfc_pure (NULL
))
11160 if (lhs
->ts
.type
== BT_DERIVED
11161 && lhs
->expr_type
== EXPR_VARIABLE
11162 && lhs
->ts
.u
.derived
->attr
.pointer_comp
11163 && rhs
->expr_type
== EXPR_VARIABLE
11164 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
11165 || gfc_is_coindexed (rhs
)))
11167 /* F2008, C1283. */
11168 if (gfc_is_coindexed (rhs
))
11169 gfc_error ("Coindexed expression at %L is assigned to "
11170 "a derived type variable with a POINTER "
11171 "component in a PURE procedure",
11174 /* F2008, C1283 (4). */
11175 gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
11176 "shall not be used as the expr at %L of an intrinsic "
11177 "assignment statement in which the variable is of a "
11178 "derived type if the derived type has a pointer "
11179 "component at any level of component selection.",
11184 /* Fortran 2008, C1283. */
11185 if (gfc_is_coindexed (lhs
))
11187 gfc_error ("Assignment to coindexed variable at %L in a PURE "
11188 "procedure", &rhs
->where
);
11193 if (gfc_implicit_pure (NULL
))
11195 if (lhs
->expr_type
== EXPR_VARIABLE
11196 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
11197 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
11198 gfc_unset_implicit_pure (NULL
);
11200 if (lhs
->ts
.type
== BT_DERIVED
11201 && lhs
->expr_type
== EXPR_VARIABLE
11202 && lhs
->ts
.u
.derived
->attr
.pointer_comp
11203 && rhs
->expr_type
== EXPR_VARIABLE
11204 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
11205 || gfc_is_coindexed (rhs
)))
11206 gfc_unset_implicit_pure (NULL
);
11208 /* Fortran 2008, C1283. */
11209 if (gfc_is_coindexed (lhs
))
11210 gfc_unset_implicit_pure (NULL
);
11213 /* F2008, 7.2.1.2. */
11214 attr
= gfc_expr_attr (lhs
);
11215 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
11217 if (attr
.codimension
)
11219 gfc_error ("Assignment to polymorphic coarray at %L is not "
11220 "permitted", &lhs
->where
);
11223 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
11224 "polymorphic variable at %L", &lhs
->where
))
11226 if (!flag_realloc_lhs
)
11228 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
11229 "requires %<-frealloc-lhs%>", &lhs
->where
);
11233 else if (lhs
->ts
.type
== BT_CLASS
)
11235 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
11236 "assignment at %L - check that there is a matching specific "
11237 "subroutine for %<=%> operator", &lhs
->where
);
11241 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
11243 /* F2008, Section 7.2.1.2. */
11244 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
11246 gfc_error ("Coindexed variable must not have an allocatable ultimate "
11247 "component in assignment at %L", &lhs
->where
);
11251 /* Assign the 'data' of a class object to a derived type. */
11252 if (lhs
->ts
.type
== BT_DERIVED
11253 && rhs
->ts
.type
== BT_CLASS
11254 && rhs
->expr_type
!= EXPR_ARRAY
)
11255 gfc_add_data_component (rhs
);
11257 /* Make sure there is a vtable and, in particular, a _copy for the
11259 if (lhs
->ts
.type
== BT_CLASS
&& rhs
->ts
.type
!= BT_CLASS
)
11260 gfc_find_vtab (&rhs
->ts
);
11262 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
11264 || (code
->expr2
->expr_type
== EXPR_FUNCTION
11265 && code
->expr2
->value
.function
.isym
11266 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
11267 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
11268 && !gfc_expr_attr (rhs
).allocatable
11269 && !gfc_has_vector_subscript (rhs
)));
11271 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
11273 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
11274 Additionally, insert this code when the RHS is a CAF as we then use the
11275 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
11276 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
11277 noncoindexed array and the RHS is a coindexed scalar, use the normal code
11279 if (caf_convert_to_send
)
11281 if (code
->expr2
->expr_type
== EXPR_FUNCTION
11282 && code
->expr2
->value
.function
.isym
11283 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11284 remove_caf_get_intrinsic (code
->expr2
);
11285 code
->op
= EXEC_CALL
;
11286 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
11287 code
->resolved_sym
= code
->symtree
->n
.sym
;
11288 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
11289 code
->resolved_sym
->attr
.intrinsic
= 1;
11290 code
->resolved_sym
->attr
.subroutine
= 1;
11291 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
11292 gfc_commit_symbol (code
->resolved_sym
);
11293 code
->ext
.actual
= gfc_get_actual_arglist ();
11294 code
->ext
.actual
->expr
= lhs
;
11295 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
11296 code
->ext
.actual
->next
->expr
= rhs
;
11297 code
->expr1
= NULL
;
11298 code
->expr2
= NULL
;
11305 /* Add a component reference onto an expression. */
11308 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
11313 ref
= &((*ref
)->next
);
11314 *ref
= gfc_get_ref ();
11315 (*ref
)->type
= REF_COMPONENT
;
11316 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
11317 (*ref
)->u
.c
.component
= c
;
11320 /* Add a full array ref, as necessary. */
11323 gfc_add_full_array_ref (e
, c
->as
);
11324 e
->rank
= c
->as
->rank
;
11329 /* Build an assignment. Keep the argument 'op' for future use, so that
11330 pointer assignments can be made. */
11333 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
11334 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
11336 gfc_code
*this_code
;
11338 this_code
= gfc_get_code (op
);
11339 this_code
->next
= NULL
;
11340 this_code
->expr1
= gfc_copy_expr (expr1
);
11341 this_code
->expr2
= gfc_copy_expr (expr2
);
11342 this_code
->loc
= loc
;
11343 if (comp1
&& comp2
)
11345 add_comp_ref (this_code
->expr1
, comp1
);
11346 add_comp_ref (this_code
->expr2
, comp2
);
11353 /* Makes a temporary variable expression based on the characteristics of
11354 a given variable expression. */
11357 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
11359 static int serial
= 0;
11360 char name
[GFC_MAX_SYMBOL_LEN
];
11362 gfc_array_spec
*as
;
11363 gfc_array_ref
*aref
;
11366 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
11367 gfc_get_sym_tree (name
, ns
, &tmp
, false);
11368 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
11370 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
11371 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
11373 e
->value
.character
.length
);
11379 /* Obtain the arrayspec for the temporary. */
11380 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
11381 && e
->expr_type
!= EXPR_FUNCTION
11382 && e
->expr_type
!= EXPR_OP
)
11384 aref
= gfc_find_array_ref (e
);
11385 if (e
->expr_type
== EXPR_VARIABLE
11386 && e
->symtree
->n
.sym
->as
== aref
->as
)
11390 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
11391 if (ref
->type
== REF_COMPONENT
11392 && ref
->u
.c
.component
->as
== aref
->as
)
11400 /* Add the attributes and the arrayspec to the temporary. */
11401 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
11402 tmp
->n
.sym
->attr
.function
= 0;
11403 tmp
->n
.sym
->attr
.proc_pointer
= 0;
11404 tmp
->n
.sym
->attr
.result
= 0;
11405 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
11406 tmp
->n
.sym
->attr
.dummy
= 0;
11407 tmp
->n
.sym
->attr
.use_assoc
= 0;
11408 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
11413 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
11416 if (as
->type
== AS_DEFERRED
)
11417 tmp
->n
.sym
->attr
.allocatable
= 1;
11419 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
11420 || e
->expr_type
== EXPR_FUNCTION
11421 || e
->expr_type
== EXPR_OP
))
11423 tmp
->n
.sym
->as
= gfc_get_array_spec ();
11424 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
11425 tmp
->n
.sym
->as
->rank
= e
->rank
;
11426 tmp
->n
.sym
->attr
.allocatable
= 1;
11427 tmp
->n
.sym
->attr
.dimension
= 1;
11430 tmp
->n
.sym
->attr
.dimension
= 0;
11432 gfc_set_sym_referenced (tmp
->n
.sym
);
11433 gfc_commit_symbol (tmp
->n
.sym
);
11434 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
11436 /* Should the lhs be a section, use its array ref for the
11437 temporary expression. */
11438 if (aref
&& aref
->type
!= AR_FULL
)
11440 gfc_free_ref_list (e
->ref
);
11441 e
->ref
= gfc_copy_ref (ref
);
11447 /* Add one line of code to the code chain, making sure that 'head' and
11448 'tail' are appropriately updated. */
11451 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
11453 gcc_assert (this_code
);
11455 *head
= *tail
= *this_code
;
11457 *tail
= gfc_append_code (*tail
, *this_code
);
11462 /* Generate a final call from a variable expression */
11465 generate_final_call (gfc_expr
*tmp_expr
, gfc_code
**head
, gfc_code
**tail
)
11467 gfc_code
*this_code
;
11468 gfc_expr
*final_expr
= NULL
;
11469 gfc_expr
*size_expr
;
11470 gfc_expr
*fini_coarray
;
11472 gcc_assert (tmp_expr
->expr_type
== EXPR_VARIABLE
);
11473 if (!gfc_is_finalizable (tmp_expr
->ts
.u
.derived
, &final_expr
) || !final_expr
)
11476 /* Now generate the finalizer call. */
11477 this_code
= gfc_get_code (EXEC_CALL
);
11478 this_code
->symtree
= final_expr
->symtree
;
11479 this_code
->resolved_sym
= final_expr
->symtree
->n
.sym
;
11481 //* Expression to be finalized */
11482 this_code
->ext
.actual
= gfc_get_actual_arglist ();
11483 this_code
->ext
.actual
->expr
= gfc_copy_expr (tmp_expr
);
11485 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
11486 this_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
11487 size_expr
= gfc_get_expr ();
11488 size_expr
->where
= gfc_current_locus
;
11489 size_expr
->expr_type
= EXPR_OP
;
11490 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
11491 size_expr
->value
.op
.op1
11492 = gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_STORAGE_SIZE
,
11493 "storage_size", gfc_current_locus
, 2,
11494 gfc_lval_expr_from_sym (tmp_expr
->symtree
->n
.sym
),
11495 gfc_get_int_expr (gfc_index_integer_kind
,
11497 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
11498 gfc_character_storage_size
);
11499 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
11500 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
11501 this_code
->ext
.actual
->next
->expr
= size_expr
;
11504 this_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
11505 fini_coarray
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
11507 fini_coarray
->value
.logical
= (int)gfc_expr_attr (tmp_expr
).codimension
;
11508 this_code
->ext
.actual
->next
->next
->expr
= fini_coarray
;
11510 add_code_to_chain (&this_code
, head
, tail
);
11514 /* Counts the potential number of part array references that would
11515 result from resolution of typebound defined assignments. */
11519 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
11522 int c_depth
= 0, t_depth
;
11524 for (c
= derived
->components
; c
; c
= c
->next
)
11526 if ((!gfc_bt_struct (c
->ts
.type
)
11528 || c
->attr
.allocatable
11529 || c
->attr
.proc_pointer_comp
11530 || c
->attr
.class_pointer
11531 || c
->attr
.proc_pointer
)
11532 && !c
->attr
.defined_assign_comp
)
11535 if (c
->as
&& c_depth
== 0)
11538 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
11539 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
11544 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
11546 return depth
+ c_depth
;
11550 /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
11551 "An intrinsic assignment where the variable is of derived type is performed
11552 as if each component of the variable were assigned from the corresponding
11553 component of expr using pointer assignment (10.2.2) for each pointer
11554 component, defined assignment for each nonpointer nonallocatable component
11555 of a type that has a type-bound defined assignment consistent with the
11556 component, intrinsic assignment for each other nonpointer nonallocatable
11557 component, and intrinsic assignment for each allocated coarray component.
11558 For unallocated coarray components, the corresponding component of the
11559 variable shall be unallocated. For a noncoarray allocatable component the
11560 following sequence of operations is applied.
11561 (1) If the component of the variable is allocated, it is deallocated.
11562 (2) If the component of the value of expr is allocated, the
11563 corresponding component of the variable is allocated with the same
11564 dynamic type and type parameters as the component of the value of
11565 expr. If it is an array, it is allocated with the same bounds. The
11566 value of the component of the value of expr is then assigned to the
11567 corresponding component of the variable using defined assignment if
11568 the declared type of the component has a type-bound defined
11569 assignment consistent with the component, and intrinsic assignment
11570 for the dynamic type of that component otherwise."
11572 The pointer assignments are taken care of by the intrinsic assignment of the
11573 structure itself. This function recursively adds defined assignments where
11574 required. The recursion is accomplished by calling gfc_resolve_code.
11576 When the lhs in a defined assignment has intent INOUT or is intent OUT
11577 and the component of 'var' is finalizable, we need a temporary for the
11578 lhs. In pseudo-code for an assignment var = expr:
11580 ! Confine finalization of temporaries, as far as possible.
11581 Enclose the code for the assignment in a block
11582 ! Only call function 'expr' once.
11583 #if ('expr is not a constant or an variable)
11586 ! Do the intrinsic assignment
11587 #if typeof ('var') has a typebound final subroutine
11590 ! Now do the component assignments
11591 #do over derived type components [%cmp]
11592 #if (cmp is a pointer of any kind)
11594 build the assignment
11596 #if the code is a typebound assignment
11597 #if (arg1 is INOUT or finalizable OUT && !t1)
11600 deal with allocatation or not of var and this component
11601 #elseif the code is an assignment by itself
11602 #if this component does not need finalization
11603 delete code and continue
11605 remove the leading assignment
11608 #if (t1 and (arg1 is INOUT or finalizable OUT))
11611 put all code chunks involving t1 to the top of the generated code
11612 insert the generated block in place of the original code
11616 is_finalizable_type (gfc_typespec ts
)
11620 if (ts
.type
!= BT_DERIVED
)
11623 /* (1) Check for FINAL subroutines. */
11624 if (ts
.u
.derived
->f2k_derived
&& ts
.u
.derived
->f2k_derived
->finalizers
)
11627 /* (2) Check for components of finalizable type. */
11628 for (c
= ts
.u
.derived
->components
; c
; c
= c
->next
)
11629 if (c
->ts
.type
== BT_DERIVED
11630 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
11631 && c
->ts
.u
.derived
->f2k_derived
11632 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
11638 /* The temporary assignments have to be put on top of the additional
11639 code to avoid the result being changed by the intrinsic assignment.
11641 static int component_assignment_level
= 0;
11642 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
11643 static bool finalizable_comp
;
11646 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
11648 gfc_component
*comp1
, *comp2
;
11649 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
11650 gfc_code
*tmp_code
= NULL
;
11651 gfc_expr
*t1
= NULL
;
11652 gfc_expr
*tmp_expr
= NULL
;
11653 int error_count
, depth
;
11654 bool finalizable_lhs
;
11656 gfc_get_errors (NULL
, &error_count
);
11658 /* Filter out continuing processing after an error. */
11660 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
11661 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
11664 /* TODO: Handle more than one part array reference in assignments. */
11665 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
11666 (*code
)->expr1
->rank
? 1 : 0);
11669 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
11670 "done because multiple part array references would "
11671 "occur in intermediate expressions.", &(*code
)->loc
);
11675 if (!component_assignment_level
)
11676 finalizable_comp
= true;
11678 /* Build a block so that function result temporaries are finalized
11679 locally on exiting the rather than enclosing scope. */
11680 if (!component_assignment_level
)
11682 ns
= gfc_build_block_ns (ns
);
11683 tmp_code
= gfc_get_code (EXEC_NOP
);
11684 *tmp_code
= **code
;
11685 tmp_code
->next
= NULL
;
11686 (*code
)->op
= EXEC_BLOCK
;
11687 (*code
)->ext
.block
.ns
= ns
;
11688 (*code
)->ext
.block
.assoc
= NULL
;
11689 (*code
)->expr1
= (*code
)->expr2
= NULL
;
11690 ns
->code
= tmp_code
;
11694 component_assignment_level
++;
11696 finalizable_lhs
= is_finalizable_type ((*code
)->expr1
->ts
);
11698 /* Create a temporary so that functions get called only once. */
11699 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
11700 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
11702 /* Assign the rhs to the temporary. */
11703 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11704 this_code
= build_assignment (EXEC_ASSIGN
,
11705 tmp_expr
, (*code
)->expr2
,
11706 NULL
, NULL
, (*code
)->loc
);
11707 this_code
->expr2
->must_finalize
= 1;
11708 /* Add the code and substitute the rhs expression. */
11709 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
11710 gfc_free_expr ((*code
)->expr2
);
11711 (*code
)->expr2
= tmp_expr
;
11714 /* Do the intrinsic assignment. This is not needed if the lhs is one
11715 of the temporaries generated here, since the intrinsic assignment
11716 to the final result already does this. */
11717 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '.')
11719 if (finalizable_lhs
)
11720 (*code
)->expr1
->must_finalize
= 1;
11721 this_code
= build_assignment (EXEC_ASSIGN
,
11722 (*code
)->expr1
, (*code
)->expr2
,
11723 NULL
, NULL
, (*code
)->loc
);
11724 add_code_to_chain (&this_code
, &head
, &tail
);
11727 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
11728 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
11730 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
11732 bool inout
= false;
11733 bool finalizable_out
= false;
11735 /* The intrinsic assignment does the right thing for pointers
11736 of all kinds and allocatable components. */
11737 if (!gfc_bt_struct (comp1
->ts
.type
)
11738 || comp1
->attr
.pointer
11739 || comp1
->attr
.proc_pointer_comp
11740 || comp1
->attr
.class_pointer
11741 || comp1
->attr
.proc_pointer
)
11744 finalizable_comp
= is_finalizable_type (comp1
->ts
)
11745 && !finalizable_lhs
;
11747 /* Make an assignment for this component. */
11748 this_code
= build_assignment (EXEC_ASSIGN
,
11749 (*code
)->expr1
, (*code
)->expr2
,
11750 comp1
, comp2
, (*code
)->loc
);
11752 /* Convert the assignment if there is a defined assignment for
11753 this type. Otherwise, using the call from gfc_resolve_code,
11754 recurse into its components. */
11755 gfc_resolve_code (this_code
, ns
);
11757 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11759 gfc_formal_arglist
*dummy_args
;
11761 /* Check that there is a typebound defined assignment. If not,
11762 then this must be a module defined assignment. We cannot
11763 use the defined_assign_comp attribute here because it must
11764 be this derived type that has the defined assignment and not
11766 if (!(comp1
->ts
.u
.derived
->f2k_derived
11767 && comp1
->ts
.u
.derived
->f2k_derived
11768 ->tb_op
[INTRINSIC_ASSIGN
]))
11770 gfc_free_statements (this_code
);
11775 /* If the first argument of the subroutine has intent INOUT
11776 a temporary must be generated and used instead. */
11777 rsym
= this_code
->resolved_sym
;
11778 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11779 finalizable_out
= gfc_may_be_finalized (comp1
->ts
)
11781 && dummy_args
->sym
->attr
.intent
== INTENT_OUT
;
11783 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
;
11784 if ((inout
|| finalizable_out
)
11785 && !comp1
->attr
.allocatable
)
11787 gfc_code
*temp_code
;
11790 /* Build the temporary required for the assignment and put
11791 it at the head of the generated code. */
11794 gfc_namespace
*tmp_ns
= ns
;
11795 if (ns
->parent
&& gfc_may_be_finalized (comp1
->ts
))
11796 tmp_ns
= (*code
)->expr1
->symtree
->n
.sym
->ns
;
11797 t1
= get_temp_from_expr ((*code
)->expr1
, tmp_ns
);
11798 t1
->symtree
->n
.sym
->attr
.artificial
= 1;
11799 temp_code
= build_assignment (EXEC_ASSIGN
,
11800 t1
, (*code
)->expr1
,
11801 NULL
, NULL
, (*code
)->loc
);
11803 /* For allocatable LHS, check whether it is allocated. Note
11804 that allocatable components with defined assignment are
11805 not yet support. See PR 57696. */
11806 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11810 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11811 block
= gfc_get_code (EXEC_IF
);
11812 block
->block
= gfc_get_code (EXEC_IF
);
11813 block
->block
->expr1
11814 = gfc_build_intrinsic_call (ns
,
11815 GFC_ISYM_ALLOCATED
, "allocated",
11816 (*code
)->loc
, 1, e
);
11817 block
->block
->next
= temp_code
;
11820 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11823 /* Replace the first actual arg with the component of the
11825 gfc_free_expr (this_code
->ext
.actual
->expr
);
11826 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11827 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11829 /* If the LHS variable is allocatable and wasn't allocated and
11830 the temporary is allocatable, pointer assign the address of
11831 the freshly allocated LHS to the temporary. */
11832 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11833 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11838 cond
= gfc_get_expr ();
11839 cond
->ts
.type
= BT_LOGICAL
;
11840 cond
->ts
.kind
= gfc_default_logical_kind
;
11841 cond
->expr_type
= EXPR_OP
;
11842 cond
->where
= (*code
)->loc
;
11843 cond
->value
.op
.op
= INTRINSIC_NOT
;
11844 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11845 GFC_ISYM_ALLOCATED
, "allocated",
11846 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11847 block
= gfc_get_code (EXEC_IF
);
11848 block
->block
= gfc_get_code (EXEC_IF
);
11849 block
->block
->expr1
= cond
;
11850 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11851 t1
, (*code
)->expr1
,
11852 NULL
, NULL
, (*code
)->loc
);
11853 add_code_to_chain (&block
, &head
, &tail
);
11857 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11859 /* Don't add intrinsic assignments since they are already
11860 effected by the intrinsic assignment of the structure, unless
11861 finalization is required. */
11862 if (finalizable_comp
)
11863 this_code
->expr1
->must_finalize
= 1;
11866 gfc_free_statements (this_code
);
11873 /* Resolution has expanded an assignment of a derived type with
11874 defined assigned components. Remove the redundant, leading
11876 gcc_assert (this_code
->op
== EXEC_ASSIGN
);
11877 gfc_code
*tmp
= this_code
;
11878 this_code
= this_code
->next
;
11880 gfc_free_statements (tmp
);
11883 add_code_to_chain (&this_code
, &head
, &tail
);
11885 if (t1
&& (inout
|| finalizable_out
))
11887 /* Transfer the value to the final result. */
11888 this_code
= build_assignment (EXEC_ASSIGN
,
11889 (*code
)->expr1
, t1
,
11890 comp1
, comp2
, (*code
)->loc
);
11891 this_code
->expr1
->must_finalize
= 0;
11892 add_code_to_chain (&this_code
, &head
, &tail
);
11896 /* Put the temporary assignments at the top of the generated code. */
11897 if (tmp_head
&& component_assignment_level
== 1)
11899 gfc_append_code (tmp_head
, head
);
11901 tmp_head
= tmp_tail
= NULL
;
11904 /* If we did a pointer assignment - thus, we need to ensure that the LHS is
11905 not accidentally deallocated. Hence, nullify t1. */
11906 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11907 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11913 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11914 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11915 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11916 block
= gfc_get_code (EXEC_IF
);
11917 block
->block
= gfc_get_code (EXEC_IF
);
11918 block
->block
->expr1
= cond
;
11919 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11920 t1
, gfc_get_null_expr (&(*code
)->loc
),
11921 NULL
, NULL
, (*code
)->loc
);
11922 gfc_append_code (tail
, block
);
11926 component_assignment_level
--;
11928 /* Make an explicit final call for the function result. */
11930 generate_final_call (tmp_expr
, &head
, &tail
);
11938 /* Now attach the remaining code chain to the input code. Step on
11939 to the end of the new code since resolution is complete. */
11940 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11941 tail
->next
= (*code
)->next
;
11942 /* Overwrite 'code' because this would place the intrinsic assignment
11943 before the temporary for the lhs is created. */
11944 gfc_free_expr ((*code
)->expr1
);
11945 gfc_free_expr ((*code
)->expr2
);
11953 /* F2008: Pointer function assignments are of the form:
11954 ptr_fcn (args) = expr
11955 This function breaks these assignments into two statements:
11956 temporary_pointer => ptr_fcn(args)
11957 temporary_pointer = expr */
11960 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11962 gfc_expr
*tmp_ptr_expr
;
11963 gfc_code
*this_code
;
11964 gfc_component
*comp
;
11967 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11970 /* Even if standard does not support this feature, continue to build
11971 the two statements to avoid upsetting frontend_passes.c. */
11972 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11973 "%L", &(*code
)->loc
);
11975 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11978 s
= comp
->ts
.interface
;
11980 s
= (*code
)->expr1
->symtree
->n
.sym
;
11982 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11984 gfc_error ("The function result on the lhs of the assignment at "
11985 "%L must have the pointer attribute.",
11986 &(*code
)->expr1
->where
);
11987 (*code
)->op
= EXEC_NOP
;
11991 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11993 /* get_temp_from_expression is set up for ordinary assignments. To that
11994 end, where array bounds are not known, arrays are made allocatable.
11995 Change the temporary to a pointer here. */
11996 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11997 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11998 tmp_ptr_expr
->where
= (*code
)->loc
;
12000 this_code
= build_assignment (EXEC_ASSIGN
,
12001 tmp_ptr_expr
, (*code
)->expr2
,
12002 NULL
, NULL
, (*code
)->loc
);
12003 this_code
->next
= (*code
)->next
;
12004 (*code
)->next
= this_code
;
12005 (*code
)->op
= EXEC_POINTER_ASSIGN
;
12006 (*code
)->expr2
= (*code
)->expr1
;
12007 (*code
)->expr1
= tmp_ptr_expr
;
12013 /* Deferred character length assignments from an operator expression
12014 require a temporary because the character length of the lhs can
12015 change in the course of the assignment. */
12018 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
12020 gfc_expr
*tmp_expr
;
12021 gfc_code
*this_code
;
12023 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
12024 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
12025 && (*code
)->expr2
->ts
.type
== BT_CHARACTER
12026 && (*code
)->expr2
->expr_type
== EXPR_OP
))
12029 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
12032 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
12035 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
12036 tmp_expr
->where
= (*code
)->loc
;
12038 /* A new charlen is required to ensure that the variable string
12039 length is different to that of the original lhs. */
12040 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
12041 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
12042 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
12043 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
12045 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
12047 this_code
= build_assignment (EXEC_ASSIGN
,
12049 gfc_copy_expr (tmp_expr
),
12050 NULL
, NULL
, (*code
)->loc
);
12052 (*code
)->expr1
= tmp_expr
;
12054 this_code
->next
= (*code
)->next
;
12055 (*code
)->next
= this_code
;
12062 check_team (gfc_expr
*team
, const char *intrinsic
)
12064 if (team
->rank
!= 0
12065 || team
->ts
.type
!= BT_DERIVED
12066 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
12067 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
12069 gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
12070 "of type TEAM_TYPE", intrinsic
, &team
->where
);
12078 /* Given a block of code, recursively resolve everything pointed to by this
12082 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
12084 int omp_workshare_save
;
12085 int forall_save
, do_concurrent_save
;
12089 frame
.prev
= cs_base
;
12093 find_reachable_labels (code
);
12095 for (; code
; code
= code
->next
)
12097 frame
.current
= code
;
12098 forall_save
= forall_flag
;
12099 do_concurrent_save
= gfc_do_concurrent_flag
;
12101 if (code
->op
== EXEC_FORALL
)
12104 gfc_resolve_forall (code
, ns
, forall_save
);
12107 else if (code
->block
)
12109 omp_workshare_save
= -1;
12112 case EXEC_OACC_PARALLEL_LOOP
:
12113 case EXEC_OACC_PARALLEL
:
12114 case EXEC_OACC_KERNELS_LOOP
:
12115 case EXEC_OACC_KERNELS
:
12116 case EXEC_OACC_SERIAL_LOOP
:
12117 case EXEC_OACC_SERIAL
:
12118 case EXEC_OACC_DATA
:
12119 case EXEC_OACC_HOST_DATA
:
12120 case EXEC_OACC_LOOP
:
12121 gfc_resolve_oacc_blocks (code
, ns
);
12123 case EXEC_OMP_PARALLEL_WORKSHARE
:
12124 omp_workshare_save
= omp_workshare_flag
;
12125 omp_workshare_flag
= 1;
12126 gfc_resolve_omp_parallel_blocks (code
, ns
);
12128 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
12129 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
12130 case EXEC_OMP_MASKED_TASKLOOP
:
12131 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
12132 case EXEC_OMP_MASTER_TASKLOOP
:
12133 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
12134 case EXEC_OMP_PARALLEL
:
12135 case EXEC_OMP_PARALLEL_DO
:
12136 case EXEC_OMP_PARALLEL_DO_SIMD
:
12137 case EXEC_OMP_PARALLEL_LOOP
:
12138 case EXEC_OMP_PARALLEL_MASKED
:
12139 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
12140 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
12141 case EXEC_OMP_PARALLEL_MASTER
:
12142 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
12143 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
12144 case EXEC_OMP_PARALLEL_SECTIONS
:
12145 case EXEC_OMP_TARGET_PARALLEL
:
12146 case EXEC_OMP_TARGET_PARALLEL_DO
:
12147 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
12148 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
12149 case EXEC_OMP_TARGET_TEAMS
:
12150 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
12151 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12152 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12153 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
12154 case EXEC_OMP_TARGET_TEAMS_LOOP
:
12155 case EXEC_OMP_TASK
:
12156 case EXEC_OMP_TASKLOOP
:
12157 case EXEC_OMP_TASKLOOP_SIMD
:
12158 case EXEC_OMP_TEAMS
:
12159 case EXEC_OMP_TEAMS_DISTRIBUTE
:
12160 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12161 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12162 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
12163 case EXEC_OMP_TEAMS_LOOP
:
12164 omp_workshare_save
= omp_workshare_flag
;
12165 omp_workshare_flag
= 0;
12166 gfc_resolve_omp_parallel_blocks (code
, ns
);
12168 case EXEC_OMP_DISTRIBUTE
:
12169 case EXEC_OMP_DISTRIBUTE_SIMD
:
12171 case EXEC_OMP_DO_SIMD
:
12172 case EXEC_OMP_LOOP
:
12173 case EXEC_OMP_SIMD
:
12174 case EXEC_OMP_TARGET_SIMD
:
12175 gfc_resolve_omp_do_blocks (code
, ns
);
12177 case EXEC_SELECT_TYPE
:
12178 case EXEC_SELECT_RANK
:
12179 /* Blocks are handled in resolve_select_type/rank because we
12180 have to transform the SELECT TYPE into ASSOCIATE first. */
12182 case EXEC_DO_CONCURRENT
:
12183 gfc_do_concurrent_flag
= 1;
12184 gfc_resolve_blocks (code
->block
, ns
);
12185 gfc_do_concurrent_flag
= 2;
12187 case EXEC_OMP_WORKSHARE
:
12188 omp_workshare_save
= omp_workshare_flag
;
12189 omp_workshare_flag
= 1;
12192 gfc_resolve_blocks (code
->block
, ns
);
12196 if (omp_workshare_save
!= -1)
12197 omp_workshare_flag
= omp_workshare_save
;
12201 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
12202 t
= gfc_resolve_expr (code
->expr1
);
12203 forall_flag
= forall_save
;
12204 gfc_do_concurrent_flag
= do_concurrent_save
;
12206 if (!gfc_resolve_expr (code
->expr2
))
12209 if (code
->op
== EXEC_ALLOCATE
12210 && !gfc_resolve_expr (code
->expr3
))
12216 case EXEC_END_BLOCK
:
12217 case EXEC_END_NESTED_BLOCK
:
12223 case EXEC_ERROR_STOP
:
12224 if (code
->expr2
!= NULL
12225 && (code
->expr2
->ts
.type
!= BT_LOGICAL
12226 || code
->expr2
->rank
!= 0))
12227 gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
12228 &code
->expr2
->where
);
12232 case EXEC_CONTINUE
:
12234 case EXEC_ASSIGN_CALL
:
12237 case EXEC_CRITICAL
:
12238 resolve_critical (code
);
12241 case EXEC_SYNC_ALL
:
12242 case EXEC_SYNC_IMAGES
:
12243 case EXEC_SYNC_MEMORY
:
12244 resolve_sync (code
);
12249 case EXEC_EVENT_POST
:
12250 case EXEC_EVENT_WAIT
:
12251 resolve_lock_unlock_event (code
);
12254 case EXEC_FAIL_IMAGE
:
12257 case EXEC_FORM_TEAM
:
12258 if (code
->expr1
!= NULL
12259 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
12260 gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
12261 "a scalar INTEGER", &code
->expr1
->where
);
12262 check_team (code
->expr2
, "FORM TEAM");
12265 case EXEC_CHANGE_TEAM
:
12266 check_team (code
->expr1
, "CHANGE TEAM");
12269 case EXEC_END_TEAM
:
12272 case EXEC_SYNC_TEAM
:
12273 check_team (code
->expr1
, "SYNC TEAM");
12277 /* Keep track of which entry we are up to. */
12278 current_entry_id
= code
->ext
.entry
->id
;
12282 resolve_where (code
, NULL
);
12286 if (code
->expr1
!= NULL
)
12288 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
12289 || code
->expr1
->ts
.type
!= BT_INTEGER
12290 || (code
->expr1
->ref
12291 && code
->expr1
->ref
->type
== REF_ARRAY
)
12292 || code
->expr1
->symtree
== NULL
12293 || (code
->expr1
->symtree
->n
.sym
12294 && (code
->expr1
->symtree
->n
.sym
->attr
.flavor
12296 gfc_error ("ASSIGNED GOTO statement at %L requires a "
12297 "scalar INTEGER variable", &code
->expr1
->where
);
12298 else if (code
->expr1
->symtree
->n
.sym
12299 && code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
12300 gfc_error ("Variable %qs has not been assigned a target "
12301 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
12302 &code
->expr1
->where
);
12305 resolve_branch (code
->label1
, code
);
12309 if (code
->expr1
!= NULL
12310 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
12311 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
12312 "INTEGER return specifier", &code
->expr1
->where
);
12315 case EXEC_INIT_ASSIGN
:
12316 case EXEC_END_PROCEDURE
:
12323 if (code
->expr1
->ts
.type
== BT_CLASS
)
12324 gfc_find_vtab (&code
->expr2
->ts
);
12326 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
12328 if (code
->expr1
->expr_type
== EXPR_FUNCTION
12329 && code
->expr1
->value
.function
.isym
12330 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
12331 remove_caf_get_intrinsic (code
->expr1
);
12333 /* If this is a pointer function in an lvalue variable context,
12334 the new code will have to be resolved afresh. This is also the
12335 case with an error, where the code is transformed into NOP to
12336 prevent ICEs downstream. */
12337 if (resolve_ptr_fcn_assign (&code
, ns
)
12338 || code
->op
== EXEC_NOP
)
12341 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
12345 if (resolve_ordinary_assign (code
, ns
))
12347 if (omp_workshare_flag
)
12349 gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
12350 "at %L", &code
->loc
);
12353 if (code
->op
== EXEC_COMPCALL
)
12359 /* Check for dependencies in deferred character length array
12360 assignments and generate a temporary, if necessary. */
12361 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
12364 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
12365 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
12366 && code
->expr1
->ts
.u
.derived
12367 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
12368 generate_component_assignments (&code
, ns
);
12369 else if (code
->op
== EXEC_ASSIGN
)
12371 if (gfc_may_be_finalized (code
->expr1
->ts
))
12372 code
->expr1
->must_finalize
= 1;
12373 if (code
->expr2
->expr_type
== EXPR_ARRAY
12374 && gfc_may_be_finalized (code
->expr2
->ts
))
12375 code
->expr2
->must_finalize
= 1;
12380 case EXEC_LABEL_ASSIGN
:
12381 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
12382 gfc_error ("Label %d referenced at %L is never defined",
12383 code
->label1
->value
, &code
->label1
->where
);
12385 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
12386 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
12387 || code
->expr1
->symtree
->n
.sym
->ts
.kind
12388 != gfc_default_integer_kind
12389 || code
->expr1
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
12390 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
12391 gfc_error ("ASSIGN statement at %L requires a scalar "
12392 "default INTEGER variable", &code
->expr1
->where
);
12395 case EXEC_POINTER_ASSIGN
:
12402 /* This is both a variable definition and pointer assignment
12403 context, so check both of them. For rank remapping, a final
12404 array ref may be present on the LHS and fool gfc_expr_attr
12405 used in gfc_check_vardef_context. Remove it. */
12406 e
= remove_last_array_ref (code
->expr1
);
12407 t
= gfc_check_vardef_context (e
, true, false, false,
12408 _("pointer assignment"));
12410 t
= gfc_check_vardef_context (e
, false, false, false,
12411 _("pointer assignment"));
12414 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
12419 /* Assigning a class object always is a regular assign. */
12420 if (code
->expr2
->ts
.type
== BT_CLASS
12421 && code
->expr1
->ts
.type
== BT_CLASS
12422 && CLASS_DATA (code
->expr2
)
12423 && !CLASS_DATA (code
->expr2
)->attr
.dimension
12424 && !(gfc_expr_attr (code
->expr1
).proc_pointer
12425 && code
->expr2
->expr_type
== EXPR_VARIABLE
12426 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
12428 code
->op
= EXEC_ASSIGN
;
12432 case EXEC_ARITHMETIC_IF
:
12434 gfc_expr
*e
= code
->expr1
;
12436 gfc_resolve_expr (e
);
12437 if (e
->expr_type
== EXPR_NULL
)
12438 gfc_error ("Invalid NULL at %L", &e
->where
);
12440 if (t
&& (e
->rank
> 0
12441 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
12442 gfc_error ("Arithmetic IF statement at %L requires a scalar "
12443 "REAL or INTEGER expression", &e
->where
);
12445 resolve_branch (code
->label1
, code
);
12446 resolve_branch (code
->label2
, code
);
12447 resolve_branch (code
->label3
, code
);
12452 if (t
&& code
->expr1
!= NULL
12453 && (code
->expr1
->ts
.type
!= BT_LOGICAL
12454 || code
->expr1
->rank
!= 0))
12455 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12456 &code
->expr1
->where
);
12461 resolve_call (code
);
12464 case EXEC_COMPCALL
:
12466 resolve_typebound_subroutine (code
);
12469 case EXEC_CALL_PPC
:
12470 resolve_ppc_call (code
);
12474 /* Select is complicated. Also, a SELECT construct could be
12475 a transformed computed GOTO. */
12476 resolve_select (code
, false);
12479 case EXEC_SELECT_TYPE
:
12480 resolve_select_type (code
, ns
);
12483 case EXEC_SELECT_RANK
:
12484 resolve_select_rank (code
, ns
);
12488 resolve_block_construct (code
);
12492 if (code
->ext
.iterator
!= NULL
)
12494 gfc_iterator
*iter
= code
->ext
.iterator
;
12495 if (gfc_resolve_iterator (iter
, true, false))
12496 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
12501 case EXEC_DO_WHILE
:
12502 if (code
->expr1
== NULL
)
12503 gfc_internal_error ("gfc_resolve_code(): No expression on "
12506 && (code
->expr1
->rank
!= 0
12507 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
12508 gfc_error ("Exit condition of DO WHILE loop at %L must be "
12509 "a scalar LOGICAL expression", &code
->expr1
->where
);
12512 case EXEC_ALLOCATE
:
12514 resolve_allocate_deallocate (code
, "ALLOCATE");
12518 case EXEC_DEALLOCATE
:
12520 resolve_allocate_deallocate (code
, "DEALLOCATE");
12525 if (!gfc_resolve_open (code
->ext
.open
, &code
->loc
))
12528 resolve_branch (code
->ext
.open
->err
, code
);
12532 if (!gfc_resolve_close (code
->ext
.close
, &code
->loc
))
12535 resolve_branch (code
->ext
.close
->err
, code
);
12538 case EXEC_BACKSPACE
:
12542 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
12545 resolve_branch (code
->ext
.filepos
->err
, code
);
12549 if (!gfc_resolve_inquire (code
->ext
.inquire
))
12552 resolve_branch (code
->ext
.inquire
->err
, code
);
12555 case EXEC_IOLENGTH
:
12556 gcc_assert (code
->ext
.inquire
!= NULL
);
12557 if (!gfc_resolve_inquire (code
->ext
.inquire
))
12560 resolve_branch (code
->ext
.inquire
->err
, code
);
12564 if (!gfc_resolve_wait (code
->ext
.wait
))
12567 resolve_branch (code
->ext
.wait
->err
, code
);
12568 resolve_branch (code
->ext
.wait
->end
, code
);
12569 resolve_branch (code
->ext
.wait
->eor
, code
);
12574 if (!gfc_resolve_dt (code
, code
->ext
.dt
, &code
->loc
))
12577 resolve_branch (code
->ext
.dt
->err
, code
);
12578 resolve_branch (code
->ext
.dt
->end
, code
);
12579 resolve_branch (code
->ext
.dt
->eor
, code
);
12582 case EXEC_TRANSFER
:
12583 resolve_transfer (code
);
12586 case EXEC_DO_CONCURRENT
:
12588 resolve_forall_iterators (code
->ext
.forall_iterator
);
12590 if (code
->expr1
!= NULL
12591 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
12592 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
12593 "expression", &code
->expr1
->where
);
12596 case EXEC_OACC_PARALLEL_LOOP
:
12597 case EXEC_OACC_PARALLEL
:
12598 case EXEC_OACC_KERNELS_LOOP
:
12599 case EXEC_OACC_KERNELS
:
12600 case EXEC_OACC_SERIAL_LOOP
:
12601 case EXEC_OACC_SERIAL
:
12602 case EXEC_OACC_DATA
:
12603 case EXEC_OACC_HOST_DATA
:
12604 case EXEC_OACC_LOOP
:
12605 case EXEC_OACC_UPDATE
:
12606 case EXEC_OACC_WAIT
:
12607 case EXEC_OACC_CACHE
:
12608 case EXEC_OACC_ENTER_DATA
:
12609 case EXEC_OACC_EXIT_DATA
:
12610 case EXEC_OACC_ATOMIC
:
12611 case EXEC_OACC_DECLARE
:
12612 gfc_resolve_oacc_directive (code
, ns
);
12615 case EXEC_OMP_ASSUME
:
12616 case EXEC_OMP_ATOMIC
:
12617 case EXEC_OMP_BARRIER
:
12618 case EXEC_OMP_CANCEL
:
12619 case EXEC_OMP_CANCELLATION_POINT
:
12620 case EXEC_OMP_CRITICAL
:
12621 case EXEC_OMP_FLUSH
:
12622 case EXEC_OMP_DEPOBJ
:
12623 case EXEC_OMP_DISTRIBUTE
:
12624 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
12625 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
12626 case EXEC_OMP_DISTRIBUTE_SIMD
:
12628 case EXEC_OMP_DO_SIMD
:
12629 case EXEC_OMP_ERROR
:
12630 case EXEC_OMP_LOOP
:
12631 case EXEC_OMP_MASTER
:
12632 case EXEC_OMP_MASTER_TASKLOOP
:
12633 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
12634 case EXEC_OMP_MASKED
:
12635 case EXEC_OMP_MASKED_TASKLOOP
:
12636 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
12637 case EXEC_OMP_ORDERED
:
12638 case EXEC_OMP_SCAN
:
12639 case EXEC_OMP_SCOPE
:
12640 case EXEC_OMP_SECTIONS
:
12641 case EXEC_OMP_SIMD
:
12642 case EXEC_OMP_SINGLE
:
12643 case EXEC_OMP_TARGET
:
12644 case EXEC_OMP_TARGET_DATA
:
12645 case EXEC_OMP_TARGET_ENTER_DATA
:
12646 case EXEC_OMP_TARGET_EXIT_DATA
:
12647 case EXEC_OMP_TARGET_PARALLEL
:
12648 case EXEC_OMP_TARGET_PARALLEL_DO
:
12649 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
12650 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
12651 case EXEC_OMP_TARGET_SIMD
:
12652 case EXEC_OMP_TARGET_TEAMS
:
12653 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
12654 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12655 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12656 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
12657 case EXEC_OMP_TARGET_TEAMS_LOOP
:
12658 case EXEC_OMP_TARGET_UPDATE
:
12659 case EXEC_OMP_TASK
:
12660 case EXEC_OMP_TASKGROUP
:
12661 case EXEC_OMP_TASKLOOP
:
12662 case EXEC_OMP_TASKLOOP_SIMD
:
12663 case EXEC_OMP_TASKWAIT
:
12664 case EXEC_OMP_TASKYIELD
:
12665 case EXEC_OMP_TEAMS
:
12666 case EXEC_OMP_TEAMS_DISTRIBUTE
:
12667 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12668 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12669 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
12670 case EXEC_OMP_TEAMS_LOOP
:
12671 case EXEC_OMP_WORKSHARE
:
12672 gfc_resolve_omp_directive (code
, ns
);
12675 case EXEC_OMP_PARALLEL
:
12676 case EXEC_OMP_PARALLEL_DO
:
12677 case EXEC_OMP_PARALLEL_DO_SIMD
:
12678 case EXEC_OMP_PARALLEL_LOOP
:
12679 case EXEC_OMP_PARALLEL_MASKED
:
12680 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
12681 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
12682 case EXEC_OMP_PARALLEL_MASTER
:
12683 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
12684 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
12685 case EXEC_OMP_PARALLEL_SECTIONS
:
12686 case EXEC_OMP_PARALLEL_WORKSHARE
:
12687 omp_workshare_save
= omp_workshare_flag
;
12688 omp_workshare_flag
= 0;
12689 gfc_resolve_omp_directive (code
, ns
);
12690 omp_workshare_flag
= omp_workshare_save
;
12694 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
12698 cs_base
= frame
.prev
;
12702 /* Resolve initial values and make sure they are compatible with
12706 resolve_values (gfc_symbol
*sym
)
12710 if (sym
->value
== NULL
)
12713 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
) && sym
->attr
.referenced
)
12714 gfc_warning (OPT_Wdeprecated_declarations
,
12715 "Using parameter %qs declared at %L is deprecated",
12716 sym
->name
, &sym
->declared_at
);
12718 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
12719 t
= resolve_structure_cons (sym
->value
, 1);
12721 t
= gfc_resolve_expr (sym
->value
);
12726 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
12730 /* Verify any BIND(C) derived types in the namespace so we can report errors
12731 for them once, rather than for each variable declared of that type. */
12734 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
12736 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
12737 && derived_sym
->attr
.is_bind_c
== 1)
12738 verify_bind_c_derived_type (derived_sym
);
12744 /* Check the interfaces of DTIO procedures associated with derived
12745 type 'sym'. These procedures can either have typebound bindings or
12746 can appear in DTIO generic interfaces. */
12749 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
12751 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
12754 gfc_check_dtio_interfaces (sym
);
12759 /* Verify that any binding labels used in a given namespace do not collide
12760 with the names or binding labels of any global symbols. Multiple INTERFACE
12761 for the same procedure are permitted. */
12764 gfc_verify_binding_labels (gfc_symbol
*sym
)
12767 const char *module
;
12769 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
12770 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
12773 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
12776 module
= sym
->module
;
12777 else if (sym
->ns
&& sym
->ns
->proc_name
12778 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
12779 module
= sym
->ns
->proc_name
->name
;
12780 else if (sym
->ns
&& sym
->ns
->parent
12781 && sym
->ns
&& sym
->ns
->parent
->proc_name
12782 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12783 module
= sym
->ns
->parent
->proc_name
->name
;
12789 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
12792 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
12793 gsym
->where
= sym
->declared_at
;
12794 gsym
->sym_name
= sym
->name
;
12795 gsym
->binding_label
= sym
->binding_label
;
12796 gsym
->ns
= sym
->ns
;
12797 gsym
->mod_name
= module
;
12798 if (sym
->attr
.function
)
12799 gsym
->type
= GSYM_FUNCTION
;
12800 else if (sym
->attr
.subroutine
)
12801 gsym
->type
= GSYM_SUBROUTINE
;
12802 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
12803 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
12807 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
12809 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
12810 "identifier as entity at %L", sym
->name
,
12811 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12812 /* Clear the binding label to prevent checking multiple times. */
12813 sym
->binding_label
= NULL
;
12817 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
12818 && (strcmp (module
, gsym
->mod_name
) != 0
12819 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
12821 /* This can only happen if the variable is defined in a module - if it
12822 isn't the same module, reject it. */
12823 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
12824 "uses the same global identifier as entity at %L from module %qs",
12825 sym
->name
, module
, sym
->binding_label
,
12826 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
12827 sym
->binding_label
= NULL
;
12831 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
12832 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
12833 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
12834 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
12835 && (module
!= gsym
->mod_name
12836 || strcmp (gsym
->sym_name
, sym
->name
) != 0
12837 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
12839 /* Print an error if the procedure is defined multiple times; we have to
12840 exclude references to the same procedure via module association or
12841 multiple checks for the same procedure. */
12842 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
12843 "global identifier as entity at %L", sym
->name
,
12844 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12845 sym
->binding_label
= NULL
;
12850 /* Resolve an index expression. */
12853 resolve_index_expr (gfc_expr
*e
)
12855 if (!gfc_resolve_expr (e
))
12858 if (!gfc_simplify_expr (e
, 0))
12861 if (!gfc_specification_expr (e
))
12868 /* Resolve a charlen structure. */
12871 resolve_charlen (gfc_charlen
*cl
)
12874 bool saved_specification_expr
;
12880 saved_specification_expr
= specification_expr
;
12881 specification_expr
= true;
12883 if (cl
->length_from_typespec
)
12885 if (!gfc_resolve_expr (cl
->length
))
12887 specification_expr
= saved_specification_expr
;
12891 if (!gfc_simplify_expr (cl
->length
, 0))
12893 specification_expr
= saved_specification_expr
;
12897 /* cl->length has been resolved. It should have an integer type. */
12899 && (cl
->length
->ts
.type
!= BT_INTEGER
|| cl
->length
->rank
!= 0))
12901 gfc_error ("Scalar INTEGER expression expected at %L",
12902 &cl
->length
->where
);
12908 if (!resolve_index_expr (cl
->length
))
12910 specification_expr
= saved_specification_expr
;
12915 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12916 a negative value, the length of character entities declared is zero. */
12917 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12918 && mpz_sgn (cl
->length
->value
.integer
) < 0)
12919 gfc_replace_expr (cl
->length
,
12920 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
12922 /* Check that the character length is not too large. */
12923 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
12924 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12925 && cl
->length
->ts
.type
== BT_INTEGER
12926 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
12928 gfc_error ("String length at %L is too large", &cl
->length
->where
);
12929 specification_expr
= saved_specification_expr
;
12933 specification_expr
= saved_specification_expr
;
12938 /* Test for non-constant shape arrays. */
12941 is_non_constant_shape_array (gfc_symbol
*sym
)
12947 not_constant
= false;
12948 if (sym
->as
!= NULL
)
12950 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12951 has not been simplified; parameter array references. Do the
12952 simplification now. */
12953 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12955 if (i
== GFC_MAX_DIMENSIONS
)
12958 e
= sym
->as
->lower
[i
];
12959 if (e
&& (!resolve_index_expr(e
)
12960 || !gfc_is_constant_expr (e
)))
12961 not_constant
= true;
12962 e
= sym
->as
->upper
[i
];
12963 if (e
&& (!resolve_index_expr(e
)
12964 || !gfc_is_constant_expr (e
)))
12965 not_constant
= true;
12968 return not_constant
;
12971 /* Given a symbol and an initialization expression, add code to initialize
12972 the symbol to the function entry. */
12974 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12978 gfc_namespace
*ns
= sym
->ns
;
12980 /* Search for the function namespace if this is a contained
12981 function without an explicit result. */
12982 if (sym
->attr
.function
&& sym
== sym
->result
12983 && sym
->name
!= sym
->ns
->proc_name
->name
)
12985 ns
= ns
->contained
;
12986 for (;ns
; ns
= ns
->sibling
)
12987 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12993 gfc_free_expr (init
);
12997 /* Build an l-value expression for the result. */
12998 lval
= gfc_lval_expr_from_sym (sym
);
13000 /* Add the code at scope entry. */
13001 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
13002 init_st
->next
= ns
->code
;
13003 ns
->code
= init_st
;
13005 /* Assign the default initializer to the l-value. */
13006 init_st
->loc
= sym
->declared_at
;
13007 init_st
->expr1
= lval
;
13008 init_st
->expr2
= init
;
13012 /* Whether or not we can generate a default initializer for a symbol. */
13015 can_generate_init (gfc_symbol
*sym
)
13017 symbol_attribute
*a
;
13022 /* These symbols should never have a default initialization. */
13027 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
13028 && (CLASS_DATA (sym
)->attr
.class_pointer
13029 || CLASS_DATA (sym
)->attr
.proc_pointer
))
13030 || a
->in_equivalence
13037 || (!a
->referenced
&& !a
->result
)
13038 || (a
->dummy
&& (a
->intent
!= INTENT_OUT
13039 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
))
13040 || (a
->function
&& sym
!= sym
->result
)
13045 /* Assign the default initializer to a derived type variable or result. */
13048 apply_default_init (gfc_symbol
*sym
)
13050 gfc_expr
*init
= NULL
;
13052 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
13055 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
13056 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
13058 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
13061 build_init_assign (sym
, init
);
13062 sym
->attr
.referenced
= 1;
13066 /* Build an initializer for a local. Returns null if the symbol should not have
13067 a default initialization. */
13070 build_default_init_expr (gfc_symbol
*sym
)
13072 /* These symbols should never have a default initialization. */
13073 if (sym
->attr
.allocatable
13074 || sym
->attr
.external
13076 || sym
->attr
.pointer
13077 || sym
->attr
.in_equivalence
13078 || sym
->attr
.in_common
13081 || sym
->attr
.cray_pointee
13082 || sym
->attr
.cray_pointer
13086 /* Get the appropriate init expression. */
13087 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
13090 /* Add an initialization expression to a local variable. */
13092 apply_default_init_local (gfc_symbol
*sym
)
13094 gfc_expr
*init
= NULL
;
13096 /* The symbol should be a variable or a function return value. */
13097 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
13098 || (sym
->attr
.function
&& sym
->result
!= sym
))
13101 /* Try to build the initializer expression. If we can't initialize
13102 this symbol, then init will be NULL. */
13103 init
= build_default_init_expr (sym
);
13107 /* For saved variables, we don't want to add an initializer at function
13108 entry, so we just add a static initializer. Note that automatic variables
13109 are stack allocated even with -fno-automatic; we have also to exclude
13110 result variable, which are also nonstatic. */
13111 if (!sym
->attr
.automatic
13112 && (sym
->attr
.save
|| sym
->ns
->save_all
13113 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
13114 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
13115 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
13117 /* Don't clobber an existing initializer! */
13118 gcc_assert (sym
->value
== NULL
);
13123 build_init_assign (sym
, init
);
13127 /* Resolution of common features of flavors variable and procedure. */
13130 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
13132 gfc_array_spec
*as
;
13134 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13135 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
))
13136 as
= CLASS_DATA (sym
)->as
;
13140 /* Constraints on deferred shape variable. */
13141 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
13143 bool pointer
, allocatable
, dimension
;
13145 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13146 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
))
13148 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
13149 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
13150 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
13154 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
13155 allocatable
= sym
->attr
.allocatable
;
13156 dimension
= sym
->attr
.dimension
;
13161 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
13163 gfc_error ("Allocatable array %qs at %L must have a deferred "
13164 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
13167 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
13168 "%qs at %L may not be ALLOCATABLE",
13169 sym
->name
, &sym
->declared_at
))
13173 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
13175 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
13176 "assumed rank", sym
->name
, &sym
->declared_at
);
13183 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
13184 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
13186 gfc_error ("Array %qs at %L cannot have a deferred shape",
13187 sym
->name
, &sym
->declared_at
);
13192 /* Constraints on polymorphic variables. */
13193 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
13196 if (sym
->attr
.class_ok
13197 && sym
->ts
.u
.derived
13198 && !sym
->attr
.select_type_temporary
13199 && !UNLIMITED_POLY (sym
)
13200 && CLASS_DATA (sym
)->ts
.u
.derived
13201 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
13203 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
13204 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
13205 &sym
->declared_at
);
13210 /* Assume that use associated symbols were checked in the module ns.
13211 Class-variables that are associate-names are also something special
13212 and excepted from the test. */
13213 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
13215 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
13216 "or pointer", sym
->name
, &sym
->declared_at
);
13225 /* Additional checks for symbols with flavor variable and derived
13226 type. To be called from resolve_fl_variable. */
13229 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
13231 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
13233 /* Check to see if a derived type is blocked from being host
13234 associated by the presence of another class I symbol in the same
13235 namespace. 14.6.1.3 of the standard and the discussion on
13236 comp.lang.fortran. */
13237 if (sym
->ts
.u
.derived
13238 && sym
->ns
!= sym
->ts
.u
.derived
->ns
13239 && !sym
->ts
.u
.derived
->attr
.use_assoc
13240 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
13243 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
13244 if (s
&& s
->attr
.generic
)
13245 s
= gfc_find_dt_in_generic (s
);
13246 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
13248 gfc_error ("The type %qs cannot be host associated at %L "
13249 "because it is blocked by an incompatible object "
13250 "of the same name declared at %L",
13251 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
13257 /* 4th constraint in section 11.3: "If an object of a type for which
13258 component-initialization is specified (R429) appears in the
13259 specification-part of a module and does not have the ALLOCATABLE
13260 or POINTER attribute, the object shall have the SAVE attribute."
13262 The check for initializers is performed with
13263 gfc_has_default_initializer because gfc_default_initializer generates
13264 a hidden default for allocatable components. */
13265 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
13266 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13267 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
13268 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
13269 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
13270 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
13271 "%qs at %L, needed due to the default "
13272 "initialization", sym
->name
, &sym
->declared_at
))
13275 /* Assign default initializer. */
13276 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
13278 || (sym
->attr
.intent
== INTENT_OUT
13279 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)))
13280 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
13286 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
13287 except in the declaration of an entity or component that has the POINTER
13288 or ALLOCATABLE attribute. */
13291 deferred_requirements (gfc_symbol
*sym
)
13293 if (sym
->ts
.deferred
13294 && !(sym
->attr
.pointer
13295 || sym
->attr
.allocatable
13296 || sym
->attr
.associate_var
13297 || sym
->attr
.omp_udr_artificial_var
))
13299 /* If a function has a result variable, only check the variable. */
13300 if (sym
->result
&& sym
->name
!= sym
->result
->name
)
13303 gfc_error ("Entity %qs at %L has a deferred type parameter and "
13304 "requires either the POINTER or ALLOCATABLE attribute",
13305 sym
->name
, &sym
->declared_at
);
13312 /* Resolve symbols with flavor variable. */
13315 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
13317 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
13320 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
13323 /* Set this flag to check that variables are parameters of all entries.
13324 This check is effected by the call to gfc_resolve_expr through
13325 is_non_constant_shape_array. */
13326 bool saved_specification_expr
= specification_expr
;
13327 specification_expr
= true;
13329 if (sym
->ns
->proc_name
13330 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13331 || sym
->ns
->proc_name
->attr
.is_main_program
)
13332 && !sym
->attr
.use_assoc
13333 && !sym
->attr
.allocatable
13334 && !sym
->attr
.pointer
13335 && is_non_constant_shape_array (sym
))
13337 /* F08:C541. The shape of an array defined in a main program or module
13338 * needs to be constant. */
13339 gfc_error ("The module or main program array %qs at %L must "
13340 "have constant shape", sym
->name
, &sym
->declared_at
);
13341 specification_expr
= saved_specification_expr
;
13345 /* Constraints on deferred type parameter. */
13346 if (!deferred_requirements (sym
))
13349 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
13351 /* Make sure that character string variables with assumed length are
13352 dummy arguments. */
13353 gfc_expr
*e
= NULL
;
13356 e
= sym
->ts
.u
.cl
->length
;
13360 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
13361 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
13362 && !sym
->attr
.omp_udr_artificial_var
)
13364 gfc_error ("Entity with assumed character length at %L must be a "
13365 "dummy argument or a PARAMETER", &sym
->declared_at
);
13366 specification_expr
= saved_specification_expr
;
13370 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
13372 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
13373 specification_expr
= saved_specification_expr
;
13377 if (!gfc_is_constant_expr (e
)
13378 && !(e
->expr_type
== EXPR_VARIABLE
13379 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
13381 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
13382 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13383 || sym
->ns
->proc_name
->attr
.is_main_program
))
13385 gfc_error ("%qs at %L must have constant character length "
13386 "in this context", sym
->name
, &sym
->declared_at
);
13387 specification_expr
= saved_specification_expr
;
13390 if (sym
->attr
.in_common
)
13392 gfc_error ("COMMON variable %qs at %L must have constant "
13393 "character length", sym
->name
, &sym
->declared_at
);
13394 specification_expr
= saved_specification_expr
;
13400 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
13401 apply_default_init_local (sym
); /* Try to apply a default initialization. */
13403 /* Determine if the symbol may not have an initializer. */
13404 int no_init_flag
= 0, automatic_flag
= 0;
13405 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
13406 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
13408 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
13409 && is_non_constant_shape_array (sym
))
13411 no_init_flag
= automatic_flag
= 1;
13413 /* Also, they must not have the SAVE attribute.
13414 SAVE_IMPLICIT is checked below. */
13415 if (sym
->as
&& sym
->attr
.codimension
)
13417 int corank
= sym
->as
->corank
;
13418 sym
->as
->corank
= 0;
13419 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
13420 sym
->as
->corank
= corank
;
13422 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
13424 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
13425 specification_expr
= saved_specification_expr
;
13430 /* Ensure that any initializer is simplified. */
13432 gfc_simplify_expr (sym
->value
, 1);
13434 /* Reject illegal initializers. */
13435 if (!sym
->mark
&& sym
->value
)
13437 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
13438 && CLASS_DATA (sym
)->attr
.allocatable
))
13439 gfc_error ("Allocatable %qs at %L cannot have an initializer",
13440 sym
->name
, &sym
->declared_at
);
13441 else if (sym
->attr
.external
)
13442 gfc_error ("External %qs at %L cannot have an initializer",
13443 sym
->name
, &sym
->declared_at
);
13444 else if (sym
->attr
.dummy
)
13445 gfc_error ("Dummy %qs at %L cannot have an initializer",
13446 sym
->name
, &sym
->declared_at
);
13447 else if (sym
->attr
.intrinsic
)
13448 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
13449 sym
->name
, &sym
->declared_at
);
13450 else if (sym
->attr
.result
)
13451 gfc_error ("Function result %qs at %L cannot have an initializer",
13452 sym
->name
, &sym
->declared_at
);
13453 else if (automatic_flag
)
13454 gfc_error ("Automatic array %qs at %L cannot have an initializer",
13455 sym
->name
, &sym
->declared_at
);
13457 goto no_init_error
;
13458 specification_expr
= saved_specification_expr
;
13463 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
13465 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
13466 specification_expr
= saved_specification_expr
;
13470 specification_expr
= saved_specification_expr
;
13475 /* Compare the dummy characteristics of a module procedure interface
13476 declaration with the corresponding declaration in a submodule. */
13477 static gfc_formal_arglist
*new_formal
;
13478 static char errmsg
[200];
13481 compare_fsyms (gfc_symbol
*sym
)
13485 if (sym
== NULL
|| new_formal
== NULL
)
13488 fsym
= new_formal
->sym
;
13493 if (strcmp (sym
->name
, fsym
->name
) == 0)
13495 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
13496 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
13501 /* Resolve a procedure. */
13504 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
13506 gfc_formal_arglist
*arg
;
13507 bool allocatable_or_pointer
= false;
13509 if (sym
->attr
.function
13510 && !resolve_fl_var_and_proc (sym
, mp_flag
))
13513 /* Constraints on deferred type parameter. */
13514 if (!deferred_requirements (sym
))
13517 if (sym
->ts
.type
== BT_CHARACTER
)
13519 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13521 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
13522 && !resolve_charlen (cl
))
13525 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13526 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
13528 gfc_error ("Character-valued statement function %qs at %L must "
13529 "have constant length", sym
->name
, &sym
->declared_at
);
13534 /* Ensure that derived type for are not of a private type. Internal
13535 module procedures are excluded by 2.2.3.3 - i.e., they are not
13536 externally accessible and can access all the objects accessible in
13538 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
13539 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
13540 && gfc_check_symbol_access (sym
))
13542 gfc_interface
*iface
;
13544 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
13547 && arg
->sym
->ts
.type
== BT_DERIVED
13548 && arg
->sym
->ts
.u
.derived
13549 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
13550 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
13551 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
13552 "and cannot be a dummy argument"
13553 " of %qs, which is PUBLIC at %L",
13554 arg
->sym
->name
, sym
->name
,
13555 &sym
->declared_at
))
13557 /* Stop this message from recurring. */
13558 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
13563 /* PUBLIC interfaces may expose PRIVATE procedures that take types
13564 PRIVATE to the containing module. */
13565 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
13567 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
13570 && arg
->sym
->ts
.type
== BT_DERIVED
13571 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
13572 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
13573 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
13574 "PUBLIC interface %qs at %L "
13575 "takes dummy arguments of %qs which "
13576 "is PRIVATE", iface
->sym
->name
,
13577 sym
->name
, &iface
->sym
->declared_at
,
13578 gfc_typename(&arg
->sym
->ts
)))
13580 /* Stop this message from recurring. */
13581 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
13588 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
13589 && !sym
->attr
.proc_pointer
)
13591 gfc_error ("Function %qs at %L cannot have an initializer",
13592 sym
->name
, &sym
->declared_at
);
13594 /* Make sure no second error is issued for this. */
13595 sym
->value
->error
= 1;
13599 /* An external symbol may not have an initializer because it is taken to be
13600 a procedure. Exception: Procedure Pointers. */
13601 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
13603 gfc_error ("External object %qs at %L may not have an initializer",
13604 sym
->name
, &sym
->declared_at
);
13608 /* An elemental function is required to return a scalar 12.7.1 */
13609 if (sym
->attr
.elemental
&& sym
->attr
.function
13610 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13611 && CLASS_DATA (sym
)->as
)))
13613 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
13614 "result", sym
->name
, &sym
->declared_at
);
13615 /* Reset so that the error only occurs once. */
13616 sym
->attr
.elemental
= 0;
13620 if (sym
->attr
.proc
== PROC_ST_FUNCTION
13621 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
13623 gfc_error ("Statement function %qs at %L may not have pointer or "
13624 "allocatable attribute", sym
->name
, &sym
->declared_at
);
13628 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
13629 char-len-param shall not be array-valued, pointer-valued, recursive
13630 or pure. ....snip... A character value of * may only be used in the
13631 following ways: (i) Dummy arg of procedure - dummy associates with
13632 actual length; (ii) To declare a named constant; or (iii) External
13633 function - but length must be declared in calling scoping unit. */
13634 if (sym
->attr
.function
13635 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
13636 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
13638 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
13639 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
13641 if (sym
->as
&& sym
->as
->rank
)
13642 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13643 "array-valued", sym
->name
, &sym
->declared_at
);
13645 if (sym
->attr
.pointer
)
13646 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13647 "pointer-valued", sym
->name
, &sym
->declared_at
);
13649 if (sym
->attr
.pure
)
13650 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13651 "pure", sym
->name
, &sym
->declared_at
);
13653 if (sym
->attr
.recursive
)
13654 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13655 "recursive", sym
->name
, &sym
->declared_at
);
13660 /* Appendix B.2 of the standard. Contained functions give an
13661 error anyway. Deferred character length is an F2003 feature.
13662 Don't warn on intrinsic conversion functions, which start
13663 with two underscores. */
13664 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
13665 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
13666 gfc_notify_std (GFC_STD_F95_OBS
,
13667 "CHARACTER(*) function %qs at %L",
13668 sym
->name
, &sym
->declared_at
);
13671 /* F2008, C1218. */
13672 if (sym
->attr
.elemental
)
13674 if (sym
->attr
.proc_pointer
)
13676 const char* name
= (sym
->attr
.result
? sym
->ns
->proc_name
->name
13678 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
13679 name
, &sym
->declared_at
);
13682 if (sym
->attr
.dummy
)
13684 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
13685 sym
->name
, &sym
->declared_at
);
13690 /* F2018, C15100: "The result of an elemental function shall be scalar,
13691 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
13692 pointer is tested and caught elsewhere. */
13694 allocatable_or_pointer
= sym
->result
->ts
.type
== BT_CLASS
13695 && CLASS_DATA (sym
->result
) ?
13696 (CLASS_DATA (sym
->result
)->attr
.allocatable
13697 || CLASS_DATA (sym
->result
)->attr
.pointer
) :
13698 (sym
->result
->attr
.allocatable
13699 || sym
->result
->attr
.pointer
);
13701 if (sym
->attr
.elemental
&& sym
->result
13702 && allocatable_or_pointer
)
13704 gfc_error ("Function result variable %qs at %L of elemental "
13705 "function %qs shall not have an ALLOCATABLE or POINTER "
13706 "attribute", sym
->result
->name
,
13707 &sym
->result
->declared_at
, sym
->name
);
13711 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
13713 gfc_formal_arglist
*curr_arg
;
13714 int has_non_interop_arg
= 0;
13716 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13717 sym
->common_block
))
13719 /* Clear these to prevent looking at them again if there was an
13721 sym
->attr
.is_bind_c
= 0;
13722 sym
->attr
.is_c_interop
= 0;
13723 sym
->ts
.is_c_interop
= 0;
13727 /* So far, no errors have been found. */
13728 sym
->attr
.is_c_interop
= 1;
13729 sym
->ts
.is_c_interop
= 1;
13732 curr_arg
= gfc_sym_get_dummy_args (sym
);
13733 while (curr_arg
!= NULL
)
13735 /* Skip implicitly typed dummy args here. */
13736 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
13737 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
13738 /* If something is found to fail, record the fact so we
13739 can mark the symbol for the procedure as not being
13740 BIND(C) to try and prevent multiple errors being
13742 has_non_interop_arg
= 1;
13744 curr_arg
= curr_arg
->next
;
13747 /* See if any of the arguments were not interoperable and if so, clear
13748 the procedure symbol to prevent duplicate error messages. */
13749 if (has_non_interop_arg
!= 0)
13751 sym
->attr
.is_c_interop
= 0;
13752 sym
->ts
.is_c_interop
= 0;
13753 sym
->attr
.is_bind_c
= 0;
13757 if (!sym
->attr
.proc_pointer
)
13759 if (sym
->attr
.save
== SAVE_EXPLICIT
)
13761 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
13762 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13765 if (sym
->attr
.intent
)
13767 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
13768 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13771 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
13773 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
13774 "in %qs at %L", sym
->ns
->proc_name
->name
, &sym
->declared_at
);
13777 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
13778 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
13779 || sym
->attr
.contained
))
13781 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
13782 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13785 if (strcmp ("ppr@", sym
->name
) == 0)
13787 gfc_error ("Procedure pointer result %qs at %L "
13788 "is missing the pointer attribute",
13789 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
13794 /* Assume that a procedure whose body is not known has references
13795 to external arrays. */
13796 if (sym
->attr
.if_source
!= IFSRC_DECL
)
13797 sym
->attr
.array_outer_dependency
= 1;
13799 /* Compare the characteristics of a module procedure with the
13800 interface declaration. Ideally this would be done with
13801 gfc_compare_interfaces but, at present, the formal interface
13802 cannot be copied to the ts.interface. */
13803 if (sym
->attr
.module_procedure
13804 && sym
->attr
.if_source
== IFSRC_DECL
)
13807 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
13809 char *submodule_name
;
13810 strcpy (name
, sym
->ns
->proc_name
->name
);
13811 module_name
= strtok (name
, ".");
13812 submodule_name
= strtok (NULL
, ".");
13814 iface
= sym
->tlink
;
13817 /* Make sure that the result uses the correct charlen for deferred
13819 if (iface
&& sym
->result
13820 && iface
->ts
.type
== BT_CHARACTER
13821 && iface
->ts
.deferred
)
13822 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
13827 /* Check the procedure characteristics. */
13828 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
13830 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
13831 "PROCEDURE at %L and its interface in %s",
13832 &sym
->declared_at
, module_name
);
13836 if (sym
->attr
.pure
!= iface
->attr
.pure
)
13838 gfc_error ("Mismatch in PURE attribute between MODULE "
13839 "PROCEDURE at %L and its interface in %s",
13840 &sym
->declared_at
, module_name
);
13844 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
13846 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
13847 "PROCEDURE at %L and its interface in %s",
13848 &sym
->declared_at
, module_name
);
13852 /* Check the result characteristics. */
13853 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
13855 gfc_error ("%s between the MODULE PROCEDURE declaration "
13856 "in MODULE %qs and the declaration at %L in "
13858 errmsg
, module_name
, &sym
->declared_at
,
13859 submodule_name
? submodule_name
: module_name
);
13864 /* Check the characteristics of the formal arguments. */
13865 if (sym
->formal
&& sym
->formal_ns
)
13867 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
13870 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
13878 /* Resolve a list of finalizer procedures. That is, after they have hopefully
13879 been defined and we now know their defined arguments, check that they fulfill
13880 the requirements of the standard for procedures used as finalizers. */
13883 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
13885 gfc_finalizer
* list
;
13886 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
13887 bool result
= true;
13888 bool seen_scalar
= false;
13891 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
13894 gfc_resolve_finalizers (parent
, finalizable
);
13896 /* Ensure that derived-type components have a their finalizers resolved. */
13897 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
13898 for (c
= derived
->components
; c
; c
= c
->next
)
13899 if (c
->ts
.type
== BT_DERIVED
13900 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
13902 bool has_final2
= false;
13903 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
13904 return false; /* Error. */
13905 has_final
= has_final
|| has_final2
;
13907 /* Return early if not finalizable. */
13911 *finalizable
= false;
13915 /* Walk over the list of finalizer-procedures, check them, and if any one
13916 does not fit in with the standard's definition, print an error and remove
13917 it from the list. */
13918 prev_link
= &derived
->f2k_derived
->finalizers
;
13919 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
13921 gfc_formal_arglist
*dummy_args
;
13926 /* Skip this finalizer if we already resolved it. */
13927 if (list
->proc_tree
)
13929 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
13930 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
13931 seen_scalar
= true;
13932 prev_link
= &(list
->next
);
13936 /* Check this exists and is a SUBROUTINE. */
13937 if (!list
->proc_sym
->attr
.subroutine
)
13939 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
13940 list
->proc_sym
->name
, &list
->where
);
13944 /* We should have exactly one argument. */
13945 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
13946 if (!dummy_args
|| dummy_args
->next
)
13948 gfc_error ("FINAL procedure at %L must have exactly one argument",
13952 arg
= dummy_args
->sym
;
13954 if (arg
->as
&& arg
->as
->type
== AS_ASSUMED_RANK
13955 && ((list
!= derived
->f2k_derived
->finalizers
) || list
->next
))
13957 gfc_error ("FINAL procedure at %L with assumed rank argument must "
13958 "be the only finalizer with the same kind/type "
13959 "(F2018: C790)", &list
->where
);
13963 /* This argument must be of our type. */
13964 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
13966 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
13967 &arg
->declared_at
, derived
->name
);
13971 /* It must neither be a pointer nor allocatable nor optional. */
13972 if (arg
->attr
.pointer
)
13974 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13975 &arg
->declared_at
);
13978 if (arg
->attr
.allocatable
)
13980 gfc_error ("Argument of FINAL procedure at %L must not be"
13981 " ALLOCATABLE", &arg
->declared_at
);
13984 if (arg
->attr
.optional
)
13986 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13987 &arg
->declared_at
);
13991 /* It must not be INTENT(OUT). */
13992 if (arg
->attr
.intent
== INTENT_OUT
)
13994 gfc_error ("Argument of FINAL procedure at %L must not be"
13995 " INTENT(OUT)", &arg
->declared_at
);
13999 /* Warn if the procedure is non-scalar and not assumed shape. */
14000 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
14001 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
14002 gfc_warning (OPT_Wsurprising
,
14003 "Non-scalar FINAL procedure at %L should have assumed"
14004 " shape argument", &arg
->declared_at
);
14006 /* Check that it does not match in kind and rank with a FINAL procedure
14007 defined earlier. To really loop over the *earlier* declarations,
14008 we need to walk the tail of the list as new ones were pushed at the
14010 /* TODO: Handle kind parameters once they are implemented. */
14011 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
14012 for (i
= list
->next
; i
; i
= i
->next
)
14014 gfc_formal_arglist
*dummy_args
;
14016 /* Argument list might be empty; that is an error signalled earlier,
14017 but we nevertheless continued resolving. */
14018 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
14021 gfc_symbol
* i_arg
= dummy_args
->sym
;
14022 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
14023 if (i_rank
== my_rank
)
14025 gfc_error ("FINAL procedure %qs declared at %L has the same"
14026 " rank (%d) as %qs",
14027 list
->proc_sym
->name
, &list
->where
, my_rank
,
14028 i
->proc_sym
->name
);
14034 /* Is this the/a scalar finalizer procedure? */
14036 seen_scalar
= true;
14038 /* Find the symtree for this procedure. */
14039 gcc_assert (!list
->proc_tree
);
14040 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
14042 prev_link
= &list
->next
;
14045 /* Remove wrong nodes immediately from the list so we don't risk any
14046 troubles in the future when they might fail later expectations. */
14049 *prev_link
= list
->next
;
14050 gfc_free_finalizer (i
);
14054 if (result
== false)
14057 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
14058 were nodes in the list, must have been for arrays. It is surely a good
14059 idea to have a scalar version there if there's something to finalize. */
14060 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
14061 gfc_warning (OPT_Wsurprising
,
14062 "Only array FINAL procedures declared for derived type %qs"
14063 " defined at %L, suggest also scalar one unless an assumed"
14064 " rank finalizer has been declared",
14065 derived
->name
, &derived
->declared_at
);
14067 vtab
= gfc_find_derived_vtab (derived
);
14068 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
14069 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
14072 *finalizable
= true;
14078 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
14081 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
14082 const char* generic_name
, locus where
)
14084 gfc_symbol
*sym1
, *sym2
;
14085 const char *pass1
, *pass2
;
14086 gfc_formal_arglist
*dummy_args
;
14088 gcc_assert (t1
->specific
&& t2
->specific
);
14089 gcc_assert (!t1
->specific
->is_generic
);
14090 gcc_assert (!t2
->specific
->is_generic
);
14091 gcc_assert (t1
->is_operator
== t2
->is_operator
);
14093 sym1
= t1
->specific
->u
.specific
->n
.sym
;
14094 sym2
= t2
->specific
->u
.specific
->n
.sym
;
14099 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
14100 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
14101 || sym1
->attr
.function
!= sym2
->attr
.function
)
14103 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
14104 " GENERIC %qs at %L",
14105 sym1
->name
, sym2
->name
, generic_name
, &where
);
14109 /* Determine PASS arguments. */
14110 if (t1
->specific
->nopass
)
14112 else if (t1
->specific
->pass_arg
)
14113 pass1
= t1
->specific
->pass_arg
;
14116 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
14118 pass1
= dummy_args
->sym
->name
;
14122 if (t2
->specific
->nopass
)
14124 else if (t2
->specific
->pass_arg
)
14125 pass2
= t2
->specific
->pass_arg
;
14128 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
14130 pass2
= dummy_args
->sym
->name
;
14135 /* Compare the interfaces. */
14136 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
14137 NULL
, 0, pass1
, pass2
))
14139 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
14140 sym1
->name
, sym2
->name
, generic_name
, &where
);
14148 /* Worker function for resolving a generic procedure binding; this is used to
14149 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
14151 The difference between those cases is finding possible inherited bindings
14152 that are overridden, as one has to look for them in tb_sym_root,
14153 tb_uop_root or tb_op, respectively. Thus the caller must already find
14154 the super-type and set p->overridden correctly. */
14157 resolve_tb_generic_targets (gfc_symbol
* super_type
,
14158 gfc_typebound_proc
* p
, const char* name
)
14160 gfc_tbp_generic
* target
;
14161 gfc_symtree
* first_target
;
14162 gfc_symtree
* inherited
;
14164 gcc_assert (p
&& p
->is_generic
);
14166 /* Try to find the specific bindings for the symtrees in our target-list. */
14167 gcc_assert (p
->u
.generic
);
14168 for (target
= p
->u
.generic
; target
; target
= target
->next
)
14169 if (!target
->specific
)
14171 gfc_typebound_proc
* overridden_tbp
;
14172 gfc_tbp_generic
* g
;
14173 const char* target_name
;
14175 target_name
= target
->specific_st
->name
;
14177 /* Defined for this type directly. */
14178 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
14180 target
->specific
= target
->specific_st
->n
.tb
;
14181 goto specific_found
;
14184 /* Look for an inherited specific binding. */
14187 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
14192 gcc_assert (inherited
->n
.tb
);
14193 target
->specific
= inherited
->n
.tb
;
14194 goto specific_found
;
14198 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
14199 " at %L", target_name
, name
, &p
->where
);
14202 /* Once we've found the specific binding, check it is not ambiguous with
14203 other specifics already found or inherited for the same GENERIC. */
14205 gcc_assert (target
->specific
);
14207 /* This must really be a specific binding! */
14208 if (target
->specific
->is_generic
)
14210 gfc_error ("GENERIC %qs at %L must target a specific binding,"
14211 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
14215 /* Check those already resolved on this type directly. */
14216 for (g
= p
->u
.generic
; g
; g
= g
->next
)
14217 if (g
!= target
&& g
->specific
14218 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
14221 /* Check for ambiguity with inherited specific targets. */
14222 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
14223 overridden_tbp
= overridden_tbp
->overridden
)
14224 if (overridden_tbp
->is_generic
)
14226 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
14228 gcc_assert (g
->specific
);
14229 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
14235 /* If we attempt to "overwrite" a specific binding, this is an error. */
14236 if (p
->overridden
&& !p
->overridden
->is_generic
)
14238 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
14239 " the same name", name
, &p
->where
);
14243 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
14244 all must have the same attributes here. */
14245 first_target
= p
->u
.generic
->specific
->u
.specific
;
14246 gcc_assert (first_target
);
14247 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
14248 p
->function
= first_target
->n
.sym
->attr
.function
;
14254 /* Resolve a GENERIC procedure binding for a derived type. */
14257 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
14259 gfc_symbol
* super_type
;
14261 /* Find the overridden binding if any. */
14262 st
->n
.tb
->overridden
= NULL
;
14263 super_type
= gfc_get_derived_super_type (derived
);
14266 gfc_symtree
* overridden
;
14267 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
14270 if (overridden
&& overridden
->n
.tb
)
14271 st
->n
.tb
->overridden
= overridden
->n
.tb
;
14274 /* Resolve using worker function. */
14275 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
14279 /* Retrieve the target-procedure of an operator binding and do some checks in
14280 common for intrinsic and user-defined type-bound operators. */
14283 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
14285 gfc_symbol
* target_proc
;
14287 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
14288 target_proc
= target
->specific
->u
.specific
->n
.sym
;
14289 gcc_assert (target_proc
);
14291 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
14292 if (target
->specific
->nopass
)
14294 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
14298 return target_proc
;
14302 /* Resolve a type-bound intrinsic operator. */
14305 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
14306 gfc_typebound_proc
* p
)
14308 gfc_symbol
* super_type
;
14309 gfc_tbp_generic
* target
;
14311 /* If there's already an error here, do nothing (but don't fail again). */
14315 /* Operators should always be GENERIC bindings. */
14316 gcc_assert (p
->is_generic
);
14318 /* Look for an overridden binding. */
14319 super_type
= gfc_get_derived_super_type (derived
);
14320 if (super_type
&& super_type
->f2k_derived
)
14321 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
14324 p
->overridden
= NULL
;
14326 /* Resolve general GENERIC properties using worker function. */
14327 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
14330 /* Check the targets to be procedures of correct interface. */
14331 for (target
= p
->u
.generic
; target
; target
= target
->next
)
14333 gfc_symbol
* target_proc
;
14335 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
14339 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
14342 /* Add target to non-typebound operator list. */
14343 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
14344 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
14346 gfc_interface
*head
, *intr
;
14348 /* Preempt 'gfc_check_new_interface' for submodules, where the
14349 mechanism for handling module procedures winds up resolving
14350 operator interfaces twice and would otherwise cause an error. */
14351 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
14352 if (intr
->sym
== target_proc
14353 && target_proc
->attr
.used_in_submodule
)
14356 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
14357 target_proc
, p
->where
))
14359 head
= derived
->ns
->op
[op
];
14360 intr
= gfc_get_interface ();
14361 intr
->sym
= target_proc
;
14362 intr
->where
= p
->where
;
14364 derived
->ns
->op
[op
] = intr
;
14376 /* Resolve a type-bound user operator (tree-walker callback). */
14378 static gfc_symbol
* resolve_bindings_derived
;
14379 static bool resolve_bindings_result
;
14381 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
14384 resolve_typebound_user_op (gfc_symtree
* stree
)
14386 gfc_symbol
* super_type
;
14387 gfc_tbp_generic
* target
;
14389 gcc_assert (stree
&& stree
->n
.tb
);
14391 if (stree
->n
.tb
->error
)
14394 /* Operators should always be GENERIC bindings. */
14395 gcc_assert (stree
->n
.tb
->is_generic
);
14397 /* Find overridden procedure, if any. */
14398 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
14399 if (super_type
&& super_type
->f2k_derived
)
14401 gfc_symtree
* overridden
;
14402 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
14403 stree
->name
, true, NULL
);
14405 if (overridden
&& overridden
->n
.tb
)
14406 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
14409 stree
->n
.tb
->overridden
= NULL
;
14411 /* Resolve basically using worker function. */
14412 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
14415 /* Check the targets to be functions of correct interface. */
14416 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
14418 gfc_symbol
* target_proc
;
14420 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
14424 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
14431 resolve_bindings_result
= false;
14432 stree
->n
.tb
->error
= 1;
14436 /* Resolve the type-bound procedures for a derived type. */
14439 resolve_typebound_procedure (gfc_symtree
* stree
)
14443 gfc_symbol
* me_arg
;
14444 gfc_symbol
* super_type
;
14445 gfc_component
* comp
;
14447 gcc_assert (stree
);
14449 /* Undefined specific symbol from GENERIC target definition. */
14453 if (stree
->n
.tb
->error
)
14456 /* If this is a GENERIC binding, use that routine. */
14457 if (stree
->n
.tb
->is_generic
)
14459 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
14464 /* Get the target-procedure to check it. */
14465 gcc_assert (!stree
->n
.tb
->is_generic
);
14466 gcc_assert (stree
->n
.tb
->u
.specific
);
14467 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
14468 where
= stree
->n
.tb
->where
;
14470 /* Default access should already be resolved from the parser. */
14471 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
14473 if (stree
->n
.tb
->deferred
)
14475 if (!check_proc_interface (proc
, &where
))
14480 /* If proc has not been resolved at this point, proc->name may
14481 actually be a USE associated entity. See PR fortran/89647. */
14482 if (!proc
->resolve_symbol_called
14483 && proc
->attr
.function
== 0 && proc
->attr
.subroutine
== 0)
14486 gfc_find_symbol (proc
->name
, gfc_current_ns
->parent
, 1, &tmp
);
14487 if (tmp
&& tmp
->attr
.use_assoc
)
14489 proc
->module
= tmp
->module
;
14490 proc
->attr
.proc
= tmp
->attr
.proc
;
14491 proc
->attr
.function
= tmp
->attr
.function
;
14492 proc
->attr
.subroutine
= tmp
->attr
.subroutine
;
14493 proc
->attr
.use_assoc
= tmp
->attr
.use_assoc
;
14494 proc
->ts
= tmp
->ts
;
14495 proc
->result
= tmp
->result
;
14499 /* Check for F08:C465. */
14500 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
14501 || (proc
->attr
.proc
!= PROC_MODULE
14502 && proc
->attr
.if_source
!= IFSRC_IFBODY
14503 && !proc
->attr
.module_procedure
)
14504 || proc
->attr
.abstract
)
14506 gfc_error ("%qs must be a module procedure or an external "
14507 "procedure with an explicit interface at %L",
14508 proc
->name
, &where
);
14513 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
14514 stree
->n
.tb
->function
= proc
->attr
.function
;
14516 /* Find the super-type of the current derived type. We could do this once and
14517 store in a global if speed is needed, but as long as not I believe this is
14518 more readable and clearer. */
14519 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
14521 /* If PASS, resolve and check arguments if not already resolved / loaded
14522 from a .mod file. */
14523 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
14525 gfc_formal_arglist
*dummy_args
;
14527 dummy_args
= gfc_sym_get_dummy_args (proc
);
14528 if (stree
->n
.tb
->pass_arg
)
14530 gfc_formal_arglist
*i
;
14532 /* If an explicit passing argument name is given, walk the arg-list
14533 and look for it. */
14536 stree
->n
.tb
->pass_arg_num
= 1;
14537 for (i
= dummy_args
; i
; i
= i
->next
)
14539 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
14544 ++stree
->n
.tb
->pass_arg_num
;
14549 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
14551 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
14552 stree
->n
.tb
->pass_arg
);
14558 /* Otherwise, take the first one; there should in fact be at least
14560 stree
->n
.tb
->pass_arg_num
= 1;
14563 gfc_error ("Procedure %qs with PASS at %L must have at"
14564 " least one argument", proc
->name
, &where
);
14567 me_arg
= dummy_args
->sym
;
14570 /* Now check that the argument-type matches and the passed-object
14571 dummy argument is generally fine. */
14573 gcc_assert (me_arg
);
14575 if (me_arg
->ts
.type
!= BT_CLASS
)
14577 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14578 " at %L", proc
->name
, &where
);
14582 if (CLASS_DATA (me_arg
)->ts
.u
.derived
14583 != resolve_bindings_derived
)
14585 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14586 " the derived-type %qs", me_arg
->name
, proc
->name
,
14587 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
14591 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
14592 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
14594 gfc_error ("Passed-object dummy argument of %qs at %L must be"
14595 " scalar", proc
->name
, &where
);
14598 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14600 gfc_error ("Passed-object dummy argument of %qs at %L must not"
14601 " be ALLOCATABLE", proc
->name
, &where
);
14604 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14606 gfc_error ("Passed-object dummy argument of %qs at %L must not"
14607 " be POINTER", proc
->name
, &where
);
14612 /* If we are extending some type, check that we don't override a procedure
14613 flagged NON_OVERRIDABLE. */
14614 stree
->n
.tb
->overridden
= NULL
;
14617 gfc_symtree
* overridden
;
14618 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
14619 stree
->name
, true, NULL
);
14623 if (overridden
->n
.tb
)
14624 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
14626 if (!gfc_check_typebound_override (stree
, overridden
))
14631 /* See if there's a name collision with a component directly in this type. */
14632 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
14633 if (!strcmp (comp
->name
, stree
->name
))
14635 gfc_error ("Procedure %qs at %L has the same name as a component of"
14637 stree
->name
, &where
, resolve_bindings_derived
->name
);
14641 /* Try to find a name collision with an inherited component. */
14642 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
14645 gfc_error ("Procedure %qs at %L has the same name as an inherited"
14646 " component of %qs",
14647 stree
->name
, &where
, resolve_bindings_derived
->name
);
14651 stree
->n
.tb
->error
= 0;
14655 resolve_bindings_result
= false;
14656 stree
->n
.tb
->error
= 1;
14661 resolve_typebound_procedures (gfc_symbol
* derived
)
14664 gfc_symbol
* super_type
;
14666 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
14669 super_type
= gfc_get_derived_super_type (derived
);
14671 resolve_symbol (super_type
);
14673 resolve_bindings_derived
= derived
;
14674 resolve_bindings_result
= true;
14676 if (derived
->f2k_derived
->tb_sym_root
)
14677 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
14678 &resolve_typebound_procedure
);
14680 if (derived
->f2k_derived
->tb_uop_root
)
14681 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
14682 &resolve_typebound_user_op
);
14684 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
14686 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
14687 if (p
&& !resolve_typebound_intrinsic_op (derived
,
14688 (gfc_intrinsic_op
)op
, p
))
14689 resolve_bindings_result
= false;
14692 return resolve_bindings_result
;
14696 /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
14697 to give all identical derived types the same backend_decl. */
14699 add_dt_to_dt_list (gfc_symbol
*derived
)
14701 if (!derived
->dt_next
)
14703 if (gfc_derived_types
)
14705 derived
->dt_next
= gfc_derived_types
->dt_next
;
14706 gfc_derived_types
->dt_next
= derived
;
14710 derived
->dt_next
= derived
;
14712 gfc_derived_types
= derived
;
14717 /* Ensure that a derived-type is really not abstract, meaning that every
14718 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
14721 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
14726 if (!ensure_not_abstract_walker (sub
, st
->left
))
14728 if (!ensure_not_abstract_walker (sub
, st
->right
))
14731 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
14733 gfc_symtree
* overriding
;
14734 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
14737 gcc_assert (overriding
->n
.tb
);
14738 if (overriding
->n
.tb
->deferred
)
14740 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
14741 " %qs is DEFERRED and not overridden",
14742 sub
->name
, &sub
->declared_at
, st
->name
);
14751 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
14753 /* The algorithm used here is to recursively travel up the ancestry of sub
14754 and for each ancestor-type, check all bindings. If any of them is
14755 DEFERRED, look it up starting from sub and see if the found (overriding)
14756 binding is not DEFERRED.
14757 This is not the most efficient way to do this, but it should be ok and is
14758 clearer than something sophisticated. */
14760 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
14762 if (!ancestor
->attr
.abstract
)
14765 /* Walk bindings of this ancestor. */
14766 if (ancestor
->f2k_derived
)
14769 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
14774 /* Find next ancestor type and recurse on it. */
14775 ancestor
= gfc_get_derived_super_type (ancestor
);
14777 return ensure_not_abstract (sub
, ancestor
);
14783 /* This check for typebound defined assignments is done recursively
14784 since the order in which derived types are resolved is not always in
14785 order of the declarations. */
14788 check_defined_assignments (gfc_symbol
*derived
)
14792 for (c
= derived
->components
; c
; c
= c
->next
)
14794 if (!gfc_bt_struct (c
->ts
.type
)
14796 || c
->attr
.proc_pointer_comp
14797 || c
->attr
.class_pointer
14798 || c
->attr
.proc_pointer
)
14801 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
14802 || (c
->ts
.u
.derived
->f2k_derived
14803 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
14805 derived
->attr
.defined_assign_comp
= 1;
14809 if (c
->attr
.allocatable
)
14812 check_defined_assignments (c
->ts
.u
.derived
);
14813 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
14815 derived
->attr
.defined_assign_comp
= 1;
14822 /* Resolve a single component of a derived type or structure. */
14825 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
14827 gfc_symbol
*super_type
;
14828 symbol_attribute
*attr
;
14830 if (c
->attr
.artificial
)
14833 /* Do not allow vtype components to be resolved in nameless namespaces
14834 such as block data because the procedure pointers will cause ICEs
14835 and vtables are not needed in these contexts. */
14836 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
14837 && sym
->ns
->proc_name
== NULL
)
14841 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
14842 && c
->attr
.codimension
14843 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
14845 gfc_error ("Coarray component %qs at %L must be allocatable with "
14846 "deferred shape", c
->name
, &c
->loc
);
14851 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
14852 && c
->ts
.u
.derived
->ts
.is_iso_c
)
14854 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14855 "shall not be a coarray", c
->name
, &c
->loc
);
14860 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
14861 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
14862 || c
->attr
.allocatable
))
14864 gfc_error ("Component %qs at %L with coarray component "
14865 "shall be a nonpointer, nonallocatable scalar",
14871 if (c
->ts
.type
== BT_CLASS
)
14873 if (c
->attr
.class_ok
&& CLASS_DATA (c
))
14875 attr
= &(CLASS_DATA (c
)->attr
);
14877 /* Fix up contiguous attribute. */
14878 if (c
->attr
.contiguous
)
14879 attr
->contiguous
= 1;
14887 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
14889 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
14890 "is not an array pointer", c
->name
, &c
->loc
);
14894 /* F2003, 15.2.1 - length has to be one. */
14895 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
14896 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
14897 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
14898 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
14900 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
14905 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
14907 gfc_symbol
*ifc
= c
->ts
.interface
;
14909 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
14915 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
14917 /* Resolve interface and copy attributes. */
14918 if (ifc
->formal
&& !ifc
->formal_ns
)
14919 resolve_symbol (ifc
);
14920 if (ifc
->attr
.intrinsic
)
14921 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
14925 c
->ts
= ifc
->result
->ts
;
14926 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
14927 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
14928 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
14929 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
14930 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
14935 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
14936 c
->attr
.pointer
= ifc
->attr
.pointer
;
14937 c
->attr
.dimension
= ifc
->attr
.dimension
;
14938 c
->as
= gfc_copy_array_spec (ifc
->as
);
14939 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
14941 c
->ts
.interface
= ifc
;
14942 c
->attr
.function
= ifc
->attr
.function
;
14943 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
14945 c
->attr
.pure
= ifc
->attr
.pure
;
14946 c
->attr
.elemental
= ifc
->attr
.elemental
;
14947 c
->attr
.recursive
= ifc
->attr
.recursive
;
14948 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
14949 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
14950 /* Copy char length. */
14951 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
14953 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
14954 if (cl
->length
&& !cl
->resolved
14955 && !gfc_resolve_expr (cl
->length
))
14964 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
14966 /* Since PPCs are not implicitly typed, a PPC without an explicit
14967 interface must be a subroutine. */
14968 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
14971 /* Procedure pointer components: Check PASS arg. */
14972 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
14973 && !sym
->attr
.vtype
)
14975 gfc_symbol
* me_arg
;
14977 if (c
->tb
->pass_arg
)
14979 gfc_formal_arglist
* i
;
14981 /* If an explicit passing argument name is given, walk the arg-list
14982 and look for it. */
14985 c
->tb
->pass_arg_num
= 1;
14986 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
14988 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
14993 c
->tb
->pass_arg_num
++;
14998 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14999 "at %L has no argument %qs", c
->name
,
15000 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
15007 /* Otherwise, take the first one; there should in fact be at least
15009 c
->tb
->pass_arg_num
= 1;
15010 if (!c
->ts
.interface
->formal
)
15012 gfc_error ("Procedure pointer component %qs with PASS at %L "
15013 "must have at least one argument",
15018 me_arg
= c
->ts
.interface
->formal
->sym
;
15021 /* Now check that the argument-type matches. */
15022 gcc_assert (me_arg
);
15023 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
15024 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
15025 || (me_arg
->ts
.type
== BT_CLASS
15026 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
15028 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
15029 " the derived type %qs", me_arg
->name
, c
->name
,
15030 me_arg
->name
, &c
->loc
, sym
->name
);
15035 /* Check for F03:C453. */
15036 if (CLASS_DATA (me_arg
)->attr
.dimension
)
15038 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15039 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
15045 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
15047 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15048 "may not have the POINTER attribute", me_arg
->name
,
15049 c
->name
, me_arg
->name
, &c
->loc
);
15054 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
15056 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15057 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
15058 me_arg
->name
, &c
->loc
);
15063 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
15065 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
15066 " at %L", c
->name
, &c
->loc
);
15072 /* Check type-spec if this is not the parent-type component. */
15073 if (((sym
->attr
.is_class
15074 && (!sym
->components
->ts
.u
.derived
->attr
.extension
15075 || c
!= sym
->components
->ts
.u
.derived
->components
))
15076 || (!sym
->attr
.is_class
15077 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
15078 && !sym
->attr
.vtype
15079 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
15082 super_type
= gfc_get_derived_super_type (sym
);
15084 /* If this type is an extension, set the accessibility of the parent
15087 && ((sym
->attr
.is_class
15088 && c
== sym
->components
->ts
.u
.derived
->components
)
15089 || (!sym
->attr
.is_class
&& c
== sym
->components
))
15090 && strcmp (super_type
->name
, c
->name
) == 0)
15091 c
->attr
.access
= super_type
->attr
.access
;
15093 /* If this type is an extension, see if this component has the same name
15094 as an inherited type-bound procedure. */
15095 if (super_type
&& !sym
->attr
.is_class
15096 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
15098 gfc_error ("Component %qs of %qs at %L has the same name as an"
15099 " inherited type-bound procedure",
15100 c
->name
, sym
->name
, &c
->loc
);
15104 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
15105 && !c
->ts
.deferred
)
15107 if (c
->ts
.u
.cl
->length
== NULL
15108 || (!resolve_charlen(c
->ts
.u
.cl
))
15109 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
15111 gfc_error ("Character length of component %qs needs to "
15112 "be a constant specification expression at %L",
15114 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
15118 if (c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
15120 if (!c
->ts
.u
.cl
->length
->error
)
15122 gfc_error ("Character length expression of component %qs at %L "
15123 "must be of INTEGER type, found %s",
15124 c
->name
, &c
->ts
.u
.cl
->length
->where
,
15125 gfc_basic_typename (c
->ts
.u
.cl
->length
->ts
.type
));
15126 c
->ts
.u
.cl
->length
->error
= 1;
15132 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
15133 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
15135 gfc_error ("Character component %qs of %qs at %L with deferred "
15136 "length must be a POINTER or ALLOCATABLE",
15137 c
->name
, sym
->name
, &c
->loc
);
15141 /* Add the hidden deferred length field. */
15142 if (c
->ts
.type
== BT_CHARACTER
15143 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
15144 && !c
->attr
.function
15145 && !sym
->attr
.is_class
)
15147 char name
[GFC_MAX_SYMBOL_LEN
+9];
15148 gfc_component
*strlen
;
15149 sprintf (name
, "_%s_length", c
->name
);
15150 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
15151 if (strlen
== NULL
)
15153 if (!gfc_add_component (sym
, name
, &strlen
))
15155 strlen
->ts
.type
= BT_INTEGER
;
15156 strlen
->ts
.kind
= gfc_charlen_int_kind
;
15157 strlen
->attr
.access
= ACCESS_PRIVATE
;
15158 strlen
->attr
.artificial
= 1;
15162 if (c
->ts
.type
== BT_DERIVED
15163 && sym
->component_access
!= ACCESS_PRIVATE
15164 && gfc_check_symbol_access (sym
)
15165 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
15166 && !c
->ts
.u
.derived
->attr
.use_assoc
15167 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
15168 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
15169 "PRIVATE type and cannot be a component of "
15170 "%qs, which is PUBLIC at %L", c
->name
,
15171 sym
->name
, &sym
->declared_at
))
15174 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
15176 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
15177 "type %s", c
->name
, &c
->loc
, sym
->name
);
15181 if (sym
->attr
.sequence
)
15183 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
15185 gfc_error ("Component %s of SEQUENCE type declared at %L does "
15186 "not have the SEQUENCE attribute",
15187 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
15192 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
15193 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
15194 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
15195 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
15196 CLASS_DATA (c
)->ts
.u
.derived
15197 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
15199 /* If an allocatable component derived type is of the same type as
15200 the enclosing derived type, we need a vtable generating so that
15201 the __deallocate procedure is created. */
15202 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
15203 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
15204 gfc_find_vtab (&c
->ts
);
15206 /* Ensure that all the derived type components are put on the
15207 derived type list; even in formal namespaces, where derived type
15208 pointer components might not have been declared. */
15209 if (c
->ts
.type
== BT_DERIVED
15211 && c
->ts
.u
.derived
->components
15213 && sym
!= c
->ts
.u
.derived
)
15214 add_dt_to_dt_list (c
->ts
.u
.derived
);
15216 if (c
->as
&& c
->as
->type
!= AS_DEFERRED
15217 && (c
->attr
.pointer
|| c
->attr
.allocatable
))
15220 if (!gfc_resolve_array_spec (c
->as
,
15221 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
15222 || c
->attr
.allocatable
)))
15225 if (c
->initializer
&& !sym
->attr
.vtype
15226 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
15227 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
15234 /* Be nice about the locus for a structure expression - show the locus of the
15235 first non-null sub-expression if we can. */
15238 cons_where (gfc_expr
*struct_expr
)
15240 gfc_constructor
*cons
;
15242 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
15244 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
15245 for (; cons
; cons
= gfc_constructor_next (cons
))
15247 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
15248 return &cons
->expr
->where
;
15251 return &struct_expr
->where
;
15254 /* Resolve the components of a structure type. Much less work than derived
15258 resolve_fl_struct (gfc_symbol
*sym
)
15261 gfc_expr
*init
= NULL
;
15264 /* Make sure UNIONs do not have overlapping initializers. */
15265 if (sym
->attr
.flavor
== FL_UNION
)
15267 for (c
= sym
->components
; c
; c
= c
->next
)
15269 if (init
&& c
->initializer
)
15271 gfc_error ("Conflicting initializers in union at %L and %L",
15272 cons_where (init
), cons_where (c
->initializer
));
15273 gfc_free_expr (c
->initializer
);
15274 c
->initializer
= NULL
;
15277 init
= c
->initializer
;
15282 for (c
= sym
->components
; c
; c
= c
->next
)
15283 if (!resolve_component (c
, sym
))
15289 if (sym
->components
)
15290 add_dt_to_dt_list (sym
);
15296 /* Resolve the components of a derived type. This does not have to wait until
15297 resolution stage, but can be done as soon as the dt declaration has been
15301 resolve_fl_derived0 (gfc_symbol
*sym
)
15303 gfc_symbol
* super_type
;
15305 gfc_formal_arglist
*f
;
15308 if (sym
->attr
.unlimited_polymorphic
)
15311 super_type
= gfc_get_derived_super_type (sym
);
15314 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
15316 gfc_error ("As extending type %qs at %L has a coarray component, "
15317 "parent type %qs shall also have one", sym
->name
,
15318 &sym
->declared_at
, super_type
->name
);
15322 /* Ensure the extended type gets resolved before we do. */
15323 if (super_type
&& !resolve_fl_derived0 (super_type
))
15326 /* An ABSTRACT type must be extensible. */
15327 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
15329 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
15330 sym
->name
, &sym
->declared_at
);
15334 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
15338 for ( ; c
!= NULL
; c
= c
->next
)
15339 if (!resolve_component (c
, sym
))
15345 /* Now add the caf token field, where needed. */
15346 if (flag_coarray
!= GFC_FCOARRAY_NONE
15347 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
15349 for (c
= sym
->components
; c
; c
= c
->next
)
15350 if (!c
->attr
.dimension
&& !c
->attr
.codimension
15351 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
15353 char name
[GFC_MAX_SYMBOL_LEN
+9];
15354 gfc_component
*token
;
15355 sprintf (name
, "_caf_%s", c
->name
);
15356 token
= gfc_find_component (sym
, name
, true, true, NULL
);
15359 if (!gfc_add_component (sym
, name
, &token
))
15361 token
->ts
.type
= BT_VOID
;
15362 token
->ts
.kind
= gfc_default_integer_kind
;
15363 token
->attr
.access
= ACCESS_PRIVATE
;
15364 token
->attr
.artificial
= 1;
15365 token
->attr
.caf_token
= 1;
15370 check_defined_assignments (sym
);
15372 if (!sym
->attr
.defined_assign_comp
&& super_type
)
15373 sym
->attr
.defined_assign_comp
15374 = super_type
->attr
.defined_assign_comp
;
15376 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
15377 all DEFERRED bindings are overridden. */
15378 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
15379 && !sym
->attr
.is_class
15380 && !ensure_not_abstract (sym
, super_type
))
15383 /* Check that there is a component for every PDT parameter. */
15384 if (sym
->attr
.pdt_template
)
15386 for (f
= sym
->formal
; f
; f
= f
->next
)
15390 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
15393 gfc_error ("Parameterized type %qs does not have a component "
15394 "corresponding to parameter %qs at %L", sym
->name
,
15395 f
->sym
->name
, &sym
->declared_at
);
15401 /* Add derived type to the derived type list. */
15402 add_dt_to_dt_list (sym
);
15408 /* The following procedure does the full resolution of a derived type,
15409 including resolution of all type-bound procedures (if present). In contrast
15410 to 'resolve_fl_derived0' this can only be done after the module has been
15411 parsed completely. */
15414 resolve_fl_derived (gfc_symbol
*sym
)
15416 gfc_symbol
*gen_dt
= NULL
;
15418 if (sym
->attr
.unlimited_polymorphic
)
15421 if (!sym
->attr
.is_class
)
15422 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
15423 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
15424 && (!gen_dt
->generic
->sym
->attr
.use_assoc
15425 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
15426 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
15427 "%qs at %L being the same name as derived "
15428 "type at %L", sym
->name
,
15429 gen_dt
->generic
->sym
== sym
15430 ? gen_dt
->generic
->next
->sym
->name
15431 : gen_dt
->generic
->sym
->name
,
15432 gen_dt
->generic
->sym
== sym
15433 ? &gen_dt
->generic
->next
->sym
->declared_at
15434 : &gen_dt
->generic
->sym
->declared_at
,
15435 &sym
->declared_at
))
15438 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
15440 gfc_error ("Derived type %qs at %L has not been declared",
15441 sym
->name
, &sym
->declared_at
);
15445 /* Resolve the finalizer procedures. */
15446 if (!gfc_resolve_finalizers (sym
, NULL
))
15449 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
15451 /* Fix up incomplete CLASS symbols. */
15452 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
15453 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
15455 /* Nothing more to do for unlimited polymorphic entities. */
15456 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
15458 add_dt_to_dt_list (sym
);
15461 else if (vptr
->ts
.u
.derived
== NULL
)
15463 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
15465 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
15466 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
15471 if (!resolve_fl_derived0 (sym
))
15474 /* Resolve the type-bound procedures. */
15475 if (!resolve_typebound_procedures (sym
))
15478 /* Generate module vtables subject to their accessibility and their not
15479 being vtables or pdt templates. If this is not done class declarations
15480 in external procedures wind up with their own version and so SELECT TYPE
15481 fails because the vptrs do not have the same address. */
15482 if (gfc_option
.allow_std
& GFC_STD_F2003
15483 && sym
->ns
->proc_name
15484 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15485 && sym
->attr
.access
!= ACCESS_PRIVATE
15486 && !(sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
15488 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
15489 gfc_set_sym_referenced (vtab
);
15497 resolve_fl_namelist (gfc_symbol
*sym
)
15502 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
15504 /* Check again, the check in match only works if NAMELIST comes
15506 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
15508 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
15509 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15513 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
15514 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
15515 "with assumed shape in namelist %qs at %L",
15516 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
15519 if (is_non_constant_shape_array (nl
->sym
)
15520 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
15521 "with nonconstant shape in namelist %qs at %L",
15522 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
15525 if (nl
->sym
->ts
.type
== BT_CHARACTER
15526 && (nl
->sym
->ts
.u
.cl
->length
== NULL
15527 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
15528 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
15529 "nonconstant character length in "
15530 "namelist %qs at %L", nl
->sym
->name
,
15531 sym
->name
, &sym
->declared_at
))
15536 /* Reject PRIVATE objects in a PUBLIC namelist. */
15537 if (gfc_check_symbol_access (sym
))
15539 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
15541 if (!nl
->sym
->attr
.use_assoc
15542 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
15543 && !gfc_check_symbol_access (nl
->sym
))
15545 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
15546 "cannot be member of PUBLIC namelist %qs at %L",
15547 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15551 if (nl
->sym
->ts
.type
== BT_DERIVED
15552 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
15553 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
15555 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
15556 "namelist %qs at %L with ALLOCATABLE "
15557 "or POINTER components", nl
->sym
->name
,
15558 sym
->name
, &sym
->declared_at
))
15563 /* Types with private components that came here by USE-association. */
15564 if (nl
->sym
->ts
.type
== BT_DERIVED
15565 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
15567 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
15568 "components and cannot be member of namelist %qs at %L",
15569 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15573 /* Types with private components that are defined in the same module. */
15574 if (nl
->sym
->ts
.type
== BT_DERIVED
15575 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
15576 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
15578 gfc_error ("NAMELIST object %qs has PRIVATE components and "
15579 "cannot be a member of PUBLIC namelist %qs at %L",
15580 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15587 /* 14.1.2 A module or internal procedure represent local entities
15588 of the same type as a namelist member and so are not allowed. */
15589 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
15591 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
15594 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
15595 if ((nl
->sym
== sym
->ns
->proc_name
)
15597 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
15602 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
15603 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
15605 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
15606 "attribute in %qs at %L", nlsym
->name
,
15607 &sym
->declared_at
);
15617 resolve_fl_parameter (gfc_symbol
*sym
)
15619 /* A parameter array's shape needs to be constant. */
15620 if (sym
->as
!= NULL
15621 && (sym
->as
->type
== AS_DEFERRED
15622 || is_non_constant_shape_array (sym
)))
15624 gfc_error ("Parameter array %qs at %L cannot be automatic "
15625 "or of deferred shape", sym
->name
, &sym
->declared_at
);
15629 /* Constraints on deferred type parameter. */
15630 if (!deferred_requirements (sym
))
15633 /* Make sure a parameter that has been implicitly typed still
15634 matches the implicit type, since PARAMETER statements can precede
15635 IMPLICIT statements. */
15636 if (sym
->attr
.implicit_type
15637 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
15640 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
15641 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
15645 /* Make sure the types of derived parameters are consistent. This
15646 type checking is deferred until resolution because the type may
15647 refer to a derived type from the host. */
15648 if (sym
->ts
.type
== BT_DERIVED
15649 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
15651 gfc_error ("Incompatible derived type in PARAMETER at %L",
15652 &sym
->value
->where
);
15656 /* F03:C509,C514. */
15657 if (sym
->ts
.type
== BT_CLASS
)
15659 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
15660 sym
->name
, &sym
->declared_at
);
15668 /* Called by resolve_symbol to check PDTs. */
15671 resolve_pdt (gfc_symbol
* sym
)
15673 gfc_symbol
*derived
= NULL
;
15674 gfc_actual_arglist
*param
;
15676 bool const_len_exprs
= true;
15677 bool assumed_len_exprs
= false;
15678 symbol_attribute
*attr
;
15680 if (sym
->ts
.type
== BT_DERIVED
)
15682 derived
= sym
->ts
.u
.derived
;
15683 attr
= &(sym
->attr
);
15685 else if (sym
->ts
.type
== BT_CLASS
)
15687 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
15688 attr
= &(CLASS_DATA (sym
)->attr
);
15691 gcc_unreachable ();
15693 gcc_assert (derived
->attr
.pdt_type
);
15695 for (param
= sym
->param_list
; param
; param
= param
->next
)
15697 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
15699 if (c
->attr
.pdt_kind
)
15702 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
15703 && c
->attr
.pdt_len
)
15704 const_len_exprs
= false;
15705 else if (param
->spec_type
== SPEC_ASSUMED
)
15706 assumed_len_exprs
= true;
15708 if (param
->spec_type
== SPEC_DEFERRED
15709 && !attr
->allocatable
&& !attr
->pointer
)
15710 gfc_error ("The object %qs at %L has a deferred LEN "
15711 "parameter %qs and is neither allocatable "
15712 "nor a pointer", sym
->name
, &sym
->declared_at
,
15717 if (!const_len_exprs
15718 && (sym
->ns
->proc_name
->attr
.is_main_program
15719 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15720 || sym
->attr
.save
!= SAVE_NONE
))
15721 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
15722 "SAVE attribute or be a variable declared in the "
15723 "main program, a module or a submodule(F08/C513)",
15724 sym
->name
, &sym
->declared_at
);
15726 if (assumed_len_exprs
&& !(sym
->attr
.dummy
15727 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
15728 gfc_error ("The object %qs at %L with ASSUMED type parameters "
15729 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
15730 sym
->name
, &sym
->declared_at
);
15734 /* Do anything necessary to resolve a symbol. Right now, we just
15735 assume that an otherwise unknown symbol is a variable. This sort
15736 of thing commonly happens for symbols in module. */
15739 resolve_symbol (gfc_symbol
*sym
)
15741 int check_constant
, mp_flag
;
15742 gfc_symtree
*symtree
;
15743 gfc_symtree
*this_symtree
;
15746 symbol_attribute class_attr
;
15747 gfc_array_spec
*as
;
15748 bool saved_specification_expr
;
15750 if (sym
->resolve_symbol_called
>= 1)
15752 sym
->resolve_symbol_called
= 1;
15754 /* No symbol will ever have union type; only components can be unions.
15755 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
15756 (just like derived type declaration symbols have flavor FL_DERIVED). */
15757 gcc_assert (sym
->ts
.type
!= BT_UNION
);
15759 /* Coarrayed polymorphic objects with allocatable or pointer components are
15760 yet unsupported for -fcoarray=lib. */
15761 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
15762 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
15763 && CLASS_DATA (sym
)->attr
.codimension
15764 && CLASS_DATA (sym
)->ts
.u
.derived
15765 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
15766 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
15768 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
15769 "type coarrays at %L are unsupported", &sym
->declared_at
);
15773 if (sym
->attr
.artificial
)
15776 if (sym
->attr
.unlimited_polymorphic
)
15779 if (UNLIKELY (flag_openmp
&& strcmp (sym
->name
, "omp_all_memory") == 0))
15781 gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
15782 "the OpenMP DEPEND clause", &sym
->declared_at
);
15786 if (sym
->attr
.flavor
== FL_UNKNOWN
15787 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
15788 && !sym
->attr
.generic
&& !sym
->attr
.external
15789 && sym
->attr
.if_source
== IFSRC_UNKNOWN
15790 && sym
->ts
.type
== BT_UNKNOWN
))
15793 /* If we find that a flavorless symbol is an interface in one of the
15794 parent namespaces, find its symtree in this namespace, free the
15795 symbol and set the symtree to point to the interface symbol. */
15796 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
15798 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
15799 if (symtree
&& (symtree
->n
.sym
->generic
||
15800 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
15801 && sym
->ns
->construct_entities
)))
15803 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
15805 if (this_symtree
->n
.sym
== sym
)
15807 symtree
->n
.sym
->refs
++;
15808 gfc_release_symbol (sym
);
15809 this_symtree
->n
.sym
= symtree
->n
.sym
;
15815 /* Otherwise give it a flavor according to such attributes as
15817 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
15818 && sym
->attr
.intrinsic
== 0)
15819 sym
->attr
.flavor
= FL_VARIABLE
;
15820 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
15822 sym
->attr
.flavor
= FL_PROCEDURE
;
15823 if (sym
->attr
.dimension
)
15824 sym
->attr
.function
= 1;
15828 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
15829 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15831 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
15832 && !resolve_procedure_interface (sym
))
15835 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
15836 && (sym
->attr
.procedure
|| sym
->attr
.external
))
15838 if (sym
->attr
.external
)
15839 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
15840 "at %L", &sym
->declared_at
);
15842 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
15843 "at %L", &sym
->declared_at
);
15848 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
15851 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
15852 && !resolve_fl_struct (sym
))
15855 /* Symbols that are module procedures with results (functions) have
15856 the types and array specification copied for type checking in
15857 procedures that call them, as well as for saving to a module
15858 file. These symbols can't stand the scrutiny that their results
15860 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
15862 /* Make sure that the intrinsic is consistent with its internal
15863 representation. This needs to be done before assigning a default
15864 type to avoid spurious warnings. */
15865 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
15866 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
15869 /* Resolve associate names. */
15871 resolve_assoc_var (sym
, true);
15873 /* Assign default type to symbols that need one and don't have one. */
15874 if (sym
->ts
.type
== BT_UNKNOWN
)
15876 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
15878 gfc_set_default_type (sym
, 1, NULL
);
15881 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
15882 && !sym
->attr
.function
&& !sym
->attr
.subroutine
15883 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
15884 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15886 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15888 /* The specific case of an external procedure should emit an error
15889 in the case that there is no implicit type. */
15892 if (!sym
->attr
.mixed_entry_master
)
15893 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
15897 /* Result may be in another namespace. */
15898 resolve_symbol (sym
->result
);
15900 if (!sym
->result
->attr
.proc_pointer
)
15902 sym
->ts
= sym
->result
->ts
;
15903 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
15904 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
15905 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
15906 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
15907 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
15912 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15914 bool saved_specification_expr
= specification_expr
;
15915 bool saved_formal_arg_flag
= formal_arg_flag
;
15917 specification_expr
= true;
15918 formal_arg_flag
= true;
15919 gfc_resolve_array_spec (sym
->result
->as
, false);
15920 formal_arg_flag
= saved_formal_arg_flag
;
15921 specification_expr
= saved_specification_expr
;
15924 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
&& sym
->ts
.u
.derived
)
15926 as
= CLASS_DATA (sym
)->as
;
15927 class_attr
= CLASS_DATA (sym
)->attr
;
15928 class_attr
.pointer
= class_attr
.class_pointer
;
15932 class_attr
= sym
->attr
;
15937 if (sym
->attr
.contiguous
15938 && (!class_attr
.dimension
15939 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
15940 && !class_attr
.pointer
)))
15942 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
15943 "array pointer or an assumed-shape or assumed-rank array",
15944 sym
->name
, &sym
->declared_at
);
15948 /* Assumed size arrays and assumed shape arrays must be dummy
15949 arguments. Array-spec's of implied-shape should have been resolved to
15950 AS_EXPLICIT already. */
15954 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
15955 specification expression. */
15956 if (as
->type
== AS_IMPLIED_SHAPE
)
15959 for (i
=0; i
<as
->rank
; i
++)
15961 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
15963 gfc_error ("Bad specification for assumed size array at %L",
15964 &as
->lower
[i
]->where
);
15971 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
15972 || as
->type
== AS_ASSUMED_SHAPE
)
15973 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
15975 if (as
->type
== AS_ASSUMED_SIZE
)
15976 gfc_error ("Assumed size array at %L must be a dummy argument",
15977 &sym
->declared_at
);
15979 gfc_error ("Assumed shape array at %L must be a dummy argument",
15980 &sym
->declared_at
);
15983 /* TS 29113, C535a. */
15984 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
15985 && !sym
->attr
.select_type_temporary
15986 && !(cs_base
&& cs_base
->current
15987 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
15989 gfc_error ("Assumed-rank array at %L must be a dummy argument",
15990 &sym
->declared_at
);
15993 if (as
->type
== AS_ASSUMED_RANK
15994 && (sym
->attr
.codimension
|| sym
->attr
.value
))
15996 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15997 "CODIMENSION attribute", &sym
->declared_at
);
16002 /* Make sure symbols with known intent or optional are really dummy
16003 variable. Because of ENTRY statement, this has to be deferred
16004 until resolution time. */
16006 if (!sym
->attr
.dummy
16007 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
16009 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
16013 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
16015 gfc_error ("%qs at %L cannot have the VALUE attribute because "
16016 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
16020 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
16022 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
16023 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
16025 gfc_error ("Character dummy variable %qs at %L with VALUE "
16026 "attribute must have constant length",
16027 sym
->name
, &sym
->declared_at
);
16031 if (sym
->ts
.is_c_interop
16032 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
16034 gfc_error ("C interoperable character dummy variable %qs at %L "
16035 "with VALUE attribute must have length one",
16036 sym
->name
, &sym
->declared_at
);
16041 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
16042 && sym
->ts
.u
.derived
->attr
.generic
)
16044 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
16045 if (!sym
->ts
.u
.derived
)
16047 gfc_error ("The derived type %qs at %L is of type %qs, "
16048 "which has not been defined", sym
->name
,
16049 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16050 sym
->ts
.type
= BT_UNKNOWN
;
16055 /* Use the same constraints as TYPE(*), except for the type check
16056 and that only scalars and assumed-size arrays are permitted. */
16057 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
16059 if (!sym
->attr
.dummy
)
16061 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
16062 "a dummy argument", sym
->name
, &sym
->declared_at
);
16066 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
16067 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
16068 && sym
->ts
.type
!= BT_COMPLEX
)
16070 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
16071 "of type TYPE(*) or of an numeric intrinsic type",
16072 sym
->name
, &sym
->declared_at
);
16076 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
16077 || sym
->attr
.pointer
|| sym
->attr
.value
)
16079 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
16080 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
16081 "attribute", sym
->name
, &sym
->declared_at
);
16085 if (sym
->attr
.intent
== INTENT_OUT
)
16087 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
16088 "have the INTENT(OUT) attribute",
16089 sym
->name
, &sym
->declared_at
);
16092 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
16094 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
16095 "either be a scalar or an assumed-size array",
16096 sym
->name
, &sym
->declared_at
);
16100 /* Set the type to TYPE(*) and add a dimension(*) to ensure
16101 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
16103 sym
->ts
.type
= BT_ASSUMED
;
16104 sym
->as
= gfc_get_array_spec ();
16105 sym
->as
->type
= AS_ASSUMED_SIZE
;
16107 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
16109 else if (sym
->ts
.type
== BT_ASSUMED
)
16111 /* TS 29113, C407a. */
16112 if (!sym
->attr
.dummy
)
16114 gfc_error ("Assumed type of variable %s at %L is only permitted "
16115 "for dummy variables", sym
->name
, &sym
->declared_at
);
16118 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
16119 || sym
->attr
.pointer
|| sym
->attr
.value
)
16121 gfc_error ("Assumed-type variable %s at %L may not have the "
16122 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
16123 sym
->name
, &sym
->declared_at
);
16126 if (sym
->attr
.intent
== INTENT_OUT
)
16128 gfc_error ("Assumed-type variable %s at %L may not have the "
16129 "INTENT(OUT) attribute",
16130 sym
->name
, &sym
->declared_at
);
16133 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
16135 gfc_error ("Assumed-type variable %s at %L shall not be an "
16136 "explicit-shape array", sym
->name
, &sym
->declared_at
);
16141 /* If the symbol is marked as bind(c), that it is declared at module level
16142 scope and verify its type and kind. Do not do the latter for symbols
16143 that are implicitly typed because that is handled in
16144 gfc_set_default_type. Handle dummy arguments and procedure definitions
16145 separately. Also, anything that is use associated is not handled here
16146 but instead is handled in the module it is declared in. Finally, derived
16147 type definitions are allowed to be BIND(C) since that only implies that
16148 they're interoperable, and they are checked fully for interoperability
16149 when a variable is declared of that type. */
16150 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
16151 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
16152 && sym
->attr
.flavor
!= FL_DERIVED
)
16156 /* First, make sure the variable is declared at the
16157 module-level scope (J3/04-007, Section 15.3). */
16158 if (!(sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16159 && !sym
->attr
.in_common
)
16161 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
16162 "is neither a COMMON block nor declared at the "
16163 "module level scope", sym
->name
, &(sym
->declared_at
));
16166 else if (sym
->ts
.type
== BT_CHARACTER
16167 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
16168 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
16169 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
16171 gfc_error ("BIND(C) Variable %qs at %L must have length one",
16172 sym
->name
, &sym
->declared_at
);
16175 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
16177 t
= verify_com_block_vars_c_interop (sym
->common_head
);
16179 else if (sym
->attr
.implicit_type
== 0)
16181 /* If type() declaration, we need to verify that the components
16182 of the given type are all C interoperable, etc. */
16183 if (sym
->ts
.type
== BT_DERIVED
&&
16184 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
16186 /* Make sure the user marked the derived type as BIND(C). If
16187 not, call the verify routine. This could print an error
16188 for the derived type more than once if multiple variables
16189 of that type are declared. */
16190 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
16191 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
16195 /* Verify the variable itself as C interoperable if it
16196 is BIND(C). It is not possible for this to succeed if
16197 the verify_bind_c_derived_type failed, so don't have to handle
16198 any error returned by verify_bind_c_derived_type. */
16199 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
16200 sym
->common_block
);
16205 /* clear the is_bind_c flag to prevent reporting errors more than
16206 once if something failed. */
16207 sym
->attr
.is_bind_c
= 0;
16212 /* If a derived type symbol has reached this point, without its
16213 type being declared, we have an error. Notice that most
16214 conditions that produce undefined derived types have already
16215 been dealt with. However, the likes of:
16216 implicit type(t) (t) ..... call foo (t) will get us here if
16217 the type is not declared in the scope of the implicit
16218 statement. Change the type to BT_UNKNOWN, both because it is so
16219 and to prevent an ICE. */
16220 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
16221 && sym
->ts
.u
.derived
->components
== NULL
16222 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
16224 gfc_error ("The derived type %qs at %L is of type %qs, "
16225 "which has not been defined", sym
->name
,
16226 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16227 sym
->ts
.type
= BT_UNKNOWN
;
16231 /* Make sure that the derived type has been resolved and that the
16232 derived type is visible in the symbol's namespace, if it is a
16233 module function and is not PRIVATE. */
16234 if (sym
->ts
.type
== BT_DERIVED
16235 && sym
->ts
.u
.derived
->attr
.use_assoc
16236 && sym
->ns
->proc_name
16237 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
16238 && !resolve_fl_derived (sym
->ts
.u
.derived
))
16241 /* Unless the derived-type declaration is use associated, Fortran 95
16242 does not allow public entries of private derived types.
16243 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
16244 161 in 95-006r3. */
16245 if (sym
->ts
.type
== BT_DERIVED
16246 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
16247 && !sym
->ts
.u
.derived
->attr
.use_assoc
16248 && gfc_check_symbol_access (sym
)
16249 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16250 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
16251 "derived type %qs",
16252 (sym
->attr
.flavor
== FL_PARAMETER
)
16253 ? "parameter" : "variable",
16254 sym
->name
, &sym
->declared_at
,
16255 sym
->ts
.u
.derived
->name
))
16258 /* F2008, C1302. */
16259 if (sym
->ts
.type
== BT_DERIVED
16260 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
16261 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
16262 || sym
->ts
.u
.derived
->attr
.lock_comp
)
16263 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
16265 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
16266 "type LOCK_TYPE must be a coarray", sym
->name
,
16267 &sym
->declared_at
);
16271 /* TS18508, C702/C703. */
16272 if (sym
->ts
.type
== BT_DERIVED
16273 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
16274 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
16275 || sym
->ts
.u
.derived
->attr
.event_comp
)
16276 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
16278 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
16279 "type EVENT_TYPE must be a coarray", sym
->name
,
16280 &sym
->declared_at
);
16284 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
16285 default initialization is defined (5.1.2.4.4). */
16286 if (sym
->ts
.type
== BT_DERIVED
16288 && sym
->attr
.intent
== INTENT_OUT
16290 && sym
->as
->type
== AS_ASSUMED_SIZE
)
16292 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
16294 if (c
->initializer
)
16296 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
16297 "ASSUMED SIZE and so cannot have a default initializer",
16298 sym
->name
, &sym
->declared_at
);
16305 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
16306 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
16308 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
16309 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
16314 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
16315 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
16317 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
16318 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
16323 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
16324 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
16325 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
16326 && CLASS_DATA (sym
)->attr
.coarray_comp
))
16327 || class_attr
.codimension
)
16328 && (sym
->attr
.result
|| sym
->result
== sym
))
16330 gfc_error ("Function result %qs at %L shall not be a coarray or have "
16331 "a coarray component", sym
->name
, &sym
->declared_at
);
16336 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
16337 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
16339 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
16340 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
16345 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
16346 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
16347 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
16348 && CLASS_DATA (sym
)->attr
.coarray_comp
))
16349 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
16350 || class_attr
.allocatable
))
16352 gfc_error ("Variable %qs at %L with coarray component shall be a "
16353 "nonpointer, nonallocatable scalar, which is not a coarray",
16354 sym
->name
, &sym
->declared_at
);
16358 /* F2008, C526. The function-result case was handled above. */
16359 if (class_attr
.codimension
16360 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
16361 || sym
->attr
.select_type_temporary
16362 || sym
->attr
.associate_var
16363 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
16364 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
16365 || sym
->ns
->proc_name
->attr
.is_main_program
16366 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
16368 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
16369 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
16373 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
16374 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
16376 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
16377 "deferred shape", sym
->name
, &sym
->declared_at
);
16380 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
16381 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
16383 gfc_error ("Allocatable coarray variable %qs at %L must have "
16384 "deferred shape", sym
->name
, &sym
->declared_at
);
16389 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
16390 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
16391 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
16392 && CLASS_DATA (sym
)->attr
.coarray_comp
))
16393 || (class_attr
.codimension
&& class_attr
.allocatable
))
16394 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
16396 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
16397 "allocatable coarray or have coarray components",
16398 sym
->name
, &sym
->declared_at
);
16402 if (class_attr
.codimension
&& sym
->attr
.dummy
16403 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
16405 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
16406 "procedure %qs", sym
->name
, &sym
->declared_at
,
16407 sym
->ns
->proc_name
->name
);
16411 if (sym
->ts
.type
== BT_LOGICAL
16412 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
16413 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
16414 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
16417 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
16418 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
16420 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
16421 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
16422 "%L with non-C_Bool kind in BIND(C) procedure "
16423 "%qs", sym
->name
, &sym
->declared_at
,
16424 sym
->ns
->proc_name
->name
))
16426 else if (!gfc_logical_kinds
[i
].c_bool
16427 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
16428 "%qs at %L with non-C_Bool kind in "
16429 "BIND(C) procedure %qs", sym
->name
,
16431 sym
->attr
.function
? sym
->name
16432 : sym
->ns
->proc_name
->name
))
16436 switch (sym
->attr
.flavor
)
16439 if (!resolve_fl_variable (sym
, mp_flag
))
16444 if (sym
->formal
&& !sym
->formal_ns
)
16446 /* Check that none of the arguments are a namelist. */
16447 gfc_formal_arglist
*formal
= sym
->formal
;
16449 for (; formal
; formal
= formal
->next
)
16450 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
16452 gfc_error ("Namelist %qs cannot be an argument to "
16453 "subroutine or function at %L",
16454 formal
->sym
->name
, &sym
->declared_at
);
16459 if (!resolve_fl_procedure (sym
, mp_flag
))
16464 if (!resolve_fl_namelist (sym
))
16469 if (!resolve_fl_parameter (sym
))
16477 /* Resolve array specifier. Check as well some constraints
16478 on COMMON blocks. */
16480 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
16482 /* Set the formal_arg_flag so that check_conflict will not throw
16483 an error for host associated variables in the specification
16484 expression for an array_valued function. */
16485 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
16486 formal_arg_flag
= true;
16488 saved_specification_expr
= specification_expr
;
16489 specification_expr
= true;
16490 gfc_resolve_array_spec (sym
->as
, check_constant
);
16491 specification_expr
= saved_specification_expr
;
16493 formal_arg_flag
= false;
16495 /* Resolve formal namespaces. */
16496 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
16497 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
16498 gfc_resolve (sym
->formal_ns
);
16500 /* Make sure the formal namespace is present. */
16501 if (sym
->formal
&& !sym
->formal_ns
)
16503 gfc_formal_arglist
*formal
= sym
->formal
;
16504 while (formal
&& !formal
->sym
)
16505 formal
= formal
->next
;
16509 sym
->formal_ns
= formal
->sym
->ns
;
16510 if (sym
->formal_ns
&& sym
->ns
!= formal
->sym
->ns
)
16511 sym
->formal_ns
->refs
++;
16515 /* Check threadprivate restrictions. */
16516 if (sym
->attr
.threadprivate
16517 && !(sym
->attr
.save
|| sym
->attr
.data
|| sym
->attr
.in_common
)
16518 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
16519 && sym
->module
== NULL
16520 && (sym
->ns
->proc_name
== NULL
16521 || (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
16522 && !sym
->ns
->proc_name
->attr
.is_main_program
)))
16523 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
16525 /* Check omp declare target restrictions. */
16526 if (sym
->attr
.omp_declare_target
16527 && sym
->attr
.flavor
== FL_VARIABLE
16529 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
16530 && (!sym
->attr
.in_common
16531 && sym
->module
== NULL
16532 && (sym
->ns
->proc_name
== NULL
16533 || (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
16534 && !sym
->ns
->proc_name
->attr
.is_main_program
))))
16535 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
16536 sym
->name
, &sym
->declared_at
);
16538 /* If we have come this far we can apply default-initializers, as
16539 described in 14.7.5, to those variables that have not already
16540 been assigned one. */
16541 if (sym
->ts
.type
== BT_DERIVED
16543 && !sym
->attr
.allocatable
16544 && !sym
->attr
.alloc_comp
)
16546 symbol_attribute
*a
= &sym
->attr
;
16548 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
16549 && !a
->in_common
&& !a
->use_assoc
16551 && !((a
->function
|| a
->result
)
16553 || sym
->ts
.u
.derived
->attr
.alloc_comp
16554 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
16555 && !(a
->function
&& sym
!= sym
->result
))
16556 || (a
->dummy
&& !a
->pointer
&& a
->intent
== INTENT_OUT
16557 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
))
16558 apply_default_init (sym
);
16559 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
16560 && (sym
->ts
.u
.derived
->attr
.alloc_comp
16561 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
16562 /* Mark the result symbol to be referenced, when it has allocatable
16564 sym
->result
->attr
.referenced
= 1;
16567 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
16568 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
16569 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
16570 && !CLASS_DATA (sym
)->attr
.class_pointer
16571 && !CLASS_DATA (sym
)->attr
.allocatable
)
16572 apply_default_init (sym
);
16574 /* If this symbol has a type-spec, check it. */
16575 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
16576 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
16577 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
16580 if (sym
->param_list
)
16583 if (!sym
->attr
.referenced
16584 && (sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
))
16586 gfc_expr
*final_expr
= gfc_lval_expr_from_sym (sym
);
16587 if (gfc_is_finalizable (final_expr
->ts
.u
.derived
, NULL
))
16588 gfc_set_sym_referenced (sym
);
16589 gfc_free_expr (final_expr
);
16594 /************* Resolve DATA statements *************/
16598 gfc_data_value
*vnode
;
16604 /* Advance the values structure to point to the next value in the data list. */
16607 next_data_value (void)
16609 while (mpz_cmp_ui (values
.left
, 0) == 0)
16612 if (values
.vnode
->next
== NULL
)
16615 values
.vnode
= values
.vnode
->next
;
16616 mpz_set (values
.left
, values
.vnode
->repeat
);
16624 check_data_variable (gfc_data_variable
*var
, locus
*where
)
16630 ar_type mark
= AR_UNKNOWN
;
16632 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
16638 if (!gfc_resolve_expr (var
->expr
))
16642 mpz_init_set_si (offset
, 0);
16645 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
16646 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
16647 e
= e
->value
.function
.actual
->expr
;
16649 if (e
->expr_type
!= EXPR_VARIABLE
)
16651 gfc_error ("Expecting definable entity near %L", where
);
16655 sym
= e
->symtree
->n
.sym
;
16657 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
16659 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
16660 sym
->name
, &sym
->declared_at
);
16664 if (e
->ref
== NULL
&& sym
->as
)
16666 gfc_error ("DATA array %qs at %L must be specified in a previous"
16667 " declaration", sym
->name
, where
);
16671 if (gfc_is_coindexed (e
))
16673 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
16678 has_pointer
= sym
->attr
.pointer
;
16680 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
16682 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
16687 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_FULL
)
16689 gfc_error ("DATA element %qs at %L is a pointer and so must "
16690 "be a full array", sym
->name
, where
);
16694 if (values
.vnode
->expr
->expr_type
== EXPR_CONSTANT
)
16696 gfc_error ("DATA object near %L has the pointer attribute "
16697 "and the corresponding DATA value is not a valid "
16698 "initial-data-target", where
);
16703 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.allocatable
)
16705 gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
16706 "attribute", ref
->u
.c
.component
->name
, &e
->where
);
16711 if (e
->rank
== 0 || has_pointer
)
16713 mpz_init_set_ui (size
, 1);
16720 /* Find the array section reference. */
16721 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
16723 if (ref
->type
!= REF_ARRAY
)
16725 if (ref
->u
.ar
.type
== AR_ELEMENT
)
16731 /* Set marks according to the reference pattern. */
16732 switch (ref
->u
.ar
.type
)
16740 /* Get the start position of array section. */
16741 gfc_get_section_index (ar
, section_index
, &offset
);
16746 gcc_unreachable ();
16749 if (!gfc_array_size (e
, &size
))
16751 gfc_error ("Nonconstant array section at %L in DATA statement",
16753 mpz_clear (offset
);
16760 while (mpz_cmp_ui (size
, 0) > 0)
16762 if (!next_data_value ())
16764 gfc_error ("DATA statement at %L has more variables than values",
16770 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
16774 /* If we have more than one element left in the repeat count,
16775 and we have more than one element left in the target variable,
16776 then create a range assignment. */
16777 /* FIXME: Only done for full arrays for now, since array sections
16779 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
16780 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
16784 if (mpz_cmp (size
, values
.left
) >= 0)
16786 mpz_init_set (range
, values
.left
);
16787 mpz_sub (size
, size
, values
.left
);
16788 mpz_set_ui (values
.left
, 0);
16792 mpz_init_set (range
, size
);
16793 mpz_sub (values
.left
, values
.left
, size
);
16794 mpz_set_ui (size
, 0);
16797 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16800 mpz_add (offset
, offset
, range
);
16807 /* Assign initial value to symbol. */
16810 mpz_sub_ui (values
.left
, values
.left
, 1);
16811 mpz_sub_ui (size
, size
, 1);
16813 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16818 if (mark
== AR_FULL
)
16819 mpz_add_ui (offset
, offset
, 1);
16821 /* Modify the array section indexes and recalculate the offset
16822 for next element. */
16823 else if (mark
== AR_SECTION
)
16824 gfc_advance_section (section_index
, ar
, &offset
);
16828 if (mark
== AR_SECTION
)
16830 for (i
= 0; i
< ar
->dimen
; i
++)
16831 mpz_clear (section_index
[i
]);
16835 mpz_clear (offset
);
16841 static bool traverse_data_var (gfc_data_variable
*, locus
*);
16843 /* Iterate over a list of elements in a DATA statement. */
16846 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
16849 iterator_stack frame
;
16850 gfc_expr
*e
, *start
, *end
, *step
;
16851 bool retval
= true;
16853 mpz_init (frame
.value
);
16856 start
= gfc_copy_expr (var
->iter
.start
);
16857 end
= gfc_copy_expr (var
->iter
.end
);
16858 step
= gfc_copy_expr (var
->iter
.step
);
16860 if (!gfc_simplify_expr (start
, 1)
16861 || start
->expr_type
!= EXPR_CONSTANT
)
16863 gfc_error ("start of implied-do loop at %L could not be "
16864 "simplified to a constant value", &start
->where
);
16868 if (!gfc_simplify_expr (end
, 1)
16869 || end
->expr_type
!= EXPR_CONSTANT
)
16871 gfc_error ("end of implied-do loop at %L could not be "
16872 "simplified to a constant value", &end
->where
);
16876 if (!gfc_simplify_expr (step
, 1)
16877 || step
->expr_type
!= EXPR_CONSTANT
)
16879 gfc_error ("step of implied-do loop at %L could not be "
16880 "simplified to a constant value", &step
->where
);
16884 if (mpz_cmp_si (step
->value
.integer
, 0) == 0)
16886 gfc_error ("step of implied-do loop at %L shall not be zero",
16892 mpz_set (trip
, end
->value
.integer
);
16893 mpz_sub (trip
, trip
, start
->value
.integer
);
16894 mpz_add (trip
, trip
, step
->value
.integer
);
16896 mpz_div (trip
, trip
, step
->value
.integer
);
16898 mpz_set (frame
.value
, start
->value
.integer
);
16900 frame
.prev
= iter_stack
;
16901 frame
.variable
= var
->iter
.var
->symtree
;
16902 iter_stack
= &frame
;
16904 while (mpz_cmp_ui (trip
, 0) > 0)
16906 if (!traverse_data_var (var
->list
, where
))
16912 e
= gfc_copy_expr (var
->expr
);
16913 if (!gfc_simplify_expr (e
, 1))
16920 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
16922 mpz_sub_ui (trip
, trip
, 1);
16926 mpz_clear (frame
.value
);
16929 gfc_free_expr (start
);
16930 gfc_free_expr (end
);
16931 gfc_free_expr (step
);
16933 iter_stack
= frame
.prev
;
16938 /* Type resolve variables in the variable list of a DATA statement. */
16941 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
16945 for (; var
; var
= var
->next
)
16947 if (var
->expr
== NULL
)
16948 t
= traverse_data_list (var
, where
);
16950 t
= check_data_variable (var
, where
);
16960 /* Resolve the expressions and iterators associated with a data statement.
16961 This is separate from the assignment checking because data lists should
16962 only be resolved once. */
16965 resolve_data_variables (gfc_data_variable
*d
)
16967 for (; d
; d
= d
->next
)
16969 if (d
->list
== NULL
)
16971 if (!gfc_resolve_expr (d
->expr
))
16976 if (!gfc_resolve_iterator (&d
->iter
, false, true))
16979 if (!resolve_data_variables (d
->list
))
16988 /* Resolve a single DATA statement. We implement this by storing a pointer to
16989 the value list into static variables, and then recursively traversing the
16990 variables list, expanding iterators and such. */
16993 resolve_data (gfc_data
*d
)
16996 if (!resolve_data_variables (d
->var
))
16999 values
.vnode
= d
->value
;
17000 if (d
->value
== NULL
)
17001 mpz_set_ui (values
.left
, 0);
17003 mpz_set (values
.left
, d
->value
->repeat
);
17005 if (!traverse_data_var (d
->var
, &d
->where
))
17008 /* At this point, we better not have any values left. */
17010 if (next_data_value ())
17011 gfc_error ("DATA statement at %L has more values than variables",
17016 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
17017 accessed by host or use association, is a dummy argument to a pure function,
17018 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
17019 is storage associated with any such variable, shall not be used in the
17020 following contexts: (clients of this function). */
17022 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
17023 procedure. Returns zero if assignment is OK, nonzero if there is a
17026 gfc_impure_variable (gfc_symbol
*sym
)
17031 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
17034 /* Check if the symbol's ns is inside the pure procedure. */
17035 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
17039 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
17043 proc
= sym
->ns
->proc_name
;
17044 if (sym
->attr
.dummy
17045 && !sym
->attr
.value
17046 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
17047 || proc
->attr
.function
))
17050 /* TODO: Sort out what can be storage associated, if anything, and include
17051 it here. In principle equivalences should be scanned but it does not
17052 seem to be possible to storage associate an impure variable this way. */
17057 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
17058 current namespace is inside a pure procedure. */
17061 gfc_pure (gfc_symbol
*sym
)
17063 symbol_attribute attr
;
17068 /* Check if the current namespace or one of its parents
17069 belongs to a pure procedure. */
17070 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
17072 sym
= ns
->proc_name
;
17076 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
17084 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
17088 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
17089 checks if the current namespace is implicitly pure. Note that this
17090 function returns false for a PURE procedure. */
17093 gfc_implicit_pure (gfc_symbol
*sym
)
17099 /* Check if the current procedure is implicit_pure. Walk up
17100 the procedure list until we find a procedure. */
17101 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
17103 sym
= ns
->proc_name
;
17107 if (sym
->attr
.flavor
== FL_PROCEDURE
)
17112 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
17113 && !sym
->attr
.pure
;
17118 gfc_unset_implicit_pure (gfc_symbol
*sym
)
17124 /* Check if the current procedure is implicit_pure. Walk up
17125 the procedure list until we find a procedure. */
17126 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
17128 sym
= ns
->proc_name
;
17132 if (sym
->attr
.flavor
== FL_PROCEDURE
)
17137 if (sym
->attr
.flavor
== FL_PROCEDURE
)
17138 sym
->attr
.implicit_pure
= 0;
17140 sym
->attr
.pure
= 0;
17144 /* Test whether the current procedure is elemental or not. */
17147 gfc_elemental (gfc_symbol
*sym
)
17149 symbol_attribute attr
;
17152 sym
= gfc_current_ns
->proc_name
;
17157 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
17161 /* Warn about unused labels. */
17164 warn_unused_fortran_label (gfc_st_label
*label
)
17169 warn_unused_fortran_label (label
->left
);
17171 if (label
->defined
== ST_LABEL_UNKNOWN
)
17174 switch (label
->referenced
)
17176 case ST_LABEL_UNKNOWN
:
17177 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
17178 label
->value
, &label
->where
);
17181 case ST_LABEL_BAD_TARGET
:
17182 gfc_warning (OPT_Wunused_label
,
17183 "Label %d at %L defined but cannot be used",
17184 label
->value
, &label
->where
);
17191 warn_unused_fortran_label (label
->right
);
17195 /* Returns the sequence type of a symbol or sequence. */
17198 sequence_type (gfc_typespec ts
)
17207 if (ts
.u
.derived
->components
== NULL
)
17208 return SEQ_NONDEFAULT
;
17210 result
= sequence_type (ts
.u
.derived
->components
->ts
);
17211 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
17212 if (sequence_type (c
->ts
) != result
)
17218 if (ts
.kind
!= gfc_default_character_kind
)
17219 return SEQ_NONDEFAULT
;
17221 return SEQ_CHARACTER
;
17224 if (ts
.kind
!= gfc_default_integer_kind
)
17225 return SEQ_NONDEFAULT
;
17227 return SEQ_NUMERIC
;
17230 if (!(ts
.kind
== gfc_default_real_kind
17231 || ts
.kind
== gfc_default_double_kind
))
17232 return SEQ_NONDEFAULT
;
17234 return SEQ_NUMERIC
;
17237 if (ts
.kind
!= gfc_default_complex_kind
)
17238 return SEQ_NONDEFAULT
;
17240 return SEQ_NUMERIC
;
17243 if (ts
.kind
!= gfc_default_logical_kind
)
17244 return SEQ_NONDEFAULT
;
17246 return SEQ_NUMERIC
;
17249 return SEQ_NONDEFAULT
;
17254 /* Resolve derived type EQUIVALENCE object. */
17257 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
17259 gfc_component
*c
= derived
->components
;
17264 /* Shall not be an object of nonsequence derived type. */
17265 if (!derived
->attr
.sequence
)
17267 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
17268 "attribute to be an EQUIVALENCE object", sym
->name
,
17273 /* Shall not have allocatable components. */
17274 if (derived
->attr
.alloc_comp
)
17276 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
17277 "components to be an EQUIVALENCE object",sym
->name
,
17282 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
17284 gfc_error ("Derived type variable %qs at %L with default "
17285 "initialization cannot be in EQUIVALENCE with a variable "
17286 "in COMMON", sym
->name
, &e
->where
);
17290 for (; c
; c
= c
->next
)
17292 if (gfc_bt_struct (c
->ts
.type
)
17293 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
17296 /* Shall not be an object of sequence derived type containing a pointer
17297 in the structure. */
17298 if (c
->attr
.pointer
)
17300 gfc_error ("Derived type variable %qs at %L with pointer "
17301 "component(s) cannot be an EQUIVALENCE object",
17302 sym
->name
, &e
->where
);
17310 /* Resolve equivalence object.
17311 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
17312 an allocatable array, an object of nonsequence derived type, an object of
17313 sequence derived type containing a pointer at any level of component
17314 selection, an automatic object, a function name, an entry name, a result
17315 name, a named constant, a structure component, or a subobject of any of
17316 the preceding objects. A substring shall not have length zero. A
17317 derived type shall not have components with default initialization nor
17318 shall two objects of an equivalence group be initialized.
17319 Either all or none of the objects shall have an protected attribute.
17320 The simple constraints are done in symbol.cc(check_conflict) and the rest
17321 are implemented here. */
17324 resolve_equivalence (gfc_equiv
*eq
)
17327 gfc_symbol
*first_sym
;
17330 locus
*last_where
= NULL
;
17331 seq_type eq_type
, last_eq_type
;
17332 gfc_typespec
*last_ts
;
17333 int object
, cnt_protected
;
17336 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
17338 first_sym
= eq
->expr
->symtree
->n
.sym
;
17342 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
17346 e
->ts
= e
->symtree
->n
.sym
->ts
;
17347 /* match_varspec might not know yet if it is seeing
17348 array reference or substring reference, as it doesn't
17350 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
17352 gfc_ref
*ref
= e
->ref
;
17353 sym
= e
->symtree
->n
.sym
;
17355 if (sym
->attr
.dimension
)
17357 ref
->u
.ar
.as
= sym
->as
;
17361 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
17362 if (e
->ts
.type
== BT_CHARACTER
17364 && ref
->type
== REF_ARRAY
17365 && ref
->u
.ar
.dimen
== 1
17366 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
17367 && ref
->u
.ar
.stride
[0] == NULL
)
17369 gfc_expr
*start
= ref
->u
.ar
.start
[0];
17370 gfc_expr
*end
= ref
->u
.ar
.end
[0];
17373 /* Optimize away the (:) reference. */
17374 if (start
== NULL
&& end
== NULL
)
17377 e
->ref
= ref
->next
;
17379 e
->ref
->next
= ref
->next
;
17384 ref
->type
= REF_SUBSTRING
;
17386 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
17388 ref
->u
.ss
.start
= start
;
17389 if (end
== NULL
&& e
->ts
.u
.cl
)
17390 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
17391 ref
->u
.ss
.end
= end
;
17392 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
17399 /* Any further ref is an error. */
17402 gcc_assert (ref
->type
== REF_ARRAY
);
17403 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
17409 if (!gfc_resolve_expr (e
))
17412 sym
= e
->symtree
->n
.sym
;
17414 if (sym
->attr
.is_protected
)
17416 if (cnt_protected
> 0 && cnt_protected
!= object
)
17418 gfc_error ("Either all or none of the objects in the "
17419 "EQUIVALENCE set at %L shall have the "
17420 "PROTECTED attribute",
17425 /* Shall not equivalence common block variables in a PURE procedure. */
17426 if (sym
->ns
->proc_name
17427 && sym
->ns
->proc_name
->attr
.pure
17428 && sym
->attr
.in_common
)
17430 /* Need to check for symbols that may have entered the pure
17431 procedure via a USE statement. */
17432 bool saw_sym
= false;
17433 if (sym
->ns
->use_stmts
)
17436 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
17437 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
17443 gfc_error ("COMMON block member %qs at %L cannot be an "
17444 "EQUIVALENCE object in the pure procedure %qs",
17445 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
17449 /* Shall not be a named constant. */
17450 if (e
->expr_type
== EXPR_CONSTANT
)
17452 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
17453 "object", sym
->name
, &e
->where
);
17457 if (e
->ts
.type
== BT_DERIVED
17458 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
17461 /* Check that the types correspond correctly:
17463 A numeric sequence structure may be equivalenced to another sequence
17464 structure, an object of default integer type, default real type, double
17465 precision real type, default logical type such that components of the
17466 structure ultimately only become associated to objects of the same
17467 kind. A character sequence structure may be equivalenced to an object
17468 of default character kind or another character sequence structure.
17469 Other objects may be equivalenced only to objects of the same type and
17470 kind parameters. */
17472 /* Identical types are unconditionally OK. */
17473 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
17474 goto identical_types
;
17476 last_eq_type
= sequence_type (*last_ts
);
17477 eq_type
= sequence_type (sym
->ts
);
17479 /* Since the pair of objects is not of the same type, mixed or
17480 non-default sequences can be rejected. */
17482 msg
= "Sequence %s with mixed components in EQUIVALENCE "
17483 "statement at %L with different type objects";
17485 && last_eq_type
== SEQ_MIXED
17487 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
17488 || (eq_type
== SEQ_MIXED
17489 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
17492 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
17493 "statement at %L with objects of different type";
17495 && last_eq_type
== SEQ_NONDEFAULT
17497 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
17498 || (eq_type
== SEQ_NONDEFAULT
17499 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
17502 msg
="Non-CHARACTER object %qs in default CHARACTER "
17503 "EQUIVALENCE statement at %L";
17504 if (last_eq_type
== SEQ_CHARACTER
17505 && eq_type
!= SEQ_CHARACTER
17506 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
17509 msg
="Non-NUMERIC object %qs in default NUMERIC "
17510 "EQUIVALENCE statement at %L";
17511 if (last_eq_type
== SEQ_NUMERIC
17512 && eq_type
!= SEQ_NUMERIC
17513 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
17519 last_where
= &e
->where
;
17524 /* Shall not be an automatic array. */
17525 if (e
->ref
->type
== REF_ARRAY
&& is_non_constant_shape_array (sym
))
17527 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
17528 "an EQUIVALENCE object", sym
->name
, &e
->where
);
17535 /* Shall not be a structure component. */
17536 if (r
->type
== REF_COMPONENT
)
17538 gfc_error ("Structure component %qs at %L cannot be an "
17539 "EQUIVALENCE object",
17540 r
->u
.c
.component
->name
, &e
->where
);
17544 /* A substring shall not have length zero. */
17545 if (r
->type
== REF_SUBSTRING
)
17547 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
17549 gfc_error ("Substring at %L has length zero",
17550 &r
->u
.ss
.start
->where
);
17560 /* Function called by resolve_fntype to flag other symbols used in the
17561 length type parameter specification of function results. */
17564 flag_fn_result_spec (gfc_expr
*expr
,
17566 int *f ATTRIBUTE_UNUSED
)
17571 if (expr
->expr_type
== EXPR_VARIABLE
)
17573 s
= expr
->symtree
->n
.sym
;
17574 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
17580 gfc_error ("Self reference in character length expression "
17581 "for %qs at %L", sym
->name
, &expr
->where
);
17585 if (!s
->fn_result_spec
17586 && s
->attr
.flavor
== FL_PARAMETER
)
17588 /* Function contained in a module.... */
17589 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
17592 s
->fn_result_spec
= 1;
17593 /* Make sure that this symbol is translated as a module
17595 st
= gfc_get_unique_symtree (ns
);
17599 /* ... which is use associated and called. */
17600 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
17602 /* External function matched with an interface. */
17605 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
17606 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
17607 && s
->ns
->proc_name
->attr
.function
))
17608 s
->fn_result_spec
= 1;
17615 /* Resolve function and ENTRY types, issue diagnostics if needed. */
17618 resolve_fntype (gfc_namespace
*ns
)
17620 gfc_entry_list
*el
;
17623 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
17626 /* If there are any entries, ns->proc_name is the entry master
17627 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
17629 sym
= ns
->entries
->sym
;
17631 sym
= ns
->proc_name
;
17632 if (sym
->result
== sym
17633 && sym
->ts
.type
== BT_UNKNOWN
17634 && !gfc_set_default_type (sym
, 0, NULL
)
17635 && !sym
->attr
.untyped
)
17637 gfc_error ("Function %qs at %L has no IMPLICIT type",
17638 sym
->name
, &sym
->declared_at
);
17639 sym
->attr
.untyped
= 1;
17642 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
17643 && !sym
->attr
.contained
17644 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
17645 && gfc_check_symbol_access (sym
))
17647 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
17648 "%L of PRIVATE type %qs", sym
->name
,
17649 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
17653 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
17655 if (el
->sym
->result
== el
->sym
17656 && el
->sym
->ts
.type
== BT_UNKNOWN
17657 && !gfc_set_default_type (el
->sym
, 0, NULL
)
17658 && !el
->sym
->attr
.untyped
)
17660 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
17661 el
->sym
->name
, &el
->sym
->declared_at
);
17662 el
->sym
->attr
.untyped
= 1;
17666 if (sym
->ts
.type
== BT_CHARACTER
17667 && sym
->ts
.u
.cl
->length
17668 && sym
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
17669 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
17673 /* 12.3.2.1.1 Defined operators. */
17676 check_uop_procedure (gfc_symbol
*sym
, locus where
)
17678 gfc_formal_arglist
*formal
;
17680 if (!sym
->attr
.function
)
17682 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
17683 sym
->name
, &where
);
17687 if (sym
->ts
.type
== BT_CHARACTER
17688 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
17689 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
17690 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
17692 gfc_error ("User operator procedure %qs at %L cannot be assumed "
17693 "character length", sym
->name
, &where
);
17697 formal
= gfc_sym_get_dummy_args (sym
);
17698 if (!formal
|| !formal
->sym
)
17700 gfc_error ("User operator procedure %qs at %L must have at least "
17701 "one argument", sym
->name
, &where
);
17705 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
17707 gfc_error ("First argument of operator interface at %L must be "
17708 "INTENT(IN)", &where
);
17712 if (formal
->sym
->attr
.optional
)
17714 gfc_error ("First argument of operator interface at %L cannot be "
17715 "optional", &where
);
17719 formal
= formal
->next
;
17720 if (!formal
|| !formal
->sym
)
17723 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
17725 gfc_error ("Second argument of operator interface at %L must be "
17726 "INTENT(IN)", &where
);
17730 if (formal
->sym
->attr
.optional
)
17732 gfc_error ("Second argument of operator interface at %L cannot be "
17733 "optional", &where
);
17739 gfc_error ("Operator interface at %L must have, at most, two "
17740 "arguments", &where
);
17748 gfc_resolve_uops (gfc_symtree
*symtree
)
17750 gfc_interface
*itr
;
17752 if (symtree
== NULL
)
17755 gfc_resolve_uops (symtree
->left
);
17756 gfc_resolve_uops (symtree
->right
);
17758 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
17759 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
17763 /* Examine all of the expressions associated with a program unit,
17764 assign types to all intermediate expressions, make sure that all
17765 assignments are to compatible types and figure out which names
17766 refer to which functions or subroutines. It doesn't check code
17767 block, which is handled by gfc_resolve_code. */
17770 resolve_types (gfc_namespace
*ns
)
17776 gfc_namespace
* old_ns
= gfc_current_ns
;
17777 bool recursive
= ns
->proc_name
&& ns
->proc_name
->attr
.recursive
;
17779 if (ns
->types_resolved
)
17782 /* Check that all IMPLICIT types are ok. */
17783 if (!ns
->seen_implicit_none
)
17786 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
17787 if (ns
->set_flag
[letter
]
17788 && !resolve_typespec_used (&ns
->default_type
[letter
],
17789 &ns
->implicit_loc
[letter
], NULL
))
17793 gfc_current_ns
= ns
;
17795 resolve_entries (ns
);
17797 resolve_common_vars (&ns
->blank_common
, false);
17798 resolve_common_blocks (ns
->common_root
);
17800 resolve_contained_functions (ns
);
17802 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
17803 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
17804 gfc_resolve_formal_arglist (ns
->proc_name
);
17806 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
17808 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
17809 resolve_charlen (cl
);
17811 gfc_traverse_ns (ns
, resolve_symbol
);
17813 resolve_fntype (ns
);
17815 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17817 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
17818 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
17819 "also be PURE", n
->proc_name
->name
,
17820 &n
->proc_name
->declared_at
);
17826 gfc_do_concurrent_flag
= 0;
17827 gfc_check_interfaces (ns
);
17829 gfc_traverse_ns (ns
, resolve_values
);
17831 if (ns
->save_all
|| (!flag_automatic
&& !recursive
))
17835 for (d
= ns
->data
; d
; d
= d
->next
)
17839 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
17841 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
17843 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
17844 resolve_equivalence (eq
);
17846 /* Warn about unused labels. */
17847 if (warn_unused_label
)
17848 warn_unused_fortran_label (ns
->st_labels
);
17850 gfc_resolve_uops (ns
->uop_root
);
17852 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
17854 gfc_resolve_omp_declare_simd (ns
);
17856 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
17858 ns
->types_resolved
= 1;
17860 gfc_current_ns
= old_ns
;
17864 /* Call gfc_resolve_code recursively. */
17867 resolve_codes (gfc_namespace
*ns
)
17870 bitmap_obstack old_obstack
;
17872 if (ns
->resolved
== 1)
17875 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17878 gfc_current_ns
= ns
;
17880 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
17881 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
17884 /* Set to an out of range value. */
17885 current_entry_id
= -1;
17887 old_obstack
= labels_obstack
;
17888 bitmap_obstack_initialize (&labels_obstack
);
17890 gfc_resolve_oacc_declare (ns
);
17891 gfc_resolve_oacc_routines (ns
);
17892 gfc_resolve_omp_local_vars (ns
);
17893 gfc_resolve_code (ns
->code
, ns
);
17895 bitmap_obstack_release (&labels_obstack
);
17896 labels_obstack
= old_obstack
;
17900 /* This function is called after a complete program unit has been compiled.
17901 Its purpose is to examine all of the expressions associated with a program
17902 unit, assign types to all intermediate expressions, make sure that all
17903 assignments are to compatible types and figure out which names refer to
17904 which functions or subroutines. */
17907 gfc_resolve (gfc_namespace
*ns
)
17909 gfc_namespace
*old_ns
;
17910 code_stack
*old_cs_base
;
17911 struct gfc_omp_saved_state old_omp_state
;
17917 old_ns
= gfc_current_ns
;
17918 old_cs_base
= cs_base
;
17920 /* As gfc_resolve can be called during resolution of an OpenMP construct
17921 body, we should clear any state associated to it, so that say NS's
17922 DO loops are not interpreted as OpenMP loops. */
17923 if (!ns
->construct_entities
)
17924 gfc_omp_save_and_clear_state (&old_omp_state
);
17926 resolve_types (ns
);
17927 component_assignment_level
= 0;
17928 resolve_codes (ns
);
17930 if (ns
->omp_assumes
)
17931 gfc_resolve_omp_assumptions (ns
->omp_assumes
);
17933 gfc_current_ns
= old_ns
;
17934 cs_base
= old_cs_base
;
17937 gfc_run_passes (ns
);
17939 if (!ns
->construct_entities
)
17940 gfc_omp_restore_state (&old_omp_state
);