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 /* Provide sufficient space to hold "master.%d.%s". */
706 char name
[GFC_MAX_SYMBOL_LEN
+ 1 + 18];
707 static int master_count
= 0;
709 if (ns
->proc_name
== NULL
)
712 /* No need to do anything if this procedure doesn't have alternate entry
717 /* We may already have resolved alternate entry points. */
718 if (ns
->proc_name
->attr
.entry_master
)
721 /* If this isn't a procedure something has gone horribly wrong. */
722 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
724 /* Remember the current namespace. */
725 old_ns
= gfc_current_ns
;
729 /* Add the main entry point to the list of entry points. */
730 el
= gfc_get_entry_list ();
731 el
->sym
= ns
->proc_name
;
733 el
->next
= ns
->entries
;
735 ns
->proc_name
->attr
.entry
= 1;
737 /* If it is a module function, it needs to be in the right namespace
738 so that gfc_get_fake_result_decl can gather up the results. The
739 need for this arose in get_proc_name, where these beasts were
740 left in their own namespace, to keep prior references linked to
741 the entry declaration.*/
742 if (ns
->proc_name
->attr
.function
743 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
746 /* Do the same for entries where the master is not a module
747 procedure. These are retained in the module namespace because
748 of the module procedure declaration. */
749 for (el
= el
->next
; el
; el
= el
->next
)
750 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
751 && el
->sym
->attr
.mod_proc
)
755 /* Add an entry statement for it. */
756 c
= gfc_get_code (EXEC_ENTRY
);
761 /* Create a new symbol for the master function. */
762 /* Give the internal function a unique name (within this file).
763 Also include the function name so the user has some hope of figuring
764 out what is going on. */
765 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
766 master_count
++, ns
->proc_name
->name
);
767 gfc_get_ha_symbol (name
, &proc
);
768 gcc_assert (proc
!= NULL
);
770 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
771 if (ns
->proc_name
->attr
.subroutine
)
772 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
776 gfc_typespec
*ts
, *fts
;
777 gfc_array_spec
*as
, *fas
;
778 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
780 fas
= ns
->entries
->sym
->as
;
781 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
782 fts
= &ns
->entries
->sym
->result
->ts
;
783 if (fts
->type
== BT_UNKNOWN
)
784 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
785 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
787 ts
= &el
->sym
->result
->ts
;
789 as
= as
? as
: el
->sym
->result
->as
;
790 if (ts
->type
== BT_UNKNOWN
)
791 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
793 if (! gfc_compare_types (ts
, fts
)
794 || (el
->sym
->result
->attr
.dimension
795 != ns
->entries
->sym
->result
->attr
.dimension
)
796 || (el
->sym
->result
->attr
.pointer
797 != ns
->entries
->sym
->result
->attr
.pointer
))
799 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
800 && gfc_compare_array_spec (as
, fas
) == 0)
801 gfc_error ("Function %s at %L has entries with mismatched "
802 "array specifications", ns
->entries
->sym
->name
,
803 &ns
->entries
->sym
->declared_at
);
804 /* The characteristics need to match and thus both need to have
805 the same string length, i.e. both len=*, or both len=4.
806 Having both len=<variable> is also possible, but difficult to
807 check at compile time. */
808 else if (ts
->type
== BT_CHARACTER
809 && (el
->sym
->result
->attr
.allocatable
810 != ns
->entries
->sym
->result
->attr
.allocatable
))
812 gfc_error ("Function %s at %L has entry %s with mismatched "
813 "characteristics", ns
->entries
->sym
->name
,
814 &ns
->entries
->sym
->declared_at
, el
->sym
->name
);
817 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
818 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
819 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
821 && ts
->u
.cl
->length
->expr_type
822 != fts
->u
.cl
->length
->expr_type
)
824 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
825 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
826 fts
->u
.cl
->length
->value
.integer
) != 0)))
827 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
828 "entries returning variables of different "
829 "string lengths", ns
->entries
->sym
->name
,
830 &ns
->entries
->sym
->declared_at
);
831 else if (el
->sym
->result
->attr
.allocatable
832 != ns
->entries
->sym
->result
->attr
.allocatable
)
838 sym
= ns
->entries
->sym
->result
;
839 /* All result types the same. */
841 if (sym
->attr
.dimension
)
842 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
843 if (sym
->attr
.pointer
)
844 gfc_add_pointer (&proc
->attr
, NULL
);
845 if (sym
->attr
.allocatable
)
846 gfc_add_allocatable (&proc
->attr
, NULL
);
850 /* Otherwise the result will be passed through a union by
852 proc
->attr
.mixed_entry_master
= 1;
853 for (el
= ns
->entries
; el
; el
= el
->next
)
855 sym
= el
->sym
->result
;
856 if (sym
->attr
.dimension
)
858 if (el
== ns
->entries
)
859 gfc_error ("FUNCTION result %s cannot be an array in "
860 "FUNCTION %s at %L", sym
->name
,
861 ns
->entries
->sym
->name
, &sym
->declared_at
);
863 gfc_error ("ENTRY result %s cannot be an array in "
864 "FUNCTION %s at %L", sym
->name
,
865 ns
->entries
->sym
->name
, &sym
->declared_at
);
867 else if (sym
->attr
.pointer
)
869 if (el
== ns
->entries
)
870 gfc_error ("FUNCTION result %s cannot be a POINTER in "
871 "FUNCTION %s at %L", sym
->name
,
872 ns
->entries
->sym
->name
, &sym
->declared_at
);
874 gfc_error ("ENTRY result %s cannot be a POINTER in "
875 "FUNCTION %s at %L", sym
->name
,
876 ns
->entries
->sym
->name
, &sym
->declared_at
);
878 else if (sym
->attr
.allocatable
)
880 if (el
== ns
->entries
)
881 gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
882 "FUNCTION %s at %L", sym
->name
,
883 ns
->entries
->sym
->name
, &sym
->declared_at
);
885 gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
886 "FUNCTION %s at %L", sym
->name
,
887 ns
->entries
->sym
->name
, &sym
->declared_at
);
892 if (ts
->type
== BT_UNKNOWN
)
893 ts
= gfc_get_default_type (sym
->name
, NULL
);
897 if (ts
->kind
== gfc_default_integer_kind
)
901 if (ts
->kind
== gfc_default_real_kind
902 || ts
->kind
== gfc_default_double_kind
)
906 if (ts
->kind
== gfc_default_complex_kind
)
910 if (ts
->kind
== gfc_default_logical_kind
)
914 /* We will issue error elsewhere. */
922 if (el
== ns
->entries
)
923 gfc_error ("FUNCTION result %s cannot be of type %s "
924 "in FUNCTION %s at %L", sym
->name
,
925 gfc_typename (ts
), ns
->entries
->sym
->name
,
928 gfc_error ("ENTRY result %s cannot be of type %s "
929 "in FUNCTION %s at %L", sym
->name
,
930 gfc_typename (ts
), ns
->entries
->sym
->name
,
939 proc
->attr
.access
= ACCESS_PRIVATE
;
940 proc
->attr
.entry_master
= 1;
942 /* Merge all the entry point arguments. */
943 for (el
= ns
->entries
; el
; el
= el
->next
)
944 merge_argument_lists (proc
, el
->sym
->formal
);
946 /* Check the master formal arguments for any that are not
947 present in all entry points. */
948 for (el
= ns
->entries
; el
; el
= el
->next
)
949 check_argument_lists (proc
, el
->sym
->formal
);
951 /* Use the master function for the function body. */
952 ns
->proc_name
= proc
;
954 /* Finalize the new symbols. */
955 gfc_commit_symbols ();
957 /* Restore the original namespace. */
958 gfc_current_ns
= old_ns
;
962 /* Forward declaration. */
963 static bool is_non_constant_shape_array (gfc_symbol
*sym
);
966 /* Resolve common variables. */
968 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
970 gfc_symbol
*csym
= common_block
->head
;
973 for (; csym
; csym
= csym
->common_next
)
975 gsym
= gfc_find_gsymbol (gfc_gsym_root
, csym
->name
);
976 if (gsym
&& (gsym
->type
== GSYM_MODULE
|| gsym
->type
== GSYM_PROGRAM
))
978 if (csym
->common_block
)
979 gfc_error_now ("Global entity %qs at %L cannot appear in a "
980 "COMMON block at %L", gsym
->name
,
981 &gsym
->where
, &csym
->common_block
->where
);
983 gfc_error_now ("Global entity %qs at %L cannot appear in a "
984 "COMMON block", gsym
->name
, &gsym
->where
);
987 /* gfc_add_in_common may have been called before, but the reported errors
988 have been ignored to continue parsing.
989 We do the checks again here, unless the symbol is USE associated. */
990 if (!csym
->attr
.use_assoc
&& !csym
->attr
.used_in_submodule
)
992 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
993 gfc_notify_std (GFC_STD_F2018_OBS
, "COMMON block at %L",
994 &common_block
->where
);
997 if (csym
->value
|| csym
->attr
.data
)
999 if (!csym
->ns
->is_block_data
)
1000 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
1001 "but only in BLOCK DATA initialization is "
1002 "allowed", csym
->name
, &csym
->declared_at
);
1003 else if (!named_common
)
1004 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
1005 "in a blank COMMON but initialization is only "
1006 "allowed in named common blocks", csym
->name
,
1007 &csym
->declared_at
);
1010 if (UNLIMITED_POLY (csym
))
1011 gfc_error_now ("%qs at %L cannot appear in COMMON "
1012 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
1014 if (csym
->attr
.dimension
&& is_non_constant_shape_array (csym
))
1016 gfc_error_now ("Automatic object %qs at %L cannot appear in "
1017 "COMMON at %L", csym
->name
, &csym
->declared_at
,
1018 &common_block
->where
);
1019 /* Avoid confusing follow-on error. */
1023 if (csym
->ts
.type
!= BT_DERIVED
)
1026 if (!(csym
->ts
.u
.derived
->attr
.sequence
1027 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
1028 gfc_error_now ("Derived type variable %qs in COMMON at %L "
1029 "has neither the SEQUENCE nor the BIND(C) "
1030 "attribute", csym
->name
, &csym
->declared_at
);
1031 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
1032 gfc_error_now ("Derived type variable %qs in COMMON at %L "
1033 "has an ultimate component that is "
1034 "allocatable", csym
->name
, &csym
->declared_at
);
1035 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
1036 gfc_error_now ("Derived type variable %qs in COMMON at %L "
1037 "may not have default initializer", csym
->name
,
1038 &csym
->declared_at
);
1040 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
1041 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
1045 /* Resolve common blocks. */
1047 resolve_common_blocks (gfc_symtree
*common_root
)
1052 if (common_root
== NULL
)
1055 if (common_root
->left
)
1056 resolve_common_blocks (common_root
->left
);
1057 if (common_root
->right
)
1058 resolve_common_blocks (common_root
->right
);
1060 resolve_common_vars (common_root
->n
.common
, true);
1062 /* The common name is a global name - in Fortran 2003 also if it has a
1063 C binding name, since Fortran 2008 only the C binding name is a global
1065 if (!common_root
->n
.common
->binding_label
1066 || gfc_notification_std (GFC_STD_F2008
))
1068 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1069 common_root
->n
.common
->name
);
1071 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1072 && gsym
->type
== GSYM_COMMON
1073 && ((common_root
->n
.common
->binding_label
1074 && (!gsym
->binding_label
1075 || strcmp (common_root
->n
.common
->binding_label
,
1076 gsym
->binding_label
) != 0))
1077 || (!common_root
->n
.common
->binding_label
1078 && gsym
->binding_label
)))
1080 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1081 "identifier and must thus have the same binding name "
1082 "as the same-named COMMON block at %L: %s vs %s",
1083 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1085 common_root
->n
.common
->binding_label
1086 ? common_root
->n
.common
->binding_label
: "(blank)",
1087 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1091 if (gsym
&& gsym
->type
!= GSYM_COMMON
1092 && !common_root
->n
.common
->binding_label
)
1094 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1096 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1100 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1102 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1103 "%L sharing the identifier with global non-COMMON-block "
1104 "entity at %L", common_root
->n
.common
->name
,
1105 &common_root
->n
.common
->where
, &gsym
->where
);
1110 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
, false);
1111 gsym
->type
= GSYM_COMMON
;
1112 gsym
->where
= common_root
->n
.common
->where
;
1118 if (common_root
->n
.common
->binding_label
)
1120 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1121 common_root
->n
.common
->binding_label
);
1122 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1124 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1125 "global identifier as entity at %L",
1126 &common_root
->n
.common
->where
,
1127 common_root
->n
.common
->binding_label
, &gsym
->where
);
1132 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
, true);
1133 gsym
->type
= GSYM_COMMON
;
1134 gsym
->where
= common_root
->n
.common
->where
;
1140 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1144 if (sym
->attr
.flavor
== FL_PARAMETER
)
1145 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1146 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1148 if (sym
->attr
.external
)
1149 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1150 sym
->name
, &common_root
->n
.common
->where
);
1152 if (sym
->attr
.intrinsic
)
1153 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1154 sym
->name
, &common_root
->n
.common
->where
);
1155 else if (sym
->attr
.result
1156 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1157 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1158 "that is also a function result", sym
->name
,
1159 &common_root
->n
.common
->where
);
1160 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1161 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1162 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1163 "that is also a global procedure", sym
->name
,
1164 &common_root
->n
.common
->where
);
1168 /* Resolve contained function types. Because contained functions can call one
1169 another, they have to be worked out before any of the contained procedures
1172 The good news is that if a function doesn't already have a type, the only
1173 way it can get one is through an IMPLICIT type or a RESULT variable, because
1174 by definition contained functions are contained namespace they're contained
1175 in, not in a sibling or parent namespace. */
1178 resolve_contained_functions (gfc_namespace
*ns
)
1180 gfc_namespace
*child
;
1183 resolve_formal_arglists (ns
);
1185 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1187 /* Resolve alternate entry points first. */
1188 resolve_entries (child
);
1190 /* Then check function return types. */
1191 resolve_contained_fntype (child
->proc_name
, child
);
1192 for (el
= child
->entries
; el
; el
= el
->next
)
1193 resolve_contained_fntype (el
->sym
, child
);
1199 /* A Parameterized Derived Type constructor must contain values for
1200 the PDT KIND parameters or they must have a default initializer.
1201 Go through the constructor picking out the KIND expressions,
1202 storing them in 'param_list' and then call gfc_get_pdt_instance
1203 to obtain the PDT instance. */
1205 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1208 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1210 param
= gfc_get_actual_arglist ();
1212 param_list
= param_tail
= param
;
1215 param_tail
->next
= param
;
1216 param_tail
= param_tail
->next
;
1219 param_tail
->name
= c
->name
;
1221 param_tail
->expr
= gfc_copy_expr (expr
);
1222 else if (c
->initializer
)
1223 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1226 param_tail
->spec_type
= SPEC_ASSUMED
;
1227 if (c
->attr
.pdt_kind
)
1229 gfc_error ("The KIND parameter %qs in the PDT constructor "
1230 "at %C has no value", param
->name
);
1239 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1240 gfc_symbol
*derived
)
1242 gfc_constructor
*cons
= NULL
;
1243 gfc_component
*comp
;
1246 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1247 cons
= gfc_constructor_first (expr
->value
.constructor
);
1252 comp
= derived
->components
;
1254 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1257 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1258 && comp
->ts
.type
== BT_DERIVED
)
1260 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1264 else if (comp
->ts
.type
== BT_DERIVED
)
1266 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1270 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1271 && derived
->attr
.pdt_template
)
1273 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1282 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1283 static bool resolve_fl_struct (gfc_symbol
*sym
);
1286 /* Resolve all of the elements of a structure constructor and make sure that
1287 the types are correct. The 'init' flag indicates that the given
1288 constructor is an initializer. */
1291 resolve_structure_cons (gfc_expr
*expr
, int init
)
1293 gfc_constructor
*cons
;
1294 gfc_component
*comp
;
1300 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1302 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1303 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1305 resolve_fl_struct (expr
->ts
.u
.derived
);
1307 /* If this is a Parameterized Derived Type template, find the
1308 instance corresponding to the PDT kind parameters. */
1309 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1312 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1315 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1317 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1320 gfc_free_actual_arglist (param_list
);
1322 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1327 /* A constructor may have references if it is the result of substituting a
1328 parameter variable. In this case we just pull out the component we
1331 comp
= expr
->ref
->u
.c
.sym
->components
;
1332 else if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
1333 || expr
->ts
.type
== BT_UNION
)
1334 && expr
->ts
.u
.derived
)
1335 comp
= expr
->ts
.u
.derived
->components
;
1339 cons
= gfc_constructor_first (expr
->value
.constructor
);
1341 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1348 /* Unions use an EXPR_NULL contrived expression to tell the translation
1349 phase to generate an initializer of the appropriate length.
1351 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1354 if (!gfc_resolve_expr (cons
->expr
))
1360 rank
= comp
->as
? comp
->as
->rank
: 0;
1361 if (comp
->ts
.type
== BT_CLASS
1362 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1363 && CLASS_DATA (comp
)->as
)
1364 rank
= CLASS_DATA (comp
)->as
->rank
;
1366 if (comp
->ts
.type
== BT_CLASS
&& cons
->expr
->ts
.type
!= BT_CLASS
)
1367 gfc_find_vtab (&cons
->expr
->ts
);
1369 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1370 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1372 gfc_error ("The rank of the element in the structure "
1373 "constructor at %L does not match that of the "
1374 "component (%d/%d)", &cons
->expr
->where
,
1375 cons
->expr
->rank
, rank
);
1379 /* If we don't have the right type, try to convert it. */
1381 if (!comp
->attr
.proc_pointer
&&
1382 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1384 if (strcmp (comp
->name
, "_extends") == 0)
1386 /* Can afford to be brutal with the _extends initializer.
1387 The derived type can get lost because it is PRIVATE
1388 but it is not usage constrained by the standard. */
1389 cons
->expr
->ts
= comp
->ts
;
1391 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1393 gfc_error ("The element in the structure constructor at %L, "
1394 "for pointer component %qs, is %s but should be %s",
1395 &cons
->expr
->where
, comp
->name
,
1396 gfc_basic_typename (cons
->expr
->ts
.type
),
1397 gfc_basic_typename (comp
->ts
.type
));
1400 else if (!UNLIMITED_POLY (comp
))
1402 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1408 /* For strings, the length of the constructor should be the same as
1409 the one of the structure, ensure this if the lengths are known at
1410 compile time and when we are dealing with PARAMETER or structure
1412 if (cons
->expr
->ts
.type
== BT_CHARACTER
1413 && comp
->ts
.type
== BT_CHARACTER
1414 && comp
->ts
.u
.cl
&& comp
->ts
.u
.cl
->length
1415 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1416 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1417 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1418 && cons
->expr
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
1419 && comp
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
1420 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1421 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1423 if (comp
->attr
.pointer
)
1425 HOST_WIDE_INT la
, lb
;
1426 la
= gfc_mpz_get_hwi (comp
->ts
.u
.cl
->length
->value
.integer
);
1427 lb
= gfc_mpz_get_hwi (cons
->expr
->ts
.u
.cl
->length
->value
.integer
);
1428 gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1429 "component %qs in constructor at %L",
1430 la
, lb
, comp
->name
, &cons
->expr
->where
);
1434 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1435 && cons
->expr
->rank
!= 0
1436 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1438 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1439 to make use of the gfc_resolve_character_array_constructor
1440 machinery. The expression is later simplified away to
1441 an array of string literals. */
1442 gfc_expr
*para
= cons
->expr
;
1443 cons
->expr
= gfc_get_expr ();
1444 cons
->expr
->ts
= para
->ts
;
1445 cons
->expr
->where
= para
->where
;
1446 cons
->expr
->expr_type
= EXPR_ARRAY
;
1447 cons
->expr
->rank
= para
->rank
;
1448 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1449 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1450 para
, &cons
->expr
->where
);
1453 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1455 /* Rely on the cleanup of the namespace to deal correctly with
1456 the old charlen. (There was a block here that attempted to
1457 remove the charlen but broke the chain in so doing.) */
1458 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1459 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1460 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1461 gfc_resolve_character_array_constructor (cons
->expr
);
1465 if (cons
->expr
->expr_type
== EXPR_NULL
1466 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1467 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1468 || (comp
->ts
.type
== BT_CLASS
1469 && (CLASS_DATA (comp
)->attr
.class_pointer
1470 || CLASS_DATA (comp
)->attr
.allocatable
))))
1473 gfc_error ("The NULL in the structure constructor at %L is "
1474 "being applied to component %qs, which is neither "
1475 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1479 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1481 /* Check procedure pointer interface. */
1482 gfc_symbol
*s2
= NULL
;
1487 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1490 s2
= c2
->ts
.interface
;
1493 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1495 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1496 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1498 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1500 s2
= cons
->expr
->symtree
->n
.sym
;
1501 name
= cons
->expr
->symtree
->n
.sym
->name
;
1504 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1505 err
, sizeof (err
), NULL
, NULL
))
1507 gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1508 "component %qs in structure constructor at %L:"
1509 " %s", comp
->name
, &cons
->expr
->where
, err
);
1514 /* Validate shape, except for dynamic or PDT arrays. */
1515 if (cons
->expr
->expr_type
== EXPR_ARRAY
&& rank
== cons
->expr
->rank
1516 && comp
->as
&& !comp
->attr
.allocatable
&& !comp
->attr
.pointer
1517 && !comp
->attr
.pdt_array
)
1521 for (int n
= 0; n
< rank
; n
++)
1523 if (comp
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
1524 || comp
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
)
1526 gfc_error ("Bad array spec of component %qs referenced in "
1527 "structure constructor at %L",
1528 comp
->name
, &cons
->expr
->where
);
1532 if (cons
->expr
->shape
== NULL
)
1534 mpz_set_ui (len
, 1);
1535 mpz_add (len
, len
, comp
->as
->upper
[n
]->value
.integer
);
1536 mpz_sub (len
, len
, comp
->as
->lower
[n
]->value
.integer
);
1537 if (mpz_cmp (cons
->expr
->shape
[n
], len
) != 0)
1539 gfc_error ("The shape of component %qs in the structure "
1540 "constructor at %L differs from the shape of the "
1541 "declared component for dimension %d (%ld/%ld)",
1542 comp
->name
, &cons
->expr
->where
, n
+1,
1543 mpz_get_si (cons
->expr
->shape
[n
]),
1551 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1552 || cons
->expr
->expr_type
== EXPR_NULL
)
1555 a
= gfc_expr_attr (cons
->expr
);
1557 if (!a
.pointer
&& !a
.target
)
1560 gfc_error ("The element in the structure constructor at %L, "
1561 "for pointer component %qs should be a POINTER or "
1562 "a TARGET", &cons
->expr
->where
, comp
->name
);
1567 /* F08:C461. Additional checks for pointer initialization. */
1571 gfc_error ("Pointer initialization target at %L "
1572 "must not be ALLOCATABLE", &cons
->expr
->where
);
1577 gfc_error ("Pointer initialization target at %L "
1578 "must have the SAVE attribute", &cons
->expr
->where
);
1582 /* F2003, C1272 (3). */
1583 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1584 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1585 || gfc_is_coindexed (cons
->expr
));
1586 if (impure
&& gfc_pure (NULL
))
1589 gfc_error ("Invalid expression in the structure constructor for "
1590 "pointer component %qs at %L in PURE procedure",
1591 comp
->name
, &cons
->expr
->where
);
1595 gfc_unset_implicit_pure (NULL
);
1602 /****************** Expression name resolution ******************/
1604 /* Returns 0 if a symbol was not declared with a type or
1605 attribute declaration statement, nonzero otherwise. */
1608 was_declared (gfc_symbol
*sym
)
1614 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1617 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1618 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1619 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1620 || a
.asynchronous
|| a
.codimension
)
1627 /* Determine if a symbol is generic or not. */
1630 generic_sym (gfc_symbol
*sym
)
1634 if (sym
->attr
.generic
||
1635 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1638 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1641 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1648 return generic_sym (s
);
1655 /* Determine if a symbol is specific or not. */
1658 specific_sym (gfc_symbol
*sym
)
1662 if (sym
->attr
.if_source
== IFSRC_IFBODY
1663 || sym
->attr
.proc
== PROC_MODULE
1664 || sym
->attr
.proc
== PROC_INTERNAL
1665 || sym
->attr
.proc
== PROC_ST_FUNCTION
1666 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1667 || sym
->attr
.external
)
1670 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1673 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1675 return (s
== NULL
) ? 0 : specific_sym (s
);
1679 /* Figure out if the procedure is specific, generic or unknown. */
1682 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1685 procedure_kind (gfc_symbol
*sym
)
1687 if (generic_sym (sym
))
1688 return PTYPE_GENERIC
;
1690 if (specific_sym (sym
))
1691 return PTYPE_SPECIFIC
;
1693 return PTYPE_UNKNOWN
;
1696 /* Check references to assumed size arrays. The flag need_full_assumed_size
1697 is nonzero when matching actual arguments. */
1699 static int need_full_assumed_size
= 0;
1702 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1704 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1707 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1708 What should it be? */
1711 && (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1712 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1713 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1715 gfc_error ("The upper bound in the last dimension must "
1716 "appear in the reference to the assumed size "
1717 "array %qs at %L", sym
->name
, &e
->where
);
1724 /* Look for bad assumed size array references in argument expressions
1725 of elemental and array valued intrinsic procedures. Since this is
1726 called from procedure resolution functions, it only recurses at
1730 resolve_assumed_size_actual (gfc_expr
*e
)
1735 switch (e
->expr_type
)
1738 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1743 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1744 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1755 /* Check a generic procedure, passed as an actual argument, to see if
1756 there is a matching specific name. If none, it is an error, and if
1757 more than one, the reference is ambiguous. */
1759 count_specific_procs (gfc_expr
*e
)
1766 sym
= e
->symtree
->n
.sym
;
1768 for (p
= sym
->generic
; p
; p
= p
->next
)
1769 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1771 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1777 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1781 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1782 "argument at %L", sym
->name
, &e
->where
);
1788 /* See if a call to sym could possibly be a not allowed RECURSION because of
1789 a missing RECURSIVE declaration. This means that either sym is the current
1790 context itself, or sym is the parent of a contained procedure calling its
1791 non-RECURSIVE containing procedure.
1792 This also works if sym is an ENTRY. */
1795 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1797 gfc_symbol
* proc_sym
;
1798 gfc_symbol
* context_proc
;
1799 gfc_namespace
* real_context
;
1801 if (sym
->attr
.flavor
== FL_PROGRAM
1802 || gfc_fl_struct (sym
->attr
.flavor
))
1805 /* If we've got an ENTRY, find real procedure. */
1806 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1807 proc_sym
= sym
->ns
->entries
->sym
;
1811 /* If sym is RECURSIVE, all is well of course. */
1812 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1815 /* Find the context procedure's "real" symbol if it has entries.
1816 We look for a procedure symbol, so recurse on the parents if we don't
1817 find one (like in case of a BLOCK construct). */
1818 for (real_context
= context
; ; real_context
= real_context
->parent
)
1820 /* We should find something, eventually! */
1821 gcc_assert (real_context
);
1823 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1824 : real_context
->proc_name
);
1826 /* In some special cases, there may not be a proc_name, like for this
1828 real(bad_kind()) function foo () ...
1829 when checking the call to bad_kind ().
1830 In these cases, we simply return here and assume that the
1835 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1839 /* A call from sym's body to itself is recursion, of course. */
1840 if (context_proc
== proc_sym
)
1843 /* The same is true if context is a contained procedure and sym the
1845 if (context_proc
->attr
.contained
)
1847 gfc_symbol
* parent_proc
;
1849 gcc_assert (context
->parent
);
1850 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1851 : context
->parent
->proc_name
);
1853 if (parent_proc
== proc_sym
)
1861 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1862 its typespec and formal argument list. */
1865 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1867 gfc_intrinsic_sym
* isym
= NULL
;
1870 if (sym
->resolve_symbol_called
>= 2)
1873 sym
->resolve_symbol_called
= 2;
1875 /* Already resolved. */
1876 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1879 /* We already know this one is an intrinsic, so we don't call
1880 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1881 gfc_find_subroutine directly to check whether it is a function or
1884 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1886 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1887 isym
= gfc_intrinsic_subroutine_by_id (id
);
1889 else if (sym
->intmod_sym_id
)
1891 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1892 isym
= gfc_intrinsic_function_by_id (id
);
1894 else if (!sym
->attr
.subroutine
)
1895 isym
= gfc_find_function (sym
->name
);
1897 if (isym
&& !sym
->attr
.subroutine
)
1899 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1900 && !sym
->attr
.implicit_type
)
1901 gfc_warning (OPT_Wsurprising
,
1902 "Type specified for intrinsic function %qs at %L is"
1903 " ignored", sym
->name
, &sym
->declared_at
);
1905 if (!sym
->attr
.function
&&
1906 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1911 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1913 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1915 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1916 " specifier", sym
->name
, &sym
->declared_at
);
1920 if (!sym
->attr
.subroutine
&&
1921 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1926 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1931 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1933 sym
->attr
.pure
= isym
->pure
;
1934 sym
->attr
.elemental
= isym
->elemental
;
1936 /* Check it is actually available in the standard settings. */
1937 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1939 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1940 "available in the current standard settings but %s. Use "
1941 "an appropriate %<-std=*%> option or enable "
1942 "%<-fall-intrinsics%> in order to use it.",
1943 sym
->name
, &sym
->declared_at
, symstd
);
1951 /* Resolve a procedure expression, like passing it to a called procedure or as
1952 RHS for a procedure pointer assignment. */
1955 resolve_procedure_expression (gfc_expr
* expr
)
1959 if (expr
->expr_type
!= EXPR_VARIABLE
)
1961 gcc_assert (expr
->symtree
);
1963 sym
= expr
->symtree
->n
.sym
;
1965 if (sym
->attr
.intrinsic
)
1966 gfc_resolve_intrinsic (sym
, &expr
->where
);
1968 if (sym
->attr
.flavor
!= FL_PROCEDURE
1969 || (sym
->attr
.function
&& sym
->result
== sym
))
1972 /* A non-RECURSIVE procedure that is used as procedure expression within its
1973 own body is in danger of being called recursively. */
1974 if (is_illegal_recursion (sym
, gfc_current_ns
))
1975 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1976 " itself recursively. Declare it RECURSIVE or use"
1977 " %<-frecursive%>", sym
->name
, &expr
->where
);
1983 /* Check that name is not a derived type. */
1986 is_dt_name (const char *name
)
1988 gfc_symbol
*dt_list
, *dt_first
;
1990 dt_list
= dt_first
= gfc_derived_types
;
1991 for (; dt_list
; dt_list
= dt_list
->dt_next
)
1993 if (strcmp(dt_list
->name
, name
) == 0)
1995 if (dt_first
== dt_list
->dt_next
)
2002 /* Resolve an actual argument list. Most of the time, this is just
2003 resolving the expressions in the list.
2004 The exception is that we sometimes have to decide whether arguments
2005 that look like procedure arguments are really simple variable
2009 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
2010 bool no_formal_args
)
2013 gfc_symtree
*parent_st
;
2015 gfc_component
*comp
;
2016 int save_need_full_assumed_size
;
2017 bool return_value
= false;
2018 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
2021 first_actual_arg
= true;
2023 for (; arg
; arg
= arg
->next
)
2028 /* Check the label is a valid branching target. */
2031 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
2033 gfc_error ("Label %d referenced at %L is never defined",
2034 arg
->label
->value
, &arg
->label
->where
);
2038 first_actual_arg
= false;
2042 if (e
->expr_type
== EXPR_VARIABLE
2043 && e
->symtree
->n
.sym
->attr
.generic
2045 && count_specific_procs (e
) != 1)
2048 if (e
->ts
.type
!= BT_PROCEDURE
)
2050 save_need_full_assumed_size
= need_full_assumed_size
;
2051 if (e
->expr_type
!= EXPR_VARIABLE
)
2052 need_full_assumed_size
= 0;
2053 if (!gfc_resolve_expr (e
))
2055 need_full_assumed_size
= save_need_full_assumed_size
;
2059 /* See if the expression node should really be a variable reference. */
2061 sym
= e
->symtree
->n
.sym
;
2063 if (sym
->attr
.flavor
== FL_PROCEDURE
&& is_dt_name (sym
->name
))
2065 gfc_error ("Derived type %qs is used as an actual "
2066 "argument at %L", sym
->name
, &e
->where
);
2070 if (sym
->attr
.flavor
== FL_PROCEDURE
2071 || sym
->attr
.intrinsic
2072 || sym
->attr
.external
)
2076 /* If a procedure is not already determined to be something else
2077 check if it is intrinsic. */
2078 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
2079 sym
->attr
.intrinsic
= 1;
2081 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2083 gfc_error ("Statement function %qs at %L is not allowed as an "
2084 "actual argument", sym
->name
, &e
->where
);
2087 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
2088 sym
->attr
.subroutine
);
2089 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
2091 gfc_error ("Intrinsic %qs at %L is not allowed as an "
2092 "actual argument", sym
->name
, &e
->where
);
2095 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
2096 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
2098 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
2099 " used as actual argument at %L",
2100 sym
->name
, &e
->where
))
2104 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
2106 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2107 "allowed as an actual argument at %L", sym
->name
,
2111 /* Check if a generic interface has a specific procedure
2112 with the same name before emitting an error. */
2113 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
2116 /* Just in case a specific was found for the expression. */
2117 sym
= e
->symtree
->n
.sym
;
2119 /* If the symbol is the function that names the current (or
2120 parent) scope, then we really have a variable reference. */
2122 if (gfc_is_function_return_value (sym
, sym
->ns
))
2125 /* If all else fails, see if we have a specific intrinsic. */
2126 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
2128 gfc_intrinsic_sym
*isym
;
2130 isym
= gfc_find_function (sym
->name
);
2131 if (isym
== NULL
|| !isym
->specific
)
2133 gfc_error ("Unable to find a specific INTRINSIC procedure "
2134 "for the reference %qs at %L", sym
->name
,
2139 sym
->attr
.intrinsic
= 1;
2140 sym
->attr
.function
= 1;
2143 if (!gfc_resolve_expr (e
))
2148 /* See if the name is a module procedure in a parent unit. */
2150 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2153 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2155 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2159 if (parent_st
== NULL
)
2162 sym
= parent_st
->n
.sym
;
2163 e
->symtree
= parent_st
; /* Point to the right thing. */
2165 if (sym
->attr
.flavor
== FL_PROCEDURE
2166 || sym
->attr
.intrinsic
2167 || sym
->attr
.external
)
2169 if (!gfc_resolve_expr (e
))
2175 e
->expr_type
= EXPR_VARIABLE
;
2177 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2178 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2179 && CLASS_DATA (sym
)->as
))
2181 e
->rank
= sym
->ts
.type
== BT_CLASS
2182 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2183 e
->ref
= gfc_get_ref ();
2184 e
->ref
->type
= REF_ARRAY
;
2185 e
->ref
->u
.ar
.type
= AR_FULL
;
2186 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2187 ? CLASS_DATA (sym
)->as
: sym
->as
;
2190 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2191 primary.cc (match_actual_arg). If above code determines that it
2192 is a variable instead, it needs to be resolved as it was not
2193 done at the beginning of this function. */
2194 save_need_full_assumed_size
= need_full_assumed_size
;
2195 if (e
->expr_type
!= EXPR_VARIABLE
)
2196 need_full_assumed_size
= 0;
2197 if (!gfc_resolve_expr (e
))
2199 need_full_assumed_size
= save_need_full_assumed_size
;
2202 /* Check argument list functions %VAL, %LOC and %REF. There is
2203 nothing to do for %REF. */
2204 if (arg
->name
&& arg
->name
[0] == '%')
2206 if (strcmp ("%VAL", arg
->name
) == 0)
2208 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2210 gfc_error ("By-value argument at %L is not of numeric "
2217 gfc_error ("By-value argument at %L cannot be an array or "
2218 "an array section", &e
->where
);
2222 /* Intrinsics are still PROC_UNKNOWN here. However,
2223 since same file external procedures are not resolvable
2224 in gfortran, it is a good deal easier to leave them to
2226 if (ptype
!= PROC_UNKNOWN
2227 && ptype
!= PROC_DUMMY
2228 && ptype
!= PROC_EXTERNAL
2229 && ptype
!= PROC_MODULE
)
2231 gfc_error ("By-value argument at %L is not allowed "
2232 "in this context", &e
->where
);
2237 /* Statement functions have already been excluded above. */
2238 else if (strcmp ("%LOC", arg
->name
) == 0
2239 && e
->ts
.type
== BT_PROCEDURE
)
2241 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2243 gfc_error ("Passing internal procedure at %L by location "
2244 "not allowed", &e
->where
);
2250 comp
= gfc_get_proc_ptr_comp(e
);
2251 if (e
->expr_type
== EXPR_VARIABLE
2252 && comp
&& comp
->attr
.elemental
)
2254 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2255 "allowed as an actual argument at %L", comp
->name
,
2259 /* Fortran 2008, C1237. */
2260 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2261 && gfc_has_ultimate_pointer (e
))
2263 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2264 "component", &e
->where
);
2268 first_actual_arg
= false;
2271 return_value
= true;
2274 actual_arg
= actual_arg_sav
;
2275 first_actual_arg
= first_actual_arg_sav
;
2277 return return_value
;
2281 /* Do the checks of the actual argument list that are specific to elemental
2282 procedures. If called with c == NULL, we have a function, otherwise if
2283 expr == NULL, we have a subroutine. */
2286 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2288 gfc_actual_arglist
*arg0
;
2289 gfc_actual_arglist
*arg
;
2290 gfc_symbol
*esym
= NULL
;
2291 gfc_intrinsic_sym
*isym
= NULL
;
2293 gfc_intrinsic_arg
*iformal
= NULL
;
2294 gfc_formal_arglist
*eformal
= NULL
;
2295 bool formal_optional
= false;
2296 bool set_by_optional
= false;
2300 /* Is this an elemental procedure? */
2301 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2303 if (expr
->value
.function
.esym
!= NULL
2304 && expr
->value
.function
.esym
->attr
.elemental
)
2306 arg0
= expr
->value
.function
.actual
;
2307 esym
= expr
->value
.function
.esym
;
2309 else if (expr
->value
.function
.isym
!= NULL
2310 && expr
->value
.function
.isym
->elemental
)
2312 arg0
= expr
->value
.function
.actual
;
2313 isym
= expr
->value
.function
.isym
;
2318 else if (c
&& c
->ext
.actual
!= NULL
)
2320 arg0
= c
->ext
.actual
;
2322 if (c
->resolved_sym
)
2323 esym
= c
->resolved_sym
;
2325 esym
= c
->symtree
->n
.sym
;
2328 if (!esym
->attr
.elemental
)
2334 /* The rank of an elemental is the rank of its array argument(s). */
2335 for (arg
= arg0
; arg
; arg
= arg
->next
)
2337 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2339 rank
= arg
->expr
->rank
;
2340 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2341 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2342 set_by_optional
= true;
2344 /* Function specific; set the result rank and shape. */
2348 if (!expr
->shape
&& arg
->expr
->shape
)
2350 expr
->shape
= gfc_get_shape (rank
);
2351 for (i
= 0; i
< rank
; i
++)
2352 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2359 /* If it is an array, it shall not be supplied as an actual argument
2360 to an elemental procedure unless an array of the same rank is supplied
2361 as an actual argument corresponding to a nonoptional dummy argument of
2362 that elemental procedure(12.4.1.5). */
2363 formal_optional
= false;
2365 iformal
= isym
->formal
;
2367 eformal
= esym
->formal
;
2369 for (arg
= arg0
; arg
; arg
= arg
->next
)
2373 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2374 formal_optional
= true;
2375 eformal
= eformal
->next
;
2377 else if (isym
&& iformal
)
2379 if (iformal
->optional
)
2380 formal_optional
= true;
2381 iformal
= iformal
->next
;
2384 formal_optional
= true;
2386 if (pedantic
&& arg
->expr
!= NULL
2387 && arg
->expr
->expr_type
== EXPR_VARIABLE
2388 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2391 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2392 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2395 gfc_actual_arglist
*a
;
2397 /* Scan the argument list for a non-optional argument with the
2398 same rank as arg. */
2399 for (a
= arg0
; a
; a
= a
->next
)
2401 && a
->expr
->rank
== arg
->expr
->rank
2402 && !a
->expr
->symtree
->n
.sym
->attr
.optional
)
2409 gfc_warning (OPT_Wpedantic
,
2410 "%qs at %L is an array and OPTIONAL; If it is not "
2411 "present, then it cannot be the actual argument of "
2412 "an ELEMENTAL procedure unless there is a non-optional"
2413 " argument with the same rank "
2414 "(Fortran 2018, 15.5.2.12)",
2415 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2419 for (arg
= arg0
; arg
; arg
= arg
->next
)
2421 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2424 /* Being elemental, the last upper bound of an assumed size array
2425 argument must be present. */
2426 if (resolve_assumed_size_actual (arg
->expr
))
2429 /* Elemental procedure's array actual arguments must conform. */
2432 if (!gfc_check_conformance (arg
->expr
, e
, _("elemental procedure")))
2439 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2440 is an array, the intent inout/out variable needs to be also an array. */
2441 if (rank
> 0 && esym
&& expr
== NULL
)
2442 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2443 arg
= arg
->next
, eformal
= eformal
->next
)
2445 && (eformal
->sym
->attr
.intent
== INTENT_OUT
2446 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2447 && arg
->expr
&& arg
->expr
->rank
== 0)
2449 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2450 "ELEMENTAL subroutine %qs is a scalar, but another "
2451 "actual argument is an array", &arg
->expr
->where
,
2452 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2453 : "INOUT", eformal
->sym
->name
, esym
->name
);
2460 /* This function does the checking of references to global procedures
2461 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2462 77 and 95 standards. It checks for a gsymbol for the name, making
2463 one if it does not already exist. If it already exists, then the
2464 reference being resolved must correspond to the type of gsymbol.
2465 Otherwise, the new symbol is equipped with the attributes of the
2466 reference. The corresponding code that is called in creating
2467 global entities is parse.cc.
2469 In addition, for all but -std=legacy, the gsymbols are used to
2470 check the interfaces of external procedures from the same file.
2471 The namespace of the gsymbol is resolved and then, once this is
2472 done the interface is checked. */
2476 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2478 if (!gsym_ns
->proc_name
->attr
.recursive
)
2481 if (sym
->ns
== gsym_ns
)
2484 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2491 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2493 if (gsym_ns
->entries
)
2495 gfc_entry_list
*entry
= gsym_ns
->entries
;
2497 for (; entry
; entry
= entry
->next
)
2499 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2501 if (strcmp (gsym_ns
->proc_name
->name
,
2502 sym
->ns
->proc_name
->name
) == 0)
2506 && strcmp (gsym_ns
->proc_name
->name
,
2507 sym
->ns
->parent
->proc_name
->name
) == 0)
2516 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2519 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2521 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2523 for ( ; arg
; arg
= arg
->next
)
2528 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2530 strncpy (errmsg
, _("allocatable argument"), err_len
);
2533 else if (arg
->sym
->attr
.asynchronous
)
2535 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2538 else if (arg
->sym
->attr
.optional
)
2540 strncpy (errmsg
, _("optional argument"), err_len
);
2543 else if (arg
->sym
->attr
.pointer
)
2545 strncpy (errmsg
, _("pointer argument"), err_len
);
2548 else if (arg
->sym
->attr
.target
)
2550 strncpy (errmsg
, _("target argument"), err_len
);
2553 else if (arg
->sym
->attr
.value
)
2555 strncpy (errmsg
, _("value argument"), err_len
);
2558 else if (arg
->sym
->attr
.volatile_
)
2560 strncpy (errmsg
, _("volatile argument"), err_len
);
2563 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2565 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2568 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2570 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2573 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2575 strncpy (errmsg
, _("coarray argument"), err_len
);
2578 else if (false) /* (2d) TODO: parametrized derived type */
2580 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2583 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2585 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2588 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2590 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2593 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2595 /* As assumed-type is unlimited polymorphic (cf. above).
2596 See also TS 29113, Note 6.1. */
2597 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2602 if (sym
->attr
.function
)
2604 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2606 if (res
->attr
.dimension
) /* (3a) */
2608 strncpy (errmsg
, _("array result"), err_len
);
2611 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2613 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2616 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2617 && res
->ts
.u
.cl
->length
2618 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2620 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2625 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2627 strncpy (errmsg
, _("elemental procedure"), err_len
);
2630 else if (sym
->attr
.is_bind_c
) /* (5) */
2632 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2641 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
2645 enum gfc_symbol_type type
;
2648 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2650 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2651 sym
->binding_label
!= NULL
);
2653 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2654 gfc_global_used (gsym
, where
);
2656 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2657 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2658 && gsym
->type
!= GSYM_UNKNOWN
2659 && !gsym
->binding_label
2661 && gsym
->ns
->proc_name
2662 && not_in_recursive (sym
, gsym
->ns
)
2663 && not_entry_self_reference (sym
, gsym
->ns
))
2665 gfc_symbol
*def_sym
;
2666 def_sym
= gsym
->ns
->proc_name
;
2668 if (gsym
->ns
->resolved
!= -1)
2671 /* Resolve the gsymbol namespace if needed. */
2672 if (!gsym
->ns
->resolved
)
2674 gfc_symbol
*old_dt_list
;
2676 /* Stash away derived types so that the backend_decls
2677 do not get mixed up. */
2678 old_dt_list
= gfc_derived_types
;
2679 gfc_derived_types
= NULL
;
2681 gfc_resolve (gsym
->ns
);
2683 /* Store the new derived types with the global namespace. */
2684 if (gfc_derived_types
)
2685 gsym
->ns
->derived_types
= gfc_derived_types
;
2687 /* Restore the derived types of this namespace. */
2688 gfc_derived_types
= old_dt_list
;
2691 /* Make sure that translation for the gsymbol occurs before
2692 the procedure currently being resolved. */
2693 ns
= gfc_global_ns_list
;
2694 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2696 if (ns
->sibling
== gsym
->ns
)
2698 ns
->sibling
= gsym
->ns
->sibling
;
2699 gsym
->ns
->sibling
= gfc_global_ns_list
;
2700 gfc_global_ns_list
= gsym
->ns
;
2705 /* This can happen if a binding name has been specified. */
2706 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2707 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2709 if (def_sym
->attr
.entry_master
|| def_sym
->attr
.entry
)
2711 gfc_entry_list
*entry
;
2712 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2713 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2715 def_sym
= entry
->sym
;
2721 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2723 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2724 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2725 gfc_typename (&def_sym
->ts
));
2729 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2730 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2732 gfc_error ("Explicit interface required for %qs at %L: %s",
2733 sym
->name
, &sym
->declared_at
, reason
);
2737 bool bad_result_characteristics
;
2738 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2739 reason
, sizeof(reason
), NULL
, NULL
,
2740 &bad_result_characteristics
))
2742 /* Turn erros into warnings with -std=gnu and -std=legacy,
2743 unless a function returns a wrong type, which can lead
2744 to all kinds of ICEs and wrong code. */
2746 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
)
2747 && !bad_result_characteristics
)
2748 gfc_errors_to_warnings (true);
2750 gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2751 sym
->name
, &sym
->declared_at
, reason
);
2753 gfc_errors_to_warnings (false);
2760 if (gsym
->type
== GSYM_UNKNOWN
)
2763 gsym
->where
= *where
;
2770 /************* Function resolution *************/
2772 /* Resolve a function call known to be generic.
2773 Section 14.1.2.4.1. */
2776 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2780 if (sym
->attr
.generic
)
2782 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2785 expr
->value
.function
.name
= s
->name
;
2786 expr
->value
.function
.esym
= s
;
2788 if (s
->ts
.type
!= BT_UNKNOWN
)
2790 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2791 expr
->ts
= s
->result
->ts
;
2794 expr
->rank
= s
->as
->rank
;
2795 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2796 expr
->rank
= s
->result
->as
->rank
;
2798 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2803 /* TODO: Need to search for elemental references in generic
2807 if (sym
->attr
.intrinsic
)
2808 return gfc_intrinsic_func_interface (expr
, 0);
2815 resolve_generic_f (gfc_expr
*expr
)
2819 gfc_interface
*intr
= NULL
;
2821 sym
= expr
->symtree
->n
.sym
;
2825 m
= resolve_generic_f0 (expr
, sym
);
2828 else if (m
== MATCH_ERROR
)
2833 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2834 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2837 if (sym
->ns
->parent
== NULL
)
2839 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2843 if (!generic_sym (sym
))
2847 /* Last ditch attempt. See if the reference is to an intrinsic
2848 that possesses a matching interface. 14.1.2.4 */
2849 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2851 if (gfc_init_expr_flag
)
2852 gfc_error ("Function %qs in initialization expression at %L "
2853 "must be an intrinsic function",
2854 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2856 gfc_error ("There is no specific function for the generic %qs "
2857 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2863 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2866 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2868 return resolve_structure_cons (expr
, 0);
2871 m
= gfc_intrinsic_func_interface (expr
, 0);
2876 gfc_error ("Generic function %qs at %L is not consistent with a "
2877 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2884 /* Resolve a function call known to be specific. */
2887 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2891 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2893 if (sym
->attr
.dummy
)
2895 sym
->attr
.proc
= PROC_DUMMY
;
2899 sym
->attr
.proc
= PROC_EXTERNAL
;
2903 if (sym
->attr
.proc
== PROC_MODULE
2904 || sym
->attr
.proc
== PROC_ST_FUNCTION
2905 || sym
->attr
.proc
== PROC_INTERNAL
)
2908 if (sym
->attr
.intrinsic
)
2910 m
= gfc_intrinsic_func_interface (expr
, 1);
2914 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2915 "with an intrinsic", sym
->name
, &expr
->where
);
2923 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2926 expr
->ts
= sym
->result
->ts
;
2929 expr
->value
.function
.name
= sym
->name
;
2930 expr
->value
.function
.esym
= sym
;
2931 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2933 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2935 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2936 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2937 else if (sym
->as
!= NULL
)
2938 expr
->rank
= sym
->as
->rank
;
2945 resolve_specific_f (gfc_expr
*expr
)
2950 sym
= expr
->symtree
->n
.sym
;
2954 m
= resolve_specific_f0 (sym
, expr
);
2957 if (m
== MATCH_ERROR
)
2960 if (sym
->ns
->parent
== NULL
)
2963 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2969 gfc_error ("Unable to resolve the specific function %qs at %L",
2970 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2975 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2976 candidates in CANDIDATES_LEN. */
2979 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2981 size_t &candidates_len
)
2987 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2988 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2989 vec_push (candidates
, candidates_len
, sym
->name
);
2993 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2997 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3001 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3004 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
3006 char **candidates
= NULL
;
3007 size_t candidates_len
= 0;
3008 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
3009 return gfc_closest_fuzzy_match (fn
, candidates
);
3013 /* Resolve a procedure call not known to be generic nor specific. */
3016 resolve_unknown_f (gfc_expr
*expr
)
3021 sym
= expr
->symtree
->n
.sym
;
3023 if (sym
->attr
.dummy
)
3025 sym
->attr
.proc
= PROC_DUMMY
;
3026 expr
->value
.function
.name
= sym
->name
;
3030 /* See if we have an intrinsic function reference. */
3032 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
3034 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
3039 /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3040 /* Intrinsics were handled above, only non-intrinsics left here. */
3041 if (sym
->attr
.flavor
== FL_PROCEDURE
3042 && sym
->attr
.implicit_type
3044 && sym
->ns
->has_implicit_none_export
)
3046 gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3047 "for symbol %qs at %L", sym
->name
, &sym
->declared_at
);
3052 /* The reference is to an external name. */
3054 sym
->attr
.proc
= PROC_EXTERNAL
;
3055 expr
->value
.function
.name
= sym
->name
;
3056 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
3058 if (sym
->as
!= NULL
)
3059 expr
->rank
= sym
->as
->rank
;
3061 /* Type of the expression is either the type of the symbol or the
3062 default type of the symbol. */
3065 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
3067 if (sym
->ts
.type
!= BT_UNKNOWN
)
3071 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
3073 if (ts
->type
== BT_UNKNOWN
)
3076 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3078 gfc_error ("Function %qs at %L has no IMPLICIT type"
3079 "; did you mean %qs?",
3080 sym
->name
, &expr
->where
, guessed
);
3082 gfc_error ("Function %qs at %L has no IMPLICIT type",
3083 sym
->name
, &expr
->where
);
3094 /* Return true, if the symbol is an external procedure. */
3096 is_external_proc (gfc_symbol
*sym
)
3098 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
3099 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
3100 && sym
->attr
.proc
!= PROC_ST_FUNCTION
3101 && !sym
->attr
.proc_pointer
3102 && !sym
->attr
.use_assoc
3110 /* Figure out if a function reference is pure or not. Also set the name
3111 of the function for a potential error message. Return nonzero if the
3112 function is PURE, zero if not. */
3114 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
3117 gfc_pure_function (gfc_expr
*e
, const char **name
)
3120 gfc_component
*comp
;
3124 if (e
->symtree
!= NULL
3125 && e
->symtree
->n
.sym
!= NULL
3126 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3127 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
3129 comp
= gfc_get_proc_ptr_comp (e
);
3132 pure
= gfc_pure (comp
->ts
.interface
);
3135 else if (e
->value
.function
.esym
)
3137 pure
= gfc_pure (e
->value
.function
.esym
);
3138 *name
= e
->value
.function
.esym
->name
;
3140 else if (e
->value
.function
.isym
)
3142 pure
= e
->value
.function
.isym
->pure
3143 || e
->value
.function
.isym
->elemental
;
3144 *name
= e
->value
.function
.isym
->name
;
3148 /* Implicit functions are not pure. */
3150 *name
= e
->value
.function
.name
;
3157 /* Check if the expression is a reference to an implicitly pure function. */
3160 gfc_implicit_pure_function (gfc_expr
*e
)
3162 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
3164 return gfc_implicit_pure (comp
->ts
.interface
);
3165 else if (e
->value
.function
.esym
)
3166 return gfc_implicit_pure (e
->value
.function
.esym
);
3173 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3174 int *f ATTRIBUTE_UNUSED
)
3178 /* Don't bother recursing into other statement functions
3179 since they will be checked individually for purity. */
3180 if (e
->expr_type
!= EXPR_FUNCTION
3182 || e
->symtree
->n
.sym
== sym
3183 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3186 return gfc_pure_function (e
, &name
) ? false : true;
3191 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3193 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3197 /* Check if an impure function is allowed in the current context. */
3199 static bool check_pure_function (gfc_expr
*e
)
3201 const char *name
= NULL
;
3202 if (!gfc_pure_function (e
, &name
) && name
)
3206 gfc_error ("Reference to impure function %qs at %L inside a "
3207 "FORALL %s", name
, &e
->where
,
3208 forall_flag
== 2 ? "mask" : "block");
3211 else if (gfc_do_concurrent_flag
)
3213 gfc_error ("Reference to impure function %qs at %L inside a "
3214 "DO CONCURRENT %s", name
, &e
->where
,
3215 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3218 else if (gfc_pure (NULL
))
3220 gfc_error ("Reference to impure function %qs at %L "
3221 "within a PURE procedure", name
, &e
->where
);
3224 if (!gfc_implicit_pure_function (e
))
3225 gfc_unset_implicit_pure (NULL
);
3231 /* Update current procedure's array_outer_dependency flag, considering
3232 a call to procedure SYM. */
3235 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3237 /* Check to see if this is a sibling function that has not yet
3239 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3240 for (; sibling
; sibling
= sibling
->sibling
)
3242 if (sibling
->proc_name
== sym
)
3244 gfc_resolve (sibling
);
3249 /* If SYM has references to outer arrays, so has the procedure calling
3250 SYM. If SYM is a procedure pointer, we can assume the worst. */
3251 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3252 && gfc_current_ns
->proc_name
)
3253 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3257 /* Resolve a function call, which means resolving the arguments, then figuring
3258 out which entity the name refers to. */
3261 resolve_function (gfc_expr
*expr
)
3263 gfc_actual_arglist
*arg
;
3267 procedure_type p
= PROC_INTRINSIC
;
3268 bool no_formal_args
;
3272 sym
= expr
->symtree
->n
.sym
;
3274 /* If this is a procedure pointer component, it has already been resolved. */
3275 if (gfc_is_proc_ptr_comp (expr
))
3278 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3280 if (sym
&& sym
->attr
.intrinsic
3281 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3282 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3287 gfc_error ("Unexpected junk after %qs at %L", expr
->symtree
->n
.sym
->name
,
3292 if (sym
&& sym
->attr
.intrinsic
3293 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3296 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3298 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3302 /* If this is a deferred TBP with an abstract interface (which may
3303 of course be referenced), expr->value.function.esym will be set. */
3304 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3306 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3307 sym
->name
, &expr
->where
);
3311 /* If this is a deferred TBP with an abstract interface, its result
3312 cannot be an assumed length character (F2003: C418). */
3313 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3314 && sym
->result
->ts
.u
.cl
3315 && sym
->result
->ts
.u
.cl
->length
== NULL
3316 && !sym
->result
->ts
.deferred
)
3318 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3319 "character length result (F2008: C418)", sym
->name
,
3324 /* Switch off assumed size checking and do this again for certain kinds
3325 of procedure, once the procedure itself is resolved. */
3326 need_full_assumed_size
++;
3328 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3329 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3331 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3332 inquiry_argument
= true;
3333 no_formal_args
= sym
&& is_external_proc (sym
)
3334 && gfc_sym_get_dummy_args (sym
) == NULL
;
3336 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3339 inquiry_argument
= false;
3343 inquiry_argument
= false;
3345 /* Resume assumed_size checking. */
3346 need_full_assumed_size
--;
3348 /* If the procedure is external, check for usage. */
3349 if (sym
&& is_external_proc (sym
))
3350 resolve_global_procedure (sym
, &expr
->where
, 0);
3352 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3354 && sym
->ts
.u
.cl
->length
== NULL
3356 && !sym
->ts
.deferred
3357 && expr
->value
.function
.esym
== NULL
3358 && !sym
->attr
.contained
)
3360 /* Internal procedures are taken care of in resolve_contained_fntype. */
3361 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3362 "be used at %L since it is not a dummy argument",
3363 sym
->name
, &expr
->where
);
3367 /* See if function is already resolved. */
3369 if (expr
->value
.function
.name
!= NULL
3370 || expr
->value
.function
.isym
!= NULL
)
3372 if (expr
->ts
.type
== BT_UNKNOWN
)
3378 /* Apply the rules of section 14.1.2. */
3380 switch (procedure_kind (sym
))
3383 t
= resolve_generic_f (expr
);
3386 case PTYPE_SPECIFIC
:
3387 t
= resolve_specific_f (expr
);
3391 t
= resolve_unknown_f (expr
);
3395 gfc_internal_error ("resolve_function(): bad function type");
3399 /* If the expression is still a function (it might have simplified),
3400 then we check to see if we are calling an elemental function. */
3402 if (expr
->expr_type
!= EXPR_FUNCTION
)
3405 /* Walk the argument list looking for invalid BOZ. */
3406 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3407 if (arg
->expr
&& arg
->expr
->ts
.type
== BT_BOZ
)
3409 gfc_error ("A BOZ literal constant at %L cannot appear as an "
3410 "actual argument in a function reference",
3415 temp
= need_full_assumed_size
;
3416 need_full_assumed_size
= 0;
3418 if (!resolve_elemental_actual (expr
, NULL
))
3421 if (omp_workshare_flag
3422 && expr
->value
.function
.esym
3423 && ! gfc_elemental (expr
->value
.function
.esym
))
3425 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3426 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3431 #define GENERIC_ID expr->value.function.isym->id
3432 else if (expr
->value
.function
.actual
!= NULL
3433 && expr
->value
.function
.isym
!= NULL
3434 && GENERIC_ID
!= GFC_ISYM_LBOUND
3435 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3436 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3437 && GENERIC_ID
!= GFC_ISYM_LEN
3438 && GENERIC_ID
!= GFC_ISYM_LOC
3439 && GENERIC_ID
!= GFC_ISYM_C_LOC
3440 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3442 /* Array intrinsics must also have the last upper bound of an
3443 assumed size array argument. UBOUND and SIZE have to be
3444 excluded from the check if the second argument is anything
3447 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3449 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3450 && arg
== expr
->value
.function
.actual
3451 && arg
->next
!= NULL
&& arg
->next
->expr
)
3453 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3456 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3459 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3464 if (arg
->expr
!= NULL
3465 && arg
->expr
->rank
> 0
3466 && resolve_assumed_size_actual (arg
->expr
))
3472 need_full_assumed_size
= temp
;
3474 if (!check_pure_function(expr
))
3477 /* Functions without the RECURSIVE attribution are not allowed to
3478 * call themselves. */
3479 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3482 esym
= expr
->value
.function
.esym
;
3484 if (is_illegal_recursion (esym
, gfc_current_ns
))
3486 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3487 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3488 " function %qs is not RECURSIVE",
3489 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3491 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3492 " is not RECURSIVE", esym
->name
, &expr
->where
);
3498 /* Character lengths of use associated functions may contains references to
3499 symbols not referenced from the current program unit otherwise. Make sure
3500 those symbols are marked as referenced. */
3502 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3503 && expr
->value
.function
.esym
->attr
.use_assoc
)
3505 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3508 /* Make sure that the expression has a typespec that works. */
3509 if (expr
->ts
.type
== BT_UNKNOWN
)
3511 if (expr
->symtree
->n
.sym
->result
3512 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3513 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3514 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3517 /* These derived types with an incomplete namespace, arising from use
3518 association, cause gfc_get_derived_vtab to segfault. If the function
3519 namespace does not suffice, something is badly wrong. */
3520 if (expr
->ts
.type
== BT_DERIVED
3521 && !expr
->ts
.u
.derived
->ns
->proc_name
)
3524 gfc_find_symbol (expr
->ts
.u
.derived
->name
, expr
->symtree
->n
.sym
->ns
, 1, &der
);
3527 expr
->ts
.u
.derived
->refs
--;
3528 expr
->ts
.u
.derived
= der
;
3532 expr
->ts
.u
.derived
->ns
= expr
->symtree
->n
.sym
->ns
;
3535 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3537 if (expr
->value
.function
.esym
)
3538 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3540 update_current_proc_array_outer_dependency (sym
);
3543 /* typebound procedure: Assume the worst. */
3544 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3546 if (expr
->value
.function
.esym
3547 && expr
->value
.function
.esym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
))
3548 gfc_warning (OPT_Wdeprecated_declarations
,
3549 "Using function %qs at %L is deprecated",
3550 sym
->name
, &expr
->where
);
3555 /************* Subroutine resolution *************/
3558 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3565 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3569 else if (gfc_do_concurrent_flag
)
3571 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3575 else if (gfc_pure (NULL
))
3577 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3581 gfc_unset_implicit_pure (NULL
);
3587 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3591 if (sym
->attr
.generic
)
3593 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3596 c
->resolved_sym
= s
;
3597 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3602 /* TODO: Need to search for elemental references in generic interface. */
3605 if (sym
->attr
.intrinsic
)
3606 return gfc_intrinsic_sub_interface (c
, 0);
3613 resolve_generic_s (gfc_code
*c
)
3618 sym
= c
->symtree
->n
.sym
;
3622 m
= resolve_generic_s0 (c
, sym
);
3625 else if (m
== MATCH_ERROR
)
3629 if (sym
->ns
->parent
== NULL
)
3631 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3635 if (!generic_sym (sym
))
3639 /* Last ditch attempt. See if the reference is to an intrinsic
3640 that possesses a matching interface. 14.1.2.4 */
3641 sym
= c
->symtree
->n
.sym
;
3643 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3645 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3646 sym
->name
, &c
->loc
);
3650 m
= gfc_intrinsic_sub_interface (c
, 0);
3654 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3655 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3661 /* Resolve a subroutine call known to be specific. */
3664 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3668 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3670 if (sym
->attr
.dummy
)
3672 sym
->attr
.proc
= PROC_DUMMY
;
3676 sym
->attr
.proc
= PROC_EXTERNAL
;
3680 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3683 if (sym
->attr
.intrinsic
)
3685 m
= gfc_intrinsic_sub_interface (c
, 1);
3689 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3690 "with an intrinsic", sym
->name
, &c
->loc
);
3698 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3700 c
->resolved_sym
= sym
;
3701 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3709 resolve_specific_s (gfc_code
*c
)
3714 sym
= c
->symtree
->n
.sym
;
3718 m
= resolve_specific_s0 (c
, sym
);
3721 if (m
== MATCH_ERROR
)
3724 if (sym
->ns
->parent
== NULL
)
3727 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3733 sym
= c
->symtree
->n
.sym
;
3734 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3735 sym
->name
, &c
->loc
);
3741 /* Resolve a subroutine call not known to be generic nor specific. */
3744 resolve_unknown_s (gfc_code
*c
)
3748 sym
= c
->symtree
->n
.sym
;
3750 if (sym
->attr
.dummy
)
3752 sym
->attr
.proc
= PROC_DUMMY
;
3756 /* See if we have an intrinsic function reference. */
3758 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3760 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3765 /* The reference is to an external name. */
3768 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3770 c
->resolved_sym
= sym
;
3772 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3776 /* Resolve a subroutine call. Although it was tempting to use the same code
3777 for functions, subroutines and functions are stored differently and this
3778 makes things awkward. */
3781 resolve_call (gfc_code
*c
)
3784 procedure_type ptype
= PROC_INTRINSIC
;
3785 gfc_symbol
*csym
, *sym
;
3786 bool no_formal_args
;
3788 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3790 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3792 gfc_error ("%qs at %L has a type, which is not consistent with "
3793 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3797 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3800 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3801 sym
= st
? st
->n
.sym
: NULL
;
3802 if (sym
&& csym
!= sym
3803 && sym
->ns
== gfc_current_ns
3804 && sym
->attr
.flavor
== FL_PROCEDURE
3805 && sym
->attr
.contained
)
3808 if (csym
->attr
.generic
)
3809 c
->symtree
->n
.sym
= sym
;
3812 csym
= c
->symtree
->n
.sym
;
3816 /* If this ia a deferred TBP, c->expr1 will be set. */
3817 if (!c
->expr1
&& csym
)
3819 if (csym
->attr
.abstract
)
3821 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3822 csym
->name
, &c
->loc
);
3826 /* Subroutines without the RECURSIVE attribution are not allowed to
3828 if (is_illegal_recursion (csym
, gfc_current_ns
))
3830 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3831 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3832 "as subroutine %qs is not RECURSIVE",
3833 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3835 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3836 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3842 /* Switch off assumed size checking and do this again for certain kinds
3843 of procedure, once the procedure itself is resolved. */
3844 need_full_assumed_size
++;
3847 ptype
= csym
->attr
.proc
;
3849 no_formal_args
= csym
&& is_external_proc (csym
)
3850 && gfc_sym_get_dummy_args (csym
) == NULL
;
3851 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3854 /* Resume assumed_size checking. */
3855 need_full_assumed_size
--;
3857 /* If external, check for usage. */
3858 if (csym
&& is_external_proc (csym
))
3859 resolve_global_procedure (csym
, &c
->loc
, 1);
3862 if (c
->resolved_sym
== NULL
)
3864 c
->resolved_isym
= NULL
;
3865 switch (procedure_kind (csym
))
3868 t
= resolve_generic_s (c
);
3871 case PTYPE_SPECIFIC
:
3872 t
= resolve_specific_s (c
);
3876 t
= resolve_unknown_s (c
);
3880 gfc_internal_error ("resolve_subroutine(): bad function type");
3884 /* Some checks of elemental subroutine actual arguments. */
3885 if (!resolve_elemental_actual (NULL
, c
))
3889 update_current_proc_array_outer_dependency (csym
);
3891 /* Typebound procedure: Assume the worst. */
3892 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3895 && c
->resolved_sym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
))
3896 gfc_warning (OPT_Wdeprecated_declarations
,
3897 "Using subroutine %qs at %L is deprecated",
3898 c
->resolved_sym
->name
, &c
->loc
);
3904 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3905 op1->shape and op2->shape are non-NULL return true if their shapes
3906 match. If both op1->shape and op2->shape are non-NULL return false
3907 if their shapes do not match. If either op1->shape or op2->shape is
3908 NULL, return true. */
3911 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3918 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3920 for (i
= 0; i
< op1
->rank
; i
++)
3922 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3924 gfc_error ("Shapes for operands at %L and %L are not conformable",
3925 &op1
->where
, &op2
->where
);
3935 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3936 For example A .AND. B becomes IAND(A, B). */
3938 logical_to_bitwise (gfc_expr
*e
)
3940 gfc_expr
*tmp
, *op1
, *op2
;
3942 gfc_actual_arglist
*args
= NULL
;
3944 gcc_assert (e
->expr_type
== EXPR_OP
);
3946 isym
= GFC_ISYM_NONE
;
3947 op1
= e
->value
.op
.op1
;
3948 op2
= e
->value
.op
.op2
;
3950 switch (e
->value
.op
.op
)
3953 isym
= GFC_ISYM_NOT
;
3956 isym
= GFC_ISYM_IAND
;
3959 isym
= GFC_ISYM_IOR
;
3961 case INTRINSIC_NEQV
:
3962 isym
= GFC_ISYM_IEOR
;
3965 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3966 Change the old expression to NEQV, which will get replaced by IEOR,
3967 and wrap it in NOT. */
3968 tmp
= gfc_copy_expr (e
);
3969 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3970 tmp
= logical_to_bitwise (tmp
);
3971 isym
= GFC_ISYM_NOT
;
3976 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3979 /* Inherit the original operation's operands as arguments. */
3980 args
= gfc_get_actual_arglist ();
3984 args
->next
= gfc_get_actual_arglist ();
3985 args
->next
->expr
= op2
;
3988 /* Convert the expression to a function call. */
3989 e
->expr_type
= EXPR_FUNCTION
;
3990 e
->value
.function
.actual
= args
;
3991 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3992 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3993 e
->value
.function
.esym
= NULL
;
3995 /* Make up a pre-resolved function call symtree if we need to. */
3996 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3999 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
4000 sym
= e
->symtree
->n
.sym
;
4002 sym
->attr
.flavor
= FL_PROCEDURE
;
4003 sym
->attr
.function
= 1;
4004 sym
->attr
.elemental
= 1;
4006 sym
->attr
.referenced
= 1;
4007 gfc_intrinsic_symbol (sym
);
4008 gfc_commit_symbol (sym
);
4011 args
->name
= e
->value
.function
.isym
->formal
->name
;
4012 if (e
->value
.function
.isym
->formal
->next
)
4013 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
4018 /* Recursively append candidate UOP to CANDIDATES. Store the number of
4019 candidates in CANDIDATES_LEN. */
4021 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
4023 size_t &candidates_len
)
4030 /* Not sure how to properly filter here. Use all for a start.
4031 n.uop.op is NULL for empty interface operators (is that legal?) disregard
4032 these as i suppose they don't make terribly sense. */
4034 if (uop
->n
.uop
->op
!= NULL
)
4035 vec_push (candidates
, candidates_len
, uop
->name
);
4039 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
4043 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
4046 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4049 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
4051 char **candidates
= NULL
;
4052 size_t candidates_len
= 0;
4053 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
4054 return gfc_closest_fuzzy_match (op
, candidates
);
4058 /* Callback finding an impure function as an operand to an .and. or
4059 .or. expression. Remember the last function warned about to
4060 avoid double warnings when recursing. */
4063 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4068 static gfc_expr
*last
= NULL
;
4069 bool *found
= (bool *) data
;
4071 if (f
->expr_type
== EXPR_FUNCTION
)
4074 if (f
!= last
&& !gfc_pure_function (f
, &name
)
4075 && !gfc_implicit_pure_function (f
))
4078 gfc_warning (OPT_Wfunction_elimination
,
4079 "Impure function %qs at %L might not be evaluated",
4082 gfc_warning (OPT_Wfunction_elimination
,
4083 "Impure function at %L might not be evaluated",
4092 /* Return true if TYPE is character based, false otherwise. */
4095 is_character_based (bt type
)
4097 return type
== BT_CHARACTER
|| type
== BT_HOLLERITH
;
4101 /* If expression is a hollerith, convert it to character and issue a warning
4102 for the conversion. */
4105 convert_hollerith_to_character (gfc_expr
*e
)
4107 if (e
->ts
.type
== BT_HOLLERITH
)
4111 t
.type
= BT_CHARACTER
;
4112 t
.kind
= e
->ts
.kind
;
4113 gfc_convert_type_warn (e
, &t
, 2, 1);
4117 /* Convert to numeric and issue a warning for the conversion. */
4120 convert_to_numeric (gfc_expr
*a
, gfc_expr
*b
)
4124 t
.type
= b
->ts
.type
;
4125 t
.kind
= b
->ts
.kind
;
4126 gfc_convert_type_warn (a
, &t
, 2, 1);
4129 /* Resolve an operator expression node. This can involve replacing the
4130 operation with a user defined function call. */
4133 resolve_operator (gfc_expr
*e
)
4135 gfc_expr
*op1
, *op2
;
4136 /* One error uses 3 names; additional space for wording (also via gettext). */
4137 char msg
[3*GFC_MAX_SYMBOL_LEN
+ 1 + 50];
4138 bool dual_locus_error
;
4141 /* Reduce stacked parentheses to single pair */
4142 while (e
->expr_type
== EXPR_OP
4143 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4144 && e
->value
.op
.op1
->expr_type
== EXPR_OP
4145 && e
->value
.op
.op1
->value
.op
.op
== INTRINSIC_PARENTHESES
)
4147 gfc_expr
*tmp
= gfc_copy_expr (e
->value
.op
.op1
);
4148 gfc_replace_expr (e
, tmp
);
4151 /* Resolve all subnodes-- give them types. */
4153 switch (e
->value
.op
.op
)
4156 if (!gfc_resolve_expr (e
->value
.op
.op2
))
4162 case INTRINSIC_UPLUS
:
4163 case INTRINSIC_UMINUS
:
4164 case INTRINSIC_PARENTHESES
:
4165 if (!gfc_resolve_expr (e
->value
.op
.op1
))
4168 && e
->value
.op
.op1
->ts
.type
== BT_BOZ
&& !e
->value
.op
.op2
)
4170 gfc_error ("BOZ literal constant at %L cannot be an operand of "
4171 "unary operator %qs", &e
->value
.op
.op1
->where
,
4172 gfc_op2string (e
->value
.op
.op
));
4178 /* Typecheck the new node. */
4180 op1
= e
->value
.op
.op1
;
4181 op2
= e
->value
.op
.op2
;
4182 if (op1
== NULL
&& op2
== NULL
)
4184 /* Error out if op2 did not resolve. We already diagnosed op1. */
4188 dual_locus_error
= false;
4190 /* op1 and op2 cannot both be BOZ. */
4191 if (op1
&& op1
->ts
.type
== BT_BOZ
4192 && op2
&& op2
->ts
.type
== BT_BOZ
)
4194 gfc_error ("Operands at %L and %L cannot appear as operands of "
4195 "binary operator %qs", &op1
->where
, &op2
->where
,
4196 gfc_op2string (e
->value
.op
.op
));
4200 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
4201 || (op2
&& op2
->expr_type
== EXPR_NULL
))
4203 snprintf (msg
, sizeof (msg
),
4204 _("Invalid context for NULL() pointer at %%L"));
4208 switch (e
->value
.op
.op
)
4210 case INTRINSIC_UPLUS
:
4211 case INTRINSIC_UMINUS
:
4212 if (op1
->ts
.type
== BT_INTEGER
4213 || op1
->ts
.type
== BT_REAL
4214 || op1
->ts
.type
== BT_COMPLEX
)
4220 snprintf (msg
, sizeof (msg
),
4221 _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
4222 gfc_op2string (e
->value
.op
.op
), gfc_typename (e
));
4225 case INTRINSIC_PLUS
:
4226 case INTRINSIC_MINUS
:
4227 case INTRINSIC_TIMES
:
4228 case INTRINSIC_DIVIDE
:
4229 case INTRINSIC_POWER
:
4230 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4232 /* Do not perform conversions if operands are not conformable as
4233 required for the binary intrinsic operators (F2018:10.1.5).
4234 Defer to a possibly overloading user-defined operator. */
4235 if (!gfc_op_rank_conformable (op1
, op2
))
4237 dual_locus_error
= true;
4238 snprintf (msg
, sizeof (msg
),
4239 _("Inconsistent ranks for operator at %%L and %%L"));
4243 gfc_type_convert_binary (e
, 1);
4247 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
4248 snprintf (msg
, sizeof (msg
),
4249 _("Unexpected derived-type entities in binary intrinsic "
4250 "numeric operator %%<%s%%> at %%L"),
4251 gfc_op2string (e
->value
.op
.op
));
4253 snprintf (msg
, sizeof(msg
),
4254 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
4255 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4256 gfc_typename (op2
));
4259 case INTRINSIC_CONCAT
:
4260 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4261 && op1
->ts
.kind
== op2
->ts
.kind
)
4263 e
->ts
.type
= BT_CHARACTER
;
4264 e
->ts
.kind
= op1
->ts
.kind
;
4268 snprintf (msg
, sizeof (msg
),
4269 _("Operands of string concatenation operator at %%L are %s/%s"),
4270 gfc_typename (op1
), gfc_typename (op2
));
4276 case INTRINSIC_NEQV
:
4277 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4279 e
->ts
.type
= BT_LOGICAL
;
4280 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4281 if (op1
->ts
.kind
< e
->ts
.kind
)
4282 gfc_convert_type (op1
, &e
->ts
, 2);
4283 else if (op2
->ts
.kind
< e
->ts
.kind
)
4284 gfc_convert_type (op2
, &e
->ts
, 2);
4286 if (flag_frontend_optimize
&&
4287 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4289 /* Warn about short-circuiting
4290 with impure function as second operand. */
4292 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4297 /* Logical ops on integers become bitwise ops with -fdec. */
4299 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4301 e
->ts
.type
= BT_INTEGER
;
4302 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4303 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4304 gfc_convert_type (op1
, &e
->ts
, 1);
4305 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4306 gfc_convert_type (op2
, &e
->ts
, 1);
4307 e
= logical_to_bitwise (e
);
4311 snprintf (msg
, sizeof (msg
),
4312 _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4313 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4314 gfc_typename (op2
));
4319 /* Logical ops on integers become bitwise ops with -fdec. */
4320 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4322 e
->ts
.type
= BT_INTEGER
;
4323 e
->ts
.kind
= op1
->ts
.kind
;
4324 e
= logical_to_bitwise (e
);
4328 if (op1
->ts
.type
== BT_LOGICAL
)
4330 e
->ts
.type
= BT_LOGICAL
;
4331 e
->ts
.kind
= op1
->ts
.kind
;
4335 snprintf (msg
, sizeof (msg
), _("Operand of .not. operator at %%L is %s"),
4336 gfc_typename (op1
));
4340 case INTRINSIC_GT_OS
:
4342 case INTRINSIC_GE_OS
:
4344 case INTRINSIC_LT_OS
:
4346 case INTRINSIC_LE_OS
:
4347 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4349 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4356 case INTRINSIC_EQ_OS
:
4358 case INTRINSIC_NE_OS
:
4361 && is_character_based (op1
->ts
.type
)
4362 && is_character_based (op2
->ts
.type
))
4364 convert_hollerith_to_character (op1
);
4365 convert_hollerith_to_character (op2
);
4368 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4369 && op1
->ts
.kind
== op2
->ts
.kind
)
4371 e
->ts
.type
= BT_LOGICAL
;
4372 e
->ts
.kind
= gfc_default_logical_kind
;
4376 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4377 if (op1
->ts
.type
== BT_BOZ
)
4379 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4380 "as an operand of a relational operator"),
4384 if (op2
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op1
, op2
->ts
.kind
))
4387 if (op2
->ts
.type
== BT_REAL
&& !gfc_boz2real (op1
, op2
->ts
.kind
))
4391 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4392 if (op2
->ts
.type
== BT_BOZ
)
4394 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4395 " as an operand of a relational operator"),
4399 if (op1
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op2
, op1
->ts
.kind
))
4402 if (op1
->ts
.type
== BT_REAL
&& !gfc_boz2real (op2
, op1
->ts
.kind
))
4406 && op1
->ts
.type
== BT_HOLLERITH
&& gfc_numeric_ts (&op2
->ts
))
4407 convert_to_numeric (op1
, op2
);
4410 && gfc_numeric_ts (&op1
->ts
) && op2
->ts
.type
== BT_HOLLERITH
)
4411 convert_to_numeric (op2
, op1
);
4413 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4415 /* Do not perform conversions if operands are not conformable as
4416 required for the binary intrinsic operators (F2018:10.1.5).
4417 Defer to a possibly overloading user-defined operator. */
4418 if (!gfc_op_rank_conformable (op1
, op2
))
4420 dual_locus_error
= true;
4421 snprintf (msg
, sizeof (msg
),
4422 _("Inconsistent ranks for operator at %%L and %%L"));
4426 gfc_type_convert_binary (e
, 1);
4428 e
->ts
.type
= BT_LOGICAL
;
4429 e
->ts
.kind
= gfc_default_logical_kind
;
4431 if (warn_compare_reals
)
4433 gfc_intrinsic_op op
= e
->value
.op
.op
;
4435 /* Type conversion has made sure that the types of op1 and op2
4436 agree, so it is only necessary to check the first one. */
4437 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4438 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4439 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4443 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4444 msg
= G_("Equality comparison for %s at %L");
4446 msg
= G_("Inequality comparison for %s at %L");
4448 gfc_warning (OPT_Wcompare_reals
, msg
,
4449 gfc_typename (op1
), &op1
->where
);
4456 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4457 snprintf (msg
, sizeof (msg
),
4458 _("Logicals at %%L must be compared with %s instead of %s"),
4459 (e
->value
.op
.op
== INTRINSIC_EQ
4460 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4461 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4463 snprintf (msg
, sizeof (msg
),
4464 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4465 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4466 gfc_typename (op2
));
4470 case INTRINSIC_USER
:
4471 if (e
->value
.op
.uop
->op
== NULL
)
4473 const char *name
= e
->value
.op
.uop
->name
;
4474 const char *guessed
;
4475 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4477 snprintf (msg
, sizeof (msg
),
4478 _("Unknown operator %%<%s%%> at %%L; did you mean "
4479 "%%<%s%%>?"), name
, guessed
);
4481 snprintf (msg
, sizeof (msg
), _("Unknown operator %%<%s%%> at %%L"),
4484 else if (op2
== NULL
)
4485 snprintf (msg
, sizeof (msg
),
4486 _("Operand of user operator %%<%s%%> at %%L is %s"),
4487 e
->value
.op
.uop
->name
, gfc_typename (op1
));
4490 snprintf (msg
, sizeof (msg
),
4491 _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4492 e
->value
.op
.uop
->name
, gfc_typename (op1
),
4493 gfc_typename (op2
));
4494 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4499 case INTRINSIC_PARENTHESES
:
4501 if (e
->ts
.type
== BT_CHARACTER
)
4502 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4506 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4509 /* Deal with arrayness of an operand through an operator. */
4511 switch (e
->value
.op
.op
)
4513 case INTRINSIC_PLUS
:
4514 case INTRINSIC_MINUS
:
4515 case INTRINSIC_TIMES
:
4516 case INTRINSIC_DIVIDE
:
4517 case INTRINSIC_POWER
:
4518 case INTRINSIC_CONCAT
:
4522 case INTRINSIC_NEQV
:
4524 case INTRINSIC_EQ_OS
:
4526 case INTRINSIC_NE_OS
:
4528 case INTRINSIC_GT_OS
:
4530 case INTRINSIC_GE_OS
:
4532 case INTRINSIC_LT_OS
:
4534 case INTRINSIC_LE_OS
:
4536 if (op1
->rank
== 0 && op2
->rank
== 0)
4539 if (op1
->rank
== 0 && op2
->rank
!= 0)
4541 e
->rank
= op2
->rank
;
4543 if (e
->shape
== NULL
)
4544 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4547 if (op1
->rank
!= 0 && op2
->rank
== 0)
4549 e
->rank
= op1
->rank
;
4551 if (e
->shape
== NULL
)
4552 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4555 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4557 if (op1
->rank
== op2
->rank
)
4559 e
->rank
= op1
->rank
;
4560 if (e
->shape
== NULL
)
4562 t
= compare_shapes (op1
, op2
);
4566 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4571 /* Allow higher level expressions to work. */
4574 /* Try user-defined operators, and otherwise throw an error. */
4575 dual_locus_error
= true;
4576 snprintf (msg
, sizeof (msg
),
4577 _("Inconsistent ranks for operator at %%L and %%L"));
4584 case INTRINSIC_PARENTHESES
:
4586 case INTRINSIC_UPLUS
:
4587 case INTRINSIC_UMINUS
:
4588 /* Simply copy arrayness attribute */
4589 e
->rank
= op1
->rank
;
4591 if (e
->shape
== NULL
)
4592 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4602 /* Attempt to simplify the expression. */
4605 t
= gfc_simplify_expr (e
, 0);
4606 /* Some calls do not succeed in simplification and return false
4607 even though there is no error; e.g. variable references to
4608 PARAMETER arrays. */
4609 if (!gfc_is_constant_expr (e
))
4617 match m
= gfc_extend_expr (e
);
4620 if (m
== MATCH_ERROR
)
4624 if (dual_locus_error
)
4625 gfc_error (msg
, &op1
->where
, &op2
->where
);
4627 gfc_error (msg
, &e
->where
);
4633 /************** Array resolution subroutines **************/
4636 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4638 /* Compare two integer expressions. */
4640 static compare_result
4641 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4645 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4646 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4649 /* If either of the types isn't INTEGER, we must have
4650 raised an error earlier. */
4652 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4655 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4665 /* Compare an integer expression with an integer. */
4667 static compare_result
4668 compare_bound_int (gfc_expr
*a
, int b
)
4673 || a
->expr_type
!= EXPR_CONSTANT
4674 || a
->ts
.type
!= BT_INTEGER
)
4677 i
= mpz_cmp_si (a
->value
.integer
, b
);
4687 /* Compare an integer expression with a mpz_t. */
4689 static compare_result
4690 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4695 || a
->expr_type
!= EXPR_CONSTANT
4696 || a
->ts
.type
!= BT_INTEGER
)
4699 i
= mpz_cmp (a
->value
.integer
, b
);
4709 /* Compute the last value of a sequence given by a triplet.
4710 Return 0 if it wasn't able to compute the last value, or if the
4711 sequence if empty, and 1 otherwise. */
4714 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4715 gfc_expr
*stride
, mpz_t last
)
4719 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4720 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4721 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4724 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4725 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4728 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4730 if (compare_bound (start
, end
) == CMP_GT
)
4732 mpz_set (last
, end
->value
.integer
);
4736 if (compare_bound_int (stride
, 0) == CMP_GT
)
4738 /* Stride is positive */
4739 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4744 /* Stride is negative */
4745 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4750 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4751 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4752 mpz_sub (last
, end
->value
.integer
, rem
);
4759 /* Compare a single dimension of an array reference to the array
4763 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4767 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4769 gcc_assert (ar
->stride
[i
] == NULL
);
4770 /* This implies [*] as [*:] and [*:3] are not possible. */
4771 if (ar
->start
[i
] == NULL
)
4773 gcc_assert (ar
->end
[i
] == NULL
);
4778 /* Given start, end and stride values, calculate the minimum and
4779 maximum referenced indexes. */
4781 switch (ar
->dimen_type
[i
])
4784 case DIMEN_THIS_IMAGE
:
4789 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4792 gfc_warning (0, "Array reference at %L is out of bounds "
4793 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4794 mpz_get_si (ar
->start
[i
]->value
.integer
),
4795 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4797 gfc_warning (0, "Array reference at %L is out of bounds "
4798 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4799 mpz_get_si (ar
->start
[i
]->value
.integer
),
4800 mpz_get_si (as
->lower
[i
]->value
.integer
),
4804 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4807 gfc_warning (0, "Array reference at %L is out of bounds "
4808 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4809 mpz_get_si (ar
->start
[i
]->value
.integer
),
4810 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4812 gfc_warning (0, "Array reference at %L is out of bounds "
4813 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4814 mpz_get_si (ar
->start
[i
]->value
.integer
),
4815 mpz_get_si (as
->upper
[i
]->value
.integer
),
4824 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4825 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4827 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4828 compare_result comp_stride_zero
= compare_bound_int (ar
->stride
[i
], 0);
4830 /* Check for zero stride, which is not allowed. */
4831 if (comp_stride_zero
== CMP_EQ
)
4833 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4837 /* if start == end || (stride > 0 && start < end)
4838 || (stride < 0 && start > end),
4839 then the array section contains at least one element. In this
4840 case, there is an out-of-bounds access if
4841 (start < lower || start > upper). */
4842 if (comp_start_end
== CMP_EQ
4843 || ((comp_stride_zero
== CMP_GT
|| ar
->stride
[i
] == NULL
)
4844 && comp_start_end
== CMP_LT
)
4845 || (comp_stride_zero
== CMP_LT
4846 && comp_start_end
== CMP_GT
))
4848 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4850 gfc_warning (0, "Lower array reference at %L is out of bounds "
4851 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4852 mpz_get_si (AR_START
->value
.integer
),
4853 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4856 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4858 gfc_warning (0, "Lower array reference at %L is out of bounds "
4859 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4860 mpz_get_si (AR_START
->value
.integer
),
4861 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4866 /* If we can compute the highest index of the array section,
4867 then it also has to be between lower and upper. */
4868 mpz_init (last_value
);
4869 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4872 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4874 gfc_warning (0, "Upper array reference at %L is out of bounds "
4875 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4876 mpz_get_si (last_value
),
4877 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4878 mpz_clear (last_value
);
4881 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4883 gfc_warning (0, "Upper array reference at %L is out of bounds "
4884 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4885 mpz_get_si (last_value
),
4886 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4887 mpz_clear (last_value
);
4891 mpz_clear (last_value
);
4899 gfc_internal_error ("check_dimension(): Bad array reference");
4906 /* Compare an array reference with an array specification. */
4909 compare_spec_to_ref (gfc_array_ref
*ar
)
4916 /* TODO: Full array sections are only allowed as actual parameters. */
4917 if (as
->type
== AS_ASSUMED_SIZE
4918 && (/*ar->type == AR_FULL
4919 ||*/ (ar
->type
== AR_SECTION
4920 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4922 gfc_error ("Rightmost upper bound of assumed size array section "
4923 "not specified at %L", &ar
->where
);
4927 if (ar
->type
== AR_FULL
)
4930 if (as
->rank
!= ar
->dimen
)
4932 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4933 &ar
->where
, ar
->dimen
, as
->rank
);
4937 /* ar->codimen == 0 is a local array. */
4938 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4940 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4941 &ar
->where
, ar
->codimen
, as
->corank
);
4945 for (i
= 0; i
< as
->rank
; i
++)
4946 if (!check_dimension (i
, ar
, as
))
4949 /* Local access has no coarray spec. */
4950 if (ar
->codimen
!= 0)
4951 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4953 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4954 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4956 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4957 i
+ 1 - as
->rank
, &ar
->where
);
4960 if (!check_dimension (i
, ar
, as
))
4968 /* Resolve one part of an array index. */
4971 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4972 int force_index_integer_kind
)
4979 if (!gfc_resolve_expr (index
))
4982 if (check_scalar
&& index
->rank
!= 0)
4984 gfc_error ("Array index at %L must be scalar", &index
->where
);
4988 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4990 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4991 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4995 if (index
->ts
.type
== BT_REAL
)
4996 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
5000 if ((index
->ts
.kind
!= gfc_index_integer_kind
5001 && force_index_integer_kind
)
5002 || index
->ts
.type
!= BT_INTEGER
)
5005 ts
.type
= BT_INTEGER
;
5006 ts
.kind
= gfc_index_integer_kind
;
5008 gfc_convert_type_warn (index
, &ts
, 2, 0);
5014 /* Resolve one part of an array index. */
5017 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
5019 return gfc_resolve_index_1 (index
, check_scalar
, 1);
5022 /* Resolve a dim argument to an intrinsic function. */
5025 gfc_resolve_dim_arg (gfc_expr
*dim
)
5030 if (!gfc_resolve_expr (dim
))
5035 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
5040 if (dim
->ts
.type
!= BT_INTEGER
)
5042 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
5046 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
5051 ts
.type
= BT_INTEGER
;
5052 ts
.kind
= gfc_index_integer_kind
;
5054 gfc_convert_type_warn (dim
, &ts
, 2, 0);
5060 /* Given an expression that contains array references, update those array
5061 references to point to the right array specifications. While this is
5062 filled in during matching, this information is difficult to save and load
5063 in a module, so we take care of it here.
5065 The idea here is that the original array reference comes from the
5066 base symbol. We traverse the list of reference structures, setting
5067 the stored reference to references. Component references can
5068 provide an additional array specification. */
5070 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
);
5073 find_array_spec (gfc_expr
*e
)
5078 bool class_as
= false;
5080 if (e
->symtree
->n
.sym
->assoc
)
5082 if (e
->symtree
->n
.sym
->assoc
->target
)
5083 gfc_resolve_expr (e
->symtree
->n
.sym
->assoc
->target
);
5084 resolve_assoc_var (e
->symtree
->n
.sym
, false);
5087 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
5089 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
5093 as
= e
->symtree
->n
.sym
->as
;
5095 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5101 locus loc
= ref
->u
.ar
.where
.lb
? ref
->u
.ar
.where
: e
->where
;
5102 gfc_error ("Invalid array reference of a non-array entity at %L",
5112 c
= ref
->u
.c
.component
;
5113 if (c
->attr
.dimension
)
5115 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
5116 gfc_internal_error ("find_array_spec(): unused as(1)");
5128 gfc_internal_error ("find_array_spec(): unused as(2)");
5134 /* Resolve an array reference. */
5137 resolve_array_ref (gfc_array_ref
*ar
)
5139 int i
, check_scalar
;
5142 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
5144 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
5146 /* Do not force gfc_index_integer_kind for the start. We can
5147 do fine with any integer kind. This avoids temporary arrays
5148 created for indexing with a vector. */
5149 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
5151 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
5153 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
5158 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
5162 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
5166 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
5167 if (e
->expr_type
== EXPR_VARIABLE
5168 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
5169 ar
->start
[i
] = gfc_get_parentheses (e
);
5173 gfc_error ("Array index at %L is an array of rank %d",
5174 &ar
->c_where
[i
], e
->rank
);
5178 /* Fill in the upper bound, which may be lower than the
5179 specified one for something like a(2:10:5), which is
5180 identical to a(2:7:5). Only relevant for strides not equal
5181 to one. Don't try a division by zero. */
5182 if (ar
->dimen_type
[i
] == DIMEN_RANGE
5183 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
5184 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
5185 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
5189 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
5191 if (ar
->end
[i
] == NULL
)
5194 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
5196 mpz_set (ar
->end
[i
]->value
.integer
, end
);
5198 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
5199 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
5201 mpz_set (ar
->end
[i
]->value
.integer
, end
);
5212 if (ar
->type
== AR_FULL
)
5214 if (ar
->as
->rank
== 0)
5215 ar
->type
= AR_ELEMENT
;
5217 /* Make sure array is the same as array(:,:), this way
5218 we don't need to special case all the time. */
5219 ar
->dimen
= ar
->as
->rank
;
5220 for (i
= 0; i
< ar
->dimen
; i
++)
5222 ar
->dimen_type
[i
] = DIMEN_RANGE
;
5224 gcc_assert (ar
->start
[i
] == NULL
);
5225 gcc_assert (ar
->end
[i
] == NULL
);
5226 gcc_assert (ar
->stride
[i
] == NULL
);
5230 /* If the reference type is unknown, figure out what kind it is. */
5232 if (ar
->type
== AR_UNKNOWN
)
5234 ar
->type
= AR_ELEMENT
;
5235 for (i
= 0; i
< ar
->dimen
; i
++)
5236 if (ar
->dimen_type
[i
] == DIMEN_RANGE
5237 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5239 ar
->type
= AR_SECTION
;
5244 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
5247 if (ar
->as
->corank
&& ar
->codimen
== 0)
5250 ar
->codimen
= ar
->as
->corank
;
5251 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
5252 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
5260 gfc_resolve_substring (gfc_ref
*ref
, bool *equal_length
)
5262 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5264 if (ref
->u
.ss
.start
!= NULL
)
5266 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
5269 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
5271 gfc_error ("Substring start index at %L must be of type INTEGER",
5272 &ref
->u
.ss
.start
->where
);
5276 if (ref
->u
.ss
.start
->rank
!= 0)
5278 gfc_error ("Substring start index at %L must be scalar",
5279 &ref
->u
.ss
.start
->where
);
5283 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
5284 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5285 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5287 gfc_error ("Substring start index at %L is less than one",
5288 &ref
->u
.ss
.start
->where
);
5293 if (ref
->u
.ss
.end
!= NULL
)
5295 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
5298 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
5300 gfc_error ("Substring end index at %L must be of type INTEGER",
5301 &ref
->u
.ss
.end
->where
);
5305 if (ref
->u
.ss
.end
->rank
!= 0)
5307 gfc_error ("Substring end index at %L must be scalar",
5308 &ref
->u
.ss
.end
->where
);
5312 if (ref
->u
.ss
.length
!= NULL
5313 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
5314 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5315 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5317 gfc_error ("Substring end index at %L exceeds the string length",
5318 &ref
->u
.ss
.start
->where
);
5322 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
5323 gfc_integer_kinds
[k
].huge
) == CMP_GT
5324 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5325 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5327 gfc_error ("Substring end index at %L is too large",
5328 &ref
->u
.ss
.end
->where
);
5331 /* If the substring has the same length as the original
5332 variable, the reference itself can be deleted. */
5334 if (ref
->u
.ss
.length
!= NULL
5335 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
5336 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
5337 *equal_length
= true;
5344 /* This function supplies missing substring charlens. */
5347 gfc_resolve_substring_charlen (gfc_expr
*e
)
5350 gfc_expr
*start
, *end
;
5351 gfc_typespec
*ts
= NULL
;
5354 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5356 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5358 if (char_ref
->type
== REF_COMPONENT
)
5359 ts
= &char_ref
->u
.c
.component
->ts
;
5362 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5365 gcc_assert (char_ref
->next
== NULL
);
5369 if (e
->ts
.u
.cl
->length
)
5370 gfc_free_expr (e
->ts
.u
.cl
->length
);
5371 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5376 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5378 if (char_ref
->u
.ss
.start
)
5379 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5381 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5383 if (char_ref
->u
.ss
.end
)
5384 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5385 else if (e
->expr_type
== EXPR_VARIABLE
)
5388 ts
= &e
->symtree
->n
.sym
->ts
;
5389 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5396 gfc_free_expr (start
);
5397 gfc_free_expr (end
);
5401 /* Length = (end - start + 1).
5402 Check first whether it has a constant length. */
5403 if (gfc_dep_difference (end
, start
, &diff
))
5405 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5408 mpz_add_ui (len
->value
.integer
, diff
, 1);
5410 e
->ts
.u
.cl
->length
= len
;
5411 /* The check for length < 0 is handled below */
5415 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5416 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5417 gfc_get_int_expr (gfc_charlen_int_kind
,
5421 /* F2008, 6.4.1: Both the starting point and the ending point shall
5422 be within the range 1, 2, ..., n unless the starting point exceeds
5423 the ending point, in which case the substring has length zero. */
5425 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5426 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5428 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5429 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5431 /* Make sure that the length is simplified. */
5432 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5433 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5437 /* Resolve subtype references. */
5440 gfc_resolve_ref (gfc_expr
*expr
)
5442 int current_part_dimension
, n_components
, seen_part_dimension
, dim
;
5443 gfc_ref
*ref
, **prev
, *array_ref
;
5446 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5447 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5449 if (!find_array_spec (expr
))
5454 for (prev
= &expr
->ref
; *prev
!= NULL
;
5455 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5456 switch ((*prev
)->type
)
5459 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5468 equal_length
= false;
5469 if (!gfc_resolve_substring (*prev
, &equal_length
))
5472 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5474 /* Remove the reference and move the charlen, if any. */
5478 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5479 ref
->u
.ss
.length
= NULL
;
5480 gfc_free_ref_list (ref
);
5485 /* Check constraints on part references. */
5487 current_part_dimension
= 0;
5488 seen_part_dimension
= 0;
5492 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5498 switch (ref
->u
.ar
.type
)
5501 /* Coarray scalar. */
5502 if (ref
->u
.ar
.as
->rank
== 0)
5504 current_part_dimension
= 0;
5509 current_part_dimension
= 1;
5514 current_part_dimension
= 0;
5518 gfc_internal_error ("resolve_ref(): Bad array reference");
5524 if (current_part_dimension
|| seen_part_dimension
)
5527 if (ref
->u
.c
.component
->attr
.pointer
5528 || ref
->u
.c
.component
->attr
.proc_pointer
5529 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5530 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5532 gfc_error ("Component to the right of a part reference "
5533 "with nonzero rank must not have the POINTER "
5534 "attribute at %L", &expr
->where
);
5537 else if (ref
->u
.c
.component
->attr
.allocatable
5538 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5539 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5542 gfc_error ("Component to the right of a part reference "
5543 "with nonzero rank must not have the ALLOCATABLE "
5544 "attribute at %L", &expr
->where
);
5556 /* Implement requirement in note 9.7 of F2018 that the result of the
5557 LEN inquiry be a scalar. */
5558 if (ref
->u
.i
== INQUIRY_LEN
&& array_ref
5559 && ((expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->length
)
5560 || expr
->ts
.type
== BT_INTEGER
))
5562 array_ref
->u
.ar
.type
= AR_ELEMENT
;
5564 /* INQUIRY_LEN is not evaluated from the rest of the expr
5565 but directly from the string length. This means that setting
5566 the array indices to one does not matter but might trigger
5567 a runtime bounds error. Suppress the check. */
5568 expr
->no_bounds_check
= 1;
5569 for (dim
= 0; dim
< array_ref
->u
.ar
.dimen
; dim
++)
5571 array_ref
->u
.ar
.dimen_type
[dim
] = DIMEN_ELEMENT
;
5572 if (array_ref
->u
.ar
.start
[dim
])
5573 gfc_free_expr (array_ref
->u
.ar
.start
[dim
]);
5574 array_ref
->u
.ar
.start
[dim
]
5575 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
5576 if (array_ref
->u
.ar
.end
[dim
])
5577 gfc_free_expr (array_ref
->u
.ar
.end
[dim
]);
5578 if (array_ref
->u
.ar
.stride
[dim
])
5579 gfc_free_expr (array_ref
->u
.ar
.stride
[dim
]);
5585 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5586 || ref
->next
== NULL
)
5587 && current_part_dimension
5588 && seen_part_dimension
)
5590 gfc_error ("Two or more part references with nonzero rank must "
5591 "not be specified at %L", &expr
->where
);
5595 if (ref
->type
== REF_COMPONENT
)
5597 if (current_part_dimension
)
5598 seen_part_dimension
= 1;
5600 /* reset to make sure */
5601 current_part_dimension
= 0;
5609 /* Given an expression, determine its shape. This is easier than it sounds.
5610 Leaves the shape array NULL if it is not possible to determine the shape. */
5613 expression_shape (gfc_expr
*e
)
5615 mpz_t array
[GFC_MAX_DIMENSIONS
];
5618 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5621 for (i
= 0; i
< e
->rank
; i
++)
5622 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5625 e
->shape
= gfc_get_shape (e
->rank
);
5627 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5632 for (i
--; i
>= 0; i
--)
5633 mpz_clear (array
[i
]);
5637 /* Given a variable expression node, compute the rank of the expression by
5638 examining the base symbol and any reference structures it may have. */
5641 gfc_expression_rank (gfc_expr
*e
)
5646 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5647 could lead to serious confusion... */
5648 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5652 if (e
->expr_type
== EXPR_ARRAY
)
5654 /* Constructors can have a rank different from one via RESHAPE(). */
5656 e
->rank
= ((e
->symtree
== NULL
|| e
->symtree
->n
.sym
->as
== NULL
)
5657 ? 0 : e
->symtree
->n
.sym
->as
->rank
);
5663 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5665 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5666 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5667 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5669 if (ref
->type
!= REF_ARRAY
)
5672 if (ref
->u
.ar
.type
== AR_FULL
)
5674 rank
= ref
->u
.ar
.as
->rank
;
5678 if (ref
->u
.ar
.type
== AR_SECTION
)
5680 /* Figure out the rank of the section. */
5682 gfc_internal_error ("gfc_expression_rank(): Two array specs");
5684 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5685 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5686 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5696 expression_shape (e
);
5700 /* Given two expressions, check that their rank is conformable, i.e. either
5701 both have the same rank or at least one is a scalar. */
5704 gfc_op_rank_conformable (gfc_expr
*op1
, gfc_expr
*op2
)
5706 if (op1
->expr_type
== EXPR_VARIABLE
)
5707 gfc_expression_rank (op1
);
5708 if (op2
->expr_type
== EXPR_VARIABLE
)
5709 gfc_expression_rank (op2
);
5711 return (op1
->rank
== 0 || op2
->rank
== 0 || op1
->rank
== op2
->rank
);
5716 add_caf_get_intrinsic (gfc_expr
*e
)
5718 gfc_expr
*wrapper
, *tmp_expr
;
5722 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5723 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5728 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5729 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5732 tmp_expr
= XCNEW (gfc_expr
);
5734 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5735 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5736 wrapper
->ts
= e
->ts
;
5737 wrapper
->rank
= e
->rank
;
5739 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5746 remove_caf_get_intrinsic (gfc_expr
*e
)
5748 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5749 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5750 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5751 e
->value
.function
.actual
->expr
= NULL
;
5752 gfc_free_actual_arglist (e
->value
.function
.actual
);
5753 gfc_free_shape (&e
->shape
, e
->rank
);
5759 /* Resolve a variable expression. */
5762 resolve_variable (gfc_expr
*e
)
5769 if (e
->symtree
== NULL
)
5771 sym
= e
->symtree
->n
.sym
;
5773 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5774 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5775 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5777 if (!actual_arg
|| inquiry_argument
)
5779 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5780 "be used as actual argument", sym
->name
, &e
->where
);
5784 /* TS 29113, 407b. */
5785 else if (e
->ts
.type
== BT_ASSUMED
)
5789 gfc_error ("Assumed-type variable %s at %L may only be used "
5790 "as actual argument", sym
->name
, &e
->where
);
5793 else if (inquiry_argument
&& !first_actual_arg
)
5795 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5796 for all inquiry functions in resolve_function; the reason is
5797 that the function-name resolution happens too late in that
5799 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5800 "an inquiry function shall be the first argument",
5801 sym
->name
, &e
->where
);
5805 /* TS 29113, C535b. */
5806 else if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5807 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
5808 && CLASS_DATA (sym
)->as
5809 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5810 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5811 && sym
->as
->type
== AS_ASSUMED_RANK
))
5812 && !sym
->attr
.select_rank_temporary
)
5815 && !(cs_base
&& cs_base
->current
5816 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
5818 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5819 "actual argument", sym
->name
, &e
->where
);
5822 else if (inquiry_argument
&& !first_actual_arg
)
5824 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5825 for all inquiry functions in resolve_function; the reason is
5826 that the function-name resolution happens too late in that
5828 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5829 "to an inquiry function shall be the first argument",
5830 sym
->name
, &e
->where
);
5835 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5836 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5837 && e
->ref
->next
== NULL
))
5839 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5840 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5843 /* TS 29113, 407b. */
5844 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5845 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5846 && e
->ref
->next
== NULL
))
5848 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5849 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5853 /* TS 29113, C535b. */
5854 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5855 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
5856 && CLASS_DATA (sym
)->as
5857 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5858 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5859 && sym
->as
->type
== AS_ASSUMED_RANK
))
5861 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5862 && e
->ref
->next
== NULL
))
5864 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5865 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5869 /* For variables that are used in an associate (target => object) where
5870 the object's basetype is array valued while the target is scalar,
5871 the ts' type of the component refs is still array valued, which
5872 can't be translated that way. */
5873 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5874 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5875 && sym
->assoc
->target
->ts
.u
.derived
5876 && CLASS_DATA (sym
->assoc
->target
)
5877 && CLASS_DATA (sym
->assoc
->target
)->as
)
5879 gfc_ref
*ref
= e
->ref
;
5885 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5886 /* Stop the loop. */
5896 /* If this is an associate-name, it may be parsed with an array reference
5897 in error even though the target is scalar. Fail directly in this case.
5898 TODO Understand why class scalar expressions must be excluded. */
5899 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5901 if (sym
->ts
.type
== BT_CLASS
)
5902 gfc_fix_class_refs (e
);
5903 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5905 /* Unambiguously scalar! */
5906 if (sym
->assoc
->target
5907 && (sym
->assoc
->target
->expr_type
== EXPR_CONSTANT
5908 || sym
->assoc
->target
->expr_type
== EXPR_STRUCTURE
))
5909 gfc_error ("Scalar variable %qs has an array reference at %L",
5910 sym
->name
, &e
->where
);
5913 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5915 /* This can happen because the parser did not detect that the
5916 associate name is an array and the expression had no array
5918 gfc_ref
*ref
= gfc_get_ref ();
5919 ref
->type
= REF_ARRAY
;
5920 ref
->u
.ar
.type
= AR_FULL
;
5923 ref
->u
.ar
.as
= sym
->as
;
5924 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5932 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5933 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5935 /* On the other hand, the parser may not have known this is an array;
5936 in this case, we have to add a FULL reference. */
5937 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5939 e
->ref
= gfc_get_ref ();
5940 e
->ref
->type
= REF_ARRAY
;
5941 e
->ref
->u
.ar
.type
= AR_FULL
;
5942 e
->ref
->u
.ar
.dimen
= 0;
5945 /* Like above, but for class types, where the checking whether an array
5946 ref is present is more complicated. Furthermore make sure not to add
5947 the full array ref to _vptr or _len refs. */
5948 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5950 && CLASS_DATA (sym
)->attr
.dimension
5951 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5953 gfc_ref
*ref
, *newref
;
5955 newref
= gfc_get_ref ();
5956 newref
->type
= REF_ARRAY
;
5957 newref
->u
.ar
.type
= AR_FULL
;
5958 newref
->u
.ar
.dimen
= 0;
5959 /* Because this is an associate var and the first ref either is a ref to
5960 the _data component or not, no traversal of the ref chain is
5961 needed. The array ref needs to be inserted after the _data ref,
5962 or when that is not present, which may happened for polymorphic
5963 types, then at the first position. */
5967 else if (ref
->type
== REF_COMPONENT
5968 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5970 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5972 newref
->next
= ref
->next
;
5976 /* Array ref present already. */
5977 gfc_free_ref_list (newref
);
5979 else if (ref
->type
== REF_ARRAY
)
5980 /* Array ref present already. */
5981 gfc_free_ref_list (newref
);
5989 if (e
->ref
&& !gfc_resolve_ref (e
))
5992 if (sym
->attr
.flavor
== FL_PROCEDURE
5993 && (!sym
->attr
.function
5994 || (sym
->attr
.function
&& sym
->result
5995 && sym
->result
->attr
.proc_pointer
5996 && !sym
->result
->attr
.function
)))
5998 e
->ts
.type
= BT_PROCEDURE
;
5999 goto resolve_procedure
;
6002 if (sym
->ts
.type
!= BT_UNKNOWN
)
6003 gfc_variable_attr (e
, &e
->ts
);
6004 else if (sym
->attr
.flavor
== FL_PROCEDURE
6005 && sym
->attr
.function
&& sym
->result
6006 && sym
->result
->ts
.type
!= BT_UNKNOWN
6007 && sym
->result
->attr
.proc_pointer
)
6008 e
->ts
= sym
->result
->ts
;
6011 /* Must be a simple variable reference. */
6012 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
6017 if (check_assumed_size_reference (sym
, e
))
6020 /* Deal with forward references to entries during gfc_resolve_code, to
6021 satisfy, at least partially, 12.5.2.5. */
6022 if (gfc_current_ns
->entries
6023 && current_entry_id
== sym
->entry_id
6026 && cs_base
->current
->op
!= EXEC_ENTRY
)
6028 gfc_entry_list
*entry
;
6029 gfc_formal_arglist
*formal
;
6031 bool seen
, saved_specification_expr
;
6033 /* If the symbol is a dummy... */
6034 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
6036 entry
= gfc_current_ns
->entries
;
6039 /* ...test if the symbol is a parameter of previous entries. */
6040 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
6041 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
6043 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
6050 /* If it has not been seen as a dummy, this is an error. */
6053 if (specification_expr
)
6054 gfc_error ("Variable %qs, used in a specification expression"
6055 ", is referenced at %L before the ENTRY statement "
6056 "in which it is a parameter",
6057 sym
->name
, &cs_base
->current
->loc
);
6059 gfc_error ("Variable %qs is used at %L before the ENTRY "
6060 "statement in which it is a parameter",
6061 sym
->name
, &cs_base
->current
->loc
);
6066 /* Now do the same check on the specification expressions. */
6067 saved_specification_expr
= specification_expr
;
6068 specification_expr
= true;
6069 if (sym
->ts
.type
== BT_CHARACTER
6070 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
6074 for (n
= 0; n
< sym
->as
->rank
; n
++)
6076 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
6078 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
6081 specification_expr
= saved_specification_expr
;
6084 /* Update the symbol's entry level. */
6085 sym
->entry_id
= current_entry_id
+ 1;
6088 /* If a symbol has been host_associated mark it. This is used latter,
6089 to identify if aliasing is possible via host association. */
6090 if (sym
->attr
.flavor
== FL_VARIABLE
6091 && gfc_current_ns
->parent
6092 && (gfc_current_ns
->parent
== sym
->ns
6093 || (gfc_current_ns
->parent
->parent
6094 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
6095 sym
->attr
.host_assoc
= 1;
6097 if (gfc_current_ns
->proc_name
6098 && sym
->attr
.dimension
6099 && (sym
->ns
!= gfc_current_ns
6100 || sym
->attr
.use_assoc
6101 || sym
->attr
.in_common
))
6102 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
6105 if (t
&& !resolve_procedure_expression (e
))
6108 /* F2008, C617 and C1229. */
6109 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
6110 && gfc_is_coindexed (e
))
6112 gfc_ref
*ref
, *ref2
= NULL
;
6114 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6116 if (ref
->type
== REF_COMPONENT
)
6118 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
6122 for ( ; ref
; ref
= ref
->next
)
6123 if (ref
->type
== REF_COMPONENT
)
6126 /* Expression itself is not coindexed object. */
6127 if (ref
&& e
->ts
.type
== BT_CLASS
)
6129 gfc_error ("Polymorphic subobject of coindexed object at %L",
6134 /* Expression itself is coindexed object. */
6138 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
6139 for ( ; c
; c
= c
->next
)
6140 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
6142 gfc_error ("Coindexed object with polymorphic allocatable "
6143 "subcomponent at %L", &e
->where
);
6151 gfc_expression_rank (e
);
6153 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
6154 add_caf_get_intrinsic (e
);
6156 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
) && sym
!= sym
->result
)
6157 gfc_warning (OPT_Wdeprecated_declarations
,
6158 "Using variable %qs at %L is deprecated",
6159 sym
->name
, &e
->where
);
6160 /* Simplify cases where access to a parameter array results in a
6161 single constant. Suppress errors since those will have been
6162 issued before, as warnings. */
6163 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
6165 gfc_push_suppress_errors ();
6166 gfc_simplify_expr (e
, 1);
6167 gfc_pop_suppress_errors ();
6174 /* Checks to see that the correct symbol has been host associated.
6175 The only situations where this arises are:
6176 (i) That in which a twice contained function is parsed after
6177 the host association is made. On detecting this, change
6178 the symbol in the expression and convert the array reference
6179 into an actual arglist if the old symbol is a variable; or
6180 (ii) That in which an external function is typed but not declared
6181 explicitly to be external. Here, the old symbol is changed
6182 from a variable to an external function. */
6184 check_host_association (gfc_expr
*e
)
6186 gfc_symbol
*sym
, *old_sym
;
6190 gfc_actual_arglist
*arg
, *tail
= NULL
;
6191 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
6193 /* If the expression is the result of substitution in
6194 interface.cc(gfc_extend_expr) because there is no way in
6195 which the host association can be wrong. */
6196 if (e
->symtree
== NULL
6197 || e
->symtree
->n
.sym
== NULL
6198 || e
->user_operator
)
6201 old_sym
= e
->symtree
->n
.sym
;
6203 if (gfc_current_ns
->parent
6204 && old_sym
->ns
!= gfc_current_ns
)
6206 /* Use the 'USE' name so that renamed module symbols are
6207 correctly handled. */
6208 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
6210 if (sym
&& old_sym
!= sym
6211 && sym
->attr
.flavor
== FL_PROCEDURE
6212 && sym
->attr
.contained
)
6214 /* Clear the shape, since it might not be valid. */
6215 gfc_free_shape (&e
->shape
, e
->rank
);
6217 /* Give the expression the right symtree! */
6218 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
6219 gcc_assert (st
!= NULL
);
6221 if (old_sym
->attr
.flavor
== FL_PROCEDURE
6222 || e
->expr_type
== EXPR_FUNCTION
)
6224 /* Original was function so point to the new symbol, since
6225 the actual argument list is already attached to the
6227 e
->value
.function
.esym
= NULL
;
6232 /* Original was variable so convert array references into
6233 an actual arglist. This does not need any checking now
6234 since resolve_function will take care of it. */
6235 e
->value
.function
.actual
= NULL
;
6236 e
->expr_type
= EXPR_FUNCTION
;
6239 /* Ambiguity will not arise if the array reference is not
6240 the last reference. */
6241 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6242 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6245 if ((ref
== NULL
|| ref
->type
!= REF_ARRAY
)
6246 && sym
->attr
.proc
== PROC_INTERNAL
)
6248 gfc_error ("%qs at %L is host associated at %L into "
6249 "a contained procedure with an internal "
6250 "procedure of the same name", sym
->name
,
6251 &old_sym
->declared_at
, &e
->where
);
6258 gcc_assert (ref
->type
== REF_ARRAY
);
6260 /* Grab the start expressions from the array ref and
6261 copy them into actual arguments. */
6262 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6264 arg
= gfc_get_actual_arglist ();
6265 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
6266 if (e
->value
.function
.actual
== NULL
)
6267 tail
= e
->value
.function
.actual
= arg
;
6275 /* Dump the reference list and set the rank. */
6276 gfc_free_ref_list (e
->ref
);
6278 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
6281 gfc_resolve_expr (e
);
6284 /* This case corresponds to a call, from a block or a contained
6285 procedure, to an external function, which has not been declared
6286 as being external in the main program but has been typed. */
6287 else if (sym
&& old_sym
!= sym
6289 && sym
->ts
.type
== BT_UNKNOWN
6290 && old_sym
->ts
.type
!= BT_UNKNOWN
6291 && sym
->attr
.flavor
== FL_PROCEDURE
6292 && old_sym
->attr
.flavor
== FL_VARIABLE
6293 && sym
->ns
->parent
== old_sym
->ns
6294 && sym
->ns
->proc_name
6295 && sym
->ns
->proc_name
->attr
.proc
!= PROC_MODULE
6296 && (sym
->ns
->proc_name
->attr
.flavor
== FL_LABEL
6297 || sym
->ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
))
6299 old_sym
->attr
.flavor
= FL_PROCEDURE
;
6300 old_sym
->attr
.external
= 1;
6301 old_sym
->attr
.function
= 1;
6302 old_sym
->result
= old_sym
;
6303 gfc_resolve_expr (e
);
6306 /* This might have changed! */
6307 return e
->expr_type
== EXPR_FUNCTION
;
6312 gfc_resolve_character_operator (gfc_expr
*e
)
6314 gfc_expr
*op1
= e
->value
.op
.op1
;
6315 gfc_expr
*op2
= e
->value
.op
.op2
;
6316 gfc_expr
*e1
= NULL
;
6317 gfc_expr
*e2
= NULL
;
6319 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
6321 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
6322 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
6323 else if (op1
->expr_type
== EXPR_CONSTANT
)
6324 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
6325 op1
->value
.character
.length
);
6327 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
6328 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
6329 else if (op2
->expr_type
== EXPR_CONSTANT
)
6330 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
6331 op2
->value
.character
.length
);
6333 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6343 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
6344 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
6345 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
6346 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
6347 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
6353 /* Ensure that an character expression has a charlen and, if possible, a
6354 length expression. */
6357 fixup_charlen (gfc_expr
*e
)
6359 /* The cases fall through so that changes in expression type and the need
6360 for multiple fixes are picked up. In all circumstances, a charlen should
6361 be available for the middle end to hang a backend_decl on. */
6362 switch (e
->expr_type
)
6365 gfc_resolve_character_operator (e
);
6369 if (e
->expr_type
== EXPR_ARRAY
)
6370 gfc_resolve_character_array_constructor (e
);
6373 case EXPR_SUBSTRING
:
6374 if (!e
->ts
.u
.cl
&& e
->ref
)
6375 gfc_resolve_substring_charlen (e
);
6380 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6387 /* Update an actual argument to include the passed-object for type-bound
6388 procedures at the right position. */
6390 static gfc_actual_arglist
*
6391 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
6394 gcc_assert (argpos
> 0);
6398 gfc_actual_arglist
* result
;
6400 result
= gfc_get_actual_arglist ();
6404 result
->name
= name
;
6410 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
6412 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
6417 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6420 extract_compcall_passed_object (gfc_expr
* e
)
6424 if (e
->expr_type
== EXPR_UNKNOWN
)
6426 gfc_error ("Error in typebound call at %L",
6431 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6433 if (e
->value
.compcall
.base_object
)
6434 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
6437 po
= gfc_get_expr ();
6438 po
->expr_type
= EXPR_VARIABLE
;
6439 po
->symtree
= e
->symtree
;
6440 po
->ref
= gfc_copy_ref (e
->ref
);
6441 po
->where
= e
->where
;
6444 if (!gfc_resolve_expr (po
))
6451 /* Update the arglist of an EXPR_COMPCALL expression to include the
6455 update_compcall_arglist (gfc_expr
* e
)
6458 gfc_typebound_proc
* tbp
;
6460 tbp
= e
->value
.compcall
.tbp
;
6465 po
= extract_compcall_passed_object (e
);
6469 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6475 if (tbp
->pass_arg_num
<= 0)
6478 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6486 /* Extract the passed object from a PPC call (a copy of it). */
6489 extract_ppc_passed_object (gfc_expr
*e
)
6494 po
= gfc_get_expr ();
6495 po
->expr_type
= EXPR_VARIABLE
;
6496 po
->symtree
= e
->symtree
;
6497 po
->ref
= gfc_copy_ref (e
->ref
);
6498 po
->where
= e
->where
;
6500 /* Remove PPC reference. */
6502 while ((*ref
)->next
)
6503 ref
= &(*ref
)->next
;
6504 gfc_free_ref_list (*ref
);
6507 if (!gfc_resolve_expr (po
))
6514 /* Update the actual arglist of a procedure pointer component to include the
6518 update_ppc_arglist (gfc_expr
* e
)
6522 gfc_typebound_proc
* tb
;
6524 ppc
= gfc_get_proc_ptr_comp (e
);
6532 else if (tb
->nopass
)
6535 po
= extract_ppc_passed_object (e
);
6542 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6547 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6549 gfc_error ("Base object for procedure-pointer component call at %L is of"
6550 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6554 gcc_assert (tb
->pass_arg_num
> 0);
6555 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6563 /* Check that the object a TBP is called on is valid, i.e. it must not be
6564 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6567 check_typebound_baseobject (gfc_expr
* e
)
6570 bool return_value
= false;
6572 base
= extract_compcall_passed_object (e
);
6576 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6578 gfc_error ("Error in typebound call at %L", &e
->where
);
6582 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6586 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6588 gfc_error ("Base object for type-bound procedure call at %L is of"
6589 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6593 /* F08:C1230. If the procedure called is NOPASS,
6594 the base object must be scalar. */
6595 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6597 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6598 " be scalar", &e
->where
);
6602 return_value
= true;
6605 gfc_free_expr (base
);
6606 return return_value
;
6610 /* Resolve a call to a type-bound procedure, either function or subroutine,
6611 statically from the data in an EXPR_COMPCALL expression. The adapted
6612 arglist and the target-procedure symtree are returned. */
6615 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6616 gfc_actual_arglist
** actual
)
6618 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6619 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6621 /* Update the actual arglist for PASS. */
6622 if (!update_compcall_arglist (e
))
6625 *actual
= e
->value
.compcall
.actual
;
6626 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6628 gfc_free_ref_list (e
->ref
);
6630 e
->value
.compcall
.actual
= NULL
;
6632 /* If we find a deferred typebound procedure, check for derived types
6633 that an overriding typebound procedure has not been missed. */
6634 if (e
->value
.compcall
.name
6635 && !e
->value
.compcall
.tbp
->non_overridable
6636 && e
->value
.compcall
.base_object
6637 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6640 gfc_symbol
*derived
;
6642 /* Use the derived type of the base_object. */
6643 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6646 /* If necessary, go through the inheritance chain. */
6647 while (!st
&& derived
)
6649 /* Look for the typebound procedure 'name'. */
6650 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6651 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6652 e
->value
.compcall
.name
);
6654 derived
= gfc_get_derived_super_type (derived
);
6657 /* Now find the specific name in the derived type namespace. */
6658 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6659 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6660 derived
->ns
, 1, &st
);
6668 /* Get the ultimate declared type from an expression. In addition,
6669 return the last class/derived type reference and the copy of the
6670 reference list. If check_types is set true, derived types are
6671 identified as well as class references. */
6673 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6674 gfc_expr
*e
, bool check_types
)
6676 gfc_symbol
*declared
;
6683 *new_ref
= gfc_copy_ref (e
->ref
);
6685 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6687 if (ref
->type
!= REF_COMPONENT
)
6690 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6691 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6692 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6694 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6700 if (declared
== NULL
)
6701 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6707 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6708 which of the specific bindings (if any) matches the arglist and transform
6709 the expression into a call of that binding. */
6712 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6714 gfc_typebound_proc
* genproc
;
6715 const char* genname
;
6717 gfc_symbol
*derived
;
6719 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6720 genname
= e
->value
.compcall
.name
;
6721 genproc
= e
->value
.compcall
.tbp
;
6723 if (!genproc
->is_generic
)
6726 /* Try the bindings on this type and in the inheritance hierarchy. */
6727 for (; genproc
; genproc
= genproc
->overridden
)
6731 gcc_assert (genproc
->is_generic
);
6732 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6735 gfc_actual_arglist
* args
;
6738 gcc_assert (g
->specific
);
6740 if (g
->specific
->error
)
6743 target
= g
->specific
->u
.specific
->n
.sym
;
6745 /* Get the right arglist by handling PASS/NOPASS. */
6746 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6747 if (!g
->specific
->nopass
)
6750 po
= extract_compcall_passed_object (e
);
6753 gfc_free_actual_arglist (args
);
6757 gcc_assert (g
->specific
->pass_arg_num
> 0);
6758 gcc_assert (!g
->specific
->error
);
6759 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6760 g
->specific
->pass_arg
);
6762 resolve_actual_arglist (args
, target
->attr
.proc
,
6763 is_external_proc (target
)
6764 && gfc_sym_get_dummy_args (target
) == NULL
);
6766 /* Check if this arglist matches the formal. */
6767 matches
= gfc_arglist_matches_symbol (&args
, target
);
6769 /* Clean up and break out of the loop if we've found it. */
6770 gfc_free_actual_arglist (args
);
6773 e
->value
.compcall
.tbp
= g
->specific
;
6774 genname
= g
->specific_st
->name
;
6775 /* Pass along the name for CLASS methods, where the vtab
6776 procedure pointer component has to be referenced. */
6784 /* Nothing matching found! */
6785 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6786 " %qs at %L", genname
, &e
->where
);
6790 /* Make sure that we have the right specific instance for the name. */
6791 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6793 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6795 e
->value
.compcall
.tbp
= st
->n
.tb
;
6801 /* Resolve a call to a type-bound subroutine. */
6804 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6806 gfc_actual_arglist
* newactual
;
6807 gfc_symtree
* target
;
6809 /* Check that's really a SUBROUTINE. */
6810 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6812 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6813 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6814 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6815 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6816 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6819 gfc_error ("%qs at %L should be a SUBROUTINE",
6820 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6825 if (!check_typebound_baseobject (c
->expr1
))
6828 /* Pass along the name for CLASS methods, where the vtab
6829 procedure pointer component has to be referenced. */
6831 *name
= c
->expr1
->value
.compcall
.name
;
6833 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6836 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6838 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6840 /* Transform into an ordinary EXEC_CALL for now. */
6842 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6845 c
->ext
.actual
= newactual
;
6846 c
->symtree
= target
;
6847 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6849 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6851 gfc_free_expr (c
->expr1
);
6852 c
->expr1
= gfc_get_expr ();
6853 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6854 c
->expr1
->symtree
= target
;
6855 c
->expr1
->where
= c
->loc
;
6857 return resolve_call (c
);
6861 /* Resolve a component-call expression. */
6863 resolve_compcall (gfc_expr
* e
, const char **name
)
6865 gfc_actual_arglist
* newactual
;
6866 gfc_symtree
* target
;
6868 /* Check that's really a FUNCTION. */
6869 if (!e
->value
.compcall
.tbp
->function
)
6871 gfc_error ("%qs at %L should be a FUNCTION",
6872 e
->value
.compcall
.name
, &e
->where
);
6877 /* These must not be assign-calls! */
6878 gcc_assert (!e
->value
.compcall
.assign
);
6880 if (!check_typebound_baseobject (e
))
6883 /* Pass along the name for CLASS methods, where the vtab
6884 procedure pointer component has to be referenced. */
6886 *name
= e
->value
.compcall
.name
;
6888 if (!resolve_typebound_generic_call (e
, name
))
6890 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6892 /* Take the rank from the function's symbol. */
6893 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6894 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6896 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6897 arglist to the TBP's binding target. */
6899 if (!resolve_typebound_static (e
, &target
, &newactual
))
6902 e
->value
.function
.actual
= newactual
;
6903 e
->value
.function
.name
= NULL
;
6904 e
->value
.function
.esym
= target
->n
.sym
;
6905 e
->value
.function
.isym
= NULL
;
6906 e
->symtree
= target
;
6907 e
->ts
= target
->n
.sym
->ts
;
6908 e
->expr_type
= EXPR_FUNCTION
;
6910 /* Resolution is not necessary if this is a class subroutine; this
6911 function only has to identify the specific proc. Resolution of
6912 the call will be done next in resolve_typebound_call. */
6913 return gfc_resolve_expr (e
);
6917 static bool resolve_fl_derived (gfc_symbol
*sym
);
6920 /* Resolve a typebound function, or 'method'. First separate all
6921 the non-CLASS references by calling resolve_compcall directly. */
6924 resolve_typebound_function (gfc_expr
* e
)
6926 gfc_symbol
*declared
;
6938 /* Deal with typebound operators for CLASS objects. */
6939 expr
= e
->value
.compcall
.base_object
;
6940 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6941 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6943 /* Since the typebound operators are generic, we have to ensure
6944 that any delays in resolution are corrected and that the vtab
6947 declared
= ts
.u
.derived
;
6948 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6949 if (c
->ts
.u
.derived
== NULL
)
6950 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6952 if (!resolve_compcall (e
, &name
))
6955 /* Use the generic name if it is there. */
6956 name
= name
? name
: e
->value
.function
.esym
->name
;
6957 e
->symtree
= expr
->symtree
;
6958 e
->ref
= gfc_copy_ref (expr
->ref
);
6959 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6961 /* Trim away the extraneous references that emerge from nested
6962 use of interface.cc (extend_expr). */
6963 if (class_ref
&& class_ref
->next
)
6965 gfc_free_ref_list (class_ref
->next
);
6966 class_ref
->next
= NULL
;
6968 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6970 gfc_free_ref_list (e
->ref
);
6974 gfc_add_vptr_component (e
);
6975 gfc_add_component_ref (e
, name
);
6976 e
->value
.function
.esym
= NULL
;
6977 if (expr
->expr_type
!= EXPR_VARIABLE
)
6978 e
->base_expr
= expr
;
6983 return resolve_compcall (e
, NULL
);
6985 if (!gfc_resolve_ref (e
))
6988 /* Get the CLASS declared type. */
6989 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6991 if (!resolve_fl_derived (declared
))
6994 /* Weed out cases of the ultimate component being a derived type. */
6995 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6996 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6998 gfc_free_ref_list (new_ref
);
6999 return resolve_compcall (e
, NULL
);
7002 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
7004 /* Treat the call as if it is a typebound procedure, in order to roll
7005 out the correct name for the specific function. */
7006 if (!resolve_compcall (e
, &name
))
7008 gfc_free_ref_list (new_ref
);
7015 /* Convert the expression to a procedure pointer component call. */
7016 e
->value
.function
.esym
= NULL
;
7022 /* '_vptr' points to the vtab, which contains the procedure pointers. */
7023 gfc_add_vptr_component (e
);
7024 gfc_add_component_ref (e
, name
);
7026 /* Recover the typespec for the expression. This is really only
7027 necessary for generic procedures, where the additional call
7028 to gfc_add_component_ref seems to throw the collection of the
7029 correct typespec. */
7033 gfc_free_ref_list (new_ref
);
7038 /* Resolve a typebound subroutine, or 'method'. First separate all
7039 the non-CLASS references by calling resolve_typebound_call
7043 resolve_typebound_subroutine (gfc_code
*code
)
7045 gfc_symbol
*declared
;
7055 st
= code
->expr1
->symtree
;
7057 /* Deal with typebound operators for CLASS objects. */
7058 expr
= code
->expr1
->value
.compcall
.base_object
;
7059 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
7060 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
7062 /* If the base_object is not a variable, the corresponding actual
7063 argument expression must be stored in e->base_expression so
7064 that the corresponding tree temporary can be used as the base
7065 object in gfc_conv_procedure_call. */
7066 if (expr
->expr_type
!= EXPR_VARIABLE
)
7068 gfc_actual_arglist
*args
;
7070 args
= code
->expr1
->value
.function
.actual
;
7071 for (; args
; args
= args
->next
)
7072 if (expr
== args
->expr
)
7076 /* Since the typebound operators are generic, we have to ensure
7077 that any delays in resolution are corrected and that the vtab
7079 declared
= expr
->ts
.u
.derived
;
7080 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
7081 if (c
->ts
.u
.derived
== NULL
)
7082 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
7084 if (!resolve_typebound_call (code
, &name
, NULL
))
7087 /* Use the generic name if it is there. */
7088 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
7089 code
->expr1
->symtree
= expr
->symtree
;
7090 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
7092 /* Trim away the extraneous references that emerge from nested
7093 use of interface.cc (extend_expr). */
7094 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
7095 if (class_ref
&& class_ref
->next
)
7097 gfc_free_ref_list (class_ref
->next
);
7098 class_ref
->next
= NULL
;
7100 else if (code
->expr1
->ref
&& !class_ref
)
7102 gfc_free_ref_list (code
->expr1
->ref
);
7103 code
->expr1
->ref
= NULL
;
7106 /* Now use the procedure in the vtable. */
7107 gfc_add_vptr_component (code
->expr1
);
7108 gfc_add_component_ref (code
->expr1
, name
);
7109 code
->expr1
->value
.function
.esym
= NULL
;
7110 if (expr
->expr_type
!= EXPR_VARIABLE
)
7111 code
->expr1
->base_expr
= expr
;
7116 return resolve_typebound_call (code
, NULL
, NULL
);
7118 if (!gfc_resolve_ref (code
->expr1
))
7121 /* Get the CLASS declared type. */
7122 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
7124 /* Weed out cases of the ultimate component being a derived type. */
7125 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
7126 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
7128 gfc_free_ref_list (new_ref
);
7129 return resolve_typebound_call (code
, NULL
, NULL
);
7132 if (!resolve_typebound_call (code
, &name
, &overridable
))
7134 gfc_free_ref_list (new_ref
);
7137 ts
= code
->expr1
->ts
;
7141 /* Convert the expression to a procedure pointer component call. */
7142 code
->expr1
->value
.function
.esym
= NULL
;
7143 code
->expr1
->symtree
= st
;
7146 code
->expr1
->ref
= new_ref
;
7148 /* '_vptr' points to the vtab, which contains the procedure pointers. */
7149 gfc_add_vptr_component (code
->expr1
);
7150 gfc_add_component_ref (code
->expr1
, name
);
7152 /* Recover the typespec for the expression. This is really only
7153 necessary for generic procedures, where the additional call
7154 to gfc_add_component_ref seems to throw the collection of the
7155 correct typespec. */
7156 code
->expr1
->ts
= ts
;
7159 gfc_free_ref_list (new_ref
);
7165 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
7168 resolve_ppc_call (gfc_code
* c
)
7170 gfc_component
*comp
;
7172 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
7173 gcc_assert (comp
!= NULL
);
7175 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
7176 c
->expr1
->expr_type
= EXPR_VARIABLE
;
7178 if (!comp
->attr
.subroutine
)
7179 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
7181 if (!gfc_resolve_ref (c
->expr1
))
7184 if (!update_ppc_arglist (c
->expr1
))
7187 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
7189 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
7190 !(comp
->ts
.interface
7191 && comp
->ts
.interface
->formal
)))
7194 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
7197 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
7203 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
7206 resolve_expr_ppc (gfc_expr
* e
)
7208 gfc_component
*comp
;
7210 comp
= gfc_get_proc_ptr_comp (e
);
7211 gcc_assert (comp
!= NULL
);
7213 /* Convert to EXPR_FUNCTION. */
7214 e
->expr_type
= EXPR_FUNCTION
;
7215 e
->value
.function
.isym
= NULL
;
7216 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
7218 if (comp
->as
!= NULL
)
7219 e
->rank
= comp
->as
->rank
;
7221 if (!comp
->attr
.function
)
7222 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
7224 if (!gfc_resolve_ref (e
))
7227 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
7228 !(comp
->ts
.interface
7229 && comp
->ts
.interface
->formal
)))
7232 if (!update_ppc_arglist (e
))
7235 if (!check_pure_function(e
))
7238 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
7245 gfc_is_expandable_expr (gfc_expr
*e
)
7247 gfc_constructor
*con
;
7249 if (e
->expr_type
== EXPR_ARRAY
)
7251 /* Traverse the constructor looking for variables that are flavor
7252 parameter. Parameters must be expanded since they are fully used at
7254 con
= gfc_constructor_first (e
->value
.constructor
);
7255 for (; con
; con
= gfc_constructor_next (con
))
7257 if (con
->expr
->expr_type
== EXPR_VARIABLE
7258 && con
->expr
->symtree
7259 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
7260 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
7262 if (con
->expr
->expr_type
== EXPR_ARRAY
7263 && gfc_is_expandable_expr (con
->expr
))
7272 /* Sometimes variables in specification expressions of the result
7273 of module procedures in submodules wind up not being the 'real'
7274 dummy. Find this, if possible, in the namespace of the first
7278 fixup_unique_dummy (gfc_expr
*e
)
7280 gfc_symtree
*st
= NULL
;
7281 gfc_symbol
*s
= NULL
;
7283 if (e
->symtree
->n
.sym
->ns
->proc_name
7284 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
7285 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
7288 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
7291 && st
->n
.sym
!= NULL
7292 && st
->n
.sym
->attr
.dummy
)
7296 /* Resolve an expression. That is, make sure that types of operands agree
7297 with their operators, intrinsic operators are converted to function calls
7298 for overloaded types and unresolved function references are resolved. */
7301 gfc_resolve_expr (gfc_expr
*e
)
7304 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
7306 if (e
== NULL
|| e
->do_not_resolve_again
)
7309 /* inquiry_argument only applies to variables. */
7310 inquiry_save
= inquiry_argument
;
7311 actual_arg_save
= actual_arg
;
7312 first_actual_arg_save
= first_actual_arg
;
7314 if (e
->expr_type
!= EXPR_VARIABLE
)
7316 inquiry_argument
= false;
7318 first_actual_arg
= false;
7320 else if (e
->symtree
!= NULL
7321 && *e
->symtree
->name
== '@'
7322 && e
->symtree
->n
.sym
->attr
.dummy
)
7324 /* Deal with submodule specification expressions that are not
7325 found to be referenced in module.cc(read_cleanup). */
7326 fixup_unique_dummy (e
);
7329 switch (e
->expr_type
)
7332 t
= resolve_operator (e
);
7338 if (check_host_association (e
))
7339 t
= resolve_function (e
);
7341 t
= resolve_variable (e
);
7343 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
7344 && e
->ref
->type
!= REF_SUBSTRING
)
7345 gfc_resolve_substring_charlen (e
);
7350 t
= resolve_typebound_function (e
);
7353 case EXPR_SUBSTRING
:
7354 t
= gfc_resolve_ref (e
);
7363 t
= resolve_expr_ppc (e
);
7368 if (!gfc_resolve_ref (e
))
7371 t
= gfc_resolve_array_constructor (e
);
7372 /* Also try to expand a constructor. */
7375 gfc_expression_rank (e
);
7376 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
7377 gfc_expand_constructor (e
, false);
7380 /* This provides the opportunity for the length of constructors with
7381 character valued function elements to propagate the string length
7382 to the expression. */
7383 if (t
&& e
->ts
.type
== BT_CHARACTER
)
7385 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
7386 here rather then add a duplicate test for it above. */
7387 gfc_expand_constructor (e
, false);
7388 t
= gfc_resolve_character_array_constructor (e
);
7393 case EXPR_STRUCTURE
:
7394 t
= gfc_resolve_ref (e
);
7398 t
= resolve_structure_cons (e
, 0);
7402 t
= gfc_simplify_expr (e
, 0);
7406 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7409 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
7412 inquiry_argument
= inquiry_save
;
7413 actual_arg
= actual_arg_save
;
7414 first_actual_arg
= first_actual_arg_save
;
7416 /* For some reason, resolving these expressions a second time mangles
7417 the typespec of the expression itself. */
7418 if (t
&& e
->expr_type
== EXPR_VARIABLE
7419 && e
->symtree
->n
.sym
->attr
.select_rank_temporary
7420 && UNLIMITED_POLY (e
->symtree
->n
.sym
))
7421 e
->do_not_resolve_again
= 1;
7427 /* Resolve an expression from an iterator. They must be scalar and have
7428 INTEGER or (optionally) REAL type. */
7431 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
7432 const char *name_msgid
)
7434 if (!gfc_resolve_expr (expr
))
7437 if (expr
->rank
!= 0)
7439 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7443 if (expr
->ts
.type
!= BT_INTEGER
)
7445 if (expr
->ts
.type
== BT_REAL
)
7448 return gfc_notify_std (GFC_STD_F95_DEL
,
7449 "%s at %L must be integer",
7450 _(name_msgid
), &expr
->where
);
7453 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7460 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7468 /* Resolve the expressions in an iterator structure. If REAL_OK is
7469 false allow only INTEGER type iterators, otherwise allow REAL types.
7470 Set own_scope to true for ac-implied-do and data-implied-do as those
7471 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7474 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7476 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7479 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7480 _("iterator variable")))
7483 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7484 "Start expression in DO loop"))
7487 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7488 "End expression in DO loop"))
7491 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7492 "Step expression in DO loop"))
7495 /* Convert start, end, and step to the same type as var. */
7496 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7497 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7498 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7500 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7501 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7502 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7504 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7505 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7506 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7508 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7510 if ((iter
->step
->ts
.type
== BT_INTEGER
7511 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7512 || (iter
->step
->ts
.type
== BT_REAL
7513 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7515 gfc_error ("Step expression in DO loop at %L cannot be zero",
7516 &iter
->step
->where
);
7521 if (iter
->start
->expr_type
== EXPR_CONSTANT
7522 && iter
->end
->expr_type
== EXPR_CONSTANT
7523 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7526 if (iter
->start
->ts
.type
== BT_INTEGER
)
7528 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7529 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7533 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7534 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7536 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7537 gfc_warning (OPT_Wzerotrip
,
7538 "DO loop at %L will be executed zero times",
7539 &iter
->step
->where
);
7542 if (iter
->end
->expr_type
== EXPR_CONSTANT
7543 && iter
->end
->ts
.type
== BT_INTEGER
7544 && iter
->step
->expr_type
== EXPR_CONSTANT
7545 && iter
->step
->ts
.type
== BT_INTEGER
7546 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7547 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7549 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7550 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7552 if (is_step_positive
7553 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7554 gfc_warning (OPT_Wundefined_do_loop
,
7555 "DO loop at %L is undefined as it overflows",
7556 &iter
->step
->where
);
7557 else if (!is_step_positive
7558 && mpz_cmp (iter
->end
->value
.integer
,
7559 gfc_integer_kinds
[k
].min_int
) == 0)
7560 gfc_warning (OPT_Wundefined_do_loop
,
7561 "DO loop at %L is undefined as it underflows",
7562 &iter
->step
->where
);
7569 /* Traversal function for find_forall_index. f == 2 signals that
7570 that variable itself is not to be checked - only the references. */
7573 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7575 if (expr
->expr_type
!= EXPR_VARIABLE
)
7578 /* A scalar assignment */
7579 if (!expr
->ref
|| *f
== 1)
7581 if (expr
->symtree
->n
.sym
== sym
)
7593 /* Check whether the FORALL index appears in the expression or not.
7594 Returns true if SYM is found in EXPR. */
7597 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7599 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7606 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7607 to be a scalar INTEGER variable. The subscripts and stride are scalar
7608 INTEGERs, and if stride is a constant it must be nonzero.
7609 Furthermore "A subscript or stride in a forall-triplet-spec shall
7610 not contain a reference to any index-name in the
7611 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7614 resolve_forall_iterators (gfc_forall_iterator
*it
)
7616 gfc_forall_iterator
*iter
, *iter2
;
7618 for (iter
= it
; iter
; iter
= iter
->next
)
7620 if (gfc_resolve_expr (iter
->var
)
7621 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7622 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7625 if (gfc_resolve_expr (iter
->start
)
7626 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7627 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7628 &iter
->start
->where
);
7629 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7630 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7632 if (gfc_resolve_expr (iter
->end
)
7633 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7634 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7636 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7637 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7639 if (gfc_resolve_expr (iter
->stride
))
7641 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7642 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7643 &iter
->stride
->where
, "INTEGER");
7645 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7646 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7647 gfc_error ("FORALL stride expression at %L cannot be zero",
7648 &iter
->stride
->where
);
7650 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7651 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7654 for (iter
= it
; iter
; iter
= iter
->next
)
7655 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7657 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7658 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7659 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7660 gfc_error ("FORALL index %qs may not appear in triplet "
7661 "specification at %L", iter
->var
->symtree
->name
,
7662 &iter2
->start
->where
);
7667 /* Given a pointer to a symbol that is a derived type, see if it's
7668 inaccessible, i.e. if it's defined in another module and the components are
7669 PRIVATE. The search is recursive if necessary. Returns zero if no
7670 inaccessible components are found, nonzero otherwise. */
7673 derived_inaccessible (gfc_symbol
*sym
)
7677 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7680 for (c
= sym
->components
; c
; c
= c
->next
)
7682 /* Prevent an infinite loop through this function. */
7683 if (c
->ts
.type
== BT_DERIVED
7684 && (c
->attr
.pointer
|| c
->attr
.allocatable
)
7685 && sym
== c
->ts
.u
.derived
)
7688 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7696 /* Resolve the argument of a deallocate expression. The expression must be
7697 a pointer or a full array. */
7700 resolve_deallocate_expr (gfc_expr
*e
)
7702 symbol_attribute attr
;
7703 int allocatable
, pointer
;
7709 if (!gfc_resolve_expr (e
))
7712 if (e
->expr_type
!= EXPR_VARIABLE
)
7715 sym
= e
->symtree
->n
.sym
;
7716 unlimited
= UNLIMITED_POLY(sym
);
7718 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
&& CLASS_DATA (sym
))
7720 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7721 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7725 allocatable
= sym
->attr
.allocatable
;
7726 pointer
= sym
->attr
.pointer
;
7728 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7733 if (ref
->u
.ar
.type
!= AR_FULL
7734 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7735 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7740 c
= ref
->u
.c
.component
;
7741 if (c
->ts
.type
== BT_CLASS
)
7743 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7744 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7748 allocatable
= c
->attr
.allocatable
;
7749 pointer
= c
->attr
.pointer
;
7760 attr
= gfc_expr_attr (e
);
7762 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7765 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7771 if (gfc_is_coindexed (e
))
7773 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7778 && !gfc_check_vardef_context (e
, true, true, false,
7779 _("DEALLOCATE object")))
7781 if (!gfc_check_vardef_context (e
, false, true, false,
7782 _("DEALLOCATE object")))
7789 /* Returns true if the expression e contains a reference to the symbol sym. */
7791 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7793 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7800 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7802 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7806 /* Given the expression node e for an allocatable/pointer of derived type to be
7807 allocated, get the expression node to be initialized afterwards (needed for
7808 derived types with default initializers, and derived types with allocatable
7809 components that need nullification.) */
7812 gfc_expr_to_initialize (gfc_expr
*e
)
7818 result
= gfc_copy_expr (e
);
7820 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7821 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7822 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7824 if (ref
->u
.ar
.dimen
== 0
7825 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->corank
)
7828 ref
->u
.ar
.type
= AR_FULL
;
7830 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7831 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7836 gfc_free_shape (&result
->shape
, result
->rank
);
7838 /* Recalculate rank, shape, etc. */
7839 gfc_resolve_expr (result
);
7844 /* If the last ref of an expression is an array ref, return a copy of the
7845 expression with that one removed. Otherwise, a copy of the original
7846 expression. This is used for allocate-expressions and pointer assignment
7847 LHS, where there may be an array specification that needs to be stripped
7848 off when using gfc_check_vardef_context. */
7851 remove_last_array_ref (gfc_expr
* e
)
7856 e2
= gfc_copy_expr (e
);
7857 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7858 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7860 gfc_free_ref_list (*r
);
7869 /* Used in resolve_allocate_expr to check that a allocation-object and
7870 a source-expr are conformable. This does not catch all possible
7871 cases; in particular a runtime checking is needed. */
7874 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7877 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7879 /* First compare rank. */
7880 if ((tail
&& (!tail
->u
.ar
.as
|| e1
->rank
!= tail
->u
.ar
.as
->rank
))
7881 || (!tail
&& e1
->rank
!= e2
->rank
))
7883 gfc_error ("Source-expr at %L must be scalar or have the "
7884 "same rank as the allocate-object at %L",
7885 &e1
->where
, &e2
->where
);
7896 for (i
= 0; i
< e1
->rank
; i
++)
7898 if (tail
->u
.ar
.start
[i
] == NULL
)
7901 if (tail
->u
.ar
.end
[i
])
7903 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7904 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7905 mpz_add_ui (s
, s
, 1);
7909 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7912 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7914 gfc_error ("Source-expr at %L and allocate-object at %L must "
7915 "have the same shape", &e1
->where
, &e2
->where
);
7928 /* Resolve the expression in an ALLOCATE statement, doing the additional
7929 checks to see whether the expression is OK or not. The expression must
7930 have a trailing array reference that gives the size of the array. */
7933 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7935 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7939 symbol_attribute attr
;
7940 gfc_ref
*ref
, *ref2
;
7943 gfc_symbol
*sym
= NULL
;
7948 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7949 checking of coarrays. */
7950 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7951 if (ref
->next
== NULL
)
7954 if (ref
&& ref
->type
== REF_ARRAY
)
7955 ref
->u
.ar
.in_allocate
= true;
7957 if (!gfc_resolve_expr (e
))
7960 /* Make sure the expression is allocatable or a pointer. If it is
7961 pointer, the next-to-last reference must be a pointer. */
7965 sym
= e
->symtree
->n
.sym
;
7967 /* Check whether ultimate component is abstract and CLASS. */
7970 /* Is the allocate-object unlimited polymorphic? */
7971 unlimited
= UNLIMITED_POLY(e
);
7973 if (e
->expr_type
!= EXPR_VARIABLE
)
7976 attr
= gfc_expr_attr (e
);
7977 pointer
= attr
.pointer
;
7978 dimension
= attr
.dimension
;
7979 codimension
= attr
.codimension
;
7983 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7985 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7986 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7987 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7988 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7989 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7993 allocatable
= sym
->attr
.allocatable
;
7994 pointer
= sym
->attr
.pointer
;
7995 dimension
= sym
->attr
.dimension
;
7996 codimension
= sym
->attr
.codimension
;
8001 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
8006 if (ref
->u
.ar
.codimen
> 0)
8009 for (n
= ref
->u
.ar
.dimen
;
8010 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
8011 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
8018 if (ref
->next
!= NULL
)
8026 gfc_error ("Coindexed allocatable object at %L",
8031 c
= ref
->u
.c
.component
;
8032 if (c
->ts
.type
== BT_CLASS
)
8034 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
8035 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
8036 dimension
= CLASS_DATA (c
)->attr
.dimension
;
8037 codimension
= CLASS_DATA (c
)->attr
.codimension
;
8038 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
8042 allocatable
= c
->attr
.allocatable
;
8043 pointer
= c
->attr
.pointer
;
8044 dimension
= c
->attr
.dimension
;
8045 codimension
= c
->attr
.codimension
;
8046 is_abstract
= c
->attr
.abstract
;
8059 /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
8060 pointer or an allocatable variable. */
8061 if (allocatable
== 0 && pointer
== 0)
8063 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
8068 /* Some checks for the SOURCE tag. */
8071 /* Check F03:C631. */
8072 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
8074 gfc_error ("Type of entity at %L is type incompatible with "
8075 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
8079 /* Check F03:C632 and restriction following Note 6.18. */
8080 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
8083 /* Check F03:C633. */
8084 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
8086 gfc_error ("The allocate-object at %L and the source-expr at %L "
8087 "shall have the same kind type parameter",
8088 &e
->where
, &code
->expr3
->where
);
8092 /* Check F2008, C642. */
8093 if (code
->expr3
->ts
.type
== BT_DERIVED
8094 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
8095 || (code
->expr3
->ts
.u
.derived
->from_intmod
8096 == INTMOD_ISO_FORTRAN_ENV
8097 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
8098 == ISOFORTRAN_LOCK_TYPE
)))
8100 gfc_error ("The source-expr at %L shall neither be of type "
8101 "LOCK_TYPE nor have a LOCK_TYPE component if "
8102 "allocate-object at %L is a coarray",
8103 &code
->expr3
->where
, &e
->where
);
8107 /* Check TS18508, C702/C703. */
8108 if (code
->expr3
->ts
.type
== BT_DERIVED
8109 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
8110 || (code
->expr3
->ts
.u
.derived
->from_intmod
8111 == INTMOD_ISO_FORTRAN_ENV
8112 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
8113 == ISOFORTRAN_EVENT_TYPE
)))
8115 gfc_error ("The source-expr at %L shall neither be of type "
8116 "EVENT_TYPE nor have a EVENT_TYPE component if "
8117 "allocate-object at %L is a coarray",
8118 &code
->expr3
->where
, &e
->where
);
8123 /* Check F08:C629. */
8124 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
8127 gcc_assert (e
->ts
.type
== BT_CLASS
);
8128 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
8129 "type-spec or source-expr", sym
->name
, &e
->where
);
8133 /* Check F08:C632. */
8134 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
8135 && !UNLIMITED_POLY (e
))
8139 if (!e
->ts
.u
.cl
->length
)
8142 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
8143 code
->ext
.alloc
.ts
.u
.cl
->length
);
8144 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
8146 gfc_error ("Allocating %s at %L with type-spec requires the same "
8147 "character-length parameter as in the declaration",
8148 sym
->name
, &e
->where
);
8153 /* In the variable definition context checks, gfc_expr_attr is used
8154 on the expression. This is fooled by the array specification
8155 present in e, thus we have to eliminate that one temporarily. */
8156 e2
= remove_last_array_ref (e
);
8159 t
= gfc_check_vardef_context (e2
, true, true, false,
8160 _("ALLOCATE object"));
8162 t
= gfc_check_vardef_context (e2
, false, true, false,
8163 _("ALLOCATE object"));
8168 code
->ext
.alloc
.expr3_not_explicit
= 0;
8169 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
8170 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
8172 /* For class arrays, the initialization with SOURCE is done
8173 using _copy and trans_call. It is convenient to exploit that
8174 when the allocated type is different from the declared type but
8175 no SOURCE exists by setting expr3. */
8176 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
8177 code
->ext
.alloc
.expr3_not_explicit
= 1;
8179 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
8180 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
8181 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
8183 /* We have to zero initialize the integer variable. */
8184 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
8185 code
->ext
.alloc
.expr3_not_explicit
= 1;
8188 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
8190 /* Make sure the vtab symbol is present when
8191 the module variables are generated. */
8192 gfc_typespec ts
= e
->ts
;
8194 ts
= code
->expr3
->ts
;
8195 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
8196 ts
= code
->ext
.alloc
.ts
;
8198 /* Finding the vtab also publishes the type's symbol. Therefore this
8199 statement is necessary. */
8200 gfc_find_derived_vtab (ts
.u
.derived
);
8202 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
8204 /* Again, make sure the vtab symbol is present when
8205 the module variables are generated. */
8206 gfc_typespec
*ts
= NULL
;
8208 ts
= &code
->expr3
->ts
;
8210 ts
= &code
->ext
.alloc
.ts
;
8214 /* Finding the vtab also publishes the type's symbol. Therefore this
8215 statement is necessary. */
8219 if (dimension
== 0 && codimension
== 0)
8222 /* Make sure the last reference node is an array specification. */
8224 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
8225 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
8230 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
8231 "in ALLOCATE statement at %L", &e
->where
))
8233 if (code
->expr3
->rank
!= 0)
8234 *array_alloc_wo_spec
= true;
8237 gfc_error ("Array specification or array-valued SOURCE= "
8238 "expression required in ALLOCATE statement at %L",
8245 gfc_error ("Array specification required in ALLOCATE statement "
8246 "at %L", &e
->where
);
8251 /* Make sure that the array section reference makes sense in the
8252 context of an ALLOCATE specification. */
8257 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
8259 switch (ar
->dimen_type
[i
])
8261 case DIMEN_THIS_IMAGE
:
8262 gfc_error ("Coarray specification required in ALLOCATE statement "
8263 "at %L", &e
->where
);
8268 * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
8270 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0 || ar
->stride
[i
] != NULL
)
8272 gfc_error ("Bad coarray specification in ALLOCATE statement "
8273 "at %L", &e
->where
);
8276 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
8278 gfc_error ("Upper cobound is less than lower cobound at %L",
8279 &ar
->start
[i
]->where
);
8285 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
8287 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
8288 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
8290 gfc_error ("Upper cobound is less than lower cobound "
8291 "of 1 at %L", &ar
->start
[i
]->where
);
8301 gfc_error ("Bad array specification in ALLOCATE statement at %L",
8307 for (i
= 0; i
< ar
->dimen
; i
++)
8309 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
8312 switch (ar
->dimen_type
[i
])
8318 if (ar
->start
[i
] != NULL
8319 && ar
->end
[i
] != NULL
8320 && ar
->stride
[i
] == NULL
)
8328 case DIMEN_THIS_IMAGE
:
8329 gfc_error ("Bad array specification in ALLOCATE statement at %L",
8335 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8337 sym
= a
->expr
->symtree
->n
.sym
;
8339 /* TODO - check derived type components. */
8340 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
8343 if ((ar
->start
[i
] != NULL
8344 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
8345 || (ar
->end
[i
] != NULL
8346 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
8348 gfc_error ("%qs must not appear in the array specification at "
8349 "%L in the same ALLOCATE statement where it is "
8350 "itself allocated", sym
->name
, &ar
->where
);
8356 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
8358 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
8359 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
8361 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
8363 gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
8364 "statement at %L", &e
->where
);
8370 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
8371 && ar
->stride
[i
] == NULL
)
8374 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
8388 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
8390 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
8391 gfc_alloc
*a
, *p
, *q
;
8394 errmsg
= code
->expr2
;
8396 /* Check the stat variable. */
8399 if (!gfc_check_vardef_context (stat
, false, false, false,
8400 _("STAT variable")))
8403 if (stat
->ts
.type
!= BT_INTEGER
8405 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8406 "variable", &stat
->where
);
8408 if (stat
->expr_type
== EXPR_CONSTANT
|| stat
->symtree
== NULL
)
8411 /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
8412 * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8414 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8415 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
8417 gfc_ref
*ref1
, *ref2
;
8420 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
8421 ref1
= ref1
->next
, ref2
= ref2
->next
)
8423 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8425 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8434 gfc_error ("Stat-variable at %L shall not be %sd within "
8435 "the same %s statement", &stat
->where
, fcn
, fcn
);
8443 /* Check the errmsg variable. */
8447 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8450 if (!gfc_check_vardef_context (errmsg
, false, false, false,
8451 _("ERRMSG variable")))
8454 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8455 F18:R930 errmsg-variable is scalar-default-char-variable
8456 F18:R906 default-char-variable is variable
8457 F18:C906 default-char-variable shall be default character. */
8458 if (errmsg
->ts
.type
!= BT_CHARACTER
8460 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8461 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8462 "variable", &errmsg
->where
);
8464 if (errmsg
->expr_type
== EXPR_CONSTANT
|| errmsg
->symtree
== NULL
)
8467 /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
8468 * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8470 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8471 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8473 gfc_ref
*ref1
, *ref2
;
8476 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
8477 ref1
= ref1
->next
, ref2
= ref2
->next
)
8479 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8481 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8490 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8491 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8499 /* Check that an allocate-object appears only once in the statement. */
8501 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8504 for (q
= p
->next
; q
; q
= q
->next
)
8507 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8509 /* This is a potential collision. */
8510 gfc_ref
*pr
= pe
->ref
;
8511 gfc_ref
*qr
= qe
->ref
;
8513 /* Follow the references until
8514 a) They start to differ, in which case there is no error;
8515 you can deallocate a%b and a%c in a single statement
8516 b) Both of them stop, which is an error
8517 c) One of them stops, which is also an error. */
8520 if (pr
== NULL
&& qr
== NULL
)
8522 gfc_error ("Allocate-object at %L also appears at %L",
8523 &pe
->where
, &qe
->where
);
8526 else if (pr
!= NULL
&& qr
== NULL
)
8528 gfc_error ("Allocate-object at %L is subobject of"
8529 " object at %L", &pe
->where
, &qe
->where
);
8532 else if (pr
== NULL
&& qr
!= NULL
)
8534 gfc_error ("Allocate-object at %L is subobject of"
8535 " object at %L", &qe
->where
, &pe
->where
);
8538 /* Here, pr != NULL && qr != NULL */
8539 gcc_assert(pr
->type
== qr
->type
);
8540 if (pr
->type
== REF_ARRAY
)
8542 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8544 gcc_assert (qr
->type
== REF_ARRAY
);
8546 if (pr
->next
&& qr
->next
)
8549 gfc_array_ref
*par
= &(pr
->u
.ar
);
8550 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8552 for (i
=0; i
<par
->dimen
; i
++)
8554 if ((par
->start
[i
] != NULL
8555 || qar
->start
[i
] != NULL
)
8556 && gfc_dep_compare_expr (par
->start
[i
],
8557 qar
->start
[i
]) != 0)
8564 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8577 if (strcmp (fcn
, "ALLOCATE") == 0)
8579 bool arr_alloc_wo_spec
= false;
8581 /* Resolving the expr3 in the loop over all objects to allocate would
8582 execute loop invariant code for each loop item. Therefore do it just
8584 if (code
->expr3
&& code
->expr3
->mold
8585 && code
->expr3
->ts
.type
== BT_DERIVED
)
8587 /* Default initialization via MOLD (non-polymorphic). */
8588 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8591 gfc_resolve_expr (rhs
);
8592 gfc_free_expr (code
->expr3
);
8596 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8597 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8599 if (arr_alloc_wo_spec
&& code
->expr3
)
8601 /* Mark the allocate to have to take the array specification
8603 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8608 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8609 resolve_deallocate_expr (a
->expr
);
8614 /************ SELECT CASE resolution subroutines ************/
8616 /* Callback function for our mergesort variant. Determines interval
8617 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8618 op1 > op2. Assumes we're not dealing with the default case.
8619 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8620 There are nine situations to check. */
8623 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8627 if (op1
->low
== NULL
) /* op1 = (:L) */
8629 /* op2 = (:N), so overlap. */
8631 /* op2 = (M:) or (M:N), L < M */
8632 if (op2
->low
!= NULL
8633 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8636 else if (op1
->high
== NULL
) /* op1 = (K:) */
8638 /* op2 = (M:), so overlap. */
8640 /* op2 = (:N) or (M:N), K > N */
8641 if (op2
->high
!= NULL
8642 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8645 else /* op1 = (K:L) */
8647 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8648 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8650 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8651 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8653 else /* op2 = (M:N) */
8657 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8660 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8669 /* Merge-sort a double linked case list, detecting overlap in the
8670 process. LIST is the head of the double linked case list before it
8671 is sorted. Returns the head of the sorted list if we don't see any
8672 overlap, or NULL otherwise. */
8675 check_case_overlap (gfc_case
*list
)
8677 gfc_case
*p
, *q
, *e
, *tail
;
8678 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8680 /* If the passed list was empty, return immediately. */
8687 /* Loop unconditionally. The only exit from this loop is a return
8688 statement, when we've finished sorting the case list. */
8695 /* Count the number of merges we do in this pass. */
8698 /* Loop while there exists a merge to be done. */
8703 /* Count this merge. */
8706 /* Cut the list in two pieces by stepping INSIZE places
8707 forward in the list, starting from P. */
8710 for (i
= 0; i
< insize
; i
++)
8719 /* Now we have two lists. Merge them! */
8720 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8722 /* See from which the next case to merge comes from. */
8725 /* P is empty so the next case must come from Q. */
8730 else if (qsize
== 0 || q
== NULL
)
8739 cmp
= compare_cases (p
, q
);
8742 /* The whole case range for P is less than the
8750 /* The whole case range for Q is greater than
8751 the case range for P. */
8758 /* The cases overlap, or they are the same
8759 element in the list. Either way, we must
8760 issue an error and get the next case from P. */
8761 /* FIXME: Sort P and Q by line number. */
8762 gfc_error ("CASE label at %L overlaps with CASE "
8763 "label at %L", &p
->where
, &q
->where
);
8771 /* Add the next element to the merged list. */
8780 /* P has now stepped INSIZE places along, and so has Q. So
8781 they're the same. */
8786 /* If we have done only one merge or none at all, we've
8787 finished sorting the cases. */
8796 /* Otherwise repeat, merging lists twice the size. */
8802 /* Check to see if an expression is suitable for use in a CASE statement.
8803 Makes sure that all case expressions are scalar constants of the same
8804 type. Return false if anything is wrong. */
8807 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8809 if (e
== NULL
) return true;
8811 if (e
->ts
.type
!= case_expr
->ts
.type
)
8813 gfc_error ("Expression in CASE statement at %L must be of type %s",
8814 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8818 /* C805 (R808) For a given case-construct, each case-value shall be of
8819 the same type as case-expr. For character type, length differences
8820 are allowed, but the kind type parameters shall be the same. */
8822 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8824 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8825 &e
->where
, case_expr
->ts
.kind
);
8829 /* Convert the case value kind to that of case expression kind,
8832 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8833 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8837 gfc_error ("Expression in CASE statement at %L must be scalar",
8846 /* Given a completely parsed select statement, we:
8848 - Validate all expressions and code within the SELECT.
8849 - Make sure that the selection expression is not of the wrong type.
8850 - Make sure that no case ranges overlap.
8851 - Eliminate unreachable cases and unreachable code resulting from
8852 removing case labels.
8854 The standard does allow unreachable cases, e.g. CASE (5:3). But
8855 they are a hassle for code generation, and to prevent that, we just
8856 cut them out here. This is not necessary for overlapping cases
8857 because they are illegal and we never even try to generate code.
8859 We have the additional caveat that a SELECT construct could have
8860 been a computed GOTO in the source code. Fortunately we can fairly
8861 easily work around that here: The case_expr for a "real" SELECT CASE
8862 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8863 we have to do is make sure that the case_expr is a scalar integer
8867 resolve_select (gfc_code
*code
, bool select_type
)
8870 gfc_expr
*case_expr
;
8871 gfc_case
*cp
, *default_case
, *tail
, *head
;
8872 int seen_unreachable
;
8878 if (code
->expr1
== NULL
)
8880 /* This was actually a computed GOTO statement. */
8881 case_expr
= code
->expr2
;
8882 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8883 gfc_error ("Selection expression in computed GOTO statement "
8884 "at %L must be a scalar integer expression",
8887 /* Further checking is not necessary because this SELECT was built
8888 by the compiler, so it should always be OK. Just move the
8889 case_expr from expr2 to expr so that we can handle computed
8890 GOTOs as normal SELECTs from here on. */
8891 code
->expr1
= code
->expr2
;
8896 case_expr
= code
->expr1
;
8897 type
= case_expr
->ts
.type
;
8900 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8902 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8903 &case_expr
->where
, gfc_typename (case_expr
));
8905 /* Punt. Going on here just produce more garbage error messages. */
8910 if (!select_type
&& case_expr
->rank
!= 0)
8912 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8913 "expression", &case_expr
->where
);
8919 /* Raise a warning if an INTEGER case value exceeds the range of
8920 the case-expr. Later, all expressions will be promoted to the
8921 largest kind of all case-labels. */
8923 if (type
== BT_INTEGER
)
8924 for (body
= code
->block
; body
; body
= body
->block
)
8925 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8928 && gfc_check_integer_range (cp
->low
->value
.integer
,
8929 case_expr
->ts
.kind
) != ARITH_OK
)
8930 gfc_warning (0, "Expression in CASE statement at %L is "
8931 "not in the range of %s", &cp
->low
->where
,
8932 gfc_typename (case_expr
));
8935 && cp
->low
!= cp
->high
8936 && gfc_check_integer_range (cp
->high
->value
.integer
,
8937 case_expr
->ts
.kind
) != ARITH_OK
)
8938 gfc_warning (0, "Expression in CASE statement at %L is "
8939 "not in the range of %s", &cp
->high
->where
,
8940 gfc_typename (case_expr
));
8943 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8944 of the SELECT CASE expression and its CASE values. Walk the lists
8945 of case values, and if we find a mismatch, promote case_expr to
8946 the appropriate kind. */
8948 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8950 for (body
= code
->block
; body
; body
= body
->block
)
8952 /* Walk the case label list. */
8953 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8955 /* Intercept the DEFAULT case. It does not have a kind. */
8956 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8959 /* Unreachable case ranges are discarded, so ignore. */
8960 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8961 && cp
->low
!= cp
->high
8962 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8966 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8967 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 1, 0);
8969 if (cp
->high
!= NULL
8970 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8971 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 1, 0);
8976 /* Assume there is no DEFAULT case. */
8977 default_case
= NULL
;
8982 for (body
= code
->block
; body
; body
= body
->block
)
8984 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8986 seen_unreachable
= 0;
8988 /* Walk the case label list, making sure that all case labels
8990 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8992 /* Count the number of cases in the whole construct. */
8995 /* Intercept the DEFAULT case. */
8996 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8998 if (default_case
!= NULL
)
9000 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9001 "by a second DEFAULT CASE at %L",
9002 &default_case
->where
, &cp
->where
);
9013 /* Deal with single value cases and case ranges. Errors are
9014 issued from the validation function. */
9015 if (!validate_case_label_expr (cp
->low
, case_expr
)
9016 || !validate_case_label_expr (cp
->high
, case_expr
))
9022 if (type
== BT_LOGICAL
9023 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
9024 || cp
->low
!= cp
->high
))
9026 gfc_error ("Logical range in CASE statement at %L is not "
9028 cp
->low
? &cp
->low
->where
: &cp
->high
->where
);
9033 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
9036 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
9037 if (value
& seen_logical
)
9039 gfc_error ("Constant logical value in CASE statement "
9040 "is repeated at %L",
9045 seen_logical
|= value
;
9048 if (cp
->low
!= NULL
&& cp
->high
!= NULL
9049 && cp
->low
!= cp
->high
9050 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
9052 if (warn_surprising
)
9053 gfc_warning (OPT_Wsurprising
,
9054 "Range specification at %L can never be matched",
9057 cp
->unreachable
= 1;
9058 seen_unreachable
= 1;
9062 /* If the case range can be matched, it can also overlap with
9063 other cases. To make sure it does not, we put it in a
9064 double linked list here. We sort that with a merge sort
9065 later on to detect any overlapping cases. */
9069 head
->right
= head
->left
= NULL
;
9074 tail
->right
->left
= tail
;
9081 /* It there was a failure in the previous case label, give up
9082 for this case label list. Continue with the next block. */
9086 /* See if any case labels that are unreachable have been seen.
9087 If so, we eliminate them. This is a bit of a kludge because
9088 the case lists for a single case statement (label) is a
9089 single forward linked lists. */
9090 if (seen_unreachable
)
9092 /* Advance until the first case in the list is reachable. */
9093 while (body
->ext
.block
.case_list
!= NULL
9094 && body
->ext
.block
.case_list
->unreachable
)
9096 gfc_case
*n
= body
->ext
.block
.case_list
;
9097 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
9099 gfc_free_case_list (n
);
9102 /* Strip all other unreachable cases. */
9103 if (body
->ext
.block
.case_list
)
9105 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
9107 if (cp
->next
->unreachable
)
9109 gfc_case
*n
= cp
->next
;
9110 cp
->next
= cp
->next
->next
;
9112 gfc_free_case_list (n
);
9119 /* See if there were overlapping cases. If the check returns NULL,
9120 there was overlap. In that case we don't do anything. If head
9121 is non-NULL, we prepend the DEFAULT case. The sorted list can
9122 then used during code generation for SELECT CASE constructs with
9123 a case expression of a CHARACTER type. */
9126 head
= check_case_overlap (head
);
9128 /* Prepend the default_case if it is there. */
9129 if (head
!= NULL
&& default_case
)
9131 default_case
->left
= NULL
;
9132 default_case
->right
= head
;
9133 head
->left
= default_case
;
9137 /* Eliminate dead blocks that may be the result if we've seen
9138 unreachable case labels for a block. */
9139 for (body
= code
; body
&& body
->block
; body
= body
->block
)
9141 if (body
->block
->ext
.block
.case_list
== NULL
)
9143 /* Cut the unreachable block from the code chain. */
9144 gfc_code
*c
= body
->block
;
9145 body
->block
= c
->block
;
9147 /* Kill the dead block, but not the blocks below it. */
9149 gfc_free_statements (c
);
9153 /* More than two cases is legal but insane for logical selects.
9154 Issue a warning for it. */
9155 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
9156 gfc_warning (OPT_Wsurprising
,
9157 "Logical SELECT CASE block at %L has more that two cases",
9162 /* Check if a derived type is extensible. */
9165 gfc_type_is_extensible (gfc_symbol
*sym
)
9167 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
9168 || (sym
->attr
.is_class
9169 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
9174 resolve_types (gfc_namespace
*ns
);
9176 /* Resolve an associate-name: Resolve target and ensure the type-spec is
9177 correct as well as possibly the array-spec. */
9180 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
9183 bool parentheses
= false;
9185 gcc_assert (sym
->assoc
);
9186 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
9188 /* If this is for SELECT TYPE, the target may not yet be set. In that
9189 case, return. Resolution will be called later manually again when
9191 target
= sym
->assoc
->target
;
9194 gcc_assert (!sym
->assoc
->dangling
);
9196 if (target
->expr_type
== EXPR_OP
9197 && target
->value
.op
.op
== INTRINSIC_PARENTHESES
9198 && target
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
9200 sym
->assoc
->target
= gfc_copy_expr (target
->value
.op
.op1
);
9201 gfc_free_expr (target
);
9202 target
= sym
->assoc
->target
;
9206 if (resolve_target
&& !gfc_resolve_expr (target
))
9209 /* For variable targets, we get some attributes from the target. */
9210 if (target
->expr_type
== EXPR_VARIABLE
)
9212 gfc_symbol
*tsym
, *dsym
;
9214 gcc_assert (target
->symtree
);
9215 tsym
= target
->symtree
->n
.sym
;
9217 if (gfc_expr_attr (target
).proc_pointer
)
9219 gfc_error ("Associating entity %qs at %L is a procedure pointer",
9220 tsym
->name
, &target
->where
);
9224 if (tsym
->attr
.flavor
== FL_PROCEDURE
&& tsym
->generic
9225 && (dsym
= gfc_find_dt_in_generic (tsym
)) != NULL
9226 && dsym
->attr
.flavor
== FL_DERIVED
)
9228 gfc_error ("Derived type %qs cannot be used as a variable at %L",
9229 tsym
->name
, &target
->where
);
9233 if (tsym
->attr
.flavor
== FL_PROCEDURE
)
9235 bool is_error
= true;
9236 if (tsym
->attr
.function
&& tsym
->result
== tsym
)
9237 for (gfc_namespace
*ns
= sym
->ns
; ns
; ns
= ns
->parent
)
9238 if (tsym
== ns
->proc_name
)
9245 gfc_error ("Associating entity %qs at %L is a procedure name",
9246 tsym
->name
, &target
->where
);
9251 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
9252 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
9254 sym
->attr
.target
= tsym
->attr
.target
9255 || gfc_expr_attr (target
).pointer
;
9256 if (is_subref_array (target
))
9257 sym
->attr
.subref_array_pointer
= 1;
9259 else if (target
->ts
.type
== BT_PROCEDURE
)
9261 gfc_error ("Associating selector-expression at %L yields a procedure",
9266 if (target
->expr_type
== EXPR_NULL
)
9268 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
9271 else if (target
->ts
.type
== BT_UNKNOWN
)
9273 gfc_error ("Selector at %L has no type", &target
->where
);
9277 /* Get type if this was not already set. Note that it can be
9278 some other type than the target in case this is a SELECT TYPE
9279 selector! So we must not update when the type is already there. */
9280 if (sym
->ts
.type
== BT_UNKNOWN
)
9281 sym
->ts
= target
->ts
;
9283 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
9285 /* See if this is a valid association-to-variable. */
9286 sym
->assoc
->variable
= ((target
->expr_type
== EXPR_VARIABLE
9288 && !gfc_has_vector_subscript (target
))
9289 || gfc_is_ptr_fcn (target
));
9291 /* Finally resolve if this is an array or not. */
9292 if (sym
->attr
.dimension
&& target
->rank
== 0)
9294 /* primary.cc makes the assumption that a reference to an associate
9295 name followed by a left parenthesis is an array reference. */
9296 if (sym
->ts
.type
!= BT_CHARACTER
)
9297 gfc_error ("Associate-name %qs at %L is used as array",
9298 sym
->name
, &sym
->declared_at
);
9299 sym
->attr
.dimension
= 0;
9303 /* We cannot deal with class selectors that need temporaries. */
9304 if (target
->ts
.type
== BT_CLASS
9305 && gfc_ref_needs_temporary_p (target
->ref
))
9307 gfc_error ("CLASS selector at %L needs a temporary which is not "
9308 "yet implemented", &target
->where
);
9312 if (target
->ts
.type
== BT_CLASS
)
9313 gfc_fix_class_refs (target
);
9315 if (target
->rank
!= 0 && !sym
->attr
.select_rank_temporary
)
9318 /* The rank may be incorrectly guessed at parsing, therefore make sure
9319 it is corrected now. */
9320 if (sym
->ts
.type
!= BT_CLASS
&& !sym
->as
)
9323 sym
->as
= gfc_get_array_spec ();
9325 as
->rank
= target
->rank
;
9326 as
->type
= AS_DEFERRED
;
9327 as
->corank
= gfc_get_corank (target
);
9328 sym
->attr
.dimension
= 1;
9329 if (as
->corank
!= 0)
9330 sym
->attr
.codimension
= 1;
9332 else if (sym
->ts
.type
== BT_CLASS
9333 && CLASS_DATA (sym
) && !CLASS_DATA (sym
)->as
)
9335 if (!CLASS_DATA (sym
)->as
)
9336 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
9337 as
= CLASS_DATA (sym
)->as
;
9338 as
->rank
= target
->rank
;
9339 as
->type
= AS_DEFERRED
;
9340 as
->corank
= gfc_get_corank (target
);
9341 CLASS_DATA (sym
)->attr
.dimension
= 1;
9342 if (as
->corank
!= 0)
9343 CLASS_DATA (sym
)->attr
.codimension
= 1;
9346 else if (!sym
->attr
.select_rank_temporary
)
9348 /* target's rank is 0, but the type of the sym is still array valued,
9349 which has to be corrected. */
9350 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
9351 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
9354 symbol_attribute attr
;
9355 /* The associated variable's type is still the array type
9356 correct this now. */
9357 gfc_typespec
*ts
= &target
->ts
;
9360 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
9365 ts
= &ref
->u
.c
.component
->ts
;
9368 if (ts
->type
== BT_CLASS
)
9369 ts
= &ts
->u
.derived
->components
->ts
;
9375 /* Create a scalar instance of the current class type. Because the
9376 rank of a class array goes into its name, the type has to be
9377 rebuild. The alternative of (re-)setting just the attributes
9378 and as in the current type, destroys the type also in other
9382 sym
->ts
.type
= BT_CLASS
;
9383 attr
= CLASS_DATA (sym
) ? CLASS_DATA (sym
)->attr
: sym
->attr
;
9385 attr
.associate_var
= 1;
9386 attr
.dimension
= attr
.codimension
= 0;
9387 attr
.class_pointer
= 1;
9388 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
9390 /* Make sure the _vptr is set. */
9391 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
9392 if (c
->ts
.u
.derived
== NULL
)
9393 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
9394 CLASS_DATA (sym
)->attr
.pointer
= 1;
9395 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
9396 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
9397 gfc_commit_symbol (sym
->ts
.u
.derived
);
9398 /* _vptr now has the _vtab in it, change it to the _vtype. */
9399 if (c
->ts
.u
.derived
->attr
.vtab
)
9400 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
9401 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
9402 resolve_types (c
->ts
.u
.derived
->ns
);
9406 /* Mark this as an associate variable. */
9407 sym
->attr
.associate_var
= 1;
9409 /* Fix up the type-spec for CHARACTER types. */
9410 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
9413 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
9415 if (sym
->ts
.deferred
9416 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
9418 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
9419 sym
->ts
.deferred
= 1;
9422 if (!sym
->ts
.u
.cl
->length
9423 && !sym
->ts
.deferred
9424 && target
->expr_type
== EXPR_CONSTANT
)
9426 sym
->ts
.u
.cl
->length
=
9427 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
9428 target
->value
.character
.length
);
9430 else if ((!sym
->ts
.u
.cl
->length
9431 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9432 && target
->expr_type
!= EXPR_VARIABLE
)
9434 if (!sym
->ts
.deferred
)
9436 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
9437 sym
->ts
.deferred
= 1;
9440 /* This is reset in trans-stmt.cc after the assignment
9441 of the target expression to the associate name. */
9442 sym
->attr
.allocatable
= 1;
9446 /* If the target is a good class object, so is the associate variable. */
9447 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
9448 sym
->attr
.class_ok
= 1;
9452 /* Ensure that SELECT TYPE expressions have the correct rank and a full
9453 array reference, where necessary. The symbols are artificial and so
9454 the dimension attribute and arrayspec can also be set. In addition,
9455 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
9456 This is corrected here as well.*/
9459 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
9460 int rank
, gfc_ref
*ref
)
9462 gfc_ref
*nref
= (*expr1
)->ref
;
9463 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
9465 gfc_expr
*selector
= gfc_copy_expr (expr2
);
9467 (*expr1
)->rank
= rank
;
9470 gfc_resolve_expr (selector
);
9471 if (selector
->expr_type
== EXPR_OP
9472 && selector
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9473 sym2
= selector
->value
.op
.op1
->symtree
->n
.sym
;
9474 else if (selector
->expr_type
== EXPR_VARIABLE
9475 || selector
->expr_type
== EXPR_FUNCTION
)
9476 sym2
= selector
->symtree
->n
.sym
;
9483 if (sym1
->ts
.type
== BT_CLASS
)
9485 if ((*expr1
)->ts
.type
!= BT_CLASS
)
9486 (*expr1
)->ts
= sym1
->ts
;
9488 CLASS_DATA (sym1
)->attr
.dimension
= 1;
9489 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
9490 CLASS_DATA (sym1
)->as
9491 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
9495 sym1
->attr
.dimension
= 1;
9496 if (sym1
->as
== NULL
&& sym2
)
9497 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
9500 for (; nref
; nref
= nref
->next
)
9501 if (nref
->next
== NULL
)
9504 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
9505 nref
->next
= gfc_copy_ref (ref
);
9506 else if (ref
&& !nref
)
9507 (*expr1
)->ref
= gfc_copy_ref (ref
);
9512 build_loc_call (gfc_expr
*sym_expr
)
9515 loc_call
= gfc_get_expr ();
9516 loc_call
->expr_type
= EXPR_FUNCTION
;
9517 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
9518 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
9519 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
9520 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
9521 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
9522 loc_call
->ts
.type
= BT_INTEGER
;
9523 loc_call
->ts
.kind
= gfc_index_integer_kind
;
9524 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
9525 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
9526 loc_call
->value
.function
.actual
->expr
= sym_expr
;
9527 loc_call
->where
= sym_expr
->where
;
9531 /* Resolve a SELECT TYPE statement. */
9534 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9536 gfc_symbol
*selector_type
;
9537 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9538 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9541 char name
[GFC_MAX_SYMBOL_LEN
+ 12 + 1];
9545 gfc_ref
* ref
= NULL
;
9546 gfc_expr
*selector_expr
= NULL
;
9548 ns
= code
->ext
.block
.ns
;
9551 /* Check for F03:C813. */
9552 if (code
->expr1
->ts
.type
!= BT_CLASS
9553 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9555 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9556 "at %L", &code
->loc
);
9560 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9565 gfc_ref
*ref2
= NULL
;
9566 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9567 if (ref
->type
== REF_COMPONENT
9568 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9573 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9574 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9575 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9579 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9580 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9581 /* Sometimes the selector expression is given the typespec of the
9582 '_data' field, which is logical enough but inappropriate here. */
9583 if (code
->expr2
->ts
.type
== BT_DERIVED
9584 && code
->expr2
->symtree
9585 && code
->expr2
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
9586 code
->expr2
->ts
= code
->expr2
->symtree
->n
.sym
->ts
;
9587 selector_type
= CLASS_DATA (code
->expr2
)
9588 ? CLASS_DATA (code
->expr2
)->ts
.u
.derived
: code
->expr2
->ts
.u
.derived
;
9591 if (code
->expr2
->rank
9592 && code
->expr1
->ts
.type
== BT_CLASS
9593 && CLASS_DATA (code
->expr1
)->as
)
9594 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9596 /* F2008: C803 The selector expression must not be coindexed. */
9597 if (gfc_is_coindexed (code
->expr2
))
9599 gfc_error ("Selector at %L must not be coindexed",
9600 &code
->expr2
->where
);
9607 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9609 if (gfc_is_coindexed (code
->expr1
))
9611 gfc_error ("Selector at %L must not be coindexed",
9612 &code
->expr1
->where
);
9617 /* Loop over TYPE IS / CLASS IS cases. */
9618 for (body
= code
->block
; body
; body
= body
->block
)
9620 c
= body
->ext
.block
.case_list
;
9624 /* Check for repeated cases. */
9625 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9627 gfc_case
*d
= tail
->ext
.block
.case_list
;
9631 if (c
->ts
.type
== d
->ts
.type
9632 && ((c
->ts
.type
== BT_DERIVED
9633 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9634 && !strcmp (c
->ts
.u
.derived
->name
,
9635 d
->ts
.u
.derived
->name
))
9636 || c
->ts
.type
== BT_UNKNOWN
9637 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9638 && c
->ts
.kind
== d
->ts
.kind
)))
9640 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9641 &c
->where
, &d
->where
);
9647 /* Check F03:C815. */
9648 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9650 && !selector_type
->attr
.unlimited_polymorphic
9651 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9653 gfc_error ("Derived type %qs at %L must be extensible",
9654 c
->ts
.u
.derived
->name
, &c
->where
);
9659 /* Check F03:C816. */
9660 if (c
->ts
.type
!= BT_UNKNOWN
9661 && selector_type
&& !selector_type
->attr
.unlimited_polymorphic
9662 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9663 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9665 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9666 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9667 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9669 gfc_error ("Unexpected intrinsic type %qs at %L",
9670 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9675 /* Check F03:C814. */
9676 if (c
->ts
.type
== BT_CHARACTER
9677 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9679 gfc_error ("The type-spec at %L shall specify that each length "
9680 "type parameter is assumed", &c
->where
);
9685 /* Intercept the DEFAULT case. */
9686 if (c
->ts
.type
== BT_UNKNOWN
)
9688 /* Check F03:C818. */
9691 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9692 "by a second DEFAULT CASE at %L",
9693 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9698 default_case
= body
;
9705 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9706 target if present. If there are any EXIT statements referring to the
9707 SELECT TYPE construct, this is no problem because the gfc_code
9708 reference stays the same and EXIT is equally possible from the BLOCK
9709 it is changed to. */
9710 code
->op
= EXEC_BLOCK
;
9713 gfc_association_list
* assoc
;
9715 assoc
= gfc_get_association_list ();
9716 assoc
->st
= code
->expr1
->symtree
;
9717 assoc
->target
= gfc_copy_expr (code
->expr2
);
9718 assoc
->target
->where
= code
->expr2
->where
;
9719 /* assoc->variable will be set by resolve_assoc_var. */
9721 code
->ext
.block
.assoc
= assoc
;
9722 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9724 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9727 code
->ext
.block
.assoc
= NULL
;
9729 /* Ensure that the selector rank and arrayspec are available to
9730 correct expressions in which they might be missing. */
9731 if (code
->expr2
&& code
->expr2
->rank
)
9733 rank
= code
->expr2
->rank
;
9734 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9735 if (ref
->next
== NULL
)
9737 if (ref
&& ref
->type
== REF_ARRAY
)
9738 ref
= gfc_copy_ref (ref
);
9740 /* Fixup expr1 if necessary. */
9742 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9744 else if (code
->expr1
->rank
)
9746 rank
= code
->expr1
->rank
;
9747 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9748 if (ref
->next
== NULL
)
9750 if (ref
&& ref
->type
== REF_ARRAY
)
9751 ref
= gfc_copy_ref (ref
);
9754 /* Add EXEC_SELECT to switch on type. */
9755 new_st
= gfc_get_code (code
->op
);
9756 new_st
->expr1
= code
->expr1
;
9757 new_st
->expr2
= code
->expr2
;
9758 new_st
->block
= code
->block
;
9759 code
->expr1
= code
->expr2
= NULL
;
9764 ns
->code
->next
= new_st
;
9766 code
->op
= EXEC_SELECT_TYPE
;
9768 /* Use the intrinsic LOC function to generate an integer expression
9769 for the vtable of the selector. Note that the rank of the selector
9770 expression has to be set to zero. */
9771 gfc_add_vptr_component (code
->expr1
);
9772 code
->expr1
->rank
= 0;
9773 code
->expr1
= build_loc_call (code
->expr1
);
9774 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9776 /* Loop over TYPE IS / CLASS IS cases. */
9777 for (body
= code
->block
; body
; body
= body
->block
)
9781 c
= body
->ext
.block
.case_list
;
9783 /* Generate an index integer expression for address of the
9784 TYPE/CLASS vtable and store it in c->low. The hash expression
9785 is stored in c->high and is used to resolve intrinsic cases. */
9786 if (c
->ts
.type
!= BT_UNKNOWN
)
9788 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9790 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9792 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9793 c
->ts
.u
.derived
->hash_value
);
9797 vtab
= gfc_find_vtab (&c
->ts
);
9798 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9799 e
= CLASS_DATA (vtab
)->initializer
;
9800 c
->high
= gfc_copy_expr (e
);
9801 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9804 ts
.kind
= gfc_integer_4_kind
;
9805 ts
.type
= BT_INTEGER
;
9806 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9810 e
= gfc_lval_expr_from_sym (vtab
);
9811 c
->low
= build_loc_call (e
);
9816 /* Associate temporary to selector. This should only be done
9817 when this case is actually true, so build a new ASSOCIATE
9818 that does precisely this here (instead of using the
9821 if (c
->ts
.type
== BT_CLASS
)
9822 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9823 else if (c
->ts
.type
== BT_DERIVED
)
9824 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9825 else if (c
->ts
.type
== BT_CHARACTER
)
9827 HOST_WIDE_INT charlen
= 0;
9828 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9829 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9830 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9831 snprintf (name
, sizeof (name
),
9832 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9833 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9836 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9839 st
= gfc_find_symtree (ns
->sym_root
, name
);
9840 gcc_assert (st
->n
.sym
->assoc
);
9841 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9842 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9843 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9845 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9846 /* Fixup the target expression if necessary. */
9848 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9851 new_st
= gfc_get_code (EXEC_BLOCK
);
9852 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9853 new_st
->ext
.block
.ns
->code
= body
->next
;
9854 body
->next
= new_st
;
9856 /* Chain in the new list only if it is marked as dangling. Otherwise
9857 there is a CASE label overlap and this is already used. Just ignore,
9858 the error is diagnosed elsewhere. */
9859 if (st
->n
.sym
->assoc
->dangling
)
9861 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9862 st
->n
.sym
->assoc
->dangling
= 0;
9865 resolve_assoc_var (st
->n
.sym
, false);
9868 /* Take out CLASS IS cases for separate treatment. */
9870 while (body
&& body
->block
)
9872 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9874 /* Add to class_is list. */
9875 if (class_is
== NULL
)
9877 class_is
= body
->block
;
9882 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9883 tail
->block
= body
->block
;
9886 /* Remove from EXEC_SELECT list. */
9887 body
->block
= body
->block
->block
;
9900 /* Add a default case to hold the CLASS IS cases. */
9901 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9902 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9904 tail
->ext
.block
.case_list
= gfc_get_case ();
9905 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9907 default_case
= tail
;
9910 /* More than one CLASS IS block? */
9911 if (class_is
->block
)
9915 /* Sort CLASS IS blocks by extension level. */
9919 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9922 /* F03:C817 (check for doubles). */
9923 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9924 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9926 gfc_error ("Double CLASS IS block in SELECT TYPE "
9928 &c2
->ext
.block
.case_list
->where
);
9931 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9932 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9935 (*c1
)->block
= c2
->block
;
9945 /* Generate IF chain. */
9946 if_st
= gfc_get_code (EXEC_IF
);
9948 for (body
= class_is
; body
; body
= body
->block
)
9950 new_st
->block
= gfc_get_code (EXEC_IF
);
9951 new_st
= new_st
->block
;
9952 /* Set up IF condition: Call _gfortran_is_extension_of. */
9953 new_st
->expr1
= gfc_get_expr ();
9954 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9955 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9956 new_st
->expr1
->ts
.kind
= 4;
9957 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9958 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9959 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9960 /* Set up arguments. */
9961 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9962 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9963 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9964 new_st
->expr1
->where
= code
->loc
;
9965 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9966 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9967 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9968 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9969 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9970 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9971 /* Set up types in formal arg list. */
9972 new_st
->expr1
->value
.function
.isym
->formal
= XCNEW (gfc_intrinsic_arg
);
9973 new_st
->expr1
->value
.function
.isym
->formal
->ts
= new_st
->expr1
->value
.function
.actual
->expr
->ts
;
9974 new_st
->expr1
->value
.function
.isym
->formal
->next
= XCNEW (gfc_intrinsic_arg
);
9975 new_st
->expr1
->value
.function
.isym
->formal
->next
->ts
= new_st
->expr1
->value
.function
.actual
->next
->expr
->ts
;
9977 new_st
->next
= body
->next
;
9979 if (default_case
->next
)
9981 new_st
->block
= gfc_get_code (EXEC_IF
);
9982 new_st
= new_st
->block
;
9983 new_st
->next
= default_case
->next
;
9986 /* Replace CLASS DEFAULT code by the IF chain. */
9987 default_case
->next
= if_st
;
9990 /* Resolve the internal code. This cannot be done earlier because
9991 it requires that the sym->assoc of selectors is set already. */
9992 gfc_current_ns
= ns
;
9993 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9994 gfc_current_ns
= old_ns
;
10000 /* Resolve a SELECT RANK statement. */
10003 resolve_select_rank (gfc_code
*code
, gfc_namespace
*old_ns
)
10006 gfc_code
*body
, *new_st
, *tail
;
10008 char tname
[GFC_MAX_SYMBOL_LEN
+ 7];
10009 char name
[2 * GFC_MAX_SYMBOL_LEN
];
10011 gfc_expr
*selector_expr
= NULL
;
10013 HOST_WIDE_INT charlen
= 0;
10015 ns
= code
->ext
.block
.ns
;
10018 code
->op
= EXEC_BLOCK
;
10021 gfc_association_list
* assoc
;
10023 assoc
= gfc_get_association_list ();
10024 assoc
->st
= code
->expr1
->symtree
;
10025 assoc
->target
= gfc_copy_expr (code
->expr2
);
10026 assoc
->target
->where
= code
->expr2
->where
;
10027 /* assoc->variable will be set by resolve_assoc_var. */
10029 code
->ext
.block
.assoc
= assoc
;
10030 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
10032 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
10035 code
->ext
.block
.assoc
= NULL
;
10037 /* Loop over RANK cases. Note that returning on the errors causes a
10038 cascade of further errors because the case blocks do not compile
10040 for (body
= code
->block
; body
; body
= body
->block
)
10042 c
= body
->ext
.block
.case_list
;
10044 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
10048 /* Check for repeated cases. */
10049 for (tail
= code
->block
; tail
; tail
= tail
->block
)
10051 gfc_case
*d
= tail
->ext
.block
.case_list
;
10057 /* Check F2018: C1153. */
10058 if (!c
->low
&& !d
->low
)
10059 gfc_error ("RANK DEFAULT at %L is repeated at %L",
10060 &c
->where
, &d
->where
);
10062 if (!c
->low
|| !d
->low
)
10065 /* Check F2018: C1153. */
10066 case_value2
= (int) mpz_get_si (d
->low
->value
.integer
);
10067 if ((case_value
== case_value2
) && case_value
== -1)
10068 gfc_error ("RANK (*) at %L is repeated at %L",
10069 &c
->where
, &d
->where
);
10070 else if (case_value
== case_value2
)
10071 gfc_error ("RANK (%i) at %L is repeated at %L",
10072 case_value
, &c
->where
, &d
->where
);
10078 /* Check F2018: C1155. */
10079 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
10080 || gfc_expr_attr (code
->expr1
).pointer
))
10081 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
10082 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
10085 /* Add EXEC_SELECT to switch on rank. */
10086 new_st
= gfc_get_code (code
->op
);
10087 new_st
->expr1
= code
->expr1
;
10088 new_st
->expr2
= code
->expr2
;
10089 new_st
->block
= code
->block
;
10090 code
->expr1
= code
->expr2
= NULL
;
10091 code
->block
= NULL
;
10095 ns
->code
->next
= new_st
;
10097 code
->op
= EXEC_SELECT_RANK
;
10099 selector_expr
= code
->expr1
;
10101 /* Loop over SELECT RANK cases. */
10102 for (body
= code
->block
; body
; body
= body
->block
)
10104 c
= body
->ext
.block
.case_list
;
10107 /* Pass on the default case. */
10108 if (c
->low
== NULL
)
10111 /* Associate temporary to selector. This should only be done
10112 when this case is actually true, so build a new ASSOCIATE
10113 that does precisely this here (instead of using the
10115 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
10116 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10117 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
10119 if (c
->ts
.type
== BT_CLASS
)
10120 sprintf (tname
, "class_%s", c
->ts
.u
.derived
->name
);
10121 else if (c
->ts
.type
== BT_DERIVED
)
10122 sprintf (tname
, "type_%s", c
->ts
.u
.derived
->name
);
10123 else if (c
->ts
.type
!= BT_CHARACTER
)
10124 sprintf (tname
, "%s_%d", gfc_basic_typename (c
->ts
.type
), c
->ts
.kind
);
10126 sprintf (tname
, "%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
10127 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
10129 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
10130 if (case_value
>= 0)
10131 sprintf (name
, "__tmp_%s_rank_%d", tname
, case_value
);
10133 sprintf (name
, "__tmp_%s_rank_m%d", tname
, -case_value
);
10135 st
= gfc_find_symtree (ns
->sym_root
, name
);
10136 gcc_assert (st
->n
.sym
->assoc
);
10138 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
10139 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
10141 new_st
= gfc_get_code (EXEC_BLOCK
);
10142 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
10143 new_st
->ext
.block
.ns
->code
= body
->next
;
10144 body
->next
= new_st
;
10146 /* Chain in the new list only if it is marked as dangling. Otherwise
10147 there is a CASE label overlap and this is already used. Just ignore,
10148 the error is diagnosed elsewhere. */
10149 if (st
->n
.sym
->assoc
->dangling
)
10151 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
10152 st
->n
.sym
->assoc
->dangling
= 0;
10155 resolve_assoc_var (st
->n
.sym
, false);
10158 gfc_current_ns
= ns
;
10159 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
10160 gfc_current_ns
= old_ns
;
10164 /* Resolve a transfer statement. This is making sure that:
10165 -- a derived type being transferred has only non-pointer components
10166 -- a derived type being transferred doesn't have private components, unless
10167 it's being transferred from the module where the type was defined
10168 -- we're not trying to transfer a whole assumed size array. */
10171 resolve_transfer (gfc_code
*code
)
10173 gfc_symbol
*sym
, *derived
;
10176 bool write
= false;
10177 bool formatted
= false;
10178 gfc_dt
*dt
= code
->ext
.dt
;
10179 gfc_symbol
*dtio_sub
= NULL
;
10183 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
10184 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
10185 exp
= exp
->value
.op
.op1
;
10187 if (exp
&& exp
->expr_type
== EXPR_NULL
10190 gfc_error ("Invalid context for NULL () intrinsic at %L",
10195 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
10196 && exp
->expr_type
!= EXPR_FUNCTION
10197 && exp
->expr_type
!= EXPR_ARRAY
10198 && exp
->expr_type
!= EXPR_STRUCTURE
))
10201 /* If we are reading, the variable will be changed. Note that
10202 code->ext.dt may be NULL if the TRANSFER is related to
10203 an INQUIRE statement -- but in this case, we are not reading, either. */
10204 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
10205 && !gfc_check_vardef_context (exp
, false, false, false,
10206 _("item in READ")))
10209 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
10210 || exp
->expr_type
== EXPR_FUNCTION
10211 || exp
->expr_type
== EXPR_ARRAY
10212 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
10214 /* Go to actual component transferred. */
10215 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
10216 if (ref
->type
== REF_COMPONENT
)
10217 ts
= &ref
->u
.c
.component
->ts
;
10219 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
10220 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
10222 derived
= ts
->u
.derived
;
10224 /* Determine when to use the formatted DTIO procedure. */
10225 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
10228 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
10229 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
10230 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
10232 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
10235 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
10236 /* Check to see if this is a nested DTIO call, with the
10237 dummy as the io-list object. */
10238 if (sym
&& sym
== dtio_sub
&& sym
->formal
10239 && sym
->formal
->sym
== exp
->symtree
->n
.sym
10240 && exp
->ref
== NULL
)
10242 if (!sym
->attr
.recursive
)
10244 gfc_error ("DTIO %s procedure at %L must be recursive",
10245 sym
->name
, &sym
->declared_at
);
10252 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
10254 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
10255 "it is processed by a defined input/output procedure",
10260 if (ts
->type
== BT_DERIVED
)
10262 /* Check that transferred derived type doesn't contain POINTER
10263 components unless it is processed by a defined input/output
10265 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
10267 gfc_error ("Data transfer element at %L cannot have POINTER "
10268 "components unless it is processed by a defined "
10269 "input/output procedure", &code
->loc
);
10274 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
10276 gfc_error ("Data transfer element at %L cannot have "
10277 "procedure pointer components", &code
->loc
);
10281 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
10283 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
10284 "components unless it is processed by a defined "
10285 "input/output procedure", &code
->loc
);
10289 /* C_PTR and C_FUNPTR have private components which means they cannot
10290 be printed. However, if -std=gnu and not -pedantic, allow
10291 the component to be printed to help debugging. */
10292 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
10294 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
10295 "cannot have PRIVATE components", &code
->loc
))
10298 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
10300 gfc_error ("Data transfer element at %L cannot have "
10301 "PRIVATE components unless it is processed by "
10302 "a defined input/output procedure", &code
->loc
);
10307 if (exp
->expr_type
== EXPR_STRUCTURE
)
10310 if (exp
->expr_type
== EXPR_ARRAY
)
10313 sym
= exp
->symtree
->n
.sym
;
10315 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
10316 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
10318 gfc_error ("Data transfer element at %L cannot be a full reference to "
10319 "an assumed-size array", &code
->loc
);
10325 /*********** Toplevel code resolution subroutines ***********/
10327 /* Find the set of labels that are reachable from this block. We also
10328 record the last statement in each block. */
10331 find_reachable_labels (gfc_code
*block
)
10338 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
10340 /* Collect labels in this block. We don't keep those corresponding
10341 to END {IF|SELECT}, these are checked in resolve_branch by going
10342 up through the code_stack. */
10343 for (c
= block
; c
; c
= c
->next
)
10345 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
10346 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
10349 /* Merge with labels from parent block. */
10352 gcc_assert (cs_base
->prev
->reachable_labels
);
10353 bitmap_ior_into (cs_base
->reachable_labels
,
10354 cs_base
->prev
->reachable_labels
);
10360 resolve_lock_unlock_event (gfc_code
*code
)
10362 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10363 && code
->expr1
->value
.function
.isym
10364 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10365 remove_caf_get_intrinsic (code
->expr1
);
10367 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
10368 && (code
->expr1
->ts
.type
!= BT_DERIVED
10369 || code
->expr1
->expr_type
!= EXPR_VARIABLE
10370 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
10371 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
10372 || code
->expr1
->rank
!= 0
10373 || (!gfc_is_coarray (code
->expr1
) &&
10374 !gfc_is_coindexed (code
->expr1
))))
10375 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
10376 &code
->expr1
->where
);
10377 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
10378 && (code
->expr1
->ts
.type
!= BT_DERIVED
10379 || code
->expr1
->expr_type
!= EXPR_VARIABLE
10380 || code
->expr1
->ts
.u
.derived
->from_intmod
10381 != INTMOD_ISO_FORTRAN_ENV
10382 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
10383 != ISOFORTRAN_EVENT_TYPE
10384 || code
->expr1
->rank
!= 0))
10385 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
10386 &code
->expr1
->where
);
10387 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
10388 && !gfc_is_coindexed (code
->expr1
))
10389 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
10390 &code
->expr1
->where
);
10391 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
10392 gfc_error ("Event variable argument at %L must be a coarray but not "
10393 "coindexed", &code
->expr1
->where
);
10397 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
10398 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
10399 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10400 &code
->expr2
->where
);
10403 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
10404 _("STAT variable")))
10407 /* Check ERRMSG. */
10409 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
10410 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
10411 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10412 &code
->expr3
->where
);
10415 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
10416 _("ERRMSG variable")))
10419 /* Check for LOCK the ACQUIRED_LOCK. */
10420 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
10421 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
10422 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
10423 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
10424 "variable", &code
->expr4
->where
);
10426 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
10427 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
10428 _("ACQUIRED_LOCK variable")))
10431 /* Check for EVENT WAIT the UNTIL_COUNT. */
10432 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
10434 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
10435 || code
->expr4
->rank
!= 0)
10436 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
10437 "expression", &code
->expr4
->where
);
10443 resolve_critical (gfc_code
*code
)
10445 gfc_symtree
*symtree
;
10446 gfc_symbol
*lock_type
;
10447 char name
[GFC_MAX_SYMBOL_LEN
];
10448 static int serial
= 0;
10450 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
10453 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
10454 GFC_PREFIX ("lock_type"));
10456 lock_type
= symtree
->n
.sym
;
10459 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
10461 gcc_unreachable ();
10462 lock_type
= symtree
->n
.sym
;
10463 lock_type
->attr
.flavor
= FL_DERIVED
;
10464 lock_type
->attr
.zero_comp
= 1;
10465 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
10466 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
10469 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
10470 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
10471 gcc_unreachable ();
10473 code
->resolved_sym
= symtree
->n
.sym
;
10474 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10475 symtree
->n
.sym
->attr
.referenced
= 1;
10476 symtree
->n
.sym
->attr
.artificial
= 1;
10477 symtree
->n
.sym
->attr
.codimension
= 1;
10478 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
10479 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
10480 symtree
->n
.sym
->as
= gfc_get_array_spec ();
10481 symtree
->n
.sym
->as
->corank
= 1;
10482 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
10483 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
10484 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
10486 gfc_commit_symbols();
10491 resolve_sync (gfc_code
*code
)
10493 /* Check imageset. The * case matches expr1 == NULL. */
10496 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
10497 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
10498 "INTEGER expression", &code
->expr1
->where
);
10499 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
10500 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
10501 gfc_error ("Imageset argument at %L must between 1 and num_images()",
10502 &code
->expr1
->where
);
10503 else if (code
->expr1
->expr_type
== EXPR_ARRAY
10504 && gfc_simplify_expr (code
->expr1
, 0))
10506 gfc_constructor
*cons
;
10507 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
10508 for (; cons
; cons
= gfc_constructor_next (cons
))
10509 if (cons
->expr
->expr_type
== EXPR_CONSTANT
10510 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
10511 gfc_error ("Imageset argument at %L must between 1 and "
10512 "num_images()", &cons
->expr
->where
);
10517 gfc_resolve_expr (code
->expr2
);
10520 if (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0)
10521 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10522 &code
->expr2
->where
);
10524 gfc_check_vardef_context (code
->expr2
, false, false, false,
10525 _("STAT variable"));
10528 /* Check ERRMSG. */
10529 gfc_resolve_expr (code
->expr3
);
10532 if (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0)
10533 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10534 &code
->expr3
->where
);
10536 gfc_check_vardef_context (code
->expr3
, false, false, false,
10537 _("ERRMSG variable"));
10542 /* Given a branch to a label, see if the branch is conforming.
10543 The code node describes where the branch is located. */
10546 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
10553 /* Step one: is this a valid branching target? */
10555 if (label
->defined
== ST_LABEL_UNKNOWN
)
10557 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
10562 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
10564 gfc_error ("Statement at %L is not a valid branch target statement "
10565 "for the branch statement at %L", &label
->where
, &code
->loc
);
10569 /* Step two: make sure this branch is not a branch to itself ;-) */
10571 if (code
->here
== label
)
10574 "Branch at %L may result in an infinite loop", &code
->loc
);
10578 /* Step three: See if the label is in the same block as the
10579 branching statement. The hard work has been done by setting up
10580 the bitmap reachable_labels. */
10582 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
10584 /* Check now whether there is a CRITICAL construct; if so, check
10585 whether the label is still visible outside of the CRITICAL block,
10586 which is invalid. */
10587 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10589 if (stack
->current
->op
== EXEC_CRITICAL
10590 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10591 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
10592 "label at %L", &code
->loc
, &label
->where
);
10593 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
10594 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10595 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
10596 "for label at %L", &code
->loc
, &label
->where
);
10602 /* Step four: If we haven't found the label in the bitmap, it may
10603 still be the label of the END of the enclosing block, in which
10604 case we find it by going up the code_stack. */
10606 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10608 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
10610 if (stack
->current
->op
== EXEC_CRITICAL
)
10612 /* Note: A label at END CRITICAL does not leave the CRITICAL
10613 construct as END CRITICAL is still part of it. */
10614 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
10615 " at %L", &code
->loc
, &label
->where
);
10618 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
10620 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
10621 "label at %L", &code
->loc
, &label
->where
);
10628 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
10632 /* The label is not in an enclosing block, so illegal. This was
10633 allowed in Fortran 66, so we allow it as extension. No
10634 further checks are necessary in this case. */
10635 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
10636 "as the GOTO statement at %L", &label
->where
,
10642 /* Check whether EXPR1 has the same shape as EXPR2. */
10645 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
10647 mpz_t shape
[GFC_MAX_DIMENSIONS
];
10648 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
10649 bool result
= false;
10652 /* Compare the rank. */
10653 if (expr1
->rank
!= expr2
->rank
)
10656 /* Compare the size of each dimension. */
10657 for (i
=0; i
<expr1
->rank
; i
++)
10659 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
10662 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
10665 if (mpz_cmp (shape
[i
], shape2
[i
]))
10669 /* When either of the two expression is an assumed size array, we
10670 ignore the comparison of dimension sizes. */
10675 gfc_clear_shape (shape
, i
);
10676 gfc_clear_shape (shape2
, i
);
10681 /* Check whether a WHERE assignment target or a WHERE mask expression
10682 has the same shape as the outmost WHERE mask expression. */
10685 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
10689 gfc_expr
*e
= NULL
;
10691 cblock
= code
->block
;
10693 /* Store the first WHERE mask-expr of the WHERE statement or construct.
10694 In case of nested WHERE, only the outmost one is stored. */
10695 if (mask
== NULL
) /* outmost WHERE */
10697 else /* inner WHERE */
10704 /* Check if the mask-expr has a consistent shape with the
10705 outmost WHERE mask-expr. */
10706 if (!resolve_where_shape (cblock
->expr1
, e
))
10707 gfc_error ("WHERE mask at %L has inconsistent shape",
10708 &cblock
->expr1
->where
);
10711 /* the assignment statement of a WHERE statement, or the first
10712 statement in where-body-construct of a WHERE construct */
10713 cnext
= cblock
->next
;
10718 /* WHERE assignment statement */
10721 /* Check shape consistent for WHERE assignment target. */
10722 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10723 gfc_error ("WHERE assignment target at %L has "
10724 "inconsistent shape", &cnext
->expr1
->where
);
10726 if (cnext
->op
== EXEC_ASSIGN
10727 && gfc_may_be_finalized (cnext
->expr1
->ts
))
10728 cnext
->expr1
->must_finalize
= 1;
10733 case EXEC_ASSIGN_CALL
:
10734 resolve_call (cnext
);
10735 if (!cnext
->resolved_sym
->attr
.elemental
)
10736 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10737 &cnext
->ext
.actual
->expr
->where
);
10740 /* WHERE or WHERE construct is part of a where-body-construct */
10742 resolve_where (cnext
, e
);
10746 gfc_error ("Unsupported statement inside WHERE at %L",
10749 /* the next statement within the same where-body-construct */
10750 cnext
= cnext
->next
;
10752 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10753 cblock
= cblock
->block
;
10758 /* Resolve assignment in FORALL construct.
10759 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10760 FORALL index variables. */
10763 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10767 for (n
= 0; n
< nvar
; n
++)
10769 gfc_symbol
*forall_index
;
10771 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10773 /* Check whether the assignment target is one of the FORALL index
10775 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10776 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10777 gfc_error ("Assignment to a FORALL index variable at %L",
10778 &code
->expr1
->where
);
10781 /* If one of the FORALL index variables doesn't appear in the
10782 assignment variable, then there could be a many-to-one
10783 assignment. Emit a warning rather than an error because the
10784 mask could be resolving this problem. */
10785 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10786 gfc_warning (0, "The FORALL with index %qs is not used on the "
10787 "left side of the assignment at %L and so might "
10788 "cause multiple assignment to this object",
10789 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10795 /* Resolve WHERE statement in FORALL construct. */
10798 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10799 gfc_expr
**var_expr
)
10804 cblock
= code
->block
;
10807 /* the assignment statement of a WHERE statement, or the first
10808 statement in where-body-construct of a WHERE construct */
10809 cnext
= cblock
->next
;
10814 /* WHERE assignment statement */
10816 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10818 if (cnext
->op
== EXEC_ASSIGN
10819 && gfc_may_be_finalized (cnext
->expr1
->ts
))
10820 cnext
->expr1
->must_finalize
= 1;
10824 /* WHERE operator assignment statement */
10825 case EXEC_ASSIGN_CALL
:
10826 resolve_call (cnext
);
10827 if (!cnext
->resolved_sym
->attr
.elemental
)
10828 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10829 &cnext
->ext
.actual
->expr
->where
);
10832 /* WHERE or WHERE construct is part of a where-body-construct */
10834 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10838 gfc_error ("Unsupported statement inside WHERE at %L",
10841 /* the next statement within the same where-body-construct */
10842 cnext
= cnext
->next
;
10844 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10845 cblock
= cblock
->block
;
10850 /* Traverse the FORALL body to check whether the following errors exist:
10851 1. For assignment, check if a many-to-one assignment happens.
10852 2. For WHERE statement, check the WHERE body to see if there is any
10853 many-to-one assignment. */
10856 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10860 c
= code
->block
->next
;
10866 case EXEC_POINTER_ASSIGN
:
10867 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10869 if (c
->op
== EXEC_ASSIGN
10870 && gfc_may_be_finalized (c
->expr1
->ts
))
10871 c
->expr1
->must_finalize
= 1;
10875 case EXEC_ASSIGN_CALL
:
10879 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10880 there is no need to handle it here. */
10884 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10889 /* The next statement in the FORALL body. */
10895 /* Counts the number of iterators needed inside a forall construct, including
10896 nested forall constructs. This is used to allocate the needed memory
10897 in gfc_resolve_forall. */
10900 gfc_count_forall_iterators (gfc_code
*code
)
10902 int max_iters
, sub_iters
, current_iters
;
10903 gfc_forall_iterator
*fa
;
10905 gcc_assert(code
->op
== EXEC_FORALL
);
10909 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10912 code
= code
->block
->next
;
10916 if (code
->op
== EXEC_FORALL
)
10918 sub_iters
= gfc_count_forall_iterators (code
);
10919 if (sub_iters
> max_iters
)
10920 max_iters
= sub_iters
;
10925 return current_iters
+ max_iters
;
10929 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10930 gfc_resolve_forall_body to resolve the FORALL body. */
10933 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10935 static gfc_expr
**var_expr
;
10936 static int total_var
= 0;
10937 static int nvar
= 0;
10938 int i
, old_nvar
, tmp
;
10939 gfc_forall_iterator
*fa
;
10943 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10946 /* Start to resolve a FORALL construct */
10947 if (forall_save
== 0)
10949 /* Count the total number of FORALL indices in the nested FORALL
10950 construct in order to allocate the VAR_EXPR with proper size. */
10951 total_var
= gfc_count_forall_iterators (code
);
10953 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10954 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10957 /* The information about FORALL iterator, including FORALL indices start, end
10958 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10959 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10961 /* Fortran 20008: C738 (R753). */
10962 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10964 gfc_error ("FORALL index-name at %L must be a scalar variable "
10965 "of type integer", &fa
->var
->where
);
10969 /* Check if any outer FORALL index name is the same as the current
10971 for (i
= 0; i
< nvar
; i
++)
10973 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10974 gfc_error ("An outer FORALL construct already has an index "
10975 "with this name %L", &fa
->var
->where
);
10978 /* Record the current FORALL index. */
10979 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10983 /* No memory leak. */
10984 gcc_assert (nvar
<= total_var
);
10987 /* Resolve the FORALL body. */
10988 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10990 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10991 gfc_resolve_blocks (code
->block
, ns
);
10995 /* Free only the VAR_EXPRs allocated in this frame. */
10996 for (i
= nvar
; i
< tmp
; i
++)
10997 gfc_free_expr (var_expr
[i
]);
11001 /* We are in the outermost FORALL construct. */
11002 gcc_assert (forall_save
== 0);
11004 /* VAR_EXPR is not needed any more. */
11011 /* Resolve a BLOCK construct statement. */
11014 resolve_block_construct (gfc_code
* code
)
11016 gfc_namespace
*ns
= code
->ext
.block
.ns
;
11018 /* For an ASSOCIATE block, the associations (and their targets) are already
11019 resolved during resolve_symbol. Resolve the BLOCK's namespace. */
11024 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
11028 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
11032 for (; b
; b
= b
->block
)
11034 t
= gfc_resolve_expr (b
->expr1
);
11035 if (!gfc_resolve_expr (b
->expr2
))
11041 if (t
&& b
->expr1
!= NULL
11042 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
11043 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11049 && b
->expr1
!= NULL
11050 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
11051 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
11056 resolve_branch (b
->label1
, b
);
11060 resolve_block_construct (b
);
11064 case EXEC_SELECT_TYPE
:
11065 case EXEC_SELECT_RANK
:
11068 case EXEC_DO_WHILE
:
11069 case EXEC_DO_CONCURRENT
:
11070 case EXEC_CRITICAL
:
11073 case EXEC_IOLENGTH
:
11077 case EXEC_OMP_ATOMIC
:
11078 case EXEC_OACC_ATOMIC
:
11080 /* Verify this before calling gfc_resolve_code, which might
11082 gcc_assert (b
->op
== EXEC_OMP_ATOMIC
11083 || (b
->next
&& b
->next
->op
== EXEC_ASSIGN
));
11087 case EXEC_OACC_PARALLEL_LOOP
:
11088 case EXEC_OACC_PARALLEL
:
11089 case EXEC_OACC_KERNELS_LOOP
:
11090 case EXEC_OACC_KERNELS
:
11091 case EXEC_OACC_SERIAL_LOOP
:
11092 case EXEC_OACC_SERIAL
:
11093 case EXEC_OACC_DATA
:
11094 case EXEC_OACC_HOST_DATA
:
11095 case EXEC_OACC_LOOP
:
11096 case EXEC_OACC_UPDATE
:
11097 case EXEC_OACC_WAIT
:
11098 case EXEC_OACC_CACHE
:
11099 case EXEC_OACC_ENTER_DATA
:
11100 case EXEC_OACC_EXIT_DATA
:
11101 case EXEC_OACC_ROUTINE
:
11102 case EXEC_OMP_ALLOCATE
:
11103 case EXEC_OMP_ALLOCATORS
:
11104 case EXEC_OMP_ASSUME
:
11105 case EXEC_OMP_CRITICAL
:
11106 case EXEC_OMP_DISTRIBUTE
:
11107 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11108 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11109 case EXEC_OMP_DISTRIBUTE_SIMD
:
11111 case EXEC_OMP_DO_SIMD
:
11112 case EXEC_OMP_ERROR
:
11113 case EXEC_OMP_LOOP
:
11114 case EXEC_OMP_MASKED
:
11115 case EXEC_OMP_MASKED_TASKLOOP
:
11116 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
11117 case EXEC_OMP_MASTER
:
11118 case EXEC_OMP_MASTER_TASKLOOP
:
11119 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
11120 case EXEC_OMP_ORDERED
:
11121 case EXEC_OMP_PARALLEL
:
11122 case EXEC_OMP_PARALLEL_DO
:
11123 case EXEC_OMP_PARALLEL_DO_SIMD
:
11124 case EXEC_OMP_PARALLEL_LOOP
:
11125 case EXEC_OMP_PARALLEL_MASKED
:
11126 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
11127 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
11128 case EXEC_OMP_PARALLEL_MASTER
:
11129 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
11130 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
11131 case EXEC_OMP_PARALLEL_SECTIONS
:
11132 case EXEC_OMP_PARALLEL_WORKSHARE
:
11133 case EXEC_OMP_SECTIONS
:
11134 case EXEC_OMP_SIMD
:
11135 case EXEC_OMP_SCOPE
:
11136 case EXEC_OMP_SINGLE
:
11137 case EXEC_OMP_TARGET
:
11138 case EXEC_OMP_TARGET_DATA
:
11139 case EXEC_OMP_TARGET_ENTER_DATA
:
11140 case EXEC_OMP_TARGET_EXIT_DATA
:
11141 case EXEC_OMP_TARGET_PARALLEL
:
11142 case EXEC_OMP_TARGET_PARALLEL_DO
:
11143 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11144 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
11145 case EXEC_OMP_TARGET_SIMD
:
11146 case EXEC_OMP_TARGET_TEAMS
:
11147 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11148 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11149 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11150 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11151 case EXEC_OMP_TARGET_TEAMS_LOOP
:
11152 case EXEC_OMP_TARGET_UPDATE
:
11153 case EXEC_OMP_TASK
:
11154 case EXEC_OMP_TASKGROUP
:
11155 case EXEC_OMP_TASKLOOP
:
11156 case EXEC_OMP_TASKLOOP_SIMD
:
11157 case EXEC_OMP_TASKWAIT
:
11158 case EXEC_OMP_TASKYIELD
:
11159 case EXEC_OMP_TEAMS
:
11160 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11161 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11162 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11163 case EXEC_OMP_TEAMS_LOOP
:
11164 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11165 case EXEC_OMP_WORKSHARE
:
11169 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
11172 gfc_resolve_code (b
->next
, ns
);
11177 /* Does everything to resolve an ordinary assignment. Returns true
11178 if this is an interface assignment. */
11180 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
11187 symbol_attribute attr
;
11189 if (gfc_extend_assign (code
, ns
))
11193 if (code
->op
== EXEC_ASSIGN_CALL
)
11195 lhs
= code
->ext
.actual
->expr
;
11196 rhsptr
= &code
->ext
.actual
->next
->expr
;
11200 gfc_actual_arglist
* args
;
11201 gfc_typebound_proc
* tbp
;
11203 gcc_assert (code
->op
== EXEC_COMPCALL
);
11205 args
= code
->expr1
->value
.compcall
.actual
;
11207 rhsptr
= &args
->next
->expr
;
11209 tbp
= code
->expr1
->value
.compcall
.tbp
;
11210 gcc_assert (!tbp
->is_generic
);
11213 /* Make a temporary rhs when there is a default initializer
11214 and rhs is the same symbol as the lhs. */
11215 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
11216 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
11217 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
11218 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
11219 *rhsptr
= gfc_get_parentheses (*rhsptr
);
11227 if ((lhs
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
11228 || lhs
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
11229 && !lhs
->symtree
->n
.sym
->attr
.proc_pointer
11230 && gfc_expr_attr (lhs
).proc_pointer
)
11232 gfc_error ("Variable in the ordinary assignment at %L is a procedure "
11233 "pointer component",
11238 if ((gfc_numeric_ts (&lhs
->ts
) || lhs
->ts
.type
== BT_LOGICAL
)
11239 && rhs
->ts
.type
== BT_CHARACTER
11240 && (rhs
->expr_type
!= EXPR_CONSTANT
|| !flag_dec_char_conversions
))
11242 /* Use of -fdec-char-conversions allows assignment of character data
11243 to non-character variables. This not permitted for nonconstant
11245 gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs
),
11246 gfc_typename (lhs
), &rhs
->where
);
11250 /* Handle the case of a BOZ literal on the RHS. */
11251 if (rhs
->ts
.type
== BT_BOZ
)
11253 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
11254 "statement value nor an actual argument of "
11255 "INT/REAL/DBLE/CMPLX intrinsic subprogram",
11259 switch (lhs
->ts
.type
)
11262 if (!gfc_boz2int (rhs
, lhs
->ts
.kind
))
11266 if (!gfc_boz2real (rhs
, lhs
->ts
.kind
))
11270 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs
->where
);
11275 if (lhs
->ts
.type
== BT_CHARACTER
&& warn_character_truncation
)
11277 HOST_WIDE_INT llen
= 0, rlen
= 0;
11278 if (lhs
->ts
.u
.cl
!= NULL
11279 && lhs
->ts
.u
.cl
->length
!= NULL
11280 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
11281 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
11283 if (rhs
->expr_type
== EXPR_CONSTANT
)
11284 rlen
= rhs
->value
.character
.length
;
11286 else if (rhs
->ts
.u
.cl
!= NULL
11287 && rhs
->ts
.u
.cl
->length
!= NULL
11288 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
11289 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
11291 if (rlen
&& llen
&& rlen
> llen
)
11292 gfc_warning_now (OPT_Wcharacter_truncation
,
11293 "CHARACTER expression will be truncated "
11294 "in assignment (%ld/%ld) at %L",
11295 (long) llen
, (long) rlen
, &code
->loc
);
11298 /* Ensure that a vector index expression for the lvalue is evaluated
11299 to a temporary if the lvalue symbol is referenced in it. */
11302 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
11303 if (ref
->type
== REF_ARRAY
)
11305 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
11306 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
11307 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
11308 ref
->u
.ar
.start
[n
]))
11310 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
11314 if (gfc_pure (NULL
))
11316 if (lhs
->ts
.type
== BT_DERIVED
11317 && lhs
->expr_type
== EXPR_VARIABLE
11318 && lhs
->ts
.u
.derived
->attr
.pointer_comp
11319 && rhs
->expr_type
== EXPR_VARIABLE
11320 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
11321 || gfc_is_coindexed (rhs
)))
11323 /* F2008, C1283. */
11324 if (gfc_is_coindexed (rhs
))
11325 gfc_error ("Coindexed expression at %L is assigned to "
11326 "a derived type variable with a POINTER "
11327 "component in a PURE procedure",
11330 /* F2008, C1283 (4). */
11331 gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
11332 "shall not be used as the expr at %L of an intrinsic "
11333 "assignment statement in which the variable is of a "
11334 "derived type if the derived type has a pointer "
11335 "component at any level of component selection.",
11340 /* Fortran 2008, C1283. */
11341 if (gfc_is_coindexed (lhs
))
11343 gfc_error ("Assignment to coindexed variable at %L in a PURE "
11344 "procedure", &rhs
->where
);
11349 if (gfc_implicit_pure (NULL
))
11351 if (lhs
->expr_type
== EXPR_VARIABLE
11352 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
11353 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
11354 gfc_unset_implicit_pure (NULL
);
11356 if (lhs
->ts
.type
== BT_DERIVED
11357 && lhs
->expr_type
== EXPR_VARIABLE
11358 && lhs
->ts
.u
.derived
->attr
.pointer_comp
11359 && rhs
->expr_type
== EXPR_VARIABLE
11360 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
11361 || gfc_is_coindexed (rhs
)))
11362 gfc_unset_implicit_pure (NULL
);
11364 /* Fortran 2008, C1283. */
11365 if (gfc_is_coindexed (lhs
))
11366 gfc_unset_implicit_pure (NULL
);
11369 /* F2008, 7.2.1.2. */
11370 attr
= gfc_expr_attr (lhs
);
11371 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
11373 if (attr
.codimension
)
11375 gfc_error ("Assignment to polymorphic coarray at %L is not "
11376 "permitted", &lhs
->where
);
11379 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
11380 "polymorphic variable at %L", &lhs
->where
))
11382 if (!flag_realloc_lhs
)
11384 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
11385 "requires %<-frealloc-lhs%>", &lhs
->where
);
11389 else if (lhs
->ts
.type
== BT_CLASS
)
11391 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
11392 "assignment at %L - check that there is a matching specific "
11393 "subroutine for %<=%> operator", &lhs
->where
);
11397 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
11399 /* F2008, Section 7.2.1.2. */
11400 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
11402 gfc_error ("Coindexed variable must not have an allocatable ultimate "
11403 "component in assignment at %L", &lhs
->where
);
11407 /* Assign the 'data' of a class object to a derived type. */
11408 if (lhs
->ts
.type
== BT_DERIVED
11409 && rhs
->ts
.type
== BT_CLASS
11410 && rhs
->expr_type
!= EXPR_ARRAY
)
11411 gfc_add_data_component (rhs
);
11413 /* Make sure there is a vtable and, in particular, a _copy for the
11415 if (lhs
->ts
.type
== BT_CLASS
&& rhs
->ts
.type
!= BT_CLASS
)
11416 gfc_find_vtab (&rhs
->ts
);
11418 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
11420 || (code
->expr2
->expr_type
== EXPR_FUNCTION
11421 && code
->expr2
->value
.function
.isym
11422 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
11423 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
11424 && !gfc_expr_attr (rhs
).allocatable
11425 && !gfc_has_vector_subscript (rhs
)));
11427 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
11429 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
11430 Additionally, insert this code when the RHS is a CAF as we then use the
11431 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
11432 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
11433 noncoindexed array and the RHS is a coindexed scalar, use the normal code
11435 if (caf_convert_to_send
)
11437 if (code
->expr2
->expr_type
== EXPR_FUNCTION
11438 && code
->expr2
->value
.function
.isym
11439 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11440 remove_caf_get_intrinsic (code
->expr2
);
11441 code
->op
= EXEC_CALL
;
11442 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
11443 code
->resolved_sym
= code
->symtree
->n
.sym
;
11444 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
11445 code
->resolved_sym
->attr
.intrinsic
= 1;
11446 code
->resolved_sym
->attr
.subroutine
= 1;
11447 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
11448 gfc_commit_symbol (code
->resolved_sym
);
11449 code
->ext
.actual
= gfc_get_actual_arglist ();
11450 code
->ext
.actual
->expr
= lhs
;
11451 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
11452 code
->ext
.actual
->next
->expr
= rhs
;
11453 code
->expr1
= NULL
;
11454 code
->expr2
= NULL
;
11461 /* Add a component reference onto an expression. */
11464 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
11469 ref
= &((*ref
)->next
);
11470 *ref
= gfc_get_ref ();
11471 (*ref
)->type
= REF_COMPONENT
;
11472 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
11473 (*ref
)->u
.c
.component
= c
;
11476 /* Add a full array ref, as necessary. */
11479 gfc_add_full_array_ref (e
, c
->as
);
11480 e
->rank
= c
->as
->rank
;
11485 /* Build an assignment. Keep the argument 'op' for future use, so that
11486 pointer assignments can be made. */
11489 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
11490 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
11492 gfc_code
*this_code
;
11494 this_code
= gfc_get_code (op
);
11495 this_code
->next
= NULL
;
11496 this_code
->expr1
= gfc_copy_expr (expr1
);
11497 this_code
->expr2
= gfc_copy_expr (expr2
);
11498 this_code
->loc
= loc
;
11499 if (comp1
&& comp2
)
11501 add_comp_ref (this_code
->expr1
, comp1
);
11502 add_comp_ref (this_code
->expr2
, comp2
);
11509 /* Makes a temporary variable expression based on the characteristics of
11510 a given variable expression. */
11513 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
11515 static int serial
= 0;
11516 char name
[GFC_MAX_SYMBOL_LEN
];
11518 gfc_array_spec
*as
;
11519 gfc_array_ref
*aref
;
11522 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
11523 gfc_get_sym_tree (name
, ns
, &tmp
, false);
11524 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
11526 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
11527 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
11529 e
->value
.character
.length
);
11535 /* Obtain the arrayspec for the temporary. */
11536 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
11537 && e
->expr_type
!= EXPR_FUNCTION
11538 && e
->expr_type
!= EXPR_OP
)
11540 aref
= gfc_find_array_ref (e
);
11541 if (e
->expr_type
== EXPR_VARIABLE
11542 && e
->symtree
->n
.sym
->as
== aref
->as
)
11546 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
11547 if (ref
->type
== REF_COMPONENT
11548 && ref
->u
.c
.component
->as
== aref
->as
)
11556 /* Add the attributes and the arrayspec to the temporary. */
11557 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
11558 tmp
->n
.sym
->attr
.function
= 0;
11559 tmp
->n
.sym
->attr
.proc_pointer
= 0;
11560 tmp
->n
.sym
->attr
.result
= 0;
11561 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
11562 tmp
->n
.sym
->attr
.dummy
= 0;
11563 tmp
->n
.sym
->attr
.use_assoc
= 0;
11564 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
11569 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
11572 if (as
->type
== AS_DEFERRED
)
11573 tmp
->n
.sym
->attr
.allocatable
= 1;
11575 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
11576 || e
->expr_type
== EXPR_FUNCTION
11577 || e
->expr_type
== EXPR_OP
))
11579 tmp
->n
.sym
->as
= gfc_get_array_spec ();
11580 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
11581 tmp
->n
.sym
->as
->rank
= e
->rank
;
11582 tmp
->n
.sym
->attr
.allocatable
= 1;
11583 tmp
->n
.sym
->attr
.dimension
= 1;
11586 tmp
->n
.sym
->attr
.dimension
= 0;
11588 gfc_set_sym_referenced (tmp
->n
.sym
);
11589 gfc_commit_symbol (tmp
->n
.sym
);
11590 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
11592 /* Should the lhs be a section, use its array ref for the
11593 temporary expression. */
11594 if (aref
&& aref
->type
!= AR_FULL
)
11596 gfc_free_ref_list (e
->ref
);
11597 e
->ref
= gfc_copy_ref (ref
);
11603 /* Add one line of code to the code chain, making sure that 'head' and
11604 'tail' are appropriately updated. */
11607 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
11609 gcc_assert (this_code
);
11611 *head
= *tail
= *this_code
;
11613 *tail
= gfc_append_code (*tail
, *this_code
);
11618 /* Generate a final call from a variable expression */
11621 generate_final_call (gfc_expr
*tmp_expr
, gfc_code
**head
, gfc_code
**tail
)
11623 gfc_code
*this_code
;
11624 gfc_expr
*final_expr
= NULL
;
11625 gfc_expr
*size_expr
;
11626 gfc_expr
*fini_coarray
;
11628 gcc_assert (tmp_expr
->expr_type
== EXPR_VARIABLE
);
11629 if (!gfc_is_finalizable (tmp_expr
->ts
.u
.derived
, &final_expr
) || !final_expr
)
11632 /* Now generate the finalizer call. */
11633 this_code
= gfc_get_code (EXEC_CALL
);
11634 this_code
->symtree
= final_expr
->symtree
;
11635 this_code
->resolved_sym
= final_expr
->symtree
->n
.sym
;
11637 //* Expression to be finalized */
11638 this_code
->ext
.actual
= gfc_get_actual_arglist ();
11639 this_code
->ext
.actual
->expr
= gfc_copy_expr (tmp_expr
);
11641 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
11642 this_code
->ext
.actual
->next
= gfc_get_actual_arglist ();
11643 size_expr
= gfc_get_expr ();
11644 size_expr
->where
= gfc_current_locus
;
11645 size_expr
->expr_type
= EXPR_OP
;
11646 size_expr
->value
.op
.op
= INTRINSIC_DIVIDE
;
11647 size_expr
->value
.op
.op1
11648 = gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_STORAGE_SIZE
,
11649 "storage_size", gfc_current_locus
, 2,
11650 gfc_lval_expr_from_sym (tmp_expr
->symtree
->n
.sym
),
11651 gfc_get_int_expr (gfc_index_integer_kind
,
11653 size_expr
->value
.op
.op2
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
,
11654 gfc_character_storage_size
);
11655 size_expr
->value
.op
.op1
->ts
= size_expr
->value
.op
.op2
->ts
;
11656 size_expr
->ts
= size_expr
->value
.op
.op1
->ts
;
11657 this_code
->ext
.actual
->next
->expr
= size_expr
;
11660 this_code
->ext
.actual
->next
->next
= gfc_get_actual_arglist ();
11661 fini_coarray
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
11663 fini_coarray
->value
.logical
= (int)gfc_expr_attr (tmp_expr
).codimension
;
11664 this_code
->ext
.actual
->next
->next
->expr
= fini_coarray
;
11666 add_code_to_chain (&this_code
, head
, tail
);
11670 /* Counts the potential number of part array references that would
11671 result from resolution of typebound defined assignments. */
11675 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
11678 int c_depth
= 0, t_depth
;
11680 for (c
= derived
->components
; c
; c
= c
->next
)
11682 if ((!gfc_bt_struct (c
->ts
.type
)
11684 || c
->attr
.allocatable
11685 || c
->attr
.proc_pointer_comp
11686 || c
->attr
.class_pointer
11687 || c
->attr
.proc_pointer
)
11688 && !c
->attr
.defined_assign_comp
)
11691 if (c
->as
&& c_depth
== 0)
11694 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
11695 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
11700 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
11702 return depth
+ c_depth
;
11706 /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
11707 "An intrinsic assignment where the variable is of derived type is performed
11708 as if each component of the variable were assigned from the corresponding
11709 component of expr using pointer assignment (10.2.2) for each pointer
11710 component, defined assignment for each nonpointer nonallocatable component
11711 of a type that has a type-bound defined assignment consistent with the
11712 component, intrinsic assignment for each other nonpointer nonallocatable
11713 component, and intrinsic assignment for each allocated coarray component.
11714 For unallocated coarray components, the corresponding component of the
11715 variable shall be unallocated. For a noncoarray allocatable component the
11716 following sequence of operations is applied.
11717 (1) If the component of the variable is allocated, it is deallocated.
11718 (2) If the component of the value of expr is allocated, the
11719 corresponding component of the variable is allocated with the same
11720 dynamic type and type parameters as the component of the value of
11721 expr. If it is an array, it is allocated with the same bounds. The
11722 value of the component of the value of expr is then assigned to the
11723 corresponding component of the variable using defined assignment if
11724 the declared type of the component has a type-bound defined
11725 assignment consistent with the component, and intrinsic assignment
11726 for the dynamic type of that component otherwise."
11728 The pointer assignments are taken care of by the intrinsic assignment of the
11729 structure itself. This function recursively adds defined assignments where
11730 required. The recursion is accomplished by calling gfc_resolve_code.
11732 When the lhs in a defined assignment has intent INOUT or is intent OUT
11733 and the component of 'var' is finalizable, we need a temporary for the
11734 lhs. In pseudo-code for an assignment var = expr:
11736 ! Confine finalization of temporaries, as far as possible.
11737 Enclose the code for the assignment in a block
11738 ! Only call function 'expr' once.
11739 #if ('expr is not a constant or an variable)
11742 ! Do the intrinsic assignment
11743 #if typeof ('var') has a typebound final subroutine
11746 ! Now do the component assignments
11747 #do over derived type components [%cmp]
11748 #if (cmp is a pointer of any kind)
11750 build the assignment
11752 #if the code is a typebound assignment
11753 #if (arg1 is INOUT or finalizable OUT && !t1)
11756 deal with allocatation or not of var and this component
11757 #elseif the code is an assignment by itself
11758 #if this component does not need finalization
11759 delete code and continue
11761 remove the leading assignment
11764 #if (t1 and (arg1 is INOUT or finalizable OUT))
11767 put all code chunks involving t1 to the top of the generated code
11768 insert the generated block in place of the original code
11772 is_finalizable_type (gfc_typespec ts
)
11776 if (ts
.type
!= BT_DERIVED
)
11779 /* (1) Check for FINAL subroutines. */
11780 if (ts
.u
.derived
->f2k_derived
&& ts
.u
.derived
->f2k_derived
->finalizers
)
11783 /* (2) Check for components of finalizable type. */
11784 for (c
= ts
.u
.derived
->components
; c
; c
= c
->next
)
11785 if (c
->ts
.type
== BT_DERIVED
11786 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
11787 && c
->ts
.u
.derived
->f2k_derived
11788 && c
->ts
.u
.derived
->f2k_derived
->finalizers
)
11794 /* The temporary assignments have to be put on top of the additional
11795 code to avoid the result being changed by the intrinsic assignment.
11797 static int component_assignment_level
= 0;
11798 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
11799 static bool finalizable_comp
;
11802 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
11804 gfc_component
*comp1
, *comp2
;
11805 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
11806 gfc_code
*tmp_code
= NULL
;
11807 gfc_expr
*t1
= NULL
;
11808 gfc_expr
*tmp_expr
= NULL
;
11809 int error_count
, depth
;
11810 bool finalizable_lhs
;
11812 gfc_get_errors (NULL
, &error_count
);
11814 /* Filter out continuing processing after an error. */
11816 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
11817 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
11820 /* TODO: Handle more than one part array reference in assignments. */
11821 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
11822 (*code
)->expr1
->rank
? 1 : 0);
11825 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
11826 "done because multiple part array references would "
11827 "occur in intermediate expressions.", &(*code
)->loc
);
11831 if (!component_assignment_level
)
11832 finalizable_comp
= true;
11834 /* Build a block so that function result temporaries are finalized
11835 locally on exiting the rather than enclosing scope. */
11836 if (!component_assignment_level
)
11838 ns
= gfc_build_block_ns (ns
);
11839 tmp_code
= gfc_get_code (EXEC_NOP
);
11840 *tmp_code
= **code
;
11841 tmp_code
->next
= NULL
;
11842 (*code
)->op
= EXEC_BLOCK
;
11843 (*code
)->ext
.block
.ns
= ns
;
11844 (*code
)->ext
.block
.assoc
= NULL
;
11845 (*code
)->expr1
= (*code
)->expr2
= NULL
;
11846 ns
->code
= tmp_code
;
11850 component_assignment_level
++;
11852 finalizable_lhs
= is_finalizable_type ((*code
)->expr1
->ts
);
11854 /* Create a temporary so that functions get called only once. */
11855 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
11856 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
11858 /* Assign the rhs to the temporary. */
11859 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11860 this_code
= build_assignment (EXEC_ASSIGN
,
11861 tmp_expr
, (*code
)->expr2
,
11862 NULL
, NULL
, (*code
)->loc
);
11863 this_code
->expr2
->must_finalize
= 1;
11864 /* Add the code and substitute the rhs expression. */
11865 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
11866 gfc_free_expr ((*code
)->expr2
);
11867 (*code
)->expr2
= tmp_expr
;
11870 /* Do the intrinsic assignment. This is not needed if the lhs is one
11871 of the temporaries generated here, since the intrinsic assignment
11872 to the final result already does this. */
11873 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '.')
11875 if (finalizable_lhs
)
11876 (*code
)->expr1
->must_finalize
= 1;
11877 this_code
= build_assignment (EXEC_ASSIGN
,
11878 (*code
)->expr1
, (*code
)->expr2
,
11879 NULL
, NULL
, (*code
)->loc
);
11880 add_code_to_chain (&this_code
, &head
, &tail
);
11883 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
11884 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
11886 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
11888 bool inout
= false;
11889 bool finalizable_out
= false;
11891 /* The intrinsic assignment does the right thing for pointers
11892 of all kinds and allocatable components. */
11893 if (!gfc_bt_struct (comp1
->ts
.type
)
11894 || comp1
->attr
.pointer
11895 || comp1
->attr
.allocatable
11896 || comp1
->attr
.proc_pointer_comp
11897 || comp1
->attr
.class_pointer
11898 || comp1
->attr
.proc_pointer
)
11901 finalizable_comp
= is_finalizable_type (comp1
->ts
)
11902 && !finalizable_lhs
;
11904 /* Make an assignment for this component. */
11905 this_code
= build_assignment (EXEC_ASSIGN
,
11906 (*code
)->expr1
, (*code
)->expr2
,
11907 comp1
, comp2
, (*code
)->loc
);
11909 /* Convert the assignment if there is a defined assignment for
11910 this type. Otherwise, using the call from gfc_resolve_code,
11911 recurse into its components. */
11912 gfc_resolve_code (this_code
, ns
);
11914 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11916 gfc_formal_arglist
*dummy_args
;
11918 /* Check that there is a typebound defined assignment. If not,
11919 then this must be a module defined assignment. We cannot
11920 use the defined_assign_comp attribute here because it must
11921 be this derived type that has the defined assignment and not
11923 if (!(comp1
->ts
.u
.derived
->f2k_derived
11924 && comp1
->ts
.u
.derived
->f2k_derived
11925 ->tb_op
[INTRINSIC_ASSIGN
]))
11927 gfc_free_statements (this_code
);
11932 /* If the first argument of the subroutine has intent INOUT
11933 a temporary must be generated and used instead. */
11934 rsym
= this_code
->resolved_sym
;
11935 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11936 finalizable_out
= gfc_may_be_finalized (comp1
->ts
)
11938 && dummy_args
->sym
->attr
.intent
== INTENT_OUT
;
11940 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
;
11941 if ((inout
|| finalizable_out
)
11942 && !comp1
->attr
.allocatable
)
11944 gfc_code
*temp_code
;
11947 /* Build the temporary required for the assignment and put
11948 it at the head of the generated code. */
11951 gfc_namespace
*tmp_ns
= ns
;
11952 if (ns
->parent
&& gfc_may_be_finalized (comp1
->ts
))
11953 tmp_ns
= (*code
)->expr1
->symtree
->n
.sym
->ns
;
11954 t1
= get_temp_from_expr ((*code
)->expr1
, tmp_ns
);
11955 t1
->symtree
->n
.sym
->attr
.artificial
= 1;
11956 temp_code
= build_assignment (EXEC_ASSIGN
,
11957 t1
, (*code
)->expr1
,
11958 NULL
, NULL
, (*code
)->loc
);
11960 /* For allocatable LHS, check whether it is allocated. Note
11961 that allocatable components with defined assignment are
11962 not yet support. See PR 57696. */
11963 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11967 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11968 block
= gfc_get_code (EXEC_IF
);
11969 block
->block
= gfc_get_code (EXEC_IF
);
11970 block
->block
->expr1
11971 = gfc_build_intrinsic_call (ns
,
11972 GFC_ISYM_ALLOCATED
, "allocated",
11973 (*code
)->loc
, 1, e
);
11974 block
->block
->next
= temp_code
;
11977 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11980 /* Replace the first actual arg with the component of the
11982 gfc_free_expr (this_code
->ext
.actual
->expr
);
11983 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11984 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11986 /* If the LHS variable is allocatable and wasn't allocated and
11987 the temporary is allocatable, pointer assign the address of
11988 the freshly allocated LHS to the temporary. */
11989 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11990 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11995 cond
= gfc_get_expr ();
11996 cond
->ts
.type
= BT_LOGICAL
;
11997 cond
->ts
.kind
= gfc_default_logical_kind
;
11998 cond
->expr_type
= EXPR_OP
;
11999 cond
->where
= (*code
)->loc
;
12000 cond
->value
.op
.op
= INTRINSIC_NOT
;
12001 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
12002 GFC_ISYM_ALLOCATED
, "allocated",
12003 (*code
)->loc
, 1, gfc_copy_expr (t1
));
12004 block
= gfc_get_code (EXEC_IF
);
12005 block
->block
= gfc_get_code (EXEC_IF
);
12006 block
->block
->expr1
= cond
;
12007 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
12008 t1
, (*code
)->expr1
,
12009 NULL
, NULL
, (*code
)->loc
);
12010 add_code_to_chain (&block
, &head
, &tail
);
12014 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
12016 /* Don't add intrinsic assignments since they are already
12017 effected by the intrinsic assignment of the structure, unless
12018 finalization is required. */
12019 if (finalizable_comp
)
12020 this_code
->expr1
->must_finalize
= 1;
12023 gfc_free_statements (this_code
);
12030 /* Resolution has expanded an assignment of a derived type with
12031 defined assigned components. Remove the redundant, leading
12033 gcc_assert (this_code
->op
== EXEC_ASSIGN
);
12034 gfc_code
*tmp
= this_code
;
12035 this_code
= this_code
->next
;
12037 gfc_free_statements (tmp
);
12040 add_code_to_chain (&this_code
, &head
, &tail
);
12042 if (t1
&& (inout
|| finalizable_out
))
12044 /* Transfer the value to the final result. */
12045 this_code
= build_assignment (EXEC_ASSIGN
,
12046 (*code
)->expr1
, t1
,
12047 comp1
, comp2
, (*code
)->loc
);
12048 this_code
->expr1
->must_finalize
= 0;
12049 add_code_to_chain (&this_code
, &head
, &tail
);
12053 /* Put the temporary assignments at the top of the generated code. */
12054 if (tmp_head
&& component_assignment_level
== 1)
12056 gfc_append_code (tmp_head
, head
);
12058 tmp_head
= tmp_tail
= NULL
;
12061 /* If we did a pointer assignment - thus, we need to ensure that the LHS is
12062 not accidentally deallocated. Hence, nullify t1. */
12063 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
12064 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
12070 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
12071 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
12072 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
12073 block
= gfc_get_code (EXEC_IF
);
12074 block
->block
= gfc_get_code (EXEC_IF
);
12075 block
->block
->expr1
= cond
;
12076 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
12077 t1
, gfc_get_null_expr (&(*code
)->loc
),
12078 NULL
, NULL
, (*code
)->loc
);
12079 gfc_append_code (tail
, block
);
12083 component_assignment_level
--;
12085 /* Make an explicit final call for the function result. */
12087 generate_final_call (tmp_expr
, &head
, &tail
);
12095 /* Now attach the remaining code chain to the input code. Step on
12096 to the end of the new code since resolution is complete. */
12097 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
12098 tail
->next
= (*code
)->next
;
12099 /* Overwrite 'code' because this would place the intrinsic assignment
12100 before the temporary for the lhs is created. */
12101 gfc_free_expr ((*code
)->expr1
);
12102 gfc_free_expr ((*code
)->expr2
);
12110 /* F2008: Pointer function assignments are of the form:
12111 ptr_fcn (args) = expr
12112 This function breaks these assignments into two statements:
12113 temporary_pointer => ptr_fcn(args)
12114 temporary_pointer = expr */
12117 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
12119 gfc_expr
*tmp_ptr_expr
;
12120 gfc_code
*this_code
;
12121 gfc_component
*comp
;
12124 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
12127 /* Even if standard does not support this feature, continue to build
12128 the two statements to avoid upsetting frontend_passes.c. */
12129 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
12130 "%L", &(*code
)->loc
);
12132 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
12135 s
= comp
->ts
.interface
;
12137 s
= (*code
)->expr1
->symtree
->n
.sym
;
12139 if (s
== NULL
|| !s
->result
->attr
.pointer
)
12141 gfc_error ("The function result on the lhs of the assignment at "
12142 "%L must have the pointer attribute.",
12143 &(*code
)->expr1
->where
);
12144 (*code
)->op
= EXEC_NOP
;
12148 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
12150 /* get_temp_from_expression is set up for ordinary assignments. To that
12151 end, where array bounds are not known, arrays are made allocatable.
12152 Change the temporary to a pointer here. */
12153 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
12154 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
12155 tmp_ptr_expr
->where
= (*code
)->loc
;
12157 this_code
= build_assignment (EXEC_ASSIGN
,
12158 tmp_ptr_expr
, (*code
)->expr2
,
12159 NULL
, NULL
, (*code
)->loc
);
12160 this_code
->next
= (*code
)->next
;
12161 (*code
)->next
= this_code
;
12162 (*code
)->op
= EXEC_POINTER_ASSIGN
;
12163 (*code
)->expr2
= (*code
)->expr1
;
12164 (*code
)->expr1
= tmp_ptr_expr
;
12170 /* Deferred character length assignments from an operator expression
12171 require a temporary because the character length of the lhs can
12172 change in the course of the assignment. */
12175 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
12177 gfc_expr
*tmp_expr
;
12178 gfc_code
*this_code
;
12180 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
12181 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
12182 && (*code
)->expr2
->ts
.type
== BT_CHARACTER
12183 && (*code
)->expr2
->expr_type
== EXPR_OP
))
12186 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
12189 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
12192 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
12193 tmp_expr
->where
= (*code
)->loc
;
12195 /* A new charlen is required to ensure that the variable string
12196 length is different to that of the original lhs. */
12197 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
12198 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
12199 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
12200 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
12202 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
12204 this_code
= build_assignment (EXEC_ASSIGN
,
12206 gfc_copy_expr (tmp_expr
),
12207 NULL
, NULL
, (*code
)->loc
);
12209 (*code
)->expr1
= tmp_expr
;
12211 this_code
->next
= (*code
)->next
;
12212 (*code
)->next
= this_code
;
12219 check_team (gfc_expr
*team
, const char *intrinsic
)
12221 if (team
->rank
!= 0
12222 || team
->ts
.type
!= BT_DERIVED
12223 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
12224 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
12226 gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
12227 "of type TEAM_TYPE", intrinsic
, &team
->where
);
12235 /* Given a block of code, recursively resolve everything pointed to by this
12239 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
12241 int omp_workshare_save
;
12242 int forall_save
, do_concurrent_save
;
12246 frame
.prev
= cs_base
;
12250 find_reachable_labels (code
);
12252 for (; code
; code
= code
->next
)
12254 frame
.current
= code
;
12255 forall_save
= forall_flag
;
12256 do_concurrent_save
= gfc_do_concurrent_flag
;
12258 if (code
->op
== EXEC_FORALL
)
12261 gfc_resolve_forall (code
, ns
, forall_save
);
12264 else if (code
->block
)
12266 omp_workshare_save
= -1;
12269 case EXEC_OACC_PARALLEL_LOOP
:
12270 case EXEC_OACC_PARALLEL
:
12271 case EXEC_OACC_KERNELS_LOOP
:
12272 case EXEC_OACC_KERNELS
:
12273 case EXEC_OACC_SERIAL_LOOP
:
12274 case EXEC_OACC_SERIAL
:
12275 case EXEC_OACC_DATA
:
12276 case EXEC_OACC_HOST_DATA
:
12277 case EXEC_OACC_LOOP
:
12278 gfc_resolve_oacc_blocks (code
, ns
);
12280 case EXEC_OMP_PARALLEL_WORKSHARE
:
12281 omp_workshare_save
= omp_workshare_flag
;
12282 omp_workshare_flag
= 1;
12283 gfc_resolve_omp_parallel_blocks (code
, ns
);
12285 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
12286 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
12287 case EXEC_OMP_MASKED_TASKLOOP
:
12288 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
12289 case EXEC_OMP_MASTER_TASKLOOP
:
12290 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
12291 case EXEC_OMP_PARALLEL
:
12292 case EXEC_OMP_PARALLEL_DO
:
12293 case EXEC_OMP_PARALLEL_DO_SIMD
:
12294 case EXEC_OMP_PARALLEL_LOOP
:
12295 case EXEC_OMP_PARALLEL_MASKED
:
12296 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
12297 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
12298 case EXEC_OMP_PARALLEL_MASTER
:
12299 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
12300 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
12301 case EXEC_OMP_PARALLEL_SECTIONS
:
12302 case EXEC_OMP_TARGET_PARALLEL
:
12303 case EXEC_OMP_TARGET_PARALLEL_DO
:
12304 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
12305 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
12306 case EXEC_OMP_TARGET_TEAMS
:
12307 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
12308 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12309 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12310 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
12311 case EXEC_OMP_TARGET_TEAMS_LOOP
:
12312 case EXEC_OMP_TASK
:
12313 case EXEC_OMP_TASKLOOP
:
12314 case EXEC_OMP_TASKLOOP_SIMD
:
12315 case EXEC_OMP_TEAMS
:
12316 case EXEC_OMP_TEAMS_DISTRIBUTE
:
12317 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12318 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12319 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
12320 case EXEC_OMP_TEAMS_LOOP
:
12321 omp_workshare_save
= omp_workshare_flag
;
12322 omp_workshare_flag
= 0;
12323 gfc_resolve_omp_parallel_blocks (code
, ns
);
12325 case EXEC_OMP_DISTRIBUTE
:
12326 case EXEC_OMP_DISTRIBUTE_SIMD
:
12328 case EXEC_OMP_DO_SIMD
:
12329 case EXEC_OMP_LOOP
:
12330 case EXEC_OMP_SIMD
:
12331 case EXEC_OMP_TARGET_SIMD
:
12332 gfc_resolve_omp_do_blocks (code
, ns
);
12334 case EXEC_SELECT_TYPE
:
12335 case EXEC_SELECT_RANK
:
12336 /* Blocks are handled in resolve_select_type/rank because we
12337 have to transform the SELECT TYPE into ASSOCIATE first. */
12339 case EXEC_DO_CONCURRENT
:
12340 gfc_do_concurrent_flag
= 1;
12341 gfc_resolve_blocks (code
->block
, ns
);
12342 gfc_do_concurrent_flag
= 2;
12344 case EXEC_OMP_WORKSHARE
:
12345 omp_workshare_save
= omp_workshare_flag
;
12346 omp_workshare_flag
= 1;
12349 gfc_resolve_blocks (code
->block
, ns
);
12353 if (omp_workshare_save
!= -1)
12354 omp_workshare_flag
= omp_workshare_save
;
12358 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
12359 t
= gfc_resolve_expr (code
->expr1
);
12360 forall_flag
= forall_save
;
12361 gfc_do_concurrent_flag
= do_concurrent_save
;
12363 if (!gfc_resolve_expr (code
->expr2
))
12366 if (code
->op
== EXEC_ALLOCATE
12367 && !gfc_resolve_expr (code
->expr3
))
12373 case EXEC_END_BLOCK
:
12374 case EXEC_END_NESTED_BLOCK
:
12380 case EXEC_ERROR_STOP
:
12381 if (code
->expr2
!= NULL
12382 && (code
->expr2
->ts
.type
!= BT_LOGICAL
12383 || code
->expr2
->rank
!= 0))
12384 gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
12385 &code
->expr2
->where
);
12389 case EXEC_CONTINUE
:
12391 case EXEC_ASSIGN_CALL
:
12394 case EXEC_CRITICAL
:
12395 resolve_critical (code
);
12398 case EXEC_SYNC_ALL
:
12399 case EXEC_SYNC_IMAGES
:
12400 case EXEC_SYNC_MEMORY
:
12401 resolve_sync (code
);
12406 case EXEC_EVENT_POST
:
12407 case EXEC_EVENT_WAIT
:
12408 resolve_lock_unlock_event (code
);
12411 case EXEC_FAIL_IMAGE
:
12414 case EXEC_FORM_TEAM
:
12415 if (code
->expr1
!= NULL
12416 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
12417 gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
12418 "a scalar INTEGER", &code
->expr1
->where
);
12419 check_team (code
->expr2
, "FORM TEAM");
12422 case EXEC_CHANGE_TEAM
:
12423 check_team (code
->expr1
, "CHANGE TEAM");
12426 case EXEC_END_TEAM
:
12429 case EXEC_SYNC_TEAM
:
12430 check_team (code
->expr1
, "SYNC TEAM");
12434 /* Keep track of which entry we are up to. */
12435 current_entry_id
= code
->ext
.entry
->id
;
12439 resolve_where (code
, NULL
);
12443 if (code
->expr1
!= NULL
)
12445 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
12446 || code
->expr1
->ts
.type
!= BT_INTEGER
12447 || (code
->expr1
->ref
12448 && code
->expr1
->ref
->type
== REF_ARRAY
)
12449 || code
->expr1
->symtree
== NULL
12450 || (code
->expr1
->symtree
->n
.sym
12451 && (code
->expr1
->symtree
->n
.sym
->attr
.flavor
12453 gfc_error ("ASSIGNED GOTO statement at %L requires a "
12454 "scalar INTEGER variable", &code
->expr1
->where
);
12455 else if (code
->expr1
->symtree
->n
.sym
12456 && code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
12457 gfc_error ("Variable %qs has not been assigned a target "
12458 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
12459 &code
->expr1
->where
);
12462 resolve_branch (code
->label1
, code
);
12466 if (code
->expr1
!= NULL
12467 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
12468 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
12469 "INTEGER return specifier", &code
->expr1
->where
);
12472 case EXEC_INIT_ASSIGN
:
12473 case EXEC_END_PROCEDURE
:
12480 if (code
->expr1
->ts
.type
== BT_CLASS
)
12481 gfc_find_vtab (&code
->expr2
->ts
);
12483 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
12485 if (code
->expr1
->expr_type
== EXPR_FUNCTION
12486 && code
->expr1
->value
.function
.isym
12487 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
12488 remove_caf_get_intrinsic (code
->expr1
);
12490 /* If this is a pointer function in an lvalue variable context,
12491 the new code will have to be resolved afresh. This is also the
12492 case with an error, where the code is transformed into NOP to
12493 prevent ICEs downstream. */
12494 if (resolve_ptr_fcn_assign (&code
, ns
)
12495 || code
->op
== EXEC_NOP
)
12498 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
12502 if (resolve_ordinary_assign (code
, ns
))
12504 if (omp_workshare_flag
)
12506 gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
12507 "at %L", &code
->loc
);
12510 if (code
->op
== EXEC_COMPCALL
)
12516 /* Check for dependencies in deferred character length array
12517 assignments and generate a temporary, if necessary. */
12518 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
12521 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
12522 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
12523 && code
->expr1
->ts
.u
.derived
12524 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
12525 generate_component_assignments (&code
, ns
);
12526 else if (code
->op
== EXEC_ASSIGN
)
12528 if (gfc_may_be_finalized (code
->expr1
->ts
))
12529 code
->expr1
->must_finalize
= 1;
12530 if (code
->expr2
->expr_type
== EXPR_ARRAY
12531 && gfc_may_be_finalized (code
->expr2
->ts
))
12532 code
->expr2
->must_finalize
= 1;
12537 case EXEC_LABEL_ASSIGN
:
12538 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
12539 gfc_error ("Label %d referenced at %L is never defined",
12540 code
->label1
->value
, &code
->label1
->where
);
12542 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
12543 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
12544 || code
->expr1
->symtree
->n
.sym
->ts
.kind
12545 != gfc_default_integer_kind
12546 || code
->expr1
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
12547 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
12548 gfc_error ("ASSIGN statement at %L requires a scalar "
12549 "default INTEGER variable", &code
->expr1
->where
);
12552 case EXEC_POINTER_ASSIGN
:
12559 /* This is both a variable definition and pointer assignment
12560 context, so check both of them. For rank remapping, a final
12561 array ref may be present on the LHS and fool gfc_expr_attr
12562 used in gfc_check_vardef_context. Remove it. */
12563 e
= remove_last_array_ref (code
->expr1
);
12564 t
= gfc_check_vardef_context (e
, true, false, false,
12565 _("pointer assignment"));
12567 t
= gfc_check_vardef_context (e
, false, false, false,
12568 _("pointer assignment"));
12571 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
12576 /* Assigning a class object always is a regular assign. */
12577 if (code
->expr2
->ts
.type
== BT_CLASS
12578 && code
->expr1
->ts
.type
== BT_CLASS
12579 && CLASS_DATA (code
->expr2
)
12580 && !CLASS_DATA (code
->expr2
)->attr
.dimension
12581 && !(gfc_expr_attr (code
->expr1
).proc_pointer
12582 && code
->expr2
->expr_type
== EXPR_VARIABLE
12583 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
12585 code
->op
= EXEC_ASSIGN
;
12589 case EXEC_ARITHMETIC_IF
:
12591 gfc_expr
*e
= code
->expr1
;
12593 gfc_resolve_expr (e
);
12594 if (e
->expr_type
== EXPR_NULL
)
12595 gfc_error ("Invalid NULL at %L", &e
->where
);
12597 if (t
&& (e
->rank
> 0
12598 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
12599 gfc_error ("Arithmetic IF statement at %L requires a scalar "
12600 "REAL or INTEGER expression", &e
->where
);
12602 resolve_branch (code
->label1
, code
);
12603 resolve_branch (code
->label2
, code
);
12604 resolve_branch (code
->label3
, code
);
12609 if (t
&& code
->expr1
!= NULL
12610 && (code
->expr1
->ts
.type
!= BT_LOGICAL
12611 || code
->expr1
->rank
!= 0))
12612 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12613 &code
->expr1
->where
);
12618 resolve_call (code
);
12621 case EXEC_COMPCALL
:
12623 resolve_typebound_subroutine (code
);
12626 case EXEC_CALL_PPC
:
12627 resolve_ppc_call (code
);
12631 /* Select is complicated. Also, a SELECT construct could be
12632 a transformed computed GOTO. */
12633 resolve_select (code
, false);
12636 case EXEC_SELECT_TYPE
:
12637 resolve_select_type (code
, ns
);
12640 case EXEC_SELECT_RANK
:
12641 resolve_select_rank (code
, ns
);
12645 resolve_block_construct (code
);
12649 if (code
->ext
.iterator
!= NULL
)
12651 gfc_iterator
*iter
= code
->ext
.iterator
;
12652 if (gfc_resolve_iterator (iter
, true, false))
12653 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
12658 case EXEC_DO_WHILE
:
12659 if (code
->expr1
== NULL
)
12660 gfc_internal_error ("gfc_resolve_code(): No expression on "
12663 && (code
->expr1
->rank
!= 0
12664 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
12665 gfc_error ("Exit condition of DO WHILE loop at %L must be "
12666 "a scalar LOGICAL expression", &code
->expr1
->where
);
12669 case EXEC_ALLOCATE
:
12671 resolve_allocate_deallocate (code
, "ALLOCATE");
12675 case EXEC_DEALLOCATE
:
12677 resolve_allocate_deallocate (code
, "DEALLOCATE");
12682 if (!gfc_resolve_open (code
->ext
.open
, &code
->loc
))
12685 resolve_branch (code
->ext
.open
->err
, code
);
12689 if (!gfc_resolve_close (code
->ext
.close
, &code
->loc
))
12692 resolve_branch (code
->ext
.close
->err
, code
);
12695 case EXEC_BACKSPACE
:
12699 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
12702 resolve_branch (code
->ext
.filepos
->err
, code
);
12706 if (!gfc_resolve_inquire (code
->ext
.inquire
))
12709 resolve_branch (code
->ext
.inquire
->err
, code
);
12712 case EXEC_IOLENGTH
:
12713 gcc_assert (code
->ext
.inquire
!= NULL
);
12714 if (!gfc_resolve_inquire (code
->ext
.inquire
))
12717 resolve_branch (code
->ext
.inquire
->err
, code
);
12721 if (!gfc_resolve_wait (code
->ext
.wait
))
12724 resolve_branch (code
->ext
.wait
->err
, code
);
12725 resolve_branch (code
->ext
.wait
->end
, code
);
12726 resolve_branch (code
->ext
.wait
->eor
, code
);
12731 if (!gfc_resolve_dt (code
, code
->ext
.dt
, &code
->loc
))
12734 resolve_branch (code
->ext
.dt
->err
, code
);
12735 resolve_branch (code
->ext
.dt
->end
, code
);
12736 resolve_branch (code
->ext
.dt
->eor
, code
);
12739 case EXEC_TRANSFER
:
12740 resolve_transfer (code
);
12743 case EXEC_DO_CONCURRENT
:
12745 resolve_forall_iterators (code
->ext
.forall_iterator
);
12747 if (code
->expr1
!= NULL
12748 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
12749 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
12750 "expression", &code
->expr1
->where
);
12753 case EXEC_OACC_PARALLEL_LOOP
:
12754 case EXEC_OACC_PARALLEL
:
12755 case EXEC_OACC_KERNELS_LOOP
:
12756 case EXEC_OACC_KERNELS
:
12757 case EXEC_OACC_SERIAL_LOOP
:
12758 case EXEC_OACC_SERIAL
:
12759 case EXEC_OACC_DATA
:
12760 case EXEC_OACC_HOST_DATA
:
12761 case EXEC_OACC_LOOP
:
12762 case EXEC_OACC_UPDATE
:
12763 case EXEC_OACC_WAIT
:
12764 case EXEC_OACC_CACHE
:
12765 case EXEC_OACC_ENTER_DATA
:
12766 case EXEC_OACC_EXIT_DATA
:
12767 case EXEC_OACC_ATOMIC
:
12768 case EXEC_OACC_DECLARE
:
12769 gfc_resolve_oacc_directive (code
, ns
);
12772 case EXEC_OMP_ALLOCATE
:
12773 case EXEC_OMP_ALLOCATORS
:
12774 case EXEC_OMP_ASSUME
:
12775 case EXEC_OMP_ATOMIC
:
12776 case EXEC_OMP_BARRIER
:
12777 case EXEC_OMP_CANCEL
:
12778 case EXEC_OMP_CANCELLATION_POINT
:
12779 case EXEC_OMP_CRITICAL
:
12780 case EXEC_OMP_FLUSH
:
12781 case EXEC_OMP_DEPOBJ
:
12782 case EXEC_OMP_DISTRIBUTE
:
12783 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
12784 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
12785 case EXEC_OMP_DISTRIBUTE_SIMD
:
12787 case EXEC_OMP_DO_SIMD
:
12788 case EXEC_OMP_ERROR
:
12789 case EXEC_OMP_LOOP
:
12790 case EXEC_OMP_MASTER
:
12791 case EXEC_OMP_MASTER_TASKLOOP
:
12792 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
12793 case EXEC_OMP_MASKED
:
12794 case EXEC_OMP_MASKED_TASKLOOP
:
12795 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
12796 case EXEC_OMP_ORDERED
:
12797 case EXEC_OMP_SCAN
:
12798 case EXEC_OMP_SCOPE
:
12799 case EXEC_OMP_SECTIONS
:
12800 case EXEC_OMP_SIMD
:
12801 case EXEC_OMP_SINGLE
:
12802 case EXEC_OMP_TARGET
:
12803 case EXEC_OMP_TARGET_DATA
:
12804 case EXEC_OMP_TARGET_ENTER_DATA
:
12805 case EXEC_OMP_TARGET_EXIT_DATA
:
12806 case EXEC_OMP_TARGET_PARALLEL
:
12807 case EXEC_OMP_TARGET_PARALLEL_DO
:
12808 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
12809 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
12810 case EXEC_OMP_TARGET_SIMD
:
12811 case EXEC_OMP_TARGET_TEAMS
:
12812 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
12813 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12814 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12815 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
12816 case EXEC_OMP_TARGET_TEAMS_LOOP
:
12817 case EXEC_OMP_TARGET_UPDATE
:
12818 case EXEC_OMP_TASK
:
12819 case EXEC_OMP_TASKGROUP
:
12820 case EXEC_OMP_TASKLOOP
:
12821 case EXEC_OMP_TASKLOOP_SIMD
:
12822 case EXEC_OMP_TASKWAIT
:
12823 case EXEC_OMP_TASKYIELD
:
12824 case EXEC_OMP_TEAMS
:
12825 case EXEC_OMP_TEAMS_DISTRIBUTE
:
12826 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12827 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12828 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
12829 case EXEC_OMP_TEAMS_LOOP
:
12830 case EXEC_OMP_WORKSHARE
:
12831 gfc_resolve_omp_directive (code
, ns
);
12834 case EXEC_OMP_PARALLEL
:
12835 case EXEC_OMP_PARALLEL_DO
:
12836 case EXEC_OMP_PARALLEL_DO_SIMD
:
12837 case EXEC_OMP_PARALLEL_LOOP
:
12838 case EXEC_OMP_PARALLEL_MASKED
:
12839 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
12840 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
12841 case EXEC_OMP_PARALLEL_MASTER
:
12842 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
12843 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
12844 case EXEC_OMP_PARALLEL_SECTIONS
:
12845 case EXEC_OMP_PARALLEL_WORKSHARE
:
12846 omp_workshare_save
= omp_workshare_flag
;
12847 omp_workshare_flag
= 0;
12848 gfc_resolve_omp_directive (code
, ns
);
12849 omp_workshare_flag
= omp_workshare_save
;
12853 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
12857 cs_base
= frame
.prev
;
12861 /* Resolve initial values and make sure they are compatible with
12865 resolve_values (gfc_symbol
*sym
)
12869 if (sym
->value
== NULL
)
12872 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_DEPRECATED
) && sym
->attr
.referenced
)
12873 gfc_warning (OPT_Wdeprecated_declarations
,
12874 "Using parameter %qs declared at %L is deprecated",
12875 sym
->name
, &sym
->declared_at
);
12877 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
12878 t
= resolve_structure_cons (sym
->value
, 1);
12880 t
= gfc_resolve_expr (sym
->value
);
12885 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
12889 /* Verify any BIND(C) derived types in the namespace so we can report errors
12890 for them once, rather than for each variable declared of that type. */
12893 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
12895 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
12896 && derived_sym
->attr
.is_bind_c
== 1)
12897 verify_bind_c_derived_type (derived_sym
);
12903 /* Check the interfaces of DTIO procedures associated with derived
12904 type 'sym'. These procedures can either have typebound bindings or
12905 can appear in DTIO generic interfaces. */
12908 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
12910 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
12913 gfc_check_dtio_interfaces (sym
);
12918 /* Verify that any binding labels used in a given namespace do not collide
12919 with the names or binding labels of any global symbols. Multiple INTERFACE
12920 for the same procedure are permitted. */
12923 gfc_verify_binding_labels (gfc_symbol
*sym
)
12926 const char *module
;
12928 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
12929 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
12932 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
12935 module
= sym
->module
;
12936 else if (sym
->ns
&& sym
->ns
->proc_name
12937 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
12938 module
= sym
->ns
->proc_name
->name
;
12939 else if (sym
->ns
&& sym
->ns
->parent
12940 && sym
->ns
&& sym
->ns
->parent
->proc_name
12941 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12942 module
= sym
->ns
->parent
->proc_name
->name
;
12948 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
12951 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
12952 gsym
->where
= sym
->declared_at
;
12953 gsym
->sym_name
= sym
->name
;
12954 gsym
->binding_label
= sym
->binding_label
;
12955 gsym
->ns
= sym
->ns
;
12956 gsym
->mod_name
= module
;
12957 if (sym
->attr
.function
)
12958 gsym
->type
= GSYM_FUNCTION
;
12959 else if (sym
->attr
.subroutine
)
12960 gsym
->type
= GSYM_SUBROUTINE
;
12961 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
12962 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
12966 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
12968 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
12969 "identifier as entity at %L", sym
->name
,
12970 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12971 /* Clear the binding label to prevent checking multiple times. */
12972 sym
->binding_label
= NULL
;
12976 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
12977 && (strcmp (module
, gsym
->mod_name
) != 0
12978 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
12980 /* This can only happen if the variable is defined in a module - if it
12981 isn't the same module, reject it. */
12982 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
12983 "uses the same global identifier as entity at %L from module %qs",
12984 sym
->name
, module
, sym
->binding_label
,
12985 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
12986 sym
->binding_label
= NULL
;
12990 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
12991 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
12992 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
12993 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
12994 && (module
!= gsym
->mod_name
12995 || strcmp (gsym
->sym_name
, sym
->name
) != 0
12996 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
12998 /* Print an error if the procedure is defined multiple times; we have to
12999 exclude references to the same procedure via module association or
13000 multiple checks for the same procedure. */
13001 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
13002 "global identifier as entity at %L", sym
->name
,
13003 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
13004 sym
->binding_label
= NULL
;
13009 /* Resolve an index expression. */
13012 resolve_index_expr (gfc_expr
*e
)
13014 if (!gfc_resolve_expr (e
))
13017 if (!gfc_simplify_expr (e
, 0))
13020 if (!gfc_specification_expr (e
))
13027 /* Resolve a charlen structure. */
13030 resolve_charlen (gfc_charlen
*cl
)
13033 bool saved_specification_expr
;
13039 saved_specification_expr
= specification_expr
;
13040 specification_expr
= true;
13042 if (cl
->length_from_typespec
)
13044 if (!gfc_resolve_expr (cl
->length
))
13046 specification_expr
= saved_specification_expr
;
13050 if (!gfc_simplify_expr (cl
->length
, 0))
13052 specification_expr
= saved_specification_expr
;
13056 /* cl->length has been resolved. It should have an integer type. */
13058 && (cl
->length
->ts
.type
!= BT_INTEGER
|| cl
->length
->rank
!= 0))
13060 gfc_error ("Scalar INTEGER expression expected at %L",
13061 &cl
->length
->where
);
13067 if (!resolve_index_expr (cl
->length
))
13069 specification_expr
= saved_specification_expr
;
13074 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
13075 a negative value, the length of character entities declared is zero. */
13076 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
13077 && mpz_sgn (cl
->length
->value
.integer
) < 0)
13078 gfc_replace_expr (cl
->length
,
13079 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
13081 /* Check that the character length is not too large. */
13082 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
13083 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
13084 && cl
->length
->ts
.type
== BT_INTEGER
13085 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
13087 gfc_error ("String length at %L is too large", &cl
->length
->where
);
13088 specification_expr
= saved_specification_expr
;
13092 specification_expr
= saved_specification_expr
;
13097 /* Test for non-constant shape arrays. */
13100 is_non_constant_shape_array (gfc_symbol
*sym
)
13106 not_constant
= false;
13107 if (sym
->as
!= NULL
)
13109 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
13110 has not been simplified; parameter array references. Do the
13111 simplification now. */
13112 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
13114 if (i
== GFC_MAX_DIMENSIONS
)
13117 e
= sym
->as
->lower
[i
];
13118 if (e
&& (!resolve_index_expr(e
)
13119 || !gfc_is_constant_expr (e
)))
13120 not_constant
= true;
13121 e
= sym
->as
->upper
[i
];
13122 if (e
&& (!resolve_index_expr(e
)
13123 || !gfc_is_constant_expr (e
)))
13124 not_constant
= true;
13127 return not_constant
;
13130 /* Given a symbol and an initialization expression, add code to initialize
13131 the symbol to the function entry. */
13133 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
13137 gfc_namespace
*ns
= sym
->ns
;
13139 /* Search for the function namespace if this is a contained
13140 function without an explicit result. */
13141 if (sym
->attr
.function
&& sym
== sym
->result
13142 && sym
->name
!= sym
->ns
->proc_name
->name
)
13144 ns
= ns
->contained
;
13145 for (;ns
; ns
= ns
->sibling
)
13146 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
13152 gfc_free_expr (init
);
13156 /* Build an l-value expression for the result. */
13157 lval
= gfc_lval_expr_from_sym (sym
);
13159 /* Add the code at scope entry. */
13160 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
13161 init_st
->next
= ns
->code
;
13162 ns
->code
= init_st
;
13164 /* Assign the default initializer to the l-value. */
13165 init_st
->loc
= sym
->declared_at
;
13166 init_st
->expr1
= lval
;
13167 init_st
->expr2
= init
;
13171 /* Whether or not we can generate a default initializer for a symbol. */
13174 can_generate_init (gfc_symbol
*sym
)
13176 symbol_attribute
*a
;
13181 /* These symbols should never have a default initialization. */
13186 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
13187 && (CLASS_DATA (sym
)->attr
.class_pointer
13188 || CLASS_DATA (sym
)->attr
.proc_pointer
))
13189 || a
->in_equivalence
13196 || (!a
->referenced
&& !a
->result
)
13197 || (a
->dummy
&& (a
->intent
!= INTENT_OUT
13198 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
))
13199 || (a
->function
&& sym
!= sym
->result
)
13204 /* Assign the default initializer to a derived type variable or result. */
13207 apply_default_init (gfc_symbol
*sym
)
13209 gfc_expr
*init
= NULL
;
13211 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
13214 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
13215 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
13217 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
13220 build_init_assign (sym
, init
);
13221 sym
->attr
.referenced
= 1;
13225 /* Build an initializer for a local. Returns null if the symbol should not have
13226 a default initialization. */
13229 build_default_init_expr (gfc_symbol
*sym
)
13231 /* These symbols should never have a default initialization. */
13232 if (sym
->attr
.allocatable
13233 || sym
->attr
.external
13235 || sym
->attr
.pointer
13236 || sym
->attr
.in_equivalence
13237 || sym
->attr
.in_common
13240 || sym
->attr
.cray_pointee
13241 || sym
->attr
.cray_pointer
13245 /* Get the appropriate init expression. */
13246 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
13249 /* Add an initialization expression to a local variable. */
13251 apply_default_init_local (gfc_symbol
*sym
)
13253 gfc_expr
*init
= NULL
;
13255 /* The symbol should be a variable or a function return value. */
13256 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
13257 || (sym
->attr
.function
&& sym
->result
!= sym
))
13260 /* Try to build the initializer expression. If we can't initialize
13261 this symbol, then init will be NULL. */
13262 init
= build_default_init_expr (sym
);
13266 /* For saved variables, we don't want to add an initializer at function
13267 entry, so we just add a static initializer. Note that automatic variables
13268 are stack allocated even with -fno-automatic; we have also to exclude
13269 result variable, which are also nonstatic. */
13270 if (!sym
->attr
.automatic
13271 && (sym
->attr
.save
|| sym
->ns
->save_all
13272 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
13273 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
13274 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
13276 /* Don't clobber an existing initializer! */
13277 gcc_assert (sym
->value
== NULL
);
13282 build_init_assign (sym
, init
);
13286 /* Resolution of common features of flavors variable and procedure. */
13289 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
13291 gfc_array_spec
*as
;
13293 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13294 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
))
13295 as
= CLASS_DATA (sym
)->as
;
13299 /* Constraints on deferred shape variable. */
13300 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
13302 bool pointer
, allocatable
, dimension
;
13304 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13305 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
))
13307 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
13308 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
13309 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
13313 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
13314 allocatable
= sym
->attr
.allocatable
;
13315 dimension
= sym
->attr
.dimension
;
13322 && as
->type
!= AS_ASSUMED_RANK
13323 && !sym
->attr
.select_rank_temporary
)
13325 gfc_error ("Allocatable array %qs at %L must have a deferred "
13326 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
13329 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
13330 "%qs at %L may not be ALLOCATABLE",
13331 sym
->name
, &sym
->declared_at
))
13335 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
13337 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
13338 "assumed rank", sym
->name
, &sym
->declared_at
);
13345 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
13346 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
13348 gfc_error ("Array %qs at %L cannot have a deferred shape",
13349 sym
->name
, &sym
->declared_at
);
13354 /* Constraints on polymorphic variables. */
13355 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
13358 if (sym
->attr
.class_ok
13359 && sym
->ts
.u
.derived
13360 && !sym
->attr
.select_type_temporary
13361 && !UNLIMITED_POLY (sym
)
13362 && CLASS_DATA (sym
)
13363 && CLASS_DATA (sym
)->ts
.u
.derived
13364 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
13366 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
13367 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
13368 &sym
->declared_at
);
13373 /* Assume that use associated symbols were checked in the module ns.
13374 Class-variables that are associate-names are also something special
13375 and excepted from the test. */
13376 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
13378 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
13379 "or pointer", sym
->name
, &sym
->declared_at
);
13388 /* Additional checks for symbols with flavor variable and derived
13389 type. To be called from resolve_fl_variable. */
13392 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
13394 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
13396 /* Check to see if a derived type is blocked from being host
13397 associated by the presence of another class I symbol in the same
13398 namespace. 14.6.1.3 of the standard and the discussion on
13399 comp.lang.fortran. */
13400 if (sym
->ts
.u
.derived
13401 && sym
->ns
!= sym
->ts
.u
.derived
->ns
13402 && !sym
->ts
.u
.derived
->attr
.use_assoc
13403 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
13406 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
13407 if (s
&& s
->attr
.generic
)
13408 s
= gfc_find_dt_in_generic (s
);
13409 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
13411 gfc_error ("The type %qs cannot be host associated at %L "
13412 "because it is blocked by an incompatible object "
13413 "of the same name declared at %L",
13414 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
13420 /* 4th constraint in section 11.3: "If an object of a type for which
13421 component-initialization is specified (R429) appears in the
13422 specification-part of a module and does not have the ALLOCATABLE
13423 or POINTER attribute, the object shall have the SAVE attribute."
13425 The check for initializers is performed with
13426 gfc_has_default_initializer because gfc_default_initializer generates
13427 a hidden default for allocatable components. */
13428 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
13429 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13430 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
13431 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
13432 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
13433 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
13434 "%qs at %L, needed due to the default "
13435 "initialization", sym
->name
, &sym
->declared_at
))
13438 /* Assign default initializer. */
13439 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
13441 || (sym
->attr
.intent
== INTENT_OUT
13442 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)))
13443 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
13449 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
13450 except in the declaration of an entity or component that has the POINTER
13451 or ALLOCATABLE attribute. */
13454 deferred_requirements (gfc_symbol
*sym
)
13456 if (sym
->ts
.deferred
13457 && !(sym
->attr
.pointer
13458 || sym
->attr
.allocatable
13459 || sym
->attr
.associate_var
13460 || sym
->attr
.omp_udr_artificial_var
))
13462 /* If a function has a result variable, only check the variable. */
13463 if (sym
->result
&& sym
->name
!= sym
->result
->name
)
13466 gfc_error ("Entity %qs at %L has a deferred type parameter and "
13467 "requires either the POINTER or ALLOCATABLE attribute",
13468 sym
->name
, &sym
->declared_at
);
13475 /* Resolve symbols with flavor variable. */
13478 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
13480 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
13483 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
13486 /* Set this flag to check that variables are parameters of all entries.
13487 This check is effected by the call to gfc_resolve_expr through
13488 is_non_constant_shape_array. */
13489 bool saved_specification_expr
= specification_expr
;
13490 specification_expr
= true;
13492 if (sym
->ns
->proc_name
13493 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13494 || sym
->ns
->proc_name
->attr
.is_main_program
)
13495 && !sym
->attr
.use_assoc
13496 && !sym
->attr
.allocatable
13497 && !sym
->attr
.pointer
13498 && is_non_constant_shape_array (sym
))
13500 /* F08:C541. The shape of an array defined in a main program or module
13501 * needs to be constant. */
13502 gfc_error ("The module or main program array %qs at %L must "
13503 "have constant shape", sym
->name
, &sym
->declared_at
);
13504 specification_expr
= saved_specification_expr
;
13508 /* Constraints on deferred type parameter. */
13509 if (!deferred_requirements (sym
))
13512 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
13514 /* Make sure that character string variables with assumed length are
13515 dummy arguments. */
13516 gfc_expr
*e
= NULL
;
13519 e
= sym
->ts
.u
.cl
->length
;
13523 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
13524 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
13525 && !sym
->attr
.omp_udr_artificial_var
)
13527 gfc_error ("Entity with assumed character length at %L must be a "
13528 "dummy argument or a PARAMETER", &sym
->declared_at
);
13529 specification_expr
= saved_specification_expr
;
13533 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
13535 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
13536 specification_expr
= saved_specification_expr
;
13540 if (!gfc_is_constant_expr (e
)
13541 && !(e
->expr_type
== EXPR_VARIABLE
13542 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
13544 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
13545 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13546 || sym
->ns
->proc_name
->attr
.is_main_program
))
13548 gfc_error ("%qs at %L must have constant character length "
13549 "in this context", sym
->name
, &sym
->declared_at
);
13550 specification_expr
= saved_specification_expr
;
13553 if (sym
->attr
.in_common
)
13555 gfc_error ("COMMON variable %qs at %L must have constant "
13556 "character length", sym
->name
, &sym
->declared_at
);
13557 specification_expr
= saved_specification_expr
;
13563 if (sym
->value
== NULL
&& sym
->attr
.referenced
13564 && !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
13565 apply_default_init_local (sym
); /* Try to apply a default initialization. */
13567 /* Determine if the symbol may not have an initializer. */
13568 int no_init_flag
= 0, automatic_flag
= 0;
13569 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
13570 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
13572 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
13573 && is_non_constant_shape_array (sym
))
13575 no_init_flag
= automatic_flag
= 1;
13577 /* Also, they must not have the SAVE attribute.
13578 SAVE_IMPLICIT is checked below. */
13579 if (sym
->as
&& sym
->attr
.codimension
)
13581 int corank
= sym
->as
->corank
;
13582 sym
->as
->corank
= 0;
13583 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
13584 sym
->as
->corank
= corank
;
13586 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
13588 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
13589 specification_expr
= saved_specification_expr
;
13594 /* Ensure that any initializer is simplified. */
13596 gfc_simplify_expr (sym
->value
, 1);
13598 /* Reject illegal initializers. */
13599 if (!sym
->mark
&& sym
->value
)
13601 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
13602 && CLASS_DATA (sym
)->attr
.allocatable
))
13603 gfc_error ("Allocatable %qs at %L cannot have an initializer",
13604 sym
->name
, &sym
->declared_at
);
13605 else if (sym
->attr
.external
)
13606 gfc_error ("External %qs at %L cannot have an initializer",
13607 sym
->name
, &sym
->declared_at
);
13608 else if (sym
->attr
.dummy
)
13609 gfc_error ("Dummy %qs at %L cannot have an initializer",
13610 sym
->name
, &sym
->declared_at
);
13611 else if (sym
->attr
.intrinsic
)
13612 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
13613 sym
->name
, &sym
->declared_at
);
13614 else if (sym
->attr
.result
)
13615 gfc_error ("Function result %qs at %L cannot have an initializer",
13616 sym
->name
, &sym
->declared_at
);
13617 else if (automatic_flag
)
13618 gfc_error ("Automatic array %qs at %L cannot have an initializer",
13619 sym
->name
, &sym
->declared_at
);
13621 goto no_init_error
;
13622 specification_expr
= saved_specification_expr
;
13627 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
13629 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
13630 specification_expr
= saved_specification_expr
;
13634 specification_expr
= saved_specification_expr
;
13639 /* Compare the dummy characteristics of a module procedure interface
13640 declaration with the corresponding declaration in a submodule. */
13641 static gfc_formal_arglist
*new_formal
;
13642 static char errmsg
[200];
13645 compare_fsyms (gfc_symbol
*sym
)
13649 if (sym
== NULL
|| new_formal
== NULL
)
13652 fsym
= new_formal
->sym
;
13657 if (strcmp (sym
->name
, fsym
->name
) == 0)
13659 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
13660 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
13665 /* Resolve a procedure. */
13668 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
13670 gfc_formal_arglist
*arg
;
13671 bool allocatable_or_pointer
= false;
13673 if (sym
->attr
.function
13674 && !resolve_fl_var_and_proc (sym
, mp_flag
))
13677 /* Constraints on deferred type parameter. */
13678 if (!deferred_requirements (sym
))
13681 if (sym
->ts
.type
== BT_CHARACTER
)
13683 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13685 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
13686 && !resolve_charlen (cl
))
13689 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13690 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
13692 gfc_error ("Character-valued statement function %qs at %L must "
13693 "have constant length", sym
->name
, &sym
->declared_at
);
13698 /* Ensure that derived type for are not of a private type. Internal
13699 module procedures are excluded by 2.2.3.3 - i.e., they are not
13700 externally accessible and can access all the objects accessible in
13702 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
13703 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
13704 && gfc_check_symbol_access (sym
))
13706 gfc_interface
*iface
;
13708 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
13711 && arg
->sym
->ts
.type
== BT_DERIVED
13712 && arg
->sym
->ts
.u
.derived
13713 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
13714 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
13715 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
13716 "and cannot be a dummy argument"
13717 " of %qs, which is PUBLIC at %L",
13718 arg
->sym
->name
, sym
->name
,
13719 &sym
->declared_at
))
13721 /* Stop this message from recurring. */
13722 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
13727 /* PUBLIC interfaces may expose PRIVATE procedures that take types
13728 PRIVATE to the containing module. */
13729 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
13731 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
13734 && arg
->sym
->ts
.type
== BT_DERIVED
13735 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
13736 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
13737 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
13738 "PUBLIC interface %qs at %L "
13739 "takes dummy arguments of %qs which "
13740 "is PRIVATE", iface
->sym
->name
,
13741 sym
->name
, &iface
->sym
->declared_at
,
13742 gfc_typename(&arg
->sym
->ts
)))
13744 /* Stop this message from recurring. */
13745 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
13752 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
13753 && !sym
->attr
.proc_pointer
)
13755 gfc_error ("Function %qs at %L cannot have an initializer",
13756 sym
->name
, &sym
->declared_at
);
13758 /* Make sure no second error is issued for this. */
13759 sym
->value
->error
= 1;
13763 /* An external symbol may not have an initializer because it is taken to be
13764 a procedure. Exception: Procedure Pointers. */
13765 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
13767 gfc_error ("External object %qs at %L may not have an initializer",
13768 sym
->name
, &sym
->declared_at
);
13772 /* An elemental function is required to return a scalar 12.7.1 */
13773 if (sym
->attr
.elemental
&& sym
->attr
.function
13774 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13775 && CLASS_DATA (sym
)->as
)))
13777 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
13778 "result", sym
->name
, &sym
->declared_at
);
13779 /* Reset so that the error only occurs once. */
13780 sym
->attr
.elemental
= 0;
13784 if (sym
->attr
.proc
== PROC_ST_FUNCTION
13785 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
13787 gfc_error ("Statement function %qs at %L may not have pointer or "
13788 "allocatable attribute", sym
->name
, &sym
->declared_at
);
13792 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
13793 char-len-param shall not be array-valued, pointer-valued, recursive
13794 or pure. ....snip... A character value of * may only be used in the
13795 following ways: (i) Dummy arg of procedure - dummy associates with
13796 actual length; (ii) To declare a named constant; or (iii) External
13797 function - but length must be declared in calling scoping unit. */
13798 if (sym
->attr
.function
13799 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
13800 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
13802 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
13803 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
13805 if (sym
->as
&& sym
->as
->rank
)
13806 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13807 "array-valued", sym
->name
, &sym
->declared_at
);
13809 if (sym
->attr
.pointer
)
13810 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13811 "pointer-valued", sym
->name
, &sym
->declared_at
);
13813 if (sym
->attr
.pure
)
13814 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13815 "pure", sym
->name
, &sym
->declared_at
);
13817 if (sym
->attr
.recursive
)
13818 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13819 "recursive", sym
->name
, &sym
->declared_at
);
13824 /* Appendix B.2 of the standard. Contained functions give an
13825 error anyway. Deferred character length is an F2003 feature.
13826 Don't warn on intrinsic conversion functions, which start
13827 with two underscores. */
13828 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
13829 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
13830 gfc_notify_std (GFC_STD_F95_OBS
,
13831 "CHARACTER(*) function %qs at %L",
13832 sym
->name
, &sym
->declared_at
);
13835 /* F2008, C1218. */
13836 if (sym
->attr
.elemental
)
13838 if (sym
->attr
.proc_pointer
)
13840 const char* name
= (sym
->attr
.result
? sym
->ns
->proc_name
->name
13842 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
13843 name
, &sym
->declared_at
);
13846 if (sym
->attr
.dummy
)
13848 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
13849 sym
->name
, &sym
->declared_at
);
13854 /* F2018, C15100: "The result of an elemental function shall be scalar,
13855 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
13856 pointer is tested and caught elsewhere. */
13858 allocatable_or_pointer
= sym
->result
->ts
.type
== BT_CLASS
13859 && CLASS_DATA (sym
->result
) ?
13860 (CLASS_DATA (sym
->result
)->attr
.allocatable
13861 || CLASS_DATA (sym
->result
)->attr
.pointer
) :
13862 (sym
->result
->attr
.allocatable
13863 || sym
->result
->attr
.pointer
);
13865 if (sym
->attr
.elemental
&& sym
->result
13866 && allocatable_or_pointer
)
13868 gfc_error ("Function result variable %qs at %L of elemental "
13869 "function %qs shall not have an ALLOCATABLE or POINTER "
13870 "attribute", sym
->result
->name
,
13871 &sym
->result
->declared_at
, sym
->name
);
13875 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
13877 gfc_formal_arglist
*curr_arg
;
13878 int has_non_interop_arg
= 0;
13880 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13881 sym
->common_block
))
13883 /* Clear these to prevent looking at them again if there was an
13885 sym
->attr
.is_bind_c
= 0;
13886 sym
->attr
.is_c_interop
= 0;
13887 sym
->ts
.is_c_interop
= 0;
13891 /* So far, no errors have been found. */
13892 sym
->attr
.is_c_interop
= 1;
13893 sym
->ts
.is_c_interop
= 1;
13896 curr_arg
= gfc_sym_get_dummy_args (sym
);
13897 while (curr_arg
!= NULL
)
13899 /* Skip implicitly typed dummy args here. */
13900 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
13901 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
13902 /* If something is found to fail, record the fact so we
13903 can mark the symbol for the procedure as not being
13904 BIND(C) to try and prevent multiple errors being
13906 has_non_interop_arg
= 1;
13908 curr_arg
= curr_arg
->next
;
13911 /* See if any of the arguments were not interoperable and if so, clear
13912 the procedure symbol to prevent duplicate error messages. */
13913 if (has_non_interop_arg
!= 0)
13915 sym
->attr
.is_c_interop
= 0;
13916 sym
->ts
.is_c_interop
= 0;
13917 sym
->attr
.is_bind_c
= 0;
13921 if (!sym
->attr
.proc_pointer
)
13923 if (sym
->attr
.save
== SAVE_EXPLICIT
)
13925 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
13926 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13929 if (sym
->attr
.intent
)
13931 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
13932 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13935 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
13937 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
13938 "in %qs at %L", sym
->ns
->proc_name
->name
, &sym
->declared_at
);
13941 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
13942 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
13943 || sym
->attr
.contained
))
13945 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
13946 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13949 if (strcmp ("ppr@", sym
->name
) == 0)
13951 gfc_error ("Procedure pointer result %qs at %L "
13952 "is missing the pointer attribute",
13953 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
13958 /* Assume that a procedure whose body is not known has references
13959 to external arrays. */
13960 if (sym
->attr
.if_source
!= IFSRC_DECL
)
13961 sym
->attr
.array_outer_dependency
= 1;
13963 /* Compare the characteristics of a module procedure with the
13964 interface declaration. Ideally this would be done with
13965 gfc_compare_interfaces but, at present, the formal interface
13966 cannot be copied to the ts.interface. */
13967 if (sym
->attr
.module_procedure
13968 && sym
->attr
.if_source
== IFSRC_DECL
)
13971 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
13973 char *submodule_name
;
13974 strcpy (name
, sym
->ns
->proc_name
->name
);
13975 module_name
= strtok (name
, ".");
13976 submodule_name
= strtok (NULL
, ".");
13978 iface
= sym
->tlink
;
13981 /* Make sure that the result uses the correct charlen for deferred
13983 if (iface
&& sym
->result
13984 && iface
->ts
.type
== BT_CHARACTER
13985 && iface
->ts
.deferred
)
13986 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
13991 /* Check the procedure characteristics. */
13992 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
13994 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
13995 "PROCEDURE at %L and its interface in %s",
13996 &sym
->declared_at
, module_name
);
14000 if (sym
->attr
.pure
!= iface
->attr
.pure
)
14002 gfc_error ("Mismatch in PURE attribute between MODULE "
14003 "PROCEDURE at %L and its interface in %s",
14004 &sym
->declared_at
, module_name
);
14008 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
14010 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
14011 "PROCEDURE at %L and its interface in %s",
14012 &sym
->declared_at
, module_name
);
14016 /* Check the result characteristics. */
14017 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
14019 gfc_error ("%s between the MODULE PROCEDURE declaration "
14020 "in MODULE %qs and the declaration at %L in "
14022 errmsg
, module_name
, &sym
->declared_at
,
14023 submodule_name
? submodule_name
: module_name
);
14028 /* Check the characteristics of the formal arguments. */
14029 if (sym
->formal
&& sym
->formal_ns
)
14031 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
14034 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
14039 /* F2018:15.4.2.2 requires an explicit interface for procedures with the
14040 BIND(C) attribute. */
14041 if (sym
->attr
.is_bind_c
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
)
14043 gfc_error ("Interface of %qs at %L must be explicit",
14044 sym
->name
, &sym
->declared_at
);
14052 /* Resolve a list of finalizer procedures. That is, after they have hopefully
14053 been defined and we now know their defined arguments, check that they fulfill
14054 the requirements of the standard for procedures used as finalizers. */
14057 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
14059 gfc_finalizer
* list
;
14060 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
14061 bool result
= true;
14062 bool seen_scalar
= false;
14065 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
14068 gfc_resolve_finalizers (parent
, finalizable
);
14070 /* Ensure that derived-type components have a their finalizers resolved. */
14071 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
14072 for (c
= derived
->components
; c
; c
= c
->next
)
14073 if (c
->ts
.type
== BT_DERIVED
14074 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
14076 bool has_final2
= false;
14077 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
14078 return false; /* Error. */
14079 has_final
= has_final
|| has_final2
;
14081 /* Return early if not finalizable. */
14085 *finalizable
= false;
14089 /* Walk over the list of finalizer-procedures, check them, and if any one
14090 does not fit in with the standard's definition, print an error and remove
14091 it from the list. */
14092 prev_link
= &derived
->f2k_derived
->finalizers
;
14093 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
14095 gfc_formal_arglist
*dummy_args
;
14100 /* Skip this finalizer if we already resolved it. */
14101 if (list
->proc_tree
)
14103 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
14104 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
14105 seen_scalar
= true;
14106 prev_link
= &(list
->next
);
14110 /* Check this exists and is a SUBROUTINE. */
14111 if (!list
->proc_sym
->attr
.subroutine
)
14113 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
14114 list
->proc_sym
->name
, &list
->where
);
14118 /* We should have exactly one argument. */
14119 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
14120 if (!dummy_args
|| dummy_args
->next
)
14122 gfc_error ("FINAL procedure at %L must have exactly one argument",
14126 arg
= dummy_args
->sym
;
14130 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
14131 &list
->proc_sym
->declared_at
, derived
->name
);
14135 if (arg
->as
&& arg
->as
->type
== AS_ASSUMED_RANK
14136 && ((list
!= derived
->f2k_derived
->finalizers
) || list
->next
))
14138 gfc_error ("FINAL procedure at %L with assumed rank argument must "
14139 "be the only finalizer with the same kind/type "
14140 "(F2018: C790)", &list
->where
);
14144 /* This argument must be of our type. */
14145 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
14147 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
14148 &arg
->declared_at
, derived
->name
);
14152 /* It must neither be a pointer nor allocatable nor optional. */
14153 if (arg
->attr
.pointer
)
14155 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
14156 &arg
->declared_at
);
14159 if (arg
->attr
.allocatable
)
14161 gfc_error ("Argument of FINAL procedure at %L must not be"
14162 " ALLOCATABLE", &arg
->declared_at
);
14165 if (arg
->attr
.optional
)
14167 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
14168 &arg
->declared_at
);
14172 /* It must not be INTENT(OUT). */
14173 if (arg
->attr
.intent
== INTENT_OUT
)
14175 gfc_error ("Argument of FINAL procedure at %L must not be"
14176 " INTENT(OUT)", &arg
->declared_at
);
14180 /* Warn if the procedure is non-scalar and not assumed shape. */
14181 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
14182 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
14183 gfc_warning (OPT_Wsurprising
,
14184 "Non-scalar FINAL procedure at %L should have assumed"
14185 " shape argument", &arg
->declared_at
);
14187 /* Check that it does not match in kind and rank with a FINAL procedure
14188 defined earlier. To really loop over the *earlier* declarations,
14189 we need to walk the tail of the list as new ones were pushed at the
14191 /* TODO: Handle kind parameters once they are implemented. */
14192 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
14193 for (i
= list
->next
; i
; i
= i
->next
)
14195 gfc_formal_arglist
*dummy_args
;
14197 /* Argument list might be empty; that is an error signalled earlier,
14198 but we nevertheless continued resolving. */
14199 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
14202 gfc_symbol
* i_arg
= dummy_args
->sym
;
14203 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
14204 if (i_rank
== my_rank
)
14206 gfc_error ("FINAL procedure %qs declared at %L has the same"
14207 " rank (%d) as %qs",
14208 list
->proc_sym
->name
, &list
->where
, my_rank
,
14209 i
->proc_sym
->name
);
14215 /* Is this the/a scalar finalizer procedure? */
14217 seen_scalar
= true;
14219 /* Find the symtree for this procedure. */
14220 gcc_assert (!list
->proc_tree
);
14221 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
14223 prev_link
= &list
->next
;
14226 /* Remove wrong nodes immediately from the list so we don't risk any
14227 troubles in the future when they might fail later expectations. */
14230 *prev_link
= list
->next
;
14231 gfc_free_finalizer (i
);
14235 if (result
== false)
14238 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
14239 were nodes in the list, must have been for arrays. It is surely a good
14240 idea to have a scalar version there if there's something to finalize. */
14241 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
14242 gfc_warning (OPT_Wsurprising
,
14243 "Only array FINAL procedures declared for derived type %qs"
14244 " defined at %L, suggest also scalar one unless an assumed"
14245 " rank finalizer has been declared",
14246 derived
->name
, &derived
->declared_at
);
14248 vtab
= gfc_find_derived_vtab (derived
);
14249 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
14250 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
14253 *finalizable
= true;
14259 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
14262 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
14263 const char* generic_name
, locus where
)
14265 gfc_symbol
*sym1
, *sym2
;
14266 const char *pass1
, *pass2
;
14267 gfc_formal_arglist
*dummy_args
;
14269 gcc_assert (t1
->specific
&& t2
->specific
);
14270 gcc_assert (!t1
->specific
->is_generic
);
14271 gcc_assert (!t2
->specific
->is_generic
);
14272 gcc_assert (t1
->is_operator
== t2
->is_operator
);
14274 sym1
= t1
->specific
->u
.specific
->n
.sym
;
14275 sym2
= t2
->specific
->u
.specific
->n
.sym
;
14280 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
14281 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
14282 || sym1
->attr
.function
!= sym2
->attr
.function
)
14284 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
14285 " GENERIC %qs at %L",
14286 sym1
->name
, sym2
->name
, generic_name
, &where
);
14290 /* Determine PASS arguments. */
14291 if (t1
->specific
->nopass
)
14293 else if (t1
->specific
->pass_arg
)
14294 pass1
= t1
->specific
->pass_arg
;
14297 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
14299 pass1
= dummy_args
->sym
->name
;
14303 if (t2
->specific
->nopass
)
14305 else if (t2
->specific
->pass_arg
)
14306 pass2
= t2
->specific
->pass_arg
;
14309 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
14311 pass2
= dummy_args
->sym
->name
;
14316 /* Compare the interfaces. */
14317 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
14318 NULL
, 0, pass1
, pass2
))
14320 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
14321 sym1
->name
, sym2
->name
, generic_name
, &where
);
14329 /* Worker function for resolving a generic procedure binding; this is used to
14330 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
14332 The difference between those cases is finding possible inherited bindings
14333 that are overridden, as one has to look for them in tb_sym_root,
14334 tb_uop_root or tb_op, respectively. Thus the caller must already find
14335 the super-type and set p->overridden correctly. */
14338 resolve_tb_generic_targets (gfc_symbol
* super_type
,
14339 gfc_typebound_proc
* p
, const char* name
)
14341 gfc_tbp_generic
* target
;
14342 gfc_symtree
* first_target
;
14343 gfc_symtree
* inherited
;
14345 gcc_assert (p
&& p
->is_generic
);
14347 /* Try to find the specific bindings for the symtrees in our target-list. */
14348 gcc_assert (p
->u
.generic
);
14349 for (target
= p
->u
.generic
; target
; target
= target
->next
)
14350 if (!target
->specific
)
14352 gfc_typebound_proc
* overridden_tbp
;
14353 gfc_tbp_generic
* g
;
14354 const char* target_name
;
14356 target_name
= target
->specific_st
->name
;
14358 /* Defined for this type directly. */
14359 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
14361 target
->specific
= target
->specific_st
->n
.tb
;
14362 goto specific_found
;
14365 /* Look for an inherited specific binding. */
14368 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
14373 gcc_assert (inherited
->n
.tb
);
14374 target
->specific
= inherited
->n
.tb
;
14375 goto specific_found
;
14379 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
14380 " at %L", target_name
, name
, &p
->where
);
14383 /* Once we've found the specific binding, check it is not ambiguous with
14384 other specifics already found or inherited for the same GENERIC. */
14386 gcc_assert (target
->specific
);
14388 /* This must really be a specific binding! */
14389 if (target
->specific
->is_generic
)
14391 gfc_error ("GENERIC %qs at %L must target a specific binding,"
14392 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
14396 /* Check those already resolved on this type directly. */
14397 for (g
= p
->u
.generic
; g
; g
= g
->next
)
14398 if (g
!= target
&& g
->specific
14399 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
14402 /* Check for ambiguity with inherited specific targets. */
14403 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
14404 overridden_tbp
= overridden_tbp
->overridden
)
14405 if (overridden_tbp
->is_generic
)
14407 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
14409 gcc_assert (g
->specific
);
14410 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
14416 /* If we attempt to "overwrite" a specific binding, this is an error. */
14417 if (p
->overridden
&& !p
->overridden
->is_generic
)
14419 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
14420 " the same name", name
, &p
->where
);
14424 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
14425 all must have the same attributes here. */
14426 first_target
= p
->u
.generic
->specific
->u
.specific
;
14427 gcc_assert (first_target
);
14428 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
14429 p
->function
= first_target
->n
.sym
->attr
.function
;
14435 /* Resolve a GENERIC procedure binding for a derived type. */
14438 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
14440 gfc_symbol
* super_type
;
14442 /* Find the overridden binding if any. */
14443 st
->n
.tb
->overridden
= NULL
;
14444 super_type
= gfc_get_derived_super_type (derived
);
14447 gfc_symtree
* overridden
;
14448 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
14451 if (overridden
&& overridden
->n
.tb
)
14452 st
->n
.tb
->overridden
= overridden
->n
.tb
;
14455 /* Resolve using worker function. */
14456 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
14460 /* Retrieve the target-procedure of an operator binding and do some checks in
14461 common for intrinsic and user-defined type-bound operators. */
14464 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
14466 gfc_symbol
* target_proc
;
14468 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
14469 target_proc
= target
->specific
->u
.specific
->n
.sym
;
14470 gcc_assert (target_proc
);
14472 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
14473 if (target
->specific
->nopass
)
14475 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
14479 return target_proc
;
14483 /* Resolve a type-bound intrinsic operator. */
14486 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
14487 gfc_typebound_proc
* p
)
14489 gfc_symbol
* super_type
;
14490 gfc_tbp_generic
* target
;
14492 /* If there's already an error here, do nothing (but don't fail again). */
14496 /* Operators should always be GENERIC bindings. */
14497 gcc_assert (p
->is_generic
);
14499 /* Look for an overridden binding. */
14500 super_type
= gfc_get_derived_super_type (derived
);
14501 if (super_type
&& super_type
->f2k_derived
)
14502 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
14505 p
->overridden
= NULL
;
14507 /* Resolve general GENERIC properties using worker function. */
14508 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
14511 /* Check the targets to be procedures of correct interface. */
14512 for (target
= p
->u
.generic
; target
; target
= target
->next
)
14514 gfc_symbol
* target_proc
;
14516 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
14520 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
14523 /* Add target to non-typebound operator list. */
14524 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
14525 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
14527 gfc_interface
*head
, *intr
;
14529 /* Preempt 'gfc_check_new_interface' for submodules, where the
14530 mechanism for handling module procedures winds up resolving
14531 operator interfaces twice and would otherwise cause an error. */
14532 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
14533 if (intr
->sym
== target_proc
14534 && target_proc
->attr
.used_in_submodule
)
14537 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
14538 target_proc
, p
->where
))
14540 head
= derived
->ns
->op
[op
];
14541 intr
= gfc_get_interface ();
14542 intr
->sym
= target_proc
;
14543 intr
->where
= p
->where
;
14545 derived
->ns
->op
[op
] = intr
;
14557 /* Resolve a type-bound user operator (tree-walker callback). */
14559 static gfc_symbol
* resolve_bindings_derived
;
14560 static bool resolve_bindings_result
;
14562 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
14565 resolve_typebound_user_op (gfc_symtree
* stree
)
14567 gfc_symbol
* super_type
;
14568 gfc_tbp_generic
* target
;
14570 gcc_assert (stree
&& stree
->n
.tb
);
14572 if (stree
->n
.tb
->error
)
14575 /* Operators should always be GENERIC bindings. */
14576 gcc_assert (stree
->n
.tb
->is_generic
);
14578 /* Find overridden procedure, if any. */
14579 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
14580 if (super_type
&& super_type
->f2k_derived
)
14582 gfc_symtree
* overridden
;
14583 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
14584 stree
->name
, true, NULL
);
14586 if (overridden
&& overridden
->n
.tb
)
14587 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
14590 stree
->n
.tb
->overridden
= NULL
;
14592 /* Resolve basically using worker function. */
14593 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
14596 /* Check the targets to be functions of correct interface. */
14597 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
14599 gfc_symbol
* target_proc
;
14601 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
14605 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
14612 resolve_bindings_result
= false;
14613 stree
->n
.tb
->error
= 1;
14617 /* Resolve the type-bound procedures for a derived type. */
14620 resolve_typebound_procedure (gfc_symtree
* stree
)
14624 gfc_symbol
* me_arg
;
14625 gfc_symbol
* super_type
;
14626 gfc_component
* comp
;
14628 gcc_assert (stree
);
14630 /* Undefined specific symbol from GENERIC target definition. */
14634 if (stree
->n
.tb
->error
)
14637 /* If this is a GENERIC binding, use that routine. */
14638 if (stree
->n
.tb
->is_generic
)
14640 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
14645 /* Get the target-procedure to check it. */
14646 gcc_assert (!stree
->n
.tb
->is_generic
);
14647 gcc_assert (stree
->n
.tb
->u
.specific
);
14648 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
14649 where
= stree
->n
.tb
->where
;
14651 /* Default access should already be resolved from the parser. */
14652 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
14654 if (stree
->n
.tb
->deferred
)
14656 if (!check_proc_interface (proc
, &where
))
14661 /* If proc has not been resolved at this point, proc->name may
14662 actually be a USE associated entity. See PR fortran/89647. */
14663 if (!proc
->resolve_symbol_called
14664 && proc
->attr
.function
== 0 && proc
->attr
.subroutine
== 0)
14667 gfc_find_symbol (proc
->name
, gfc_current_ns
->parent
, 1, &tmp
);
14668 if (tmp
&& tmp
->attr
.use_assoc
)
14670 proc
->module
= tmp
->module
;
14671 proc
->attr
.proc
= tmp
->attr
.proc
;
14672 proc
->attr
.function
= tmp
->attr
.function
;
14673 proc
->attr
.subroutine
= tmp
->attr
.subroutine
;
14674 proc
->attr
.use_assoc
= tmp
->attr
.use_assoc
;
14675 proc
->ts
= tmp
->ts
;
14676 proc
->result
= tmp
->result
;
14680 /* Check for F08:C465. */
14681 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
14682 || (proc
->attr
.proc
!= PROC_MODULE
14683 && proc
->attr
.if_source
!= IFSRC_IFBODY
14684 && !proc
->attr
.module_procedure
)
14685 || proc
->attr
.abstract
)
14687 gfc_error ("%qs must be a module procedure or an external "
14688 "procedure with an explicit interface at %L",
14689 proc
->name
, &where
);
14694 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
14695 stree
->n
.tb
->function
= proc
->attr
.function
;
14697 /* Find the super-type of the current derived type. We could do this once and
14698 store in a global if speed is needed, but as long as not I believe this is
14699 more readable and clearer. */
14700 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
14702 /* If PASS, resolve and check arguments if not already resolved / loaded
14703 from a .mod file. */
14704 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
14706 gfc_formal_arglist
*dummy_args
;
14708 dummy_args
= gfc_sym_get_dummy_args (proc
);
14709 if (stree
->n
.tb
->pass_arg
)
14711 gfc_formal_arglist
*i
;
14713 /* If an explicit passing argument name is given, walk the arg-list
14714 and look for it. */
14717 stree
->n
.tb
->pass_arg_num
= 1;
14718 for (i
= dummy_args
; i
; i
= i
->next
)
14720 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
14725 ++stree
->n
.tb
->pass_arg_num
;
14730 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
14732 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
14733 stree
->n
.tb
->pass_arg
);
14739 /* Otherwise, take the first one; there should in fact be at least
14741 stree
->n
.tb
->pass_arg_num
= 1;
14744 gfc_error ("Procedure %qs with PASS at %L must have at"
14745 " least one argument", proc
->name
, &where
);
14748 me_arg
= dummy_args
->sym
;
14751 /* Now check that the argument-type matches and the passed-object
14752 dummy argument is generally fine. */
14754 gcc_assert (me_arg
);
14756 if (me_arg
->ts
.type
!= BT_CLASS
)
14758 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14759 " at %L", proc
->name
, &where
);
14763 if (CLASS_DATA (me_arg
)->ts
.u
.derived
14764 != resolve_bindings_derived
)
14766 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14767 " the derived-type %qs", me_arg
->name
, proc
->name
,
14768 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
14772 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
14773 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
14775 gfc_error ("Passed-object dummy argument of %qs at %L must be"
14776 " scalar", proc
->name
, &where
);
14779 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14781 gfc_error ("Passed-object dummy argument of %qs at %L must not"
14782 " be ALLOCATABLE", proc
->name
, &where
);
14785 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14787 gfc_error ("Passed-object dummy argument of %qs at %L must not"
14788 " be POINTER", proc
->name
, &where
);
14793 /* If we are extending some type, check that we don't override a procedure
14794 flagged NON_OVERRIDABLE. */
14795 stree
->n
.tb
->overridden
= NULL
;
14798 gfc_symtree
* overridden
;
14799 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
14800 stree
->name
, true, NULL
);
14804 if (overridden
->n
.tb
)
14805 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
14807 if (!gfc_check_typebound_override (stree
, overridden
))
14812 /* See if there's a name collision with a component directly in this type. */
14813 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
14814 if (!strcmp (comp
->name
, stree
->name
))
14816 gfc_error ("Procedure %qs at %L has the same name as a component of"
14818 stree
->name
, &where
, resolve_bindings_derived
->name
);
14822 /* Try to find a name collision with an inherited component. */
14823 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
14826 gfc_error ("Procedure %qs at %L has the same name as an inherited"
14827 " component of %qs",
14828 stree
->name
, &where
, resolve_bindings_derived
->name
);
14832 stree
->n
.tb
->error
= 0;
14836 resolve_bindings_result
= false;
14837 stree
->n
.tb
->error
= 1;
14842 resolve_typebound_procedures (gfc_symbol
* derived
)
14845 gfc_symbol
* super_type
;
14847 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
14850 super_type
= gfc_get_derived_super_type (derived
);
14852 resolve_symbol (super_type
);
14854 resolve_bindings_derived
= derived
;
14855 resolve_bindings_result
= true;
14857 if (derived
->f2k_derived
->tb_sym_root
)
14858 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
14859 &resolve_typebound_procedure
);
14861 if (derived
->f2k_derived
->tb_uop_root
)
14862 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
14863 &resolve_typebound_user_op
);
14865 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
14867 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
14868 if (p
&& !resolve_typebound_intrinsic_op (derived
,
14869 (gfc_intrinsic_op
)op
, p
))
14870 resolve_bindings_result
= false;
14873 return resolve_bindings_result
;
14877 /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
14878 to give all identical derived types the same backend_decl. */
14880 add_dt_to_dt_list (gfc_symbol
*derived
)
14882 if (!derived
->dt_next
)
14884 if (gfc_derived_types
)
14886 derived
->dt_next
= gfc_derived_types
->dt_next
;
14887 gfc_derived_types
->dt_next
= derived
;
14891 derived
->dt_next
= derived
;
14893 gfc_derived_types
= derived
;
14898 /* Ensure that a derived-type is really not abstract, meaning that every
14899 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
14902 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
14907 if (!ensure_not_abstract_walker (sub
, st
->left
))
14909 if (!ensure_not_abstract_walker (sub
, st
->right
))
14912 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
14914 gfc_symtree
* overriding
;
14915 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
14918 gcc_assert (overriding
->n
.tb
);
14919 if (overriding
->n
.tb
->deferred
)
14921 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
14922 " %qs is DEFERRED and not overridden",
14923 sub
->name
, &sub
->declared_at
, st
->name
);
14932 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
14934 /* The algorithm used here is to recursively travel up the ancestry of sub
14935 and for each ancestor-type, check all bindings. If any of them is
14936 DEFERRED, look it up starting from sub and see if the found (overriding)
14937 binding is not DEFERRED.
14938 This is not the most efficient way to do this, but it should be ok and is
14939 clearer than something sophisticated. */
14941 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
14943 if (!ancestor
->attr
.abstract
)
14946 /* Walk bindings of this ancestor. */
14947 if (ancestor
->f2k_derived
)
14950 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
14955 /* Find next ancestor type and recurse on it. */
14956 ancestor
= gfc_get_derived_super_type (ancestor
);
14958 return ensure_not_abstract (sub
, ancestor
);
14964 /* This check for typebound defined assignments is done recursively
14965 since the order in which derived types are resolved is not always in
14966 order of the declarations. */
14969 check_defined_assignments (gfc_symbol
*derived
)
14973 for (c
= derived
->components
; c
; c
= c
->next
)
14975 if (!gfc_bt_struct (c
->ts
.type
)
14977 || c
->attr
.proc_pointer_comp
14978 || c
->attr
.class_pointer
14979 || c
->attr
.proc_pointer
)
14982 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
14983 || (c
->ts
.u
.derived
->f2k_derived
14984 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
14986 derived
->attr
.defined_assign_comp
= 1;
14990 if (c
->attr
.allocatable
)
14993 check_defined_assignments (c
->ts
.u
.derived
);
14994 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
14996 derived
->attr
.defined_assign_comp
= 1;
15003 /* Resolve a single component of a derived type or structure. */
15006 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
15008 gfc_symbol
*super_type
;
15009 symbol_attribute
*attr
;
15011 if (c
->attr
.artificial
)
15014 /* Do not allow vtype components to be resolved in nameless namespaces
15015 such as block data because the procedure pointers will cause ICEs
15016 and vtables are not needed in these contexts. */
15017 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
15018 && sym
->ns
->proc_name
== NULL
)
15022 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
15023 && c
->attr
.codimension
15024 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
15026 gfc_error ("Coarray component %qs at %L must be allocatable with "
15027 "deferred shape", c
->name
, &c
->loc
);
15032 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
15033 && c
->ts
.u
.derived
->ts
.is_iso_c
)
15035 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15036 "shall not be a coarray", c
->name
, &c
->loc
);
15041 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
15042 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
15043 || c
->attr
.allocatable
))
15045 gfc_error ("Component %qs at %L with coarray component "
15046 "shall be a nonpointer, nonallocatable scalar",
15052 if (c
->ts
.type
== BT_CLASS
)
15054 if (c
->attr
.class_ok
&& CLASS_DATA (c
))
15056 attr
= &(CLASS_DATA (c
)->attr
);
15058 /* Fix up contiguous attribute. */
15059 if (c
->attr
.contiguous
)
15060 attr
->contiguous
= 1;
15068 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
15070 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
15071 "is not an array pointer", c
->name
, &c
->loc
);
15075 /* F2003, 15.2.1 - length has to be one. */
15076 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
15077 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
15078 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
15079 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15081 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
15086 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
15088 gfc_symbol
*ifc
= c
->ts
.interface
;
15090 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
15096 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
15098 /* Resolve interface and copy attributes. */
15099 if (ifc
->formal
&& !ifc
->formal_ns
)
15100 resolve_symbol (ifc
);
15101 if (ifc
->attr
.intrinsic
)
15102 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
15106 c
->ts
= ifc
->result
->ts
;
15107 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
15108 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
15109 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
15110 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
15111 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
15116 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
15117 c
->attr
.pointer
= ifc
->attr
.pointer
;
15118 c
->attr
.dimension
= ifc
->attr
.dimension
;
15119 c
->as
= gfc_copy_array_spec (ifc
->as
);
15120 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
15122 c
->ts
.interface
= ifc
;
15123 c
->attr
.function
= ifc
->attr
.function
;
15124 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
15126 c
->attr
.pure
= ifc
->attr
.pure
;
15127 c
->attr
.elemental
= ifc
->attr
.elemental
;
15128 c
->attr
.recursive
= ifc
->attr
.recursive
;
15129 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
15130 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
15131 /* Copy char length. */
15132 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
15134 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
15135 if (cl
->length
&& !cl
->resolved
15136 && !gfc_resolve_expr (cl
->length
))
15145 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
15147 /* Since PPCs are not implicitly typed, a PPC without an explicit
15148 interface must be a subroutine. */
15149 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
15152 /* Procedure pointer components: Check PASS arg. */
15153 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
15154 && !sym
->attr
.vtype
)
15156 gfc_symbol
* me_arg
;
15158 if (c
->tb
->pass_arg
)
15160 gfc_formal_arglist
* i
;
15162 /* If an explicit passing argument name is given, walk the arg-list
15163 and look for it. */
15166 c
->tb
->pass_arg_num
= 1;
15167 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
15169 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
15174 c
->tb
->pass_arg_num
++;
15179 gfc_error ("Procedure pointer component %qs with PASS(%s) "
15180 "at %L has no argument %qs", c
->name
,
15181 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
15188 /* Otherwise, take the first one; there should in fact be at least
15190 c
->tb
->pass_arg_num
= 1;
15191 if (!c
->ts
.interface
->formal
)
15193 gfc_error ("Procedure pointer component %qs with PASS at %L "
15194 "must have at least one argument",
15199 me_arg
= c
->ts
.interface
->formal
->sym
;
15202 /* Now check that the argument-type matches. */
15203 gcc_assert (me_arg
);
15204 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
15205 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
15206 || (me_arg
->ts
.type
== BT_CLASS
15207 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
15209 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
15210 " the derived type %qs", me_arg
->name
, c
->name
,
15211 me_arg
->name
, &c
->loc
, sym
->name
);
15216 /* Check for F03:C453. */
15217 if (CLASS_DATA (me_arg
)->attr
.dimension
)
15219 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15220 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
15226 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
15228 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15229 "may not have the POINTER attribute", me_arg
->name
,
15230 c
->name
, me_arg
->name
, &c
->loc
);
15235 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
15237 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15238 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
15239 me_arg
->name
, &c
->loc
);
15244 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
15246 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
15247 " at %L", c
->name
, &c
->loc
);
15253 /* Check type-spec if this is not the parent-type component. */
15254 if (((sym
->attr
.is_class
15255 && (!sym
->components
->ts
.u
.derived
->attr
.extension
15256 || c
!= CLASS_DATA (sym
->components
)))
15257 || (!sym
->attr
.is_class
15258 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
15259 && !sym
->attr
.vtype
15260 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
15263 super_type
= gfc_get_derived_super_type (sym
);
15265 /* If this type is an extension, set the accessibility of the parent
15268 && ((sym
->attr
.is_class
15269 && c
== CLASS_DATA (sym
->components
))
15270 || (!sym
->attr
.is_class
&& c
== sym
->components
))
15271 && strcmp (super_type
->name
, c
->name
) == 0)
15272 c
->attr
.access
= super_type
->attr
.access
;
15274 /* If this type is an extension, see if this component has the same name
15275 as an inherited type-bound procedure. */
15276 if (super_type
&& !sym
->attr
.is_class
15277 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
15279 gfc_error ("Component %qs of %qs at %L has the same name as an"
15280 " inherited type-bound procedure",
15281 c
->name
, sym
->name
, &c
->loc
);
15285 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
15286 && !c
->ts
.deferred
)
15288 if (c
->ts
.u
.cl
->length
== NULL
15289 || (!resolve_charlen(c
->ts
.u
.cl
))
15290 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
15292 gfc_error ("Character length of component %qs needs to "
15293 "be a constant specification expression at %L",
15295 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
15299 if (c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
15301 if (!c
->ts
.u
.cl
->length
->error
)
15303 gfc_error ("Character length expression of component %qs at %L "
15304 "must be of INTEGER type, found %s",
15305 c
->name
, &c
->ts
.u
.cl
->length
->where
,
15306 gfc_basic_typename (c
->ts
.u
.cl
->length
->ts
.type
));
15307 c
->ts
.u
.cl
->length
->error
= 1;
15313 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
15314 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
15316 gfc_error ("Character component %qs of %qs at %L with deferred "
15317 "length must be a POINTER or ALLOCATABLE",
15318 c
->name
, sym
->name
, &c
->loc
);
15322 /* Add the hidden deferred length field. */
15323 if (c
->ts
.type
== BT_CHARACTER
15324 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
15325 && !c
->attr
.function
15326 && !sym
->attr
.is_class
)
15328 char name
[GFC_MAX_SYMBOL_LEN
+9];
15329 gfc_component
*strlen
;
15330 sprintf (name
, "_%s_length", c
->name
);
15331 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
15332 if (strlen
== NULL
)
15334 if (!gfc_add_component (sym
, name
, &strlen
))
15336 strlen
->ts
.type
= BT_INTEGER
;
15337 strlen
->ts
.kind
= gfc_charlen_int_kind
;
15338 strlen
->attr
.access
= ACCESS_PRIVATE
;
15339 strlen
->attr
.artificial
= 1;
15343 if (c
->ts
.type
== BT_DERIVED
15344 && sym
->component_access
!= ACCESS_PRIVATE
15345 && gfc_check_symbol_access (sym
)
15346 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
15347 && !c
->ts
.u
.derived
->attr
.use_assoc
15348 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
15349 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
15350 "PRIVATE type and cannot be a component of "
15351 "%qs, which is PUBLIC at %L", c
->name
,
15352 sym
->name
, &sym
->declared_at
))
15355 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
15357 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
15358 "type %s", c
->name
, &c
->loc
, sym
->name
);
15362 if (sym
->attr
.sequence
)
15364 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
15366 gfc_error ("Component %s of SEQUENCE type declared at %L does "
15367 "not have the SEQUENCE attribute",
15368 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
15373 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
15374 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
15375 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
15376 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
15377 CLASS_DATA (c
)->ts
.u
.derived
15378 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
15380 /* If an allocatable component derived type is of the same type as
15381 the enclosing derived type, we need a vtable generating so that
15382 the __deallocate procedure is created. */
15383 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
15384 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
15385 gfc_find_vtab (&c
->ts
);
15387 /* Ensure that all the derived type components are put on the
15388 derived type list; even in formal namespaces, where derived type
15389 pointer components might not have been declared. */
15390 if (c
->ts
.type
== BT_DERIVED
15392 && c
->ts
.u
.derived
->components
15394 && sym
!= c
->ts
.u
.derived
)
15395 add_dt_to_dt_list (c
->ts
.u
.derived
);
15397 if (c
->as
&& c
->as
->type
!= AS_DEFERRED
15398 && (c
->attr
.pointer
|| c
->attr
.allocatable
))
15401 if (!gfc_resolve_array_spec (c
->as
,
15402 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
15403 || c
->attr
.allocatable
)))
15406 if (c
->initializer
&& !sym
->attr
.vtype
15407 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
15408 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
15415 /* Be nice about the locus for a structure expression - show the locus of the
15416 first non-null sub-expression if we can. */
15419 cons_where (gfc_expr
*struct_expr
)
15421 gfc_constructor
*cons
;
15423 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
15425 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
15426 for (; cons
; cons
= gfc_constructor_next (cons
))
15428 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
15429 return &cons
->expr
->where
;
15432 return &struct_expr
->where
;
15435 /* Resolve the components of a structure type. Much less work than derived
15439 resolve_fl_struct (gfc_symbol
*sym
)
15442 gfc_expr
*init
= NULL
;
15445 /* Make sure UNIONs do not have overlapping initializers. */
15446 if (sym
->attr
.flavor
== FL_UNION
)
15448 for (c
= sym
->components
; c
; c
= c
->next
)
15450 if (init
&& c
->initializer
)
15452 gfc_error ("Conflicting initializers in union at %L and %L",
15453 cons_where (init
), cons_where (c
->initializer
));
15454 gfc_free_expr (c
->initializer
);
15455 c
->initializer
= NULL
;
15458 init
= c
->initializer
;
15463 for (c
= sym
->components
; c
; c
= c
->next
)
15464 if (!resolve_component (c
, sym
))
15470 if (sym
->components
)
15471 add_dt_to_dt_list (sym
);
15477 /* Resolve the components of a derived type. This does not have to wait until
15478 resolution stage, but can be done as soon as the dt declaration has been
15482 resolve_fl_derived0 (gfc_symbol
*sym
)
15484 gfc_symbol
* super_type
;
15486 gfc_formal_arglist
*f
;
15489 if (sym
->attr
.unlimited_polymorphic
)
15492 super_type
= gfc_get_derived_super_type (sym
);
15495 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
15497 gfc_error ("As extending type %qs at %L has a coarray component, "
15498 "parent type %qs shall also have one", sym
->name
,
15499 &sym
->declared_at
, super_type
->name
);
15503 /* Ensure the extended type gets resolved before we do. */
15504 if (super_type
&& !resolve_fl_derived0 (super_type
))
15507 /* An ABSTRACT type must be extensible. */
15508 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
15510 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
15511 sym
->name
, &sym
->declared_at
);
15515 c
= (sym
->attr
.is_class
) ? CLASS_DATA (sym
->components
)
15519 for ( ; c
!= NULL
; c
= c
->next
)
15520 if (!resolve_component (c
, sym
))
15526 /* Now add the caf token field, where needed. */
15527 if (flag_coarray
!= GFC_FCOARRAY_NONE
15528 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
15530 for (c
= sym
->components
; c
; c
= c
->next
)
15531 if (!c
->attr
.dimension
&& !c
->attr
.codimension
15532 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
15534 char name
[GFC_MAX_SYMBOL_LEN
+9];
15535 gfc_component
*token
;
15536 sprintf (name
, "_caf_%s", c
->name
);
15537 token
= gfc_find_component (sym
, name
, true, true, NULL
);
15540 if (!gfc_add_component (sym
, name
, &token
))
15542 token
->ts
.type
= BT_VOID
;
15543 token
->ts
.kind
= gfc_default_integer_kind
;
15544 token
->attr
.access
= ACCESS_PRIVATE
;
15545 token
->attr
.artificial
= 1;
15546 token
->attr
.caf_token
= 1;
15551 check_defined_assignments (sym
);
15553 if (!sym
->attr
.defined_assign_comp
&& super_type
)
15554 sym
->attr
.defined_assign_comp
15555 = super_type
->attr
.defined_assign_comp
;
15557 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
15558 all DEFERRED bindings are overridden. */
15559 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
15560 && !sym
->attr
.is_class
15561 && !ensure_not_abstract (sym
, super_type
))
15564 /* Check that there is a component for every PDT parameter. */
15565 if (sym
->attr
.pdt_template
)
15567 for (f
= sym
->formal
; f
; f
= f
->next
)
15571 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
15574 gfc_error ("Parameterized type %qs does not have a component "
15575 "corresponding to parameter %qs at %L", sym
->name
,
15576 f
->sym
->name
, &sym
->declared_at
);
15582 /* Add derived type to the derived type list. */
15583 add_dt_to_dt_list (sym
);
15589 /* The following procedure does the full resolution of a derived type,
15590 including resolution of all type-bound procedures (if present). In contrast
15591 to 'resolve_fl_derived0' this can only be done after the module has been
15592 parsed completely. */
15595 resolve_fl_derived (gfc_symbol
*sym
)
15597 gfc_symbol
*gen_dt
= NULL
;
15599 if (sym
->attr
.unlimited_polymorphic
)
15602 if (!sym
->attr
.is_class
)
15603 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
15604 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
15605 && (!gen_dt
->generic
->sym
->attr
.use_assoc
15606 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
15607 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
15608 "%qs at %L being the same name as derived "
15609 "type at %L", sym
->name
,
15610 gen_dt
->generic
->sym
== sym
15611 ? gen_dt
->generic
->next
->sym
->name
15612 : gen_dt
->generic
->sym
->name
,
15613 gen_dt
->generic
->sym
== sym
15614 ? &gen_dt
->generic
->next
->sym
->declared_at
15615 : &gen_dt
->generic
->sym
->declared_at
,
15616 &sym
->declared_at
))
15619 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
15621 gfc_error ("Derived type %qs at %L has not been declared",
15622 sym
->name
, &sym
->declared_at
);
15626 /* Resolve the finalizer procedures. */
15627 if (!gfc_resolve_finalizers (sym
, NULL
))
15630 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
15632 /* Fix up incomplete CLASS symbols. */
15633 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
15634 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
15636 /* Nothing more to do for unlimited polymorphic entities. */
15637 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
15639 add_dt_to_dt_list (sym
);
15642 else if (vptr
->ts
.u
.derived
== NULL
)
15644 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
15646 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
15647 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
15652 if (!resolve_fl_derived0 (sym
))
15655 /* Resolve the type-bound procedures. */
15656 if (!resolve_typebound_procedures (sym
))
15659 /* Generate module vtables subject to their accessibility and their not
15660 being vtables or pdt templates. If this is not done class declarations
15661 in external procedures wind up with their own version and so SELECT TYPE
15662 fails because the vptrs do not have the same address. */
15663 if (gfc_option
.allow_std
& GFC_STD_F2003
15664 && sym
->ns
->proc_name
15665 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15666 && sym
->attr
.access
!= ACCESS_PRIVATE
15667 && !(sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
15669 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
15670 gfc_set_sym_referenced (vtab
);
15678 resolve_fl_namelist (gfc_symbol
*sym
)
15683 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
15685 /* Check again, the check in match only works if NAMELIST comes
15687 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
15689 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
15690 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15694 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
15695 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
15696 "with assumed shape in namelist %qs at %L",
15697 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
15700 if (is_non_constant_shape_array (nl
->sym
)
15701 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
15702 "with nonconstant shape in namelist %qs at %L",
15703 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
15706 if (nl
->sym
->ts
.type
== BT_CHARACTER
15707 && (nl
->sym
->ts
.u
.cl
->length
== NULL
15708 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
15709 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
15710 "nonconstant character length in "
15711 "namelist %qs at %L", nl
->sym
->name
,
15712 sym
->name
, &sym
->declared_at
))
15717 /* Reject PRIVATE objects in a PUBLIC namelist. */
15718 if (gfc_check_symbol_access (sym
))
15720 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
15722 if (!nl
->sym
->attr
.use_assoc
15723 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
15724 && !gfc_check_symbol_access (nl
->sym
))
15726 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
15727 "cannot be member of PUBLIC namelist %qs at %L",
15728 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15732 if (nl
->sym
->ts
.type
== BT_DERIVED
15733 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
15734 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
15736 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
15737 "namelist %qs at %L with ALLOCATABLE "
15738 "or POINTER components", nl
->sym
->name
,
15739 sym
->name
, &sym
->declared_at
))
15744 /* Types with private components that came here by USE-association. */
15745 if (nl
->sym
->ts
.type
== BT_DERIVED
15746 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
15748 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
15749 "components and cannot be member of namelist %qs at %L",
15750 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15754 /* Types with private components that are defined in the same module. */
15755 if (nl
->sym
->ts
.type
== BT_DERIVED
15756 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
15757 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
15759 gfc_error ("NAMELIST object %qs has PRIVATE components and "
15760 "cannot be a member of PUBLIC namelist %qs at %L",
15761 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
15768 /* 14.1.2 A module or internal procedure represent local entities
15769 of the same type as a namelist member and so are not allowed. */
15770 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
15772 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
15775 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
15776 if ((nl
->sym
== sym
->ns
->proc_name
)
15778 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
15783 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
15784 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
15786 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
15787 "attribute in %qs at %L", nlsym
->name
,
15788 &sym
->declared_at
);
15798 resolve_fl_parameter (gfc_symbol
*sym
)
15800 /* A parameter array's shape needs to be constant. */
15801 if (sym
->as
!= NULL
15802 && (sym
->as
->type
== AS_DEFERRED
15803 || is_non_constant_shape_array (sym
)))
15805 gfc_error ("Parameter array %qs at %L cannot be automatic "
15806 "or of deferred shape", sym
->name
, &sym
->declared_at
);
15810 /* Constraints on deferred type parameter. */
15811 if (!deferred_requirements (sym
))
15814 /* Make sure a parameter that has been implicitly typed still
15815 matches the implicit type, since PARAMETER statements can precede
15816 IMPLICIT statements. */
15817 if (sym
->attr
.implicit_type
15818 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
15821 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
15822 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
15826 /* Make sure the types of derived parameters are consistent. This
15827 type checking is deferred until resolution because the type may
15828 refer to a derived type from the host. */
15829 if (sym
->ts
.type
== BT_DERIVED
15830 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
15832 gfc_error ("Incompatible derived type in PARAMETER at %L",
15833 &sym
->value
->where
);
15837 /* F03:C509,C514. */
15838 if (sym
->ts
.type
== BT_CLASS
)
15840 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
15841 sym
->name
, &sym
->declared_at
);
15849 /* Called by resolve_symbol to check PDTs. */
15852 resolve_pdt (gfc_symbol
* sym
)
15854 gfc_symbol
*derived
= NULL
;
15855 gfc_actual_arglist
*param
;
15857 bool const_len_exprs
= true;
15858 bool assumed_len_exprs
= false;
15859 symbol_attribute
*attr
;
15861 if (sym
->ts
.type
== BT_DERIVED
)
15863 derived
= sym
->ts
.u
.derived
;
15864 attr
= &(sym
->attr
);
15866 else if (sym
->ts
.type
== BT_CLASS
)
15868 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
15869 attr
= &(CLASS_DATA (sym
)->attr
);
15872 gcc_unreachable ();
15874 gcc_assert (derived
->attr
.pdt_type
);
15876 for (param
= sym
->param_list
; param
; param
= param
->next
)
15878 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
15880 if (c
->attr
.pdt_kind
)
15883 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
15884 && c
->attr
.pdt_len
)
15885 const_len_exprs
= false;
15886 else if (param
->spec_type
== SPEC_ASSUMED
)
15887 assumed_len_exprs
= true;
15889 if (param
->spec_type
== SPEC_DEFERRED
15890 && !attr
->allocatable
&& !attr
->pointer
)
15891 gfc_error ("The object %qs at %L has a deferred LEN "
15892 "parameter %qs and is neither allocatable "
15893 "nor a pointer", sym
->name
, &sym
->declared_at
,
15898 if (!const_len_exprs
15899 && (sym
->ns
->proc_name
->attr
.is_main_program
15900 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15901 || sym
->attr
.save
!= SAVE_NONE
))
15902 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
15903 "SAVE attribute or be a variable declared in the "
15904 "main program, a module or a submodule(F08/C513)",
15905 sym
->name
, &sym
->declared_at
);
15907 if (assumed_len_exprs
&& !(sym
->attr
.dummy
15908 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
15909 gfc_error ("The object %qs at %L with ASSUMED type parameters "
15910 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
15911 sym
->name
, &sym
->declared_at
);
15915 /* Do anything necessary to resolve a symbol. Right now, we just
15916 assume that an otherwise unknown symbol is a variable. This sort
15917 of thing commonly happens for symbols in module. */
15920 resolve_symbol (gfc_symbol
*sym
)
15922 int check_constant
, mp_flag
;
15923 gfc_symtree
*symtree
;
15924 gfc_symtree
*this_symtree
;
15927 symbol_attribute class_attr
;
15928 gfc_array_spec
*as
;
15929 bool saved_specification_expr
;
15931 if (sym
->resolve_symbol_called
>= 1)
15933 sym
->resolve_symbol_called
= 1;
15935 /* No symbol will ever have union type; only components can be unions.
15936 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
15937 (just like derived type declaration symbols have flavor FL_DERIVED). */
15938 gcc_assert (sym
->ts
.type
!= BT_UNION
);
15940 /* Coarrayed polymorphic objects with allocatable or pointer components are
15941 yet unsupported for -fcoarray=lib. */
15942 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
15943 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
15944 && CLASS_DATA (sym
)->attr
.codimension
15945 && CLASS_DATA (sym
)->ts
.u
.derived
15946 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
15947 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
15949 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
15950 "type coarrays at %L are unsupported", &sym
->declared_at
);
15954 if (sym
->attr
.artificial
)
15957 if (sym
->attr
.unlimited_polymorphic
)
15960 if (UNLIKELY (flag_openmp
&& strcmp (sym
->name
, "omp_all_memory") == 0))
15962 gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
15963 "the OpenMP DEPEND clause", &sym
->declared_at
);
15967 if (sym
->attr
.flavor
== FL_UNKNOWN
15968 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
15969 && !sym
->attr
.generic
&& !sym
->attr
.external
15970 && sym
->attr
.if_source
== IFSRC_UNKNOWN
15971 && sym
->ts
.type
== BT_UNKNOWN
))
15974 /* If we find that a flavorless symbol is an interface in one of the
15975 parent namespaces, find its symtree in this namespace, free the
15976 symbol and set the symtree to point to the interface symbol. */
15977 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
15979 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
15980 if (symtree
&& (symtree
->n
.sym
->generic
||
15981 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
15982 && sym
->ns
->construct_entities
)))
15984 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
15986 if (this_symtree
->n
.sym
== sym
)
15988 symtree
->n
.sym
->refs
++;
15989 gfc_release_symbol (sym
);
15990 this_symtree
->n
.sym
= symtree
->n
.sym
;
15996 /* Otherwise give it a flavor according to such attributes as
15998 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
15999 && sym
->attr
.intrinsic
== 0)
16000 sym
->attr
.flavor
= FL_VARIABLE
;
16001 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
16003 sym
->attr
.flavor
= FL_PROCEDURE
;
16004 if (sym
->attr
.dimension
)
16005 sym
->attr
.function
= 1;
16009 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
16010 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
16012 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
16013 && !resolve_procedure_interface (sym
))
16016 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
16017 && (sym
->attr
.procedure
|| sym
->attr
.external
))
16019 if (sym
->attr
.external
)
16020 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
16021 "at %L", &sym
->declared_at
);
16023 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
16024 "at %L", &sym
->declared_at
);
16029 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
16032 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
16033 && !resolve_fl_struct (sym
))
16036 /* Symbols that are module procedures with results (functions) have
16037 the types and array specification copied for type checking in
16038 procedures that call them, as well as for saving to a module
16039 file. These symbols can't stand the scrutiny that their results
16041 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
16043 /* Make sure that the intrinsic is consistent with its internal
16044 representation. This needs to be done before assigning a default
16045 type to avoid spurious warnings. */
16046 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
16047 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
16050 /* Resolve associate names. */
16052 resolve_assoc_var (sym
, true);
16054 /* Assign default type to symbols that need one and don't have one. */
16055 if (sym
->ts
.type
== BT_UNKNOWN
)
16057 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
16059 gfc_set_default_type (sym
, 1, NULL
);
16062 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
16063 && !sym
->attr
.function
&& !sym
->attr
.subroutine
16064 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
16065 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
16067 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
16069 /* The specific case of an external procedure should emit an error
16070 in the case that there is no implicit type. */
16073 if (!sym
->attr
.mixed_entry_master
)
16074 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
16078 /* Result may be in another namespace. */
16079 resolve_symbol (sym
->result
);
16081 if (!sym
->result
->attr
.proc_pointer
)
16083 sym
->ts
= sym
->result
->ts
;
16084 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
16085 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
16086 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
16087 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
16088 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
16093 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
16095 bool saved_specification_expr
= specification_expr
;
16096 bool saved_formal_arg_flag
= formal_arg_flag
;
16098 specification_expr
= true;
16099 formal_arg_flag
= true;
16100 gfc_resolve_array_spec (sym
->result
->as
, false);
16101 formal_arg_flag
= saved_formal_arg_flag
;
16102 specification_expr
= saved_specification_expr
;
16105 /* For a CLASS-valued function with a result variable, affirm that it has
16106 been resolved also when looking at the symbol 'sym'. */
16107 if (mp_flag
&& sym
->ts
.type
== BT_CLASS
&& sym
->result
->attr
.class_ok
)
16108 sym
->attr
.class_ok
= sym
->result
->attr
.class_ok
;
16110 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
&& sym
->ts
.u
.derived
16111 && CLASS_DATA (sym
))
16113 as
= CLASS_DATA (sym
)->as
;
16114 class_attr
= CLASS_DATA (sym
)->attr
;
16115 class_attr
.pointer
= class_attr
.class_pointer
;
16119 class_attr
= sym
->attr
;
16124 if (sym
->attr
.contiguous
16125 && (!class_attr
.dimension
16126 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
16127 && !class_attr
.pointer
)))
16129 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
16130 "array pointer or an assumed-shape or assumed-rank array",
16131 sym
->name
, &sym
->declared_at
);
16135 /* Assumed size arrays and assumed shape arrays must be dummy
16136 arguments. Array-spec's of implied-shape should have been resolved to
16137 AS_EXPLICIT already. */
16141 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
16142 specification expression. */
16143 if (as
->type
== AS_IMPLIED_SHAPE
)
16146 for (i
=0; i
<as
->rank
; i
++)
16148 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
16150 gfc_error ("Bad specification for assumed size array at %L",
16151 &as
->lower
[i
]->where
);
16158 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
16159 || as
->type
== AS_ASSUMED_SHAPE
)
16160 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
16161 && !sym
->attr
.associate_var
)
16163 if (as
->type
== AS_ASSUMED_SIZE
)
16164 gfc_error ("Assumed size array at %L must be a dummy argument",
16165 &sym
->declared_at
);
16167 gfc_error ("Assumed shape array at %L must be a dummy argument",
16168 &sym
->declared_at
);
16171 /* TS 29113, C535a. */
16172 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
16173 && !sym
->attr
.select_type_temporary
16174 && !(cs_base
&& cs_base
->current
16175 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
16177 gfc_error ("Assumed-rank array at %L must be a dummy argument",
16178 &sym
->declared_at
);
16181 if (as
->type
== AS_ASSUMED_RANK
16182 && (sym
->attr
.codimension
|| sym
->attr
.value
))
16184 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
16185 "CODIMENSION attribute", &sym
->declared_at
);
16190 /* Make sure symbols with known intent or optional are really dummy
16191 variable. Because of ENTRY statement, this has to be deferred
16192 until resolution time. */
16194 if (!sym
->attr
.dummy
16195 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
16197 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
16201 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
16203 gfc_error ("%qs at %L cannot have the VALUE attribute because "
16204 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
16208 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
16210 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
16211 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
16213 gfc_error ("Character dummy variable %qs at %L with VALUE "
16214 "attribute must have constant length",
16215 sym
->name
, &sym
->declared_at
);
16219 if (sym
->ts
.is_c_interop
16220 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
16222 gfc_error ("C interoperable character dummy variable %qs at %L "
16223 "with VALUE attribute must have length one",
16224 sym
->name
, &sym
->declared_at
);
16229 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
16230 && sym
->ts
.u
.derived
->attr
.generic
)
16232 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
16233 if (!sym
->ts
.u
.derived
)
16235 gfc_error ("The derived type %qs at %L is of type %qs, "
16236 "which has not been defined", sym
->name
,
16237 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16238 sym
->ts
.type
= BT_UNKNOWN
;
16243 /* Use the same constraints as TYPE(*), except for the type check
16244 and that only scalars and assumed-size arrays are permitted. */
16245 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
16247 if (!sym
->attr
.dummy
)
16249 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
16250 "a dummy argument", sym
->name
, &sym
->declared_at
);
16254 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
16255 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
16256 && sym
->ts
.type
!= BT_COMPLEX
)
16258 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
16259 "of type TYPE(*) or of an numeric intrinsic type",
16260 sym
->name
, &sym
->declared_at
);
16264 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
16265 || sym
->attr
.pointer
|| sym
->attr
.value
)
16267 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
16268 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
16269 "attribute", sym
->name
, &sym
->declared_at
);
16273 if (sym
->attr
.intent
== INTENT_OUT
)
16275 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
16276 "have the INTENT(OUT) attribute",
16277 sym
->name
, &sym
->declared_at
);
16280 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
16282 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
16283 "either be a scalar or an assumed-size array",
16284 sym
->name
, &sym
->declared_at
);
16288 /* Set the type to TYPE(*) and add a dimension(*) to ensure
16289 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
16291 sym
->ts
.type
= BT_ASSUMED
;
16292 sym
->as
= gfc_get_array_spec ();
16293 sym
->as
->type
= AS_ASSUMED_SIZE
;
16295 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
16297 else if (sym
->ts
.type
== BT_ASSUMED
)
16299 /* TS 29113, C407a. */
16300 if (!sym
->attr
.dummy
)
16302 gfc_error ("Assumed type of variable %s at %L is only permitted "
16303 "for dummy variables", sym
->name
, &sym
->declared_at
);
16306 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
16307 || sym
->attr
.pointer
|| sym
->attr
.value
)
16309 gfc_error ("Assumed-type variable %s at %L may not have the "
16310 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
16311 sym
->name
, &sym
->declared_at
);
16314 if (sym
->attr
.intent
== INTENT_OUT
)
16316 gfc_error ("Assumed-type variable %s at %L may not have the "
16317 "INTENT(OUT) attribute",
16318 sym
->name
, &sym
->declared_at
);
16321 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
16323 gfc_error ("Assumed-type variable %s at %L shall not be an "
16324 "explicit-shape array", sym
->name
, &sym
->declared_at
);
16329 /* If the symbol is marked as bind(c), that it is declared at module level
16330 scope and verify its type and kind. Do not do the latter for symbols
16331 that are implicitly typed because that is handled in
16332 gfc_set_default_type. Handle dummy arguments and procedure definitions
16333 separately. Also, anything that is use associated is not handled here
16334 but instead is handled in the module it is declared in. Finally, derived
16335 type definitions are allowed to be BIND(C) since that only implies that
16336 they're interoperable, and they are checked fully for interoperability
16337 when a variable is declared of that type. */
16338 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
16339 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
16340 && sym
->attr
.flavor
!= FL_DERIVED
)
16344 /* First, make sure the variable is declared at the
16345 module-level scope (J3/04-007, Section 15.3). */
16346 if (!(sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16347 && !sym
->attr
.in_common
)
16349 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
16350 "is neither a COMMON block nor declared at the "
16351 "module level scope", sym
->name
, &(sym
->declared_at
));
16354 else if (sym
->ts
.type
== BT_CHARACTER
16355 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
16356 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
16357 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
16359 gfc_error ("BIND(C) Variable %qs at %L must have length one",
16360 sym
->name
, &sym
->declared_at
);
16363 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
16365 t
= verify_com_block_vars_c_interop (sym
->common_head
);
16367 else if (sym
->attr
.implicit_type
== 0)
16369 /* If type() declaration, we need to verify that the components
16370 of the given type are all C interoperable, etc. */
16371 if (sym
->ts
.type
== BT_DERIVED
&&
16372 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
16374 /* Make sure the user marked the derived type as BIND(C). If
16375 not, call the verify routine. This could print an error
16376 for the derived type more than once if multiple variables
16377 of that type are declared. */
16378 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
16379 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
16383 /* Verify the variable itself as C interoperable if it
16384 is BIND(C). It is not possible for this to succeed if
16385 the verify_bind_c_derived_type failed, so don't have to handle
16386 any error returned by verify_bind_c_derived_type. */
16387 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
16388 sym
->common_block
);
16393 /* clear the is_bind_c flag to prevent reporting errors more than
16394 once if something failed. */
16395 sym
->attr
.is_bind_c
= 0;
16400 /* If a derived type symbol has reached this point, without its
16401 type being declared, we have an error. Notice that most
16402 conditions that produce undefined derived types have already
16403 been dealt with. However, the likes of:
16404 implicit type(t) (t) ..... call foo (t) will get us here if
16405 the type is not declared in the scope of the implicit
16406 statement. Change the type to BT_UNKNOWN, both because it is so
16407 and to prevent an ICE. */
16408 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
16409 && sym
->ts
.u
.derived
->components
== NULL
16410 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
16412 gfc_error ("The derived type %qs at %L is of type %qs, "
16413 "which has not been defined", sym
->name
,
16414 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16415 sym
->ts
.type
= BT_UNKNOWN
;
16419 /* Make sure that the derived type has been resolved and that the
16420 derived type is visible in the symbol's namespace, if it is a
16421 module function and is not PRIVATE. */
16422 if (sym
->ts
.type
== BT_DERIVED
16423 && sym
->ts
.u
.derived
->attr
.use_assoc
16424 && sym
->ns
->proc_name
16425 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
16426 && !resolve_fl_derived (sym
->ts
.u
.derived
))
16429 /* Unless the derived-type declaration is use associated, Fortran 95
16430 does not allow public entries of private derived types.
16431 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
16432 161 in 95-006r3. */
16433 if (sym
->ts
.type
== BT_DERIVED
16434 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
16435 && !sym
->ts
.u
.derived
->attr
.use_assoc
16436 && gfc_check_symbol_access (sym
)
16437 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16438 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
16439 "derived type %qs",
16440 (sym
->attr
.flavor
== FL_PARAMETER
)
16441 ? "parameter" : "variable",
16442 sym
->name
, &sym
->declared_at
,
16443 sym
->ts
.u
.derived
->name
))
16446 /* F2008, C1302. */
16447 if (sym
->ts
.type
== BT_DERIVED
16448 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
16449 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
16450 || sym
->ts
.u
.derived
->attr
.lock_comp
)
16451 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
16453 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
16454 "type LOCK_TYPE must be a coarray", sym
->name
,
16455 &sym
->declared_at
);
16459 /* TS18508, C702/C703. */
16460 if (sym
->ts
.type
== BT_DERIVED
16461 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
16462 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
16463 || sym
->ts
.u
.derived
->attr
.event_comp
)
16464 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
16466 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
16467 "type EVENT_TYPE must be a coarray", sym
->name
,
16468 &sym
->declared_at
);
16472 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
16473 default initialization is defined (5.1.2.4.4). */
16474 if (sym
->ts
.type
== BT_DERIVED
16476 && sym
->attr
.intent
== INTENT_OUT
16478 && sym
->as
->type
== AS_ASSUMED_SIZE
)
16480 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
16482 if (c
->initializer
)
16484 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
16485 "ASSUMED SIZE and so cannot have a default initializer",
16486 sym
->name
, &sym
->declared_at
);
16493 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
16494 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
16496 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
16497 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
16502 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
16503 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
16505 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
16506 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
16511 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
16512 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
16513 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
16514 && CLASS_DATA (sym
)->attr
.coarray_comp
))
16515 || class_attr
.codimension
)
16516 && (sym
->attr
.result
|| sym
->result
== sym
))
16518 gfc_error ("Function result %qs at %L shall not be a coarray or have "
16519 "a coarray component", sym
->name
, &sym
->declared_at
);
16524 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
16525 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
16527 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
16528 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
16533 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
16534 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
16535 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
16536 && CLASS_DATA (sym
)->attr
.coarray_comp
))
16537 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
16538 || class_attr
.allocatable
))
16540 gfc_error ("Variable %qs at %L with coarray component shall be a "
16541 "nonpointer, nonallocatable scalar, which is not a coarray",
16542 sym
->name
, &sym
->declared_at
);
16546 /* F2008, C526. The function-result case was handled above. */
16547 if (class_attr
.codimension
16548 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
16549 || sym
->attr
.select_type_temporary
16550 || sym
->attr
.associate_var
16551 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
16552 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
16553 || sym
->ns
->proc_name
->attr
.is_main_program
16554 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
16556 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
16557 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
16561 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
16562 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
16564 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
16565 "deferred shape", sym
->name
, &sym
->declared_at
);
16568 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
16569 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
16571 gfc_error ("Allocatable coarray variable %qs at %L must have "
16572 "deferred shape", sym
->name
, &sym
->declared_at
);
16577 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
16578 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
16579 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
16580 && CLASS_DATA (sym
)->attr
.coarray_comp
))
16581 || (class_attr
.codimension
&& class_attr
.allocatable
))
16582 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
16584 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
16585 "allocatable coarray or have coarray components",
16586 sym
->name
, &sym
->declared_at
);
16590 if (class_attr
.codimension
&& sym
->attr
.dummy
16591 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
16593 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
16594 "procedure %qs", sym
->name
, &sym
->declared_at
,
16595 sym
->ns
->proc_name
->name
);
16599 if (sym
->ts
.type
== BT_LOGICAL
16600 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
16601 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
16602 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
16605 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
16606 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
16608 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
16609 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
16610 "%L with non-C_Bool kind in BIND(C) procedure "
16611 "%qs", sym
->name
, &sym
->declared_at
,
16612 sym
->ns
->proc_name
->name
))
16614 else if (!gfc_logical_kinds
[i
].c_bool
16615 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
16616 "%qs at %L with non-C_Bool kind in "
16617 "BIND(C) procedure %qs", sym
->name
,
16619 sym
->attr
.function
? sym
->name
16620 : sym
->ns
->proc_name
->name
))
16624 switch (sym
->attr
.flavor
)
16627 if (!resolve_fl_variable (sym
, mp_flag
))
16632 if (sym
->formal
&& !sym
->formal_ns
)
16634 /* Check that none of the arguments are a namelist. */
16635 gfc_formal_arglist
*formal
= sym
->formal
;
16637 for (; formal
; formal
= formal
->next
)
16638 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
16640 gfc_error ("Namelist %qs cannot be an argument to "
16641 "subroutine or function at %L",
16642 formal
->sym
->name
, &sym
->declared_at
);
16647 if (!resolve_fl_procedure (sym
, mp_flag
))
16652 if (!resolve_fl_namelist (sym
))
16657 if (!resolve_fl_parameter (sym
))
16665 /* Resolve array specifier. Check as well some constraints
16666 on COMMON blocks. */
16668 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
&& !sym
->error
;
16670 /* Set the formal_arg_flag so that check_conflict will not throw
16671 an error for host associated variables in the specification
16672 expression for an array_valued function. */
16673 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
16674 formal_arg_flag
= true;
16676 saved_specification_expr
= specification_expr
;
16677 specification_expr
= true;
16678 gfc_resolve_array_spec (sym
->as
, check_constant
);
16679 specification_expr
= saved_specification_expr
;
16681 formal_arg_flag
= false;
16683 /* Resolve formal namespaces. */
16684 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
16685 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
16686 gfc_resolve (sym
->formal_ns
);
16688 /* Make sure the formal namespace is present. */
16689 if (sym
->formal
&& !sym
->formal_ns
)
16691 gfc_formal_arglist
*formal
= sym
->formal
;
16692 while (formal
&& !formal
->sym
)
16693 formal
= formal
->next
;
16697 sym
->formal_ns
= formal
->sym
->ns
;
16698 if (sym
->formal_ns
&& sym
->ns
!= formal
->sym
->ns
)
16699 sym
->formal_ns
->refs
++;
16703 /* Check threadprivate restrictions. */
16704 if (sym
->attr
.threadprivate
16705 && !(sym
->attr
.save
|| sym
->attr
.data
|| sym
->attr
.in_common
)
16706 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
16707 && sym
->module
== NULL
16708 && (sym
->ns
->proc_name
== NULL
16709 || (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
16710 && !sym
->ns
->proc_name
->attr
.is_main_program
)))
16711 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
16713 /* Check omp declare target restrictions. */
16714 if (sym
->attr
.omp_declare_target
16715 && sym
->attr
.flavor
== FL_VARIABLE
16717 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
16718 && (!sym
->attr
.in_common
16719 && sym
->module
== NULL
16720 && (sym
->ns
->proc_name
== NULL
16721 || (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
16722 && !sym
->ns
->proc_name
->attr
.is_main_program
))))
16723 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
16724 sym
->name
, &sym
->declared_at
);
16726 /* If we have come this far we can apply default-initializers, as
16727 described in 14.7.5, to those variables that have not already
16728 been assigned one. */
16729 if (sym
->ts
.type
== BT_DERIVED
16731 && !sym
->attr
.allocatable
16732 && !sym
->attr
.alloc_comp
)
16734 symbol_attribute
*a
= &sym
->attr
;
16736 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
16737 && !a
->in_common
&& !a
->use_assoc
16739 && !((a
->function
|| a
->result
)
16741 || sym
->ts
.u
.derived
->attr
.alloc_comp
16742 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
16743 && !(a
->function
&& sym
!= sym
->result
))
16744 || (a
->dummy
&& !a
->pointer
&& a
->intent
== INTENT_OUT
16745 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
))
16746 apply_default_init (sym
);
16747 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
16748 && (sym
->ts
.u
.derived
->attr
.alloc_comp
16749 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
16750 /* Mark the result symbol to be referenced, when it has allocatable
16752 sym
->result
->attr
.referenced
= 1;
16755 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
16756 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
16757 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
16758 && !CLASS_DATA (sym
)->attr
.class_pointer
16759 && !CLASS_DATA (sym
)->attr
.allocatable
)
16760 apply_default_init (sym
);
16762 /* If this symbol has a type-spec, check it. */
16763 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
16764 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
16765 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
16768 if (sym
->param_list
)
16771 if (!sym
->attr
.referenced
16772 && (sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
))
16774 gfc_expr
*final_expr
= gfc_lval_expr_from_sym (sym
);
16775 if (gfc_is_finalizable (final_expr
->ts
.u
.derived
, NULL
))
16776 gfc_set_sym_referenced (sym
);
16777 gfc_free_expr (final_expr
);
16782 /************* Resolve DATA statements *************/
16786 gfc_data_value
*vnode
;
16792 /* Advance the values structure to point to the next value in the data list. */
16795 next_data_value (void)
16797 while (mpz_cmp_ui (values
.left
, 0) == 0)
16800 if (values
.vnode
->next
== NULL
)
16803 values
.vnode
= values
.vnode
->next
;
16804 mpz_set (values
.left
, values
.vnode
->repeat
);
16812 check_data_variable (gfc_data_variable
*var
, locus
*where
)
16818 ar_type mark
= AR_UNKNOWN
;
16820 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
16821 int vector_offset
[GFC_MAX_DIMENSIONS
];
16827 if (!gfc_resolve_expr (var
->expr
))
16833 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
16834 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
16835 e
= e
->value
.function
.actual
->expr
;
16837 if (e
->expr_type
!= EXPR_VARIABLE
)
16839 gfc_error ("Expecting definable entity near %L", where
);
16843 sym
= e
->symtree
->n
.sym
;
16845 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
16847 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
16848 sym
->name
, &sym
->declared_at
);
16852 if (e
->ref
== NULL
&& sym
->as
)
16854 gfc_error ("DATA array %qs at %L must be specified in a previous"
16855 " declaration", sym
->name
, where
);
16859 if (gfc_is_coindexed (e
))
16861 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
16866 has_pointer
= sym
->attr
.pointer
;
16868 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
16870 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
16875 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_FULL
)
16877 gfc_error ("DATA element %qs at %L is a pointer and so must "
16878 "be a full array", sym
->name
, where
);
16882 if (values
.vnode
->expr
->expr_type
== EXPR_CONSTANT
)
16884 gfc_error ("DATA object near %L has the pointer attribute "
16885 "and the corresponding DATA value is not a valid "
16886 "initial-data-target", where
);
16891 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.allocatable
)
16893 gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
16894 "attribute", ref
->u
.c
.component
->name
, &e
->where
);
16898 /* Reject substrings of strings of non-constant length. */
16899 if (ref
->type
== REF_SUBSTRING
16900 && ref
->u
.ss
.length
16901 && ref
->u
.ss
.length
->length
16902 && !gfc_is_constant_expr (ref
->u
.ss
.length
->length
))
16906 /* Reject strings with deferred length or non-constant length. */
16907 if (e
->ts
.type
== BT_CHARACTER
16909 || (e
->ts
.u
.cl
->length
16910 && !gfc_is_constant_expr (e
->ts
.u
.cl
->length
))))
16913 mpz_init_set_si (offset
, 0);
16915 if (e
->rank
== 0 || has_pointer
)
16917 mpz_init_set_ui (size
, 1);
16924 /* Find the array section reference. */
16925 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
16927 if (ref
->type
!= REF_ARRAY
)
16929 if (ref
->u
.ar
.type
== AR_ELEMENT
)
16935 /* Set marks according to the reference pattern. */
16936 switch (ref
->u
.ar
.type
)
16944 /* Get the start position of array section. */
16945 gfc_get_section_index (ar
, section_index
, &offset
, vector_offset
);
16950 gcc_unreachable ();
16953 if (!gfc_array_size (e
, &size
))
16955 gfc_error ("Nonconstant array section at %L in DATA statement",
16957 mpz_clear (offset
);
16964 while (mpz_cmp_ui (size
, 0) > 0)
16966 if (!next_data_value ())
16968 gfc_error ("DATA statement at %L has more variables than values",
16974 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
16978 /* If we have more than one element left in the repeat count,
16979 and we have more than one element left in the target variable,
16980 then create a range assignment. */
16981 /* FIXME: Only done for full arrays for now, since array sections
16983 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
16984 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
16988 if (mpz_cmp (size
, values
.left
) >= 0)
16990 mpz_init_set (range
, values
.left
);
16991 mpz_sub (size
, size
, values
.left
);
16992 mpz_set_ui (values
.left
, 0);
16996 mpz_init_set (range
, size
);
16997 mpz_sub (values
.left
, values
.left
, size
);
16998 mpz_set_ui (size
, 0);
17001 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
17004 mpz_add (offset
, offset
, range
);
17011 /* Assign initial value to symbol. */
17014 mpz_sub_ui (values
.left
, values
.left
, 1);
17015 mpz_sub_ui (size
, size
, 1);
17017 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
17022 if (mark
== AR_FULL
)
17023 mpz_add_ui (offset
, offset
, 1);
17025 /* Modify the array section indexes and recalculate the offset
17026 for next element. */
17027 else if (mark
== AR_SECTION
)
17028 gfc_advance_section (section_index
, ar
, &offset
, vector_offset
);
17032 if (mark
== AR_SECTION
)
17034 for (i
= 0; i
< ar
->dimen
; i
++)
17035 mpz_clear (section_index
[i
]);
17039 mpz_clear (offset
);
17044 gfc_error ("Non-constant character length at %L in DATA statement",
17050 static bool traverse_data_var (gfc_data_variable
*, locus
*);
17052 /* Iterate over a list of elements in a DATA statement. */
17055 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
17058 iterator_stack frame
;
17059 gfc_expr
*e
, *start
, *end
, *step
;
17060 bool retval
= true;
17062 mpz_init (frame
.value
);
17065 start
= gfc_copy_expr (var
->iter
.start
);
17066 end
= gfc_copy_expr (var
->iter
.end
);
17067 step
= gfc_copy_expr (var
->iter
.step
);
17069 if (!gfc_simplify_expr (start
, 1)
17070 || start
->expr_type
!= EXPR_CONSTANT
)
17072 gfc_error ("start of implied-do loop at %L could not be "
17073 "simplified to a constant value", &start
->where
);
17077 if (!gfc_simplify_expr (end
, 1)
17078 || end
->expr_type
!= EXPR_CONSTANT
)
17080 gfc_error ("end of implied-do loop at %L could not be "
17081 "simplified to a constant value", &end
->where
);
17085 if (!gfc_simplify_expr (step
, 1)
17086 || step
->expr_type
!= EXPR_CONSTANT
)
17088 gfc_error ("step of implied-do loop at %L could not be "
17089 "simplified to a constant value", &step
->where
);
17093 if (mpz_cmp_si (step
->value
.integer
, 0) == 0)
17095 gfc_error ("step of implied-do loop at %L shall not be zero",
17101 mpz_set (trip
, end
->value
.integer
);
17102 mpz_sub (trip
, trip
, start
->value
.integer
);
17103 mpz_add (trip
, trip
, step
->value
.integer
);
17105 mpz_div (trip
, trip
, step
->value
.integer
);
17107 mpz_set (frame
.value
, start
->value
.integer
);
17109 frame
.prev
= iter_stack
;
17110 frame
.variable
= var
->iter
.var
->symtree
;
17111 iter_stack
= &frame
;
17113 while (mpz_cmp_ui (trip
, 0) > 0)
17115 if (!traverse_data_var (var
->list
, where
))
17121 e
= gfc_copy_expr (var
->expr
);
17122 if (!gfc_simplify_expr (e
, 1))
17129 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
17131 mpz_sub_ui (trip
, trip
, 1);
17135 mpz_clear (frame
.value
);
17138 gfc_free_expr (start
);
17139 gfc_free_expr (end
);
17140 gfc_free_expr (step
);
17142 iter_stack
= frame
.prev
;
17147 /* Type resolve variables in the variable list of a DATA statement. */
17150 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
17154 for (; var
; var
= var
->next
)
17156 if (var
->expr
== NULL
)
17157 t
= traverse_data_list (var
, where
);
17159 t
= check_data_variable (var
, where
);
17169 /* Resolve the expressions and iterators associated with a data statement.
17170 This is separate from the assignment checking because data lists should
17171 only be resolved once. */
17174 resolve_data_variables (gfc_data_variable
*d
)
17176 for (; d
; d
= d
->next
)
17178 if (d
->list
== NULL
)
17180 if (!gfc_resolve_expr (d
->expr
))
17185 if (!gfc_resolve_iterator (&d
->iter
, false, true))
17188 if (!resolve_data_variables (d
->list
))
17197 /* Resolve a single DATA statement. We implement this by storing a pointer to
17198 the value list into static variables, and then recursively traversing the
17199 variables list, expanding iterators and such. */
17202 resolve_data (gfc_data
*d
)
17205 if (!resolve_data_variables (d
->var
))
17208 values
.vnode
= d
->value
;
17209 if (d
->value
== NULL
)
17210 mpz_set_ui (values
.left
, 0);
17212 mpz_set (values
.left
, d
->value
->repeat
);
17214 if (!traverse_data_var (d
->var
, &d
->where
))
17217 /* At this point, we better not have any values left. */
17219 if (next_data_value ())
17220 gfc_error ("DATA statement at %L has more values than variables",
17225 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
17226 accessed by host or use association, is a dummy argument to a pure function,
17227 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
17228 is storage associated with any such variable, shall not be used in the
17229 following contexts: (clients of this function). */
17231 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
17232 procedure. Returns zero if assignment is OK, nonzero if there is a
17235 gfc_impure_variable (gfc_symbol
*sym
)
17240 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
17243 /* Check if the symbol's ns is inside the pure procedure. */
17244 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
17248 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
17252 proc
= sym
->ns
->proc_name
;
17253 if (sym
->attr
.dummy
17254 && !sym
->attr
.value
17255 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
17256 || proc
->attr
.function
))
17259 /* TODO: Sort out what can be storage associated, if anything, and include
17260 it here. In principle equivalences should be scanned but it does not
17261 seem to be possible to storage associate an impure variable this way. */
17266 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
17267 current namespace is inside a pure procedure. */
17270 gfc_pure (gfc_symbol
*sym
)
17272 symbol_attribute attr
;
17277 /* Check if the current namespace or one of its parents
17278 belongs to a pure procedure. */
17279 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
17281 sym
= ns
->proc_name
;
17285 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
17293 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
17297 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
17298 checks if the current namespace is implicitly pure. Note that this
17299 function returns false for a PURE procedure. */
17302 gfc_implicit_pure (gfc_symbol
*sym
)
17308 /* Check if the current procedure is implicit_pure. Walk up
17309 the procedure list until we find a procedure. */
17310 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
17312 sym
= ns
->proc_name
;
17316 if (sym
->attr
.flavor
== FL_PROCEDURE
)
17321 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
17322 && !sym
->attr
.pure
;
17327 gfc_unset_implicit_pure (gfc_symbol
*sym
)
17333 /* Check if the current procedure is implicit_pure. Walk up
17334 the procedure list until we find a procedure. */
17335 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
17337 sym
= ns
->proc_name
;
17341 if (sym
->attr
.flavor
== FL_PROCEDURE
)
17346 if (sym
->attr
.flavor
== FL_PROCEDURE
)
17347 sym
->attr
.implicit_pure
= 0;
17349 sym
->attr
.pure
= 0;
17353 /* Test whether the current procedure is elemental or not. */
17356 gfc_elemental (gfc_symbol
*sym
)
17358 symbol_attribute attr
;
17361 sym
= gfc_current_ns
->proc_name
;
17366 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
17370 /* Warn about unused labels. */
17373 warn_unused_fortran_label (gfc_st_label
*label
)
17378 warn_unused_fortran_label (label
->left
);
17380 if (label
->defined
== ST_LABEL_UNKNOWN
)
17383 switch (label
->referenced
)
17385 case ST_LABEL_UNKNOWN
:
17386 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
17387 label
->value
, &label
->where
);
17390 case ST_LABEL_BAD_TARGET
:
17391 gfc_warning (OPT_Wunused_label
,
17392 "Label %d at %L defined but cannot be used",
17393 label
->value
, &label
->where
);
17400 warn_unused_fortran_label (label
->right
);
17404 /* Returns the sequence type of a symbol or sequence. */
17407 sequence_type (gfc_typespec ts
)
17416 if (ts
.u
.derived
->components
== NULL
)
17417 return SEQ_NONDEFAULT
;
17419 result
= sequence_type (ts
.u
.derived
->components
->ts
);
17420 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
17421 if (sequence_type (c
->ts
) != result
)
17427 if (ts
.kind
!= gfc_default_character_kind
)
17428 return SEQ_NONDEFAULT
;
17430 return SEQ_CHARACTER
;
17433 if (ts
.kind
!= gfc_default_integer_kind
)
17434 return SEQ_NONDEFAULT
;
17436 return SEQ_NUMERIC
;
17439 if (!(ts
.kind
== gfc_default_real_kind
17440 || ts
.kind
== gfc_default_double_kind
))
17441 return SEQ_NONDEFAULT
;
17443 return SEQ_NUMERIC
;
17446 if (ts
.kind
!= gfc_default_complex_kind
)
17447 return SEQ_NONDEFAULT
;
17449 return SEQ_NUMERIC
;
17452 if (ts
.kind
!= gfc_default_logical_kind
)
17453 return SEQ_NONDEFAULT
;
17455 return SEQ_NUMERIC
;
17458 return SEQ_NONDEFAULT
;
17463 /* Resolve derived type EQUIVALENCE object. */
17466 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
17468 gfc_component
*c
= derived
->components
;
17473 /* Shall not be an object of nonsequence derived type. */
17474 if (!derived
->attr
.sequence
)
17476 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
17477 "attribute to be an EQUIVALENCE object", sym
->name
,
17482 /* Shall not have allocatable components. */
17483 if (derived
->attr
.alloc_comp
)
17485 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
17486 "components to be an EQUIVALENCE object",sym
->name
,
17491 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
17493 gfc_error ("Derived type variable %qs at %L with default "
17494 "initialization cannot be in EQUIVALENCE with a variable "
17495 "in COMMON", sym
->name
, &e
->where
);
17499 for (; c
; c
= c
->next
)
17501 if (gfc_bt_struct (c
->ts
.type
)
17502 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
17505 /* Shall not be an object of sequence derived type containing a pointer
17506 in the structure. */
17507 if (c
->attr
.pointer
)
17509 gfc_error ("Derived type variable %qs at %L with pointer "
17510 "component(s) cannot be an EQUIVALENCE object",
17511 sym
->name
, &e
->where
);
17519 /* Resolve equivalence object.
17520 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
17521 an allocatable array, an object of nonsequence derived type, an object of
17522 sequence derived type containing a pointer at any level of component
17523 selection, an automatic object, a function name, an entry name, a result
17524 name, a named constant, a structure component, or a subobject of any of
17525 the preceding objects. A substring shall not have length zero. A
17526 derived type shall not have components with default initialization nor
17527 shall two objects of an equivalence group be initialized.
17528 Either all or none of the objects shall have an protected attribute.
17529 The simple constraints are done in symbol.cc(check_conflict) and the rest
17530 are implemented here. */
17533 resolve_equivalence (gfc_equiv
*eq
)
17536 gfc_symbol
*first_sym
;
17539 locus
*last_where
= NULL
;
17540 seq_type eq_type
, last_eq_type
;
17541 gfc_typespec
*last_ts
;
17542 int object
, cnt_protected
;
17545 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
17547 first_sym
= eq
->expr
->symtree
->n
.sym
;
17551 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
17555 e
->ts
= e
->symtree
->n
.sym
->ts
;
17556 /* match_varspec might not know yet if it is seeing
17557 array reference or substring reference, as it doesn't
17559 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
17561 gfc_ref
*ref
= e
->ref
;
17562 sym
= e
->symtree
->n
.sym
;
17564 if (sym
->attr
.dimension
)
17566 ref
->u
.ar
.as
= sym
->as
;
17570 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
17571 if (e
->ts
.type
== BT_CHARACTER
17573 && ref
->type
== REF_ARRAY
17574 && ref
->u
.ar
.dimen
== 1
17575 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
17576 && ref
->u
.ar
.stride
[0] == NULL
)
17578 gfc_expr
*start
= ref
->u
.ar
.start
[0];
17579 gfc_expr
*end
= ref
->u
.ar
.end
[0];
17582 /* Optimize away the (:) reference. */
17583 if (start
== NULL
&& end
== NULL
)
17586 e
->ref
= ref
->next
;
17588 e
->ref
->next
= ref
->next
;
17593 ref
->type
= REF_SUBSTRING
;
17595 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
17597 ref
->u
.ss
.start
= start
;
17598 if (end
== NULL
&& e
->ts
.u
.cl
)
17599 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
17600 ref
->u
.ss
.end
= end
;
17601 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
17608 /* Any further ref is an error. */
17611 gcc_assert (ref
->type
== REF_ARRAY
);
17612 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
17618 if (!gfc_resolve_expr (e
))
17621 sym
= e
->symtree
->n
.sym
;
17623 if (sym
->attr
.is_protected
)
17625 if (cnt_protected
> 0 && cnt_protected
!= object
)
17627 gfc_error ("Either all or none of the objects in the "
17628 "EQUIVALENCE set at %L shall have the "
17629 "PROTECTED attribute",
17634 /* Shall not equivalence common block variables in a PURE procedure. */
17635 if (sym
->ns
->proc_name
17636 && sym
->ns
->proc_name
->attr
.pure
17637 && sym
->attr
.in_common
)
17639 /* Need to check for symbols that may have entered the pure
17640 procedure via a USE statement. */
17641 bool saw_sym
= false;
17642 if (sym
->ns
->use_stmts
)
17645 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
17646 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
17652 gfc_error ("COMMON block member %qs at %L cannot be an "
17653 "EQUIVALENCE object in the pure procedure %qs",
17654 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
17658 /* Shall not be a named constant. */
17659 if (e
->expr_type
== EXPR_CONSTANT
)
17661 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
17662 "object", sym
->name
, &e
->where
);
17666 if (e
->ts
.type
== BT_DERIVED
17667 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
17670 /* Check that the types correspond correctly:
17672 A numeric sequence structure may be equivalenced to another sequence
17673 structure, an object of default integer type, default real type, double
17674 precision real type, default logical type such that components of the
17675 structure ultimately only become associated to objects of the same
17676 kind. A character sequence structure may be equivalenced to an object
17677 of default character kind or another character sequence structure.
17678 Other objects may be equivalenced only to objects of the same type and
17679 kind parameters. */
17681 /* Identical types are unconditionally OK. */
17682 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
17683 goto identical_types
;
17685 last_eq_type
= sequence_type (*last_ts
);
17686 eq_type
= sequence_type (sym
->ts
);
17688 /* Since the pair of objects is not of the same type, mixed or
17689 non-default sequences can be rejected. */
17691 msg
= "Sequence %s with mixed components in EQUIVALENCE "
17692 "statement at %L with different type objects";
17694 && last_eq_type
== SEQ_MIXED
17696 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
17697 || (eq_type
== SEQ_MIXED
17698 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
17701 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
17702 "statement at %L with objects of different type";
17704 && last_eq_type
== SEQ_NONDEFAULT
17706 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
17707 || (eq_type
== SEQ_NONDEFAULT
17708 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
17711 msg
="Non-CHARACTER object %qs in default CHARACTER "
17712 "EQUIVALENCE statement at %L";
17713 if (last_eq_type
== SEQ_CHARACTER
17714 && eq_type
!= SEQ_CHARACTER
17715 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
17718 msg
="Non-NUMERIC object %qs in default NUMERIC "
17719 "EQUIVALENCE statement at %L";
17720 if (last_eq_type
== SEQ_NUMERIC
17721 && eq_type
!= SEQ_NUMERIC
17722 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
17728 last_where
= &e
->where
;
17733 /* Shall not be an automatic array. */
17734 if (e
->ref
->type
== REF_ARRAY
&& is_non_constant_shape_array (sym
))
17736 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
17737 "an EQUIVALENCE object", sym
->name
, &e
->where
);
17744 /* Shall not be a structure component. */
17745 if (r
->type
== REF_COMPONENT
)
17747 gfc_error ("Structure component %qs at %L cannot be an "
17748 "EQUIVALENCE object",
17749 r
->u
.c
.component
->name
, &e
->where
);
17753 /* A substring shall not have length zero. */
17754 if (r
->type
== REF_SUBSTRING
)
17756 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
17758 gfc_error ("Substring at %L has length zero",
17759 &r
->u
.ss
.start
->where
);
17769 /* Function called by resolve_fntype to flag other symbols used in the
17770 length type parameter specification of function results. */
17773 flag_fn_result_spec (gfc_expr
*expr
,
17775 int *f ATTRIBUTE_UNUSED
)
17780 if (expr
->expr_type
== EXPR_VARIABLE
)
17782 s
= expr
->symtree
->n
.sym
;
17783 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
17789 gfc_error ("Self reference in character length expression "
17790 "for %qs at %L", sym
->name
, &expr
->where
);
17794 if (!s
->fn_result_spec
17795 && s
->attr
.flavor
== FL_PARAMETER
)
17797 /* Function contained in a module.... */
17798 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
17801 s
->fn_result_spec
= 1;
17802 /* Make sure that this symbol is translated as a module
17804 st
= gfc_get_unique_symtree (ns
);
17808 /* ... which is use associated and called. */
17809 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
17811 /* External function matched with an interface. */
17814 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
17815 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
17816 && s
->ns
->proc_name
->attr
.function
))
17817 s
->fn_result_spec
= 1;
17824 /* Resolve function and ENTRY types, issue diagnostics if needed. */
17827 resolve_fntype (gfc_namespace
*ns
)
17829 gfc_entry_list
*el
;
17832 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
17835 /* If there are any entries, ns->proc_name is the entry master
17836 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
17838 sym
= ns
->entries
->sym
;
17840 sym
= ns
->proc_name
;
17841 if (sym
->result
== sym
17842 && sym
->ts
.type
== BT_UNKNOWN
17843 && !gfc_set_default_type (sym
, 0, NULL
)
17844 && !sym
->attr
.untyped
)
17846 gfc_error ("Function %qs at %L has no IMPLICIT type",
17847 sym
->name
, &sym
->declared_at
);
17848 sym
->attr
.untyped
= 1;
17851 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
17852 && !sym
->attr
.contained
17853 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
17854 && gfc_check_symbol_access (sym
))
17856 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
17857 "%L of PRIVATE type %qs", sym
->name
,
17858 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
17862 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
17864 if (el
->sym
->result
== el
->sym
17865 && el
->sym
->ts
.type
== BT_UNKNOWN
17866 && !gfc_set_default_type (el
->sym
, 0, NULL
)
17867 && !el
->sym
->attr
.untyped
)
17869 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
17870 el
->sym
->name
, &el
->sym
->declared_at
);
17871 el
->sym
->attr
.untyped
= 1;
17875 if (sym
->ts
.type
== BT_CHARACTER
17876 && sym
->ts
.u
.cl
->length
17877 && sym
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
17878 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
17882 /* 12.3.2.1.1 Defined operators. */
17885 check_uop_procedure (gfc_symbol
*sym
, locus where
)
17887 gfc_formal_arglist
*formal
;
17889 if (!sym
->attr
.function
)
17891 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
17892 sym
->name
, &where
);
17896 if (sym
->ts
.type
== BT_CHARACTER
17897 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
17898 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
17899 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
17901 gfc_error ("User operator procedure %qs at %L cannot be assumed "
17902 "character length", sym
->name
, &where
);
17906 formal
= gfc_sym_get_dummy_args (sym
);
17907 if (!formal
|| !formal
->sym
)
17909 gfc_error ("User operator procedure %qs at %L must have at least "
17910 "one argument", sym
->name
, &where
);
17914 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
17916 gfc_error ("First argument of operator interface at %L must be "
17917 "INTENT(IN)", &where
);
17921 if (formal
->sym
->attr
.optional
)
17923 gfc_error ("First argument of operator interface at %L cannot be "
17924 "optional", &where
);
17928 formal
= formal
->next
;
17929 if (!formal
|| !formal
->sym
)
17932 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
17934 gfc_error ("Second argument of operator interface at %L must be "
17935 "INTENT(IN)", &where
);
17939 if (formal
->sym
->attr
.optional
)
17941 gfc_error ("Second argument of operator interface at %L cannot be "
17942 "optional", &where
);
17948 gfc_error ("Operator interface at %L must have, at most, two "
17949 "arguments", &where
);
17957 gfc_resolve_uops (gfc_symtree
*symtree
)
17959 gfc_interface
*itr
;
17961 if (symtree
== NULL
)
17964 gfc_resolve_uops (symtree
->left
);
17965 gfc_resolve_uops (symtree
->right
);
17967 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
17968 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
17972 /* Examine all of the expressions associated with a program unit,
17973 assign types to all intermediate expressions, make sure that all
17974 assignments are to compatible types and figure out which names
17975 refer to which functions or subroutines. It doesn't check code
17976 block, which is handled by gfc_resolve_code. */
17979 resolve_types (gfc_namespace
*ns
)
17985 gfc_namespace
* old_ns
= gfc_current_ns
;
17986 bool recursive
= ns
->proc_name
&& ns
->proc_name
->attr
.recursive
;
17988 if (ns
->types_resolved
)
17991 /* Check that all IMPLICIT types are ok. */
17992 if (!ns
->seen_implicit_none
)
17995 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
17996 if (ns
->set_flag
[letter
]
17997 && !resolve_typespec_used (&ns
->default_type
[letter
],
17998 &ns
->implicit_loc
[letter
], NULL
))
18002 gfc_current_ns
= ns
;
18004 resolve_entries (ns
);
18006 resolve_common_vars (&ns
->blank_common
, false);
18007 resolve_common_blocks (ns
->common_root
);
18009 resolve_contained_functions (ns
);
18011 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
18012 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
18013 gfc_resolve_formal_arglist (ns
->proc_name
);
18015 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
18017 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
18018 resolve_charlen (cl
);
18020 gfc_traverse_ns (ns
, resolve_symbol
);
18022 resolve_fntype (ns
);
18024 for (n
= ns
->contained
; n
; n
= n
->sibling
)
18026 /* Exclude final wrappers with the test for the artificial attribute. */
18027 if (gfc_pure (ns
->proc_name
)
18028 && !gfc_pure (n
->proc_name
)
18029 && !n
->proc_name
->attr
.artificial
)
18030 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
18031 "also be PURE", n
->proc_name
->name
,
18032 &n
->proc_name
->declared_at
);
18038 gfc_do_concurrent_flag
= 0;
18039 gfc_check_interfaces (ns
);
18041 gfc_traverse_ns (ns
, resolve_values
);
18043 if (ns
->save_all
|| (!flag_automatic
&& !recursive
))
18047 for (d
= ns
->data
; d
; d
= d
->next
)
18051 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
18053 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
18055 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
18056 resolve_equivalence (eq
);
18058 /* Warn about unused labels. */
18059 if (warn_unused_label
)
18060 warn_unused_fortran_label (ns
->st_labels
);
18062 gfc_resolve_uops (ns
->uop_root
);
18064 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
18066 gfc_resolve_omp_declare_simd (ns
);
18068 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
18070 ns
->types_resolved
= 1;
18072 gfc_current_ns
= old_ns
;
18076 /* Call gfc_resolve_code recursively. */
18079 resolve_codes (gfc_namespace
*ns
)
18082 bitmap_obstack old_obstack
;
18084 if (ns
->resolved
== 1)
18087 for (n
= ns
->contained
; n
; n
= n
->sibling
)
18090 gfc_current_ns
= ns
;
18092 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
18093 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
18096 /* Set to an out of range value. */
18097 current_entry_id
= -1;
18099 old_obstack
= labels_obstack
;
18100 bitmap_obstack_initialize (&labels_obstack
);
18102 gfc_resolve_oacc_declare (ns
);
18103 gfc_resolve_oacc_routines (ns
);
18104 gfc_resolve_omp_local_vars (ns
);
18105 if (ns
->omp_allocate
)
18106 gfc_resolve_omp_allocate (ns
, ns
->omp_allocate
);
18107 gfc_resolve_code (ns
->code
, ns
);
18109 bitmap_obstack_release (&labels_obstack
);
18110 labels_obstack
= old_obstack
;
18114 /* This function is called after a complete program unit has been compiled.
18115 Its purpose is to examine all of the expressions associated with a program
18116 unit, assign types to all intermediate expressions, make sure that all
18117 assignments are to compatible types and figure out which names refer to
18118 which functions or subroutines. */
18121 gfc_resolve (gfc_namespace
*ns
)
18123 gfc_namespace
*old_ns
;
18124 code_stack
*old_cs_base
;
18125 struct gfc_omp_saved_state old_omp_state
;
18131 old_ns
= gfc_current_ns
;
18132 old_cs_base
= cs_base
;
18134 /* As gfc_resolve can be called during resolution of an OpenMP construct
18135 body, we should clear any state associated to it, so that say NS's
18136 DO loops are not interpreted as OpenMP loops. */
18137 if (!ns
->construct_entities
)
18138 gfc_omp_save_and_clear_state (&old_omp_state
);
18140 resolve_types (ns
);
18141 component_assignment_level
= 0;
18142 resolve_codes (ns
);
18144 if (ns
->omp_assumes
)
18145 gfc_resolve_omp_assumptions (ns
->omp_assumes
);
18147 gfc_current_ns
= old_ns
;
18148 cs_base
= old_cs_base
;
18151 gfc_run_passes (ns
);
18153 if (!ns
->construct_entities
)
18154 gfc_omp_restore_state (&old_omp_state
);