1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2020 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 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 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 '%s' of statement function '%s' 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 resolve_formal_arglist (sym
);
554 /* Given a namespace, resolve all formal argument lists within the namespace.
558 resolve_formal_arglists (gfc_namespace
*ns
)
563 gfc_traverse_ns (ns
, find_arglists
);
568 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
572 if (sym
&& sym
->attr
.flavor
== FL_PROCEDURE
574 && sym
->ns
->parent
->proc_name
575 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_PROCEDURE
576 && !strcmp (sym
->name
, sym
->ns
->parent
->proc_name
->name
))
577 gfc_error ("Contained procedure %qs at %L has the same name as its "
578 "encompassing procedure", sym
->name
, &sym
->declared_at
);
580 /* If this namespace is not a function or an entry master function,
582 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
583 || sym
->attr
.entry_master
)
589 /* Try to find out of what the return type is. */
590 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
592 t
= gfc_set_default_type (sym
->result
, 0, ns
);
594 if (!t
&& !sym
->result
->attr
.untyped
)
596 if (sym
->result
== sym
)
597 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
598 sym
->name
, &sym
->declared_at
);
599 else if (!sym
->result
->attr
.proc_pointer
)
600 gfc_error ("Result %qs of contained function %qs at %L has "
601 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
602 &sym
->result
->declared_at
);
603 sym
->result
->attr
.untyped
= 1;
607 /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
608 type, lists the only ways a character length value of * can be used:
609 dummy arguments of procedures, named constants, function results and
610 in allocate statements if the allocate_object is an assumed length dummy
611 in external functions. Internal function results and results of module
612 procedures are not on this list, ergo, not permitted. */
614 if (sym
->result
->ts
.type
== BT_CHARACTER
)
616 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
617 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
619 /* See if this is a module-procedure and adapt error message
622 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
623 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
625 gfc_error (module_proc
626 ? G_("Character-valued module procedure %qs at %L"
627 " must not be assumed length")
628 : G_("Character-valued internal function %qs at %L"
629 " must not be assumed length"),
630 sym
->name
, &sym
->declared_at
);
636 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
637 introduce duplicates. */
640 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
642 gfc_formal_arglist
*f
, *new_arglist
;
645 for (; new_args
!= NULL
; new_args
= new_args
->next
)
647 new_sym
= new_args
->sym
;
648 /* See if this arg is already in the formal argument list. */
649 for (f
= proc
->formal
; f
; f
= f
->next
)
651 if (new_sym
== f
->sym
)
658 /* Add a new argument. Argument order is not important. */
659 new_arglist
= gfc_get_formal_arglist ();
660 new_arglist
->sym
= new_sym
;
661 new_arglist
->next
= proc
->formal
;
662 proc
->formal
= new_arglist
;
667 /* Flag the arguments that are not present in all entries. */
670 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
672 gfc_formal_arglist
*f
, *head
;
675 for (f
= proc
->formal
; f
; f
= f
->next
)
680 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
682 if (new_args
->sym
== f
->sym
)
689 f
->sym
->attr
.not_always_present
= 1;
694 /* Resolve alternate entry points. If a symbol has multiple entry points we
695 create a new master symbol for the main routine, and turn the existing
696 symbol into an entry point. */
699 resolve_entries (gfc_namespace
*ns
)
701 gfc_namespace
*old_ns
;
705 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
706 static int master_count
= 0;
708 if (ns
->proc_name
== NULL
)
711 /* No need to do anything if this procedure doesn't have alternate entry
716 /* We may already have resolved alternate entry points. */
717 if (ns
->proc_name
->attr
.entry_master
)
720 /* If this isn't a procedure something has gone horribly wrong. */
721 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
723 /* Remember the current namespace. */
724 old_ns
= gfc_current_ns
;
728 /* Add the main entry point to the list of entry points. */
729 el
= gfc_get_entry_list ();
730 el
->sym
= ns
->proc_name
;
732 el
->next
= ns
->entries
;
734 ns
->proc_name
->attr
.entry
= 1;
736 /* If it is a module function, it needs to be in the right namespace
737 so that gfc_get_fake_result_decl can gather up the results. The
738 need for this arose in get_proc_name, where these beasts were
739 left in their own namespace, to keep prior references linked to
740 the entry declaration.*/
741 if (ns
->proc_name
->attr
.function
742 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
745 /* Do the same for entries where the master is not a module
746 procedure. These are retained in the module namespace because
747 of the module procedure declaration. */
748 for (el
= el
->next
; el
; el
= el
->next
)
749 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
750 && el
->sym
->attr
.mod_proc
)
754 /* Add an entry statement for it. */
755 c
= gfc_get_code (EXEC_ENTRY
);
760 /* Create a new symbol for the master function. */
761 /* Give the internal function a unique name (within this file).
762 Also include the function name so the user has some hope of figuring
763 out what is going on. */
764 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
765 master_count
++, ns
->proc_name
->name
);
766 gfc_get_ha_symbol (name
, &proc
);
767 gcc_assert (proc
!= NULL
);
769 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
770 if (ns
->proc_name
->attr
.subroutine
)
771 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
775 gfc_typespec
*ts
, *fts
;
776 gfc_array_spec
*as
, *fas
;
777 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
779 fas
= ns
->entries
->sym
->as
;
780 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
781 fts
= &ns
->entries
->sym
->result
->ts
;
782 if (fts
->type
== BT_UNKNOWN
)
783 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
784 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
786 ts
= &el
->sym
->result
->ts
;
788 as
= as
? as
: el
->sym
->result
->as
;
789 if (ts
->type
== BT_UNKNOWN
)
790 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
792 if (! gfc_compare_types (ts
, fts
)
793 || (el
->sym
->result
->attr
.dimension
794 != ns
->entries
->sym
->result
->attr
.dimension
)
795 || (el
->sym
->result
->attr
.pointer
796 != ns
->entries
->sym
->result
->attr
.pointer
))
798 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
799 && gfc_compare_array_spec (as
, fas
) == 0)
800 gfc_error ("Function %s at %L has entries with mismatched "
801 "array specifications", ns
->entries
->sym
->name
,
802 &ns
->entries
->sym
->declared_at
);
803 /* The characteristics need to match and thus both need to have
804 the same string length, i.e. both len=*, or both len=4.
805 Having both len=<variable> is also possible, but difficult to
806 check at compile time. */
807 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
808 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
809 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
811 && ts
->u
.cl
->length
->expr_type
812 != fts
->u
.cl
->length
->expr_type
)
814 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
815 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
816 fts
->u
.cl
->length
->value
.integer
) != 0)))
817 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
818 "entries returning variables of different "
819 "string lengths", ns
->entries
->sym
->name
,
820 &ns
->entries
->sym
->declared_at
);
825 sym
= ns
->entries
->sym
->result
;
826 /* All result types the same. */
828 if (sym
->attr
.dimension
)
829 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
830 if (sym
->attr
.pointer
)
831 gfc_add_pointer (&proc
->attr
, NULL
);
835 /* Otherwise the result will be passed through a union by
837 proc
->attr
.mixed_entry_master
= 1;
838 for (el
= ns
->entries
; el
; el
= el
->next
)
840 sym
= el
->sym
->result
;
841 if (sym
->attr
.dimension
)
843 if (el
== ns
->entries
)
844 gfc_error ("FUNCTION result %s cannot be an array in "
845 "FUNCTION %s at %L", sym
->name
,
846 ns
->entries
->sym
->name
, &sym
->declared_at
);
848 gfc_error ("ENTRY result %s cannot be an array in "
849 "FUNCTION %s at %L", sym
->name
,
850 ns
->entries
->sym
->name
, &sym
->declared_at
);
852 else if (sym
->attr
.pointer
)
854 if (el
== ns
->entries
)
855 gfc_error ("FUNCTION result %s cannot be a POINTER in "
856 "FUNCTION %s at %L", sym
->name
,
857 ns
->entries
->sym
->name
, &sym
->declared_at
);
859 gfc_error ("ENTRY result %s cannot be a POINTER in "
860 "FUNCTION %s at %L", sym
->name
,
861 ns
->entries
->sym
->name
, &sym
->declared_at
);
866 if (ts
->type
== BT_UNKNOWN
)
867 ts
= gfc_get_default_type (sym
->name
, NULL
);
871 if (ts
->kind
== gfc_default_integer_kind
)
875 if (ts
->kind
== gfc_default_real_kind
876 || ts
->kind
== gfc_default_double_kind
)
880 if (ts
->kind
== gfc_default_complex_kind
)
884 if (ts
->kind
== gfc_default_logical_kind
)
888 /* We will issue error elsewhere. */
896 if (el
== ns
->entries
)
897 gfc_error ("FUNCTION result %s cannot be of type %s "
898 "in FUNCTION %s at %L", sym
->name
,
899 gfc_typename (ts
), ns
->entries
->sym
->name
,
902 gfc_error ("ENTRY result %s cannot be of type %s "
903 "in FUNCTION %s at %L", sym
->name
,
904 gfc_typename (ts
), ns
->entries
->sym
->name
,
911 proc
->attr
.access
= ACCESS_PRIVATE
;
912 proc
->attr
.entry_master
= 1;
914 /* Merge all the entry point arguments. */
915 for (el
= ns
->entries
; el
; el
= el
->next
)
916 merge_argument_lists (proc
, el
->sym
->formal
);
918 /* Check the master formal arguments for any that are not
919 present in all entry points. */
920 for (el
= ns
->entries
; el
; el
= el
->next
)
921 check_argument_lists (proc
, el
->sym
->formal
);
923 /* Use the master function for the function body. */
924 ns
->proc_name
= proc
;
926 /* Finalize the new symbols. */
927 gfc_commit_symbols ();
929 /* Restore the original namespace. */
930 gfc_current_ns
= old_ns
;
934 /* Resolve common variables. */
936 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
938 gfc_symbol
*csym
= common_block
->head
;
940 for (; csym
; csym
= csym
->common_next
)
942 /* gfc_add_in_common may have been called before, but the reported errors
943 have been ignored to continue parsing.
944 We do the checks again here. */
945 if (!csym
->attr
.use_assoc
)
947 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
948 gfc_notify_std (GFC_STD_F2018_OBS
, "COMMON block at %L",
949 &common_block
->where
);
952 if (csym
->value
|| csym
->attr
.data
)
954 if (!csym
->ns
->is_block_data
)
955 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
956 "but only in BLOCK DATA initialization is "
957 "allowed", csym
->name
, &csym
->declared_at
);
958 else if (!named_common
)
959 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
960 "in a blank COMMON but initialization is only "
961 "allowed in named common blocks", csym
->name
,
965 if (UNLIMITED_POLY (csym
))
966 gfc_error_now ("%qs in cannot appear in COMMON at %L "
967 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
969 if (csym
->ts
.type
!= BT_DERIVED
)
972 if (!(csym
->ts
.u
.derived
->attr
.sequence
973 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
974 gfc_error_now ("Derived type variable %qs in COMMON at %L "
975 "has neither the SEQUENCE nor the BIND(C) "
976 "attribute", csym
->name
, &csym
->declared_at
);
977 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
978 gfc_error_now ("Derived type variable %qs in COMMON at %L "
979 "has an ultimate component that is "
980 "allocatable", csym
->name
, &csym
->declared_at
);
981 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
982 gfc_error_now ("Derived type variable %qs in COMMON at %L "
983 "may not have default initializer", csym
->name
,
986 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
987 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
991 /* Resolve common blocks. */
993 resolve_common_blocks (gfc_symtree
*common_root
)
998 if (common_root
== NULL
)
1001 if (common_root
->left
)
1002 resolve_common_blocks (common_root
->left
);
1003 if (common_root
->right
)
1004 resolve_common_blocks (common_root
->right
);
1006 resolve_common_vars (common_root
->n
.common
, true);
1008 /* The common name is a global name - in Fortran 2003 also if it has a
1009 C binding name, since Fortran 2008 only the C binding name is a global
1011 if (!common_root
->n
.common
->binding_label
1012 || gfc_notification_std (GFC_STD_F2008
))
1014 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1015 common_root
->n
.common
->name
);
1017 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1018 && gsym
->type
== GSYM_COMMON
1019 && ((common_root
->n
.common
->binding_label
1020 && (!gsym
->binding_label
1021 || strcmp (common_root
->n
.common
->binding_label
,
1022 gsym
->binding_label
) != 0))
1023 || (!common_root
->n
.common
->binding_label
1024 && gsym
->binding_label
)))
1026 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1027 "identifier and must thus have the same binding name "
1028 "as the same-named COMMON block at %L: %s vs %s",
1029 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1031 common_root
->n
.common
->binding_label
1032 ? common_root
->n
.common
->binding_label
: "(blank)",
1033 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1037 if (gsym
&& gsym
->type
!= GSYM_COMMON
1038 && !common_root
->n
.common
->binding_label
)
1040 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1042 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1046 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1048 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1049 "%L sharing the identifier with global non-COMMON-block "
1050 "entity at %L", common_root
->n
.common
->name
,
1051 &common_root
->n
.common
->where
, &gsym
->where
);
1056 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
, false);
1057 gsym
->type
= GSYM_COMMON
;
1058 gsym
->where
= common_root
->n
.common
->where
;
1064 if (common_root
->n
.common
->binding_label
)
1066 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1067 common_root
->n
.common
->binding_label
);
1068 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1070 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1071 "global identifier as entity at %L",
1072 &common_root
->n
.common
->where
,
1073 common_root
->n
.common
->binding_label
, &gsym
->where
);
1078 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
, true);
1079 gsym
->type
= GSYM_COMMON
;
1080 gsym
->where
= common_root
->n
.common
->where
;
1086 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1090 if (sym
->attr
.flavor
== FL_PARAMETER
)
1091 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1092 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1094 if (sym
->attr
.external
)
1095 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1096 sym
->name
, &common_root
->n
.common
->where
);
1098 if (sym
->attr
.intrinsic
)
1099 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1100 sym
->name
, &common_root
->n
.common
->where
);
1101 else if (sym
->attr
.result
1102 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1103 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1104 "that is also a function result", sym
->name
,
1105 &common_root
->n
.common
->where
);
1106 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1107 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1108 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1109 "that is also a global procedure", sym
->name
,
1110 &common_root
->n
.common
->where
);
1114 /* Resolve contained function types. Because contained functions can call one
1115 another, they have to be worked out before any of the contained procedures
1118 The good news is that if a function doesn't already have a type, the only
1119 way it can get one is through an IMPLICIT type or a RESULT variable, because
1120 by definition contained functions are contained namespace they're contained
1121 in, not in a sibling or parent namespace. */
1124 resolve_contained_functions (gfc_namespace
*ns
)
1126 gfc_namespace
*child
;
1129 resolve_formal_arglists (ns
);
1131 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1133 /* Resolve alternate entry points first. */
1134 resolve_entries (child
);
1136 /* Then check function return types. */
1137 resolve_contained_fntype (child
->proc_name
, child
);
1138 for (el
= child
->entries
; el
; el
= el
->next
)
1139 resolve_contained_fntype (el
->sym
, child
);
1145 /* A Parameterized Derived Type constructor must contain values for
1146 the PDT KIND parameters or they must have a default initializer.
1147 Go through the constructor picking out the KIND expressions,
1148 storing them in 'param_list' and then call gfc_get_pdt_instance
1149 to obtain the PDT instance. */
1151 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1154 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1156 param
= gfc_get_actual_arglist ();
1158 param_list
= param_tail
= param
;
1161 param_tail
->next
= param
;
1162 param_tail
= param_tail
->next
;
1165 param_tail
->name
= c
->name
;
1167 param_tail
->expr
= gfc_copy_expr (expr
);
1168 else if (c
->initializer
)
1169 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1172 param_tail
->spec_type
= SPEC_ASSUMED
;
1173 if (c
->attr
.pdt_kind
)
1175 gfc_error ("The KIND parameter %qs in the PDT constructor "
1176 "at %C has no value", param
->name
);
1185 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1186 gfc_symbol
*derived
)
1188 gfc_constructor
*cons
= NULL
;
1189 gfc_component
*comp
;
1192 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1193 cons
= gfc_constructor_first (expr
->value
.constructor
);
1198 comp
= derived
->components
;
1200 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1203 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1204 && comp
->ts
.type
== BT_DERIVED
)
1206 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1210 else if (comp
->ts
.type
== BT_DERIVED
)
1212 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1216 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1217 && derived
->attr
.pdt_template
)
1219 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1228 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1229 static bool resolve_fl_struct (gfc_symbol
*sym
);
1232 /* Resolve all of the elements of a structure constructor and make sure that
1233 the types are correct. The 'init' flag indicates that the given
1234 constructor is an initializer. */
1237 resolve_structure_cons (gfc_expr
*expr
, int init
)
1239 gfc_constructor
*cons
;
1240 gfc_component
*comp
;
1246 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1248 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1249 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1251 resolve_fl_struct (expr
->ts
.u
.derived
);
1253 /* If this is a Parameterized Derived Type template, find the
1254 instance corresponding to the PDT kind parameters. */
1255 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1258 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1261 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1263 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1266 gfc_free_actual_arglist (param_list
);
1268 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1273 cons
= gfc_constructor_first (expr
->value
.constructor
);
1275 /* A constructor may have references if it is the result of substituting a
1276 parameter variable. In this case we just pull out the component we
1279 comp
= expr
->ref
->u
.c
.sym
->components
;
1281 comp
= expr
->ts
.u
.derived
->components
;
1283 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1290 /* Unions use an EXPR_NULL contrived expression to tell the translation
1291 phase to generate an initializer of the appropriate length.
1293 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1296 if (!gfc_resolve_expr (cons
->expr
))
1302 rank
= comp
->as
? comp
->as
->rank
: 0;
1303 if (comp
->ts
.type
== BT_CLASS
1304 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1305 && CLASS_DATA (comp
)->as
)
1306 rank
= CLASS_DATA (comp
)->as
->rank
;
1308 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1309 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1311 gfc_error ("The rank of the element in the structure "
1312 "constructor at %L does not match that of the "
1313 "component (%d/%d)", &cons
->expr
->where
,
1314 cons
->expr
->rank
, rank
);
1318 /* If we don't have the right type, try to convert it. */
1320 if (!comp
->attr
.proc_pointer
&&
1321 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1323 if (strcmp (comp
->name
, "_extends") == 0)
1325 /* Can afford to be brutal with the _extends initializer.
1326 The derived type can get lost because it is PRIVATE
1327 but it is not usage constrained by the standard. */
1328 cons
->expr
->ts
= comp
->ts
;
1330 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1332 gfc_error ("The element in the structure constructor at %L, "
1333 "for pointer component %qs, is %s but should be %s",
1334 &cons
->expr
->where
, comp
->name
,
1335 gfc_basic_typename (cons
->expr
->ts
.type
),
1336 gfc_basic_typename (comp
->ts
.type
));
1341 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1347 /* For strings, the length of the constructor should be the same as
1348 the one of the structure, ensure this if the lengths are known at
1349 compile time and when we are dealing with PARAMETER or structure
1351 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1352 && comp
->ts
.u
.cl
->length
1353 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1354 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1355 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1356 && cons
->expr
->rank
!= 0
1357 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1358 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1360 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1361 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1363 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1364 to make use of the gfc_resolve_character_array_constructor
1365 machinery. The expression is later simplified away to
1366 an array of string literals. */
1367 gfc_expr
*para
= cons
->expr
;
1368 cons
->expr
= gfc_get_expr ();
1369 cons
->expr
->ts
= para
->ts
;
1370 cons
->expr
->where
= para
->where
;
1371 cons
->expr
->expr_type
= EXPR_ARRAY
;
1372 cons
->expr
->rank
= para
->rank
;
1373 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1374 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1375 para
, &cons
->expr
->where
);
1378 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1380 /* Rely on the cleanup of the namespace to deal correctly with
1381 the old charlen. (There was a block here that attempted to
1382 remove the charlen but broke the chain in so doing.) */
1383 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1384 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1385 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1386 gfc_resolve_character_array_constructor (cons
->expr
);
1390 if (cons
->expr
->expr_type
== EXPR_NULL
1391 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1392 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1393 || (comp
->ts
.type
== BT_CLASS
1394 && (CLASS_DATA (comp
)->attr
.class_pointer
1395 || CLASS_DATA (comp
)->attr
.allocatable
))))
1398 gfc_error ("The NULL in the structure constructor at %L is "
1399 "being applied to component %qs, which is neither "
1400 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1404 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1406 /* Check procedure pointer interface. */
1407 gfc_symbol
*s2
= NULL
;
1412 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1415 s2
= c2
->ts
.interface
;
1418 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1420 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1421 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1423 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1425 s2
= cons
->expr
->symtree
->n
.sym
;
1426 name
= cons
->expr
->symtree
->n
.sym
->name
;
1429 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1430 err
, sizeof (err
), NULL
, NULL
))
1432 gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1433 "component %qs in structure constructor at %L:"
1434 " %s", comp
->name
, &cons
->expr
->where
, err
);
1439 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1440 || cons
->expr
->expr_type
== EXPR_NULL
)
1443 a
= gfc_expr_attr (cons
->expr
);
1445 if (!a
.pointer
&& !a
.target
)
1448 gfc_error ("The element in the structure constructor at %L, "
1449 "for pointer component %qs should be a POINTER or "
1450 "a TARGET", &cons
->expr
->where
, comp
->name
);
1455 /* F08:C461. Additional checks for pointer initialization. */
1459 gfc_error ("Pointer initialization target at %L "
1460 "must not be ALLOCATABLE", &cons
->expr
->where
);
1465 gfc_error ("Pointer initialization target at %L "
1466 "must have the SAVE attribute", &cons
->expr
->where
);
1470 /* F2003, C1272 (3). */
1471 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1472 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1473 || gfc_is_coindexed (cons
->expr
));
1474 if (impure
&& gfc_pure (NULL
))
1477 gfc_error ("Invalid expression in the structure constructor for "
1478 "pointer component %qs at %L in PURE procedure",
1479 comp
->name
, &cons
->expr
->where
);
1483 gfc_unset_implicit_pure (NULL
);
1490 /****************** Expression name resolution ******************/
1492 /* Returns 0 if a symbol was not declared with a type or
1493 attribute declaration statement, nonzero otherwise. */
1496 was_declared (gfc_symbol
*sym
)
1502 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1505 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1506 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1507 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1508 || a
.asynchronous
|| a
.codimension
)
1515 /* Determine if a symbol is generic or not. */
1518 generic_sym (gfc_symbol
*sym
)
1522 if (sym
->attr
.generic
||
1523 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1526 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1529 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1536 return generic_sym (s
);
1543 /* Determine if a symbol is specific or not. */
1546 specific_sym (gfc_symbol
*sym
)
1550 if (sym
->attr
.if_source
== IFSRC_IFBODY
1551 || sym
->attr
.proc
== PROC_MODULE
1552 || sym
->attr
.proc
== PROC_INTERNAL
1553 || sym
->attr
.proc
== PROC_ST_FUNCTION
1554 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1555 || sym
->attr
.external
)
1558 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1561 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1563 return (s
== NULL
) ? 0 : specific_sym (s
);
1567 /* Figure out if the procedure is specific, generic or unknown. */
1570 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1573 procedure_kind (gfc_symbol
*sym
)
1575 if (generic_sym (sym
))
1576 return PTYPE_GENERIC
;
1578 if (specific_sym (sym
))
1579 return PTYPE_SPECIFIC
;
1581 return PTYPE_UNKNOWN
;
1584 /* Check references to assumed size arrays. The flag need_full_assumed_size
1585 is nonzero when matching actual arguments. */
1587 static int need_full_assumed_size
= 0;
1590 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1592 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1595 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1596 What should it be? */
1597 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1598 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1599 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1601 gfc_error ("The upper bound in the last dimension must "
1602 "appear in the reference to the assumed size "
1603 "array %qs at %L", sym
->name
, &e
->where
);
1610 /* Look for bad assumed size array references in argument expressions
1611 of elemental and array valued intrinsic procedures. Since this is
1612 called from procedure resolution functions, it only recurses at
1616 resolve_assumed_size_actual (gfc_expr
*e
)
1621 switch (e
->expr_type
)
1624 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1629 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1630 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1641 /* Check a generic procedure, passed as an actual argument, to see if
1642 there is a matching specific name. If none, it is an error, and if
1643 more than one, the reference is ambiguous. */
1645 count_specific_procs (gfc_expr
*e
)
1652 sym
= e
->symtree
->n
.sym
;
1654 for (p
= sym
->generic
; p
; p
= p
->next
)
1655 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1657 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1663 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1667 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1668 "argument at %L", sym
->name
, &e
->where
);
1674 /* See if a call to sym could possibly be a not allowed RECURSION because of
1675 a missing RECURSIVE declaration. This means that either sym is the current
1676 context itself, or sym is the parent of a contained procedure calling its
1677 non-RECURSIVE containing procedure.
1678 This also works if sym is an ENTRY. */
1681 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1683 gfc_symbol
* proc_sym
;
1684 gfc_symbol
* context_proc
;
1685 gfc_namespace
* real_context
;
1687 if (sym
->attr
.flavor
== FL_PROGRAM
1688 || gfc_fl_struct (sym
->attr
.flavor
))
1691 /* If we've got an ENTRY, find real procedure. */
1692 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1693 proc_sym
= sym
->ns
->entries
->sym
;
1697 /* If sym is RECURSIVE, all is well of course. */
1698 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1701 /* Find the context procedure's "real" symbol if it has entries.
1702 We look for a procedure symbol, so recurse on the parents if we don't
1703 find one (like in case of a BLOCK construct). */
1704 for (real_context
= context
; ; real_context
= real_context
->parent
)
1706 /* We should find something, eventually! */
1707 gcc_assert (real_context
);
1709 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1710 : real_context
->proc_name
);
1712 /* In some special cases, there may not be a proc_name, like for this
1714 real(bad_kind()) function foo () ...
1715 when checking the call to bad_kind ().
1716 In these cases, we simply return here and assume that the
1721 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1725 /* A call from sym's body to itself is recursion, of course. */
1726 if (context_proc
== proc_sym
)
1729 /* The same is true if context is a contained procedure and sym the
1731 if (context_proc
->attr
.contained
)
1733 gfc_symbol
* parent_proc
;
1735 gcc_assert (context
->parent
);
1736 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1737 : context
->parent
->proc_name
);
1739 if (parent_proc
== proc_sym
)
1747 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1748 its typespec and formal argument list. */
1751 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1753 gfc_intrinsic_sym
* isym
= NULL
;
1759 /* Already resolved. */
1760 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1763 /* We already know this one is an intrinsic, so we don't call
1764 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1765 gfc_find_subroutine directly to check whether it is a function or
1768 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1770 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1771 isym
= gfc_intrinsic_subroutine_by_id (id
);
1773 else if (sym
->intmod_sym_id
)
1775 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1776 isym
= gfc_intrinsic_function_by_id (id
);
1778 else if (!sym
->attr
.subroutine
)
1779 isym
= gfc_find_function (sym
->name
);
1781 if (isym
&& !sym
->attr
.subroutine
)
1783 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1784 && !sym
->attr
.implicit_type
)
1785 gfc_warning (OPT_Wsurprising
,
1786 "Type specified for intrinsic function %qs at %L is"
1787 " ignored", sym
->name
, &sym
->declared_at
);
1789 if (!sym
->attr
.function
&&
1790 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1795 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1797 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1799 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1800 " specifier", sym
->name
, &sym
->declared_at
);
1804 if (!sym
->attr
.subroutine
&&
1805 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1810 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1815 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1817 sym
->attr
.pure
= isym
->pure
;
1818 sym
->attr
.elemental
= isym
->elemental
;
1820 /* Check it is actually available in the standard settings. */
1821 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1823 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1824 "available in the current standard settings but %s. Use "
1825 "an appropriate %<-std=*%> option or enable "
1826 "%<-fall-intrinsics%> in order to use it.",
1827 sym
->name
, &sym
->declared_at
, symstd
);
1835 /* Resolve a procedure expression, like passing it to a called procedure or as
1836 RHS for a procedure pointer assignment. */
1839 resolve_procedure_expression (gfc_expr
* expr
)
1843 if (expr
->expr_type
!= EXPR_VARIABLE
)
1845 gcc_assert (expr
->symtree
);
1847 sym
= expr
->symtree
->n
.sym
;
1849 if (sym
->attr
.intrinsic
)
1850 gfc_resolve_intrinsic (sym
, &expr
->where
);
1852 if (sym
->attr
.flavor
!= FL_PROCEDURE
1853 || (sym
->attr
.function
&& sym
->result
== sym
))
1856 /* A non-RECURSIVE procedure that is used as procedure expression within its
1857 own body is in danger of being called recursively. */
1858 if (is_illegal_recursion (sym
, gfc_current_ns
))
1859 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1860 " itself recursively. Declare it RECURSIVE or use"
1861 " %<-frecursive%>", sym
->name
, &expr
->where
);
1867 /* Check that name is not a derived type. */
1870 is_dt_name (const char *name
)
1872 gfc_symbol
*dt_list
, *dt_first
;
1874 dt_list
= dt_first
= gfc_derived_types
;
1875 for (; dt_list
; dt_list
= dt_list
->dt_next
)
1877 if (strcmp(dt_list
->name
, name
) == 0)
1879 if (dt_first
== dt_list
->dt_next
)
1886 /* Resolve an actual argument list. Most of the time, this is just
1887 resolving the expressions in the list.
1888 The exception is that we sometimes have to decide whether arguments
1889 that look like procedure arguments are really simple variable
1893 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1894 bool no_formal_args
)
1897 gfc_symtree
*parent_st
;
1899 gfc_component
*comp
;
1900 int save_need_full_assumed_size
;
1901 bool return_value
= false;
1902 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1905 first_actual_arg
= true;
1907 for (; arg
; arg
= arg
->next
)
1912 /* Check the label is a valid branching target. */
1915 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1917 gfc_error ("Label %d referenced at %L is never defined",
1918 arg
->label
->value
, &arg
->label
->where
);
1922 first_actual_arg
= false;
1926 if (e
->expr_type
== EXPR_VARIABLE
1927 && e
->symtree
->n
.sym
->attr
.generic
1929 && count_specific_procs (e
) != 1)
1932 if (e
->ts
.type
!= BT_PROCEDURE
)
1934 save_need_full_assumed_size
= need_full_assumed_size
;
1935 if (e
->expr_type
!= EXPR_VARIABLE
)
1936 need_full_assumed_size
= 0;
1937 if (!gfc_resolve_expr (e
))
1939 need_full_assumed_size
= save_need_full_assumed_size
;
1943 /* See if the expression node should really be a variable reference. */
1945 sym
= e
->symtree
->n
.sym
;
1947 if (sym
->attr
.flavor
== FL_PROCEDURE
&& is_dt_name (sym
->name
))
1949 gfc_error ("Derived type %qs is used as an actual "
1950 "argument at %L", sym
->name
, &e
->where
);
1954 if (sym
->attr
.flavor
== FL_PROCEDURE
1955 || sym
->attr
.intrinsic
1956 || sym
->attr
.external
)
1960 /* If a procedure is not already determined to be something else
1961 check if it is intrinsic. */
1962 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1963 sym
->attr
.intrinsic
= 1;
1965 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1967 gfc_error ("Statement function %qs at %L is not allowed as an "
1968 "actual argument", sym
->name
, &e
->where
);
1971 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1972 sym
->attr
.subroutine
);
1973 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1975 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1976 "actual argument", sym
->name
, &e
->where
);
1979 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1980 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1982 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1983 " used as actual argument at %L",
1984 sym
->name
, &e
->where
))
1988 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1990 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1991 "allowed as an actual argument at %L", sym
->name
,
1995 /* Check if a generic interface has a specific procedure
1996 with the same name before emitting an error. */
1997 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
2000 /* Just in case a specific was found for the expression. */
2001 sym
= e
->symtree
->n
.sym
;
2003 /* If the symbol is the function that names the current (or
2004 parent) scope, then we really have a variable reference. */
2006 if (gfc_is_function_return_value (sym
, sym
->ns
))
2009 /* If all else fails, see if we have a specific intrinsic. */
2010 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
2012 gfc_intrinsic_sym
*isym
;
2014 isym
= gfc_find_function (sym
->name
);
2015 if (isym
== NULL
|| !isym
->specific
)
2017 gfc_error ("Unable to find a specific INTRINSIC procedure "
2018 "for the reference %qs at %L", sym
->name
,
2023 sym
->attr
.intrinsic
= 1;
2024 sym
->attr
.function
= 1;
2027 if (!gfc_resolve_expr (e
))
2032 /* See if the name is a module procedure in a parent unit. */
2034 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2037 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2039 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2043 if (parent_st
== NULL
)
2046 sym
= parent_st
->n
.sym
;
2047 e
->symtree
= parent_st
; /* Point to the right thing. */
2049 if (sym
->attr
.flavor
== FL_PROCEDURE
2050 || sym
->attr
.intrinsic
2051 || sym
->attr
.external
)
2053 if (!gfc_resolve_expr (e
))
2059 e
->expr_type
= EXPR_VARIABLE
;
2061 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2062 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2063 && CLASS_DATA (sym
)->as
))
2065 e
->rank
= sym
->ts
.type
== BT_CLASS
2066 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2067 e
->ref
= gfc_get_ref ();
2068 e
->ref
->type
= REF_ARRAY
;
2069 e
->ref
->u
.ar
.type
= AR_FULL
;
2070 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2071 ? CLASS_DATA (sym
)->as
: sym
->as
;
2074 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2075 primary.c (match_actual_arg). If above code determines that it
2076 is a variable instead, it needs to be resolved as it was not
2077 done at the beginning of this function. */
2078 save_need_full_assumed_size
= need_full_assumed_size
;
2079 if (e
->expr_type
!= EXPR_VARIABLE
)
2080 need_full_assumed_size
= 0;
2081 if (!gfc_resolve_expr (e
))
2083 need_full_assumed_size
= save_need_full_assumed_size
;
2086 /* Check argument list functions %VAL, %LOC and %REF. There is
2087 nothing to do for %REF. */
2088 if (arg
->name
&& arg
->name
[0] == '%')
2090 if (strcmp ("%VAL", arg
->name
) == 0)
2092 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2094 gfc_error ("By-value argument at %L is not of numeric "
2101 gfc_error ("By-value argument at %L cannot be an array or "
2102 "an array section", &e
->where
);
2106 /* Intrinsics are still PROC_UNKNOWN here. However,
2107 since same file external procedures are not resolvable
2108 in gfortran, it is a good deal easier to leave them to
2110 if (ptype
!= PROC_UNKNOWN
2111 && ptype
!= PROC_DUMMY
2112 && ptype
!= PROC_EXTERNAL
2113 && ptype
!= PROC_MODULE
)
2115 gfc_error ("By-value argument at %L is not allowed "
2116 "in this context", &e
->where
);
2121 /* Statement functions have already been excluded above. */
2122 else if (strcmp ("%LOC", arg
->name
) == 0
2123 && e
->ts
.type
== BT_PROCEDURE
)
2125 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2127 gfc_error ("Passing internal procedure at %L by location "
2128 "not allowed", &e
->where
);
2134 comp
= gfc_get_proc_ptr_comp(e
);
2135 if (e
->expr_type
== EXPR_VARIABLE
2136 && comp
&& comp
->attr
.elemental
)
2138 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2139 "allowed as an actual argument at %L", comp
->name
,
2143 /* Fortran 2008, C1237. */
2144 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2145 && gfc_has_ultimate_pointer (e
))
2147 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2148 "component", &e
->where
);
2152 first_actual_arg
= false;
2155 return_value
= true;
2158 actual_arg
= actual_arg_sav
;
2159 first_actual_arg
= first_actual_arg_sav
;
2161 return return_value
;
2165 /* Do the checks of the actual argument list that are specific to elemental
2166 procedures. If called with c == NULL, we have a function, otherwise if
2167 expr == NULL, we have a subroutine. */
2170 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2172 gfc_actual_arglist
*arg0
;
2173 gfc_actual_arglist
*arg
;
2174 gfc_symbol
*esym
= NULL
;
2175 gfc_intrinsic_sym
*isym
= NULL
;
2177 gfc_intrinsic_arg
*iformal
= NULL
;
2178 gfc_formal_arglist
*eformal
= NULL
;
2179 bool formal_optional
= false;
2180 bool set_by_optional
= false;
2184 /* Is this an elemental procedure? */
2185 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2187 if (expr
->value
.function
.esym
!= NULL
2188 && expr
->value
.function
.esym
->attr
.elemental
)
2190 arg0
= expr
->value
.function
.actual
;
2191 esym
= expr
->value
.function
.esym
;
2193 else if (expr
->value
.function
.isym
!= NULL
2194 && expr
->value
.function
.isym
->elemental
)
2196 arg0
= expr
->value
.function
.actual
;
2197 isym
= expr
->value
.function
.isym
;
2202 else if (c
&& c
->ext
.actual
!= NULL
)
2204 arg0
= c
->ext
.actual
;
2206 if (c
->resolved_sym
)
2207 esym
= c
->resolved_sym
;
2209 esym
= c
->symtree
->n
.sym
;
2212 if (!esym
->attr
.elemental
)
2218 /* The rank of an elemental is the rank of its array argument(s). */
2219 for (arg
= arg0
; arg
; arg
= arg
->next
)
2221 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2223 rank
= arg
->expr
->rank
;
2224 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2225 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2226 set_by_optional
= true;
2228 /* Function specific; set the result rank and shape. */
2232 if (!expr
->shape
&& arg
->expr
->shape
)
2234 expr
->shape
= gfc_get_shape (rank
);
2235 for (i
= 0; i
< rank
; i
++)
2236 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2243 /* If it is an array, it shall not be supplied as an actual argument
2244 to an elemental procedure unless an array of the same rank is supplied
2245 as an actual argument corresponding to a nonoptional dummy argument of
2246 that elemental procedure(12.4.1.5). */
2247 formal_optional
= false;
2249 iformal
= isym
->formal
;
2251 eformal
= esym
->formal
;
2253 for (arg
= arg0
; arg
; arg
= arg
->next
)
2257 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2258 formal_optional
= true;
2259 eformal
= eformal
->next
;
2261 else if (isym
&& iformal
)
2263 if (iformal
->optional
)
2264 formal_optional
= true;
2265 iformal
= iformal
->next
;
2268 formal_optional
= true;
2270 if (pedantic
&& arg
->expr
!= NULL
2271 && arg
->expr
->expr_type
== EXPR_VARIABLE
2272 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2275 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2276 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2278 gfc_warning (OPT_Wpedantic
,
2279 "%qs at %L is an array and OPTIONAL; IF IT IS "
2280 "MISSING, it cannot be the actual argument of an "
2281 "ELEMENTAL procedure unless there is a non-optional "
2282 "argument with the same rank (12.4.1.5)",
2283 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2287 for (arg
= arg0
; arg
; arg
= arg
->next
)
2289 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2292 /* Being elemental, the last upper bound of an assumed size array
2293 argument must be present. */
2294 if (resolve_assumed_size_actual (arg
->expr
))
2297 /* Elemental procedure's array actual arguments must conform. */
2300 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2307 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2308 is an array, the intent inout/out variable needs to be also an array. */
2309 if (rank
> 0 && esym
&& expr
== NULL
)
2310 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2311 arg
= arg
->next
, eformal
= eformal
->next
)
2312 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2313 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2314 && arg
->expr
&& arg
->expr
->rank
== 0)
2316 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2317 "ELEMENTAL subroutine %qs is a scalar, but another "
2318 "actual argument is an array", &arg
->expr
->where
,
2319 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2320 : "INOUT", eformal
->sym
->name
, esym
->name
);
2327 /* This function does the checking of references to global procedures
2328 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2329 77 and 95 standards. It checks for a gsymbol for the name, making
2330 one if it does not already exist. If it already exists, then the
2331 reference being resolved must correspond to the type of gsymbol.
2332 Otherwise, the new symbol is equipped with the attributes of the
2333 reference. The corresponding code that is called in creating
2334 global entities is parse.c.
2336 In addition, for all but -std=legacy, the gsymbols are used to
2337 check the interfaces of external procedures from the same file.
2338 The namespace of the gsymbol is resolved and then, once this is
2339 done the interface is checked. */
2343 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2345 if (!gsym_ns
->proc_name
->attr
.recursive
)
2348 if (sym
->ns
== gsym_ns
)
2351 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2358 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2360 if (gsym_ns
->entries
)
2362 gfc_entry_list
*entry
= gsym_ns
->entries
;
2364 for (; entry
; entry
= entry
->next
)
2366 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2368 if (strcmp (gsym_ns
->proc_name
->name
,
2369 sym
->ns
->proc_name
->name
) == 0)
2373 && strcmp (gsym_ns
->proc_name
->name
,
2374 sym
->ns
->parent
->proc_name
->name
) == 0)
2383 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2386 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2388 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2390 for ( ; arg
; arg
= arg
->next
)
2395 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2397 strncpy (errmsg
, _("allocatable argument"), err_len
);
2400 else if (arg
->sym
->attr
.asynchronous
)
2402 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2405 else if (arg
->sym
->attr
.optional
)
2407 strncpy (errmsg
, _("optional argument"), err_len
);
2410 else if (arg
->sym
->attr
.pointer
)
2412 strncpy (errmsg
, _("pointer argument"), err_len
);
2415 else if (arg
->sym
->attr
.target
)
2417 strncpy (errmsg
, _("target argument"), err_len
);
2420 else if (arg
->sym
->attr
.value
)
2422 strncpy (errmsg
, _("value argument"), err_len
);
2425 else if (arg
->sym
->attr
.volatile_
)
2427 strncpy (errmsg
, _("volatile argument"), err_len
);
2430 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2432 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2435 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2437 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2440 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2442 strncpy (errmsg
, _("coarray argument"), err_len
);
2445 else if (false) /* (2d) TODO: parametrized derived type */
2447 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2450 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2452 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2455 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2457 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2460 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2462 /* As assumed-type is unlimited polymorphic (cf. above).
2463 See also TS 29113, Note 6.1. */
2464 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2469 if (sym
->attr
.function
)
2471 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2473 if (res
->attr
.dimension
) /* (3a) */
2475 strncpy (errmsg
, _("array result"), err_len
);
2478 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2480 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2483 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2484 && res
->ts
.u
.cl
->length
2485 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2487 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2492 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2494 strncpy (errmsg
, _("elemental procedure"), err_len
);
2497 else if (sym
->attr
.is_bind_c
) /* (5) */
2499 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2508 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
2512 enum gfc_symbol_type type
;
2515 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2517 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2518 sym
->binding_label
!= NULL
);
2520 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2521 gfc_global_used (gsym
, where
);
2523 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2524 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2525 && gsym
->type
!= GSYM_UNKNOWN
2526 && !gsym
->binding_label
2528 && gsym
->ns
->proc_name
2529 && not_in_recursive (sym
, gsym
->ns
)
2530 && not_entry_self_reference (sym
, gsym
->ns
))
2532 gfc_symbol
*def_sym
;
2533 def_sym
= gsym
->ns
->proc_name
;
2535 if (gsym
->ns
->resolved
!= -1)
2538 /* Resolve the gsymbol namespace if needed. */
2539 if (!gsym
->ns
->resolved
)
2541 gfc_symbol
*old_dt_list
;
2543 /* Stash away derived types so that the backend_decls
2544 do not get mixed up. */
2545 old_dt_list
= gfc_derived_types
;
2546 gfc_derived_types
= NULL
;
2548 gfc_resolve (gsym
->ns
);
2550 /* Store the new derived types with the global namespace. */
2551 if (gfc_derived_types
)
2552 gsym
->ns
->derived_types
= gfc_derived_types
;
2554 /* Restore the derived types of this namespace. */
2555 gfc_derived_types
= old_dt_list
;
2558 /* Make sure that translation for the gsymbol occurs before
2559 the procedure currently being resolved. */
2560 ns
= gfc_global_ns_list
;
2561 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2563 if (ns
->sibling
== gsym
->ns
)
2565 ns
->sibling
= gsym
->ns
->sibling
;
2566 gsym
->ns
->sibling
= gfc_global_ns_list
;
2567 gfc_global_ns_list
= gsym
->ns
;
2572 /* This can happen if a binding name has been specified. */
2573 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2574 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2576 if (def_sym
->attr
.entry_master
|| def_sym
->attr
.entry
)
2578 gfc_entry_list
*entry
;
2579 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2580 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2582 def_sym
= entry
->sym
;
2588 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2590 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2591 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2592 gfc_typename (&def_sym
->ts
));
2596 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2597 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2599 gfc_error ("Explicit interface required for %qs at %L: %s",
2600 sym
->name
, &sym
->declared_at
, reason
);
2604 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2605 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2606 gfc_errors_to_warnings (true);
2608 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2609 reason
, sizeof(reason
), NULL
, NULL
))
2611 gfc_error_opt (0, "Interface mismatch in global procedure %qs at %L:"
2612 " %s", sym
->name
, &sym
->declared_at
, reason
);
2618 gfc_errors_to_warnings (false);
2620 if (gsym
->type
== GSYM_UNKNOWN
)
2623 gsym
->where
= *where
;
2630 /************* Function resolution *************/
2632 /* Resolve a function call known to be generic.
2633 Section 14.1.2.4.1. */
2636 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2640 if (sym
->attr
.generic
)
2642 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2645 expr
->value
.function
.name
= s
->name
;
2646 expr
->value
.function
.esym
= s
;
2648 if (s
->ts
.type
!= BT_UNKNOWN
)
2650 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2651 expr
->ts
= s
->result
->ts
;
2654 expr
->rank
= s
->as
->rank
;
2655 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2656 expr
->rank
= s
->result
->as
->rank
;
2658 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2663 /* TODO: Need to search for elemental references in generic
2667 if (sym
->attr
.intrinsic
)
2668 return gfc_intrinsic_func_interface (expr
, 0);
2675 resolve_generic_f (gfc_expr
*expr
)
2679 gfc_interface
*intr
= NULL
;
2681 sym
= expr
->symtree
->n
.sym
;
2685 m
= resolve_generic_f0 (expr
, sym
);
2688 else if (m
== MATCH_ERROR
)
2693 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2694 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2697 if (sym
->ns
->parent
== NULL
)
2699 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2703 if (!generic_sym (sym
))
2707 /* Last ditch attempt. See if the reference is to an intrinsic
2708 that possesses a matching interface. 14.1.2.4 */
2709 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2711 if (gfc_init_expr_flag
)
2712 gfc_error ("Function %qs in initialization expression at %L "
2713 "must be an intrinsic function",
2714 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2716 gfc_error ("There is no specific function for the generic %qs "
2717 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2723 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2726 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2728 return resolve_structure_cons (expr
, 0);
2731 m
= gfc_intrinsic_func_interface (expr
, 0);
2736 gfc_error ("Generic function %qs at %L is not consistent with a "
2737 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2744 /* Resolve a function call known to be specific. */
2747 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2751 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2753 if (sym
->attr
.dummy
)
2755 sym
->attr
.proc
= PROC_DUMMY
;
2759 sym
->attr
.proc
= PROC_EXTERNAL
;
2763 if (sym
->attr
.proc
== PROC_MODULE
2764 || sym
->attr
.proc
== PROC_ST_FUNCTION
2765 || sym
->attr
.proc
== PROC_INTERNAL
)
2768 if (sym
->attr
.intrinsic
)
2770 m
= gfc_intrinsic_func_interface (expr
, 1);
2774 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2775 "with an intrinsic", sym
->name
, &expr
->where
);
2783 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2786 expr
->ts
= sym
->result
->ts
;
2789 expr
->value
.function
.name
= sym
->name
;
2790 expr
->value
.function
.esym
= sym
;
2791 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2793 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2795 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2796 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2797 else if (sym
->as
!= NULL
)
2798 expr
->rank
= sym
->as
->rank
;
2805 resolve_specific_f (gfc_expr
*expr
)
2810 sym
= expr
->symtree
->n
.sym
;
2814 m
= resolve_specific_f0 (sym
, expr
);
2817 if (m
== MATCH_ERROR
)
2820 if (sym
->ns
->parent
== NULL
)
2823 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2829 gfc_error ("Unable to resolve the specific function %qs at %L",
2830 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2835 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2836 candidates in CANDIDATES_LEN. */
2839 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2841 size_t &candidates_len
)
2847 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2848 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2849 vec_push (candidates
, candidates_len
, sym
->name
);
2853 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2857 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2861 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2864 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2866 char **candidates
= NULL
;
2867 size_t candidates_len
= 0;
2868 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2869 return gfc_closest_fuzzy_match (fn
, candidates
);
2873 /* Resolve a procedure call not known to be generic nor specific. */
2876 resolve_unknown_f (gfc_expr
*expr
)
2881 sym
= expr
->symtree
->n
.sym
;
2883 if (sym
->attr
.dummy
)
2885 sym
->attr
.proc
= PROC_DUMMY
;
2886 expr
->value
.function
.name
= sym
->name
;
2890 /* See if we have an intrinsic function reference. */
2892 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2894 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2899 /* The reference is to an external name. */
2901 sym
->attr
.proc
= PROC_EXTERNAL
;
2902 expr
->value
.function
.name
= sym
->name
;
2903 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2905 if (sym
->as
!= NULL
)
2906 expr
->rank
= sym
->as
->rank
;
2908 /* Type of the expression is either the type of the symbol or the
2909 default type of the symbol. */
2912 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2914 if (sym
->ts
.type
!= BT_UNKNOWN
)
2918 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2920 if (ts
->type
== BT_UNKNOWN
)
2923 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2925 gfc_error ("Function %qs at %L has no IMPLICIT type"
2926 "; did you mean %qs?",
2927 sym
->name
, &expr
->where
, guessed
);
2929 gfc_error ("Function %qs at %L has no IMPLICIT type",
2930 sym
->name
, &expr
->where
);
2941 /* Return true, if the symbol is an external procedure. */
2943 is_external_proc (gfc_symbol
*sym
)
2945 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2946 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2947 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2948 && !sym
->attr
.proc_pointer
2949 && !sym
->attr
.use_assoc
2957 /* Figure out if a function reference is pure or not. Also set the name
2958 of the function for a potential error message. Return nonzero if the
2959 function is PURE, zero if not. */
2961 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2964 gfc_pure_function (gfc_expr
*e
, const char **name
)
2967 gfc_component
*comp
;
2971 if (e
->symtree
!= NULL
2972 && e
->symtree
->n
.sym
!= NULL
2973 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2974 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2976 comp
= gfc_get_proc_ptr_comp (e
);
2979 pure
= gfc_pure (comp
->ts
.interface
);
2982 else if (e
->value
.function
.esym
)
2984 pure
= gfc_pure (e
->value
.function
.esym
);
2985 *name
= e
->value
.function
.esym
->name
;
2987 else if (e
->value
.function
.isym
)
2989 pure
= e
->value
.function
.isym
->pure
2990 || e
->value
.function
.isym
->elemental
;
2991 *name
= e
->value
.function
.isym
->name
;
2995 /* Implicit functions are not pure. */
2997 *name
= e
->value
.function
.name
;
3004 /* Check if the expression is a reference to an implicitly pure function. */
3007 gfc_implicit_pure_function (gfc_expr
*e
)
3009 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
3011 return gfc_implicit_pure (comp
->ts
.interface
);
3012 else if (e
->value
.function
.esym
)
3013 return gfc_implicit_pure (e
->value
.function
.esym
);
3020 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3021 int *f ATTRIBUTE_UNUSED
)
3025 /* Don't bother recursing into other statement functions
3026 since they will be checked individually for purity. */
3027 if (e
->expr_type
!= EXPR_FUNCTION
3029 || e
->symtree
->n
.sym
== sym
3030 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3033 return gfc_pure_function (e
, &name
) ? false : true;
3038 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3040 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3044 /* Check if an impure function is allowed in the current context. */
3046 static bool check_pure_function (gfc_expr
*e
)
3048 const char *name
= NULL
;
3049 if (!gfc_pure_function (e
, &name
) && name
)
3053 gfc_error ("Reference to impure function %qs at %L inside a "
3054 "FORALL %s", name
, &e
->where
,
3055 forall_flag
== 2 ? "mask" : "block");
3058 else if (gfc_do_concurrent_flag
)
3060 gfc_error ("Reference to impure function %qs at %L inside a "
3061 "DO CONCURRENT %s", name
, &e
->where
,
3062 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3065 else if (gfc_pure (NULL
))
3067 gfc_error ("Reference to impure function %qs at %L "
3068 "within a PURE procedure", name
, &e
->where
);
3071 if (!gfc_implicit_pure_function (e
))
3072 gfc_unset_implicit_pure (NULL
);
3078 /* Update current procedure's array_outer_dependency flag, considering
3079 a call to procedure SYM. */
3082 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3084 /* Check to see if this is a sibling function that has not yet
3086 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3087 for (; sibling
; sibling
= sibling
->sibling
)
3089 if (sibling
->proc_name
== sym
)
3091 gfc_resolve (sibling
);
3096 /* If SYM has references to outer arrays, so has the procedure calling
3097 SYM. If SYM is a procedure pointer, we can assume the worst. */
3098 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3099 && gfc_current_ns
->proc_name
)
3100 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3104 /* Resolve a function call, which means resolving the arguments, then figuring
3105 out which entity the name refers to. */
3108 resolve_function (gfc_expr
*expr
)
3110 gfc_actual_arglist
*arg
;
3114 procedure_type p
= PROC_INTRINSIC
;
3115 bool no_formal_args
;
3119 sym
= expr
->symtree
->n
.sym
;
3121 /* If this is a procedure pointer component, it has already been resolved. */
3122 if (gfc_is_proc_ptr_comp (expr
))
3125 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3127 if (sym
&& sym
->attr
.intrinsic
3128 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3129 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3134 gfc_error ("Unexpected junk after %qs at %L", expr
->symtree
->n
.sym
->name
,
3139 if (sym
&& sym
->attr
.intrinsic
3140 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3143 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3145 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3149 /* If this is a deferred TBP with an abstract interface (which may
3150 of course be referenced), expr->value.function.esym will be set. */
3151 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3153 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3154 sym
->name
, &expr
->where
);
3158 /* If this is a deferred TBP with an abstract interface, its result
3159 cannot be an assumed length character (F2003: C418). */
3160 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3161 && sym
->result
->ts
.u
.cl
3162 && sym
->result
->ts
.u
.cl
->length
== NULL
3163 && !sym
->result
->ts
.deferred
)
3165 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3166 "character length result (F2008: C418)", sym
->name
,
3171 /* Switch off assumed size checking and do this again for certain kinds
3172 of procedure, once the procedure itself is resolved. */
3173 need_full_assumed_size
++;
3175 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3176 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3178 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3179 inquiry_argument
= true;
3180 no_formal_args
= sym
&& is_external_proc (sym
)
3181 && gfc_sym_get_dummy_args (sym
) == NULL
;
3183 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3186 inquiry_argument
= false;
3190 inquiry_argument
= false;
3192 /* Resume assumed_size checking. */
3193 need_full_assumed_size
--;
3195 /* If the procedure is external, check for usage. */
3196 if (sym
&& is_external_proc (sym
))
3197 resolve_global_procedure (sym
, &expr
->where
, 0);
3199 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3201 && sym
->ts
.u
.cl
->length
== NULL
3203 && !sym
->ts
.deferred
3204 && expr
->value
.function
.esym
== NULL
3205 && !sym
->attr
.contained
)
3207 /* Internal procedures are taken care of in resolve_contained_fntype. */
3208 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3209 "be used at %L since it is not a dummy argument",
3210 sym
->name
, &expr
->where
);
3214 /* See if function is already resolved. */
3216 if (expr
->value
.function
.name
!= NULL
3217 || expr
->value
.function
.isym
!= NULL
)
3219 if (expr
->ts
.type
== BT_UNKNOWN
)
3225 /* Apply the rules of section 14.1.2. */
3227 switch (procedure_kind (sym
))
3230 t
= resolve_generic_f (expr
);
3233 case PTYPE_SPECIFIC
:
3234 t
= resolve_specific_f (expr
);
3238 t
= resolve_unknown_f (expr
);
3242 gfc_internal_error ("resolve_function(): bad function type");
3246 /* If the expression is still a function (it might have simplified),
3247 then we check to see if we are calling an elemental function. */
3249 if (expr
->expr_type
!= EXPR_FUNCTION
)
3252 /* Walk the argument list looking for invalid BOZ. */
3253 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3254 if (arg
->expr
&& arg
->expr
->ts
.type
== BT_BOZ
)
3256 gfc_error ("A BOZ literal constant at %L cannot appear as an "
3257 "actual argument in a function reference",
3262 temp
= need_full_assumed_size
;
3263 need_full_assumed_size
= 0;
3265 if (!resolve_elemental_actual (expr
, NULL
))
3268 if (omp_workshare_flag
3269 && expr
->value
.function
.esym
3270 && ! gfc_elemental (expr
->value
.function
.esym
))
3272 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3273 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3278 #define GENERIC_ID expr->value.function.isym->id
3279 else if (expr
->value
.function
.actual
!= NULL
3280 && expr
->value
.function
.isym
!= NULL
3281 && GENERIC_ID
!= GFC_ISYM_LBOUND
3282 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3283 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3284 && GENERIC_ID
!= GFC_ISYM_LEN
3285 && GENERIC_ID
!= GFC_ISYM_LOC
3286 && GENERIC_ID
!= GFC_ISYM_C_LOC
3287 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3289 /* Array intrinsics must also have the last upper bound of an
3290 assumed size array argument. UBOUND and SIZE have to be
3291 excluded from the check if the second argument is anything
3294 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3296 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3297 && arg
== expr
->value
.function
.actual
3298 && arg
->next
!= NULL
&& arg
->next
->expr
)
3300 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3303 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3306 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3311 if (arg
->expr
!= NULL
3312 && arg
->expr
->rank
> 0
3313 && resolve_assumed_size_actual (arg
->expr
))
3319 need_full_assumed_size
= temp
;
3321 if (!check_pure_function(expr
))
3324 /* Functions without the RECURSIVE attribution are not allowed to
3325 * call themselves. */
3326 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3329 esym
= expr
->value
.function
.esym
;
3331 if (is_illegal_recursion (esym
, gfc_current_ns
))
3333 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3334 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3335 " function %qs is not RECURSIVE",
3336 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3338 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3339 " is not RECURSIVE", esym
->name
, &expr
->where
);
3345 /* Character lengths of use associated functions may contains references to
3346 symbols not referenced from the current program unit otherwise. Make sure
3347 those symbols are marked as referenced. */
3349 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3350 && expr
->value
.function
.esym
->attr
.use_assoc
)
3352 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3355 /* Make sure that the expression has a typespec that works. */
3356 if (expr
->ts
.type
== BT_UNKNOWN
)
3358 if (expr
->symtree
->n
.sym
->result
3359 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3360 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3361 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3364 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3366 if (expr
->value
.function
.esym
)
3367 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3369 update_current_proc_array_outer_dependency (sym
);
3372 /* typebound procedure: Assume the worst. */
3373 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3379 /************* Subroutine resolution *************/
3382 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3389 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3393 else if (gfc_do_concurrent_flag
)
3395 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3399 else if (gfc_pure (NULL
))
3401 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3405 gfc_unset_implicit_pure (NULL
);
3411 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3415 if (sym
->attr
.generic
)
3417 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3420 c
->resolved_sym
= s
;
3421 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3426 /* TODO: Need to search for elemental references in generic interface. */
3429 if (sym
->attr
.intrinsic
)
3430 return gfc_intrinsic_sub_interface (c
, 0);
3437 resolve_generic_s (gfc_code
*c
)
3442 sym
= c
->symtree
->n
.sym
;
3446 m
= resolve_generic_s0 (c
, sym
);
3449 else if (m
== MATCH_ERROR
)
3453 if (sym
->ns
->parent
== NULL
)
3455 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3459 if (!generic_sym (sym
))
3463 /* Last ditch attempt. See if the reference is to an intrinsic
3464 that possesses a matching interface. 14.1.2.4 */
3465 sym
= c
->symtree
->n
.sym
;
3467 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3469 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3470 sym
->name
, &c
->loc
);
3474 m
= gfc_intrinsic_sub_interface (c
, 0);
3478 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3479 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3485 /* Resolve a subroutine call known to be specific. */
3488 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3492 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3494 if (sym
->attr
.dummy
)
3496 sym
->attr
.proc
= PROC_DUMMY
;
3500 sym
->attr
.proc
= PROC_EXTERNAL
;
3504 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3507 if (sym
->attr
.intrinsic
)
3509 m
= gfc_intrinsic_sub_interface (c
, 1);
3513 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3514 "with an intrinsic", sym
->name
, &c
->loc
);
3522 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3524 c
->resolved_sym
= sym
;
3525 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3533 resolve_specific_s (gfc_code
*c
)
3538 sym
= c
->symtree
->n
.sym
;
3542 m
= resolve_specific_s0 (c
, sym
);
3545 if (m
== MATCH_ERROR
)
3548 if (sym
->ns
->parent
== NULL
)
3551 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3557 sym
= c
->symtree
->n
.sym
;
3558 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3559 sym
->name
, &c
->loc
);
3565 /* Resolve a subroutine call not known to be generic nor specific. */
3568 resolve_unknown_s (gfc_code
*c
)
3572 sym
= c
->symtree
->n
.sym
;
3574 if (sym
->attr
.dummy
)
3576 sym
->attr
.proc
= PROC_DUMMY
;
3580 /* See if we have an intrinsic function reference. */
3582 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3584 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3589 /* The reference is to an external name. */
3592 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3594 c
->resolved_sym
= sym
;
3596 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3600 /* Resolve a subroutine call. Although it was tempting to use the same code
3601 for functions, subroutines and functions are stored differently and this
3602 makes things awkward. */
3605 resolve_call (gfc_code
*c
)
3608 procedure_type ptype
= PROC_INTRINSIC
;
3609 gfc_symbol
*csym
, *sym
;
3610 bool no_formal_args
;
3612 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3614 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3616 gfc_error ("%qs at %L has a type, which is not consistent with "
3617 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3621 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3624 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3625 sym
= st
? st
->n
.sym
: NULL
;
3626 if (sym
&& csym
!= sym
3627 && sym
->ns
== gfc_current_ns
3628 && sym
->attr
.flavor
== FL_PROCEDURE
3629 && sym
->attr
.contained
)
3632 if (csym
->attr
.generic
)
3633 c
->symtree
->n
.sym
= sym
;
3636 csym
= c
->symtree
->n
.sym
;
3640 /* If this ia a deferred TBP, c->expr1 will be set. */
3641 if (!c
->expr1
&& csym
)
3643 if (csym
->attr
.abstract
)
3645 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3646 csym
->name
, &c
->loc
);
3650 /* Subroutines without the RECURSIVE attribution are not allowed to
3652 if (is_illegal_recursion (csym
, gfc_current_ns
))
3654 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3655 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3656 "as subroutine %qs is not RECURSIVE",
3657 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3659 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3660 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3666 /* Switch off assumed size checking and do this again for certain kinds
3667 of procedure, once the procedure itself is resolved. */
3668 need_full_assumed_size
++;
3671 ptype
= csym
->attr
.proc
;
3673 no_formal_args
= csym
&& is_external_proc (csym
)
3674 && gfc_sym_get_dummy_args (csym
) == NULL
;
3675 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3678 /* Resume assumed_size checking. */
3679 need_full_assumed_size
--;
3681 /* If external, check for usage. */
3682 if (csym
&& is_external_proc (csym
))
3683 resolve_global_procedure (csym
, &c
->loc
, 1);
3686 if (c
->resolved_sym
== NULL
)
3688 c
->resolved_isym
= NULL
;
3689 switch (procedure_kind (csym
))
3692 t
= resolve_generic_s (c
);
3695 case PTYPE_SPECIFIC
:
3696 t
= resolve_specific_s (c
);
3700 t
= resolve_unknown_s (c
);
3704 gfc_internal_error ("resolve_subroutine(): bad function type");
3708 /* Some checks of elemental subroutine actual arguments. */
3709 if (!resolve_elemental_actual (NULL
, c
))
3713 update_current_proc_array_outer_dependency (csym
);
3715 /* Typebound procedure: Assume the worst. */
3716 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3722 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3723 op1->shape and op2->shape are non-NULL return true if their shapes
3724 match. If both op1->shape and op2->shape are non-NULL return false
3725 if their shapes do not match. If either op1->shape or op2->shape is
3726 NULL, return true. */
3729 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3736 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3738 for (i
= 0; i
< op1
->rank
; i
++)
3740 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3742 gfc_error ("Shapes for operands at %L and %L are not conformable",
3743 &op1
->where
, &op2
->where
);
3753 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3754 For example A .AND. B becomes IAND(A, B). */
3756 logical_to_bitwise (gfc_expr
*e
)
3758 gfc_expr
*tmp
, *op1
, *op2
;
3760 gfc_actual_arglist
*args
= NULL
;
3762 gcc_assert (e
->expr_type
== EXPR_OP
);
3764 isym
= GFC_ISYM_NONE
;
3765 op1
= e
->value
.op
.op1
;
3766 op2
= e
->value
.op
.op2
;
3768 switch (e
->value
.op
.op
)
3771 isym
= GFC_ISYM_NOT
;
3774 isym
= GFC_ISYM_IAND
;
3777 isym
= GFC_ISYM_IOR
;
3779 case INTRINSIC_NEQV
:
3780 isym
= GFC_ISYM_IEOR
;
3783 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3784 Change the old expression to NEQV, which will get replaced by IEOR,
3785 and wrap it in NOT. */
3786 tmp
= gfc_copy_expr (e
);
3787 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3788 tmp
= logical_to_bitwise (tmp
);
3789 isym
= GFC_ISYM_NOT
;
3794 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3797 /* Inherit the original operation's operands as arguments. */
3798 args
= gfc_get_actual_arglist ();
3802 args
->next
= gfc_get_actual_arglist ();
3803 args
->next
->expr
= op2
;
3806 /* Convert the expression to a function call. */
3807 e
->expr_type
= EXPR_FUNCTION
;
3808 e
->value
.function
.actual
= args
;
3809 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3810 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3811 e
->value
.function
.esym
= NULL
;
3813 /* Make up a pre-resolved function call symtree if we need to. */
3814 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3817 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3818 sym
= e
->symtree
->n
.sym
;
3820 sym
->attr
.flavor
= FL_PROCEDURE
;
3821 sym
->attr
.function
= 1;
3822 sym
->attr
.elemental
= 1;
3824 sym
->attr
.referenced
= 1;
3825 gfc_intrinsic_symbol (sym
);
3826 gfc_commit_symbol (sym
);
3829 args
->name
= e
->value
.function
.isym
->formal
->name
;
3830 if (e
->value
.function
.isym
->formal
->next
)
3831 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3836 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3837 candidates in CANDIDATES_LEN. */
3839 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3841 size_t &candidates_len
)
3848 /* Not sure how to properly filter here. Use all for a start.
3849 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3850 these as i suppose they don't make terribly sense. */
3852 if (uop
->n
.uop
->op
!= NULL
)
3853 vec_push (candidates
, candidates_len
, uop
->name
);
3857 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3861 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3864 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3867 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3869 char **candidates
= NULL
;
3870 size_t candidates_len
= 0;
3871 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3872 return gfc_closest_fuzzy_match (op
, candidates
);
3876 /* Callback finding an impure function as an operand to an .and. or
3877 .or. expression. Remember the last function warned about to
3878 avoid double warnings when recursing. */
3881 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3886 static gfc_expr
*last
= NULL
;
3887 bool *found
= (bool *) data
;
3889 if (f
->expr_type
== EXPR_FUNCTION
)
3892 if (f
!= last
&& !gfc_pure_function (f
, &name
)
3893 && !gfc_implicit_pure_function (f
))
3896 gfc_warning (OPT_Wfunction_elimination
,
3897 "Impure function %qs at %L might not be evaluated",
3900 gfc_warning (OPT_Wfunction_elimination
,
3901 "Impure function at %L might not be evaluated",
3910 /* Return true if TYPE is character based, false otherwise. */
3913 is_character_based (bt type
)
3915 return type
== BT_CHARACTER
|| type
== BT_HOLLERITH
;
3919 /* If expression is a hollerith, convert it to character and issue a warning
3920 for the conversion. */
3923 convert_hollerith_to_character (gfc_expr
*e
)
3925 if (e
->ts
.type
== BT_HOLLERITH
)
3929 t
.type
= BT_CHARACTER
;
3930 t
.kind
= e
->ts
.kind
;
3931 gfc_convert_type_warn (e
, &t
, 2, 1);
3935 /* Convert to numeric and issue a warning for the conversion. */
3938 convert_to_numeric (gfc_expr
*a
, gfc_expr
*b
)
3942 t
.type
= b
->ts
.type
;
3943 t
.kind
= b
->ts
.kind
;
3944 gfc_convert_type_warn (a
, &t
, 2, 1);
3947 /* Resolve an operator expression node. This can involve replacing the
3948 operation with a user defined function call. */
3951 resolve_operator (gfc_expr
*e
)
3953 gfc_expr
*op1
, *op2
;
3955 bool dual_locus_error
;
3958 /* Resolve all subnodes-- give them types. */
3960 switch (e
->value
.op
.op
)
3963 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3969 case INTRINSIC_UPLUS
:
3970 case INTRINSIC_UMINUS
:
3971 case INTRINSIC_PARENTHESES
:
3972 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3975 && e
->value
.op
.op1
->ts
.type
== BT_BOZ
&& !e
->value
.op
.op2
)
3977 gfc_error ("BOZ literal constant at %L cannot be an operand of "
3978 "unary operator %qs", &e
->value
.op
.op1
->where
,
3979 gfc_op2string (e
->value
.op
.op
));
3985 /* Typecheck the new node. */
3987 op1
= e
->value
.op
.op1
;
3988 op2
= e
->value
.op
.op2
;
3989 dual_locus_error
= false;
3991 /* op1 and op2 cannot both be BOZ. */
3992 if (op1
&& op1
->ts
.type
== BT_BOZ
3993 && op2
&& op2
->ts
.type
== BT_BOZ
)
3995 gfc_error ("Operands at %L and %L cannot appear as operands of "
3996 "binary operator %qs", &op1
->where
, &op2
->where
,
3997 gfc_op2string (e
->value
.op
.op
));
4001 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
4002 || (op2
&& op2
->expr_type
== EXPR_NULL
))
4004 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
4008 switch (e
->value
.op
.op
)
4010 case INTRINSIC_UPLUS
:
4011 case INTRINSIC_UMINUS
:
4012 if (op1
->ts
.type
== BT_INTEGER
4013 || op1
->ts
.type
== BT_REAL
4014 || op1
->ts
.type
== BT_COMPLEX
)
4020 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
4021 gfc_op2string (e
->value
.op
.op
), gfc_typename (e
));
4024 case INTRINSIC_PLUS
:
4025 case INTRINSIC_MINUS
:
4026 case INTRINSIC_TIMES
:
4027 case INTRINSIC_DIVIDE
:
4028 case INTRINSIC_POWER
:
4029 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4031 gfc_type_convert_binary (e
, 1);
4035 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
4037 _("Unexpected derived-type entities in binary intrinsic "
4038 "numeric operator %%<%s%%> at %%L"),
4039 gfc_op2string (e
->value
.op
.op
));
4042 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
4043 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4044 gfc_typename (op2
));
4047 case INTRINSIC_CONCAT
:
4048 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4049 && op1
->ts
.kind
== op2
->ts
.kind
)
4051 e
->ts
.type
= BT_CHARACTER
;
4052 e
->ts
.kind
= op1
->ts
.kind
;
4057 _("Operands of string concatenation operator at %%L are %s/%s"),
4058 gfc_typename (op1
), gfc_typename (op2
));
4064 case INTRINSIC_NEQV
:
4065 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4067 e
->ts
.type
= BT_LOGICAL
;
4068 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4069 if (op1
->ts
.kind
< e
->ts
.kind
)
4070 gfc_convert_type (op1
, &e
->ts
, 2);
4071 else if (op2
->ts
.kind
< e
->ts
.kind
)
4072 gfc_convert_type (op2
, &e
->ts
, 2);
4074 if (flag_frontend_optimize
&&
4075 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4077 /* Warn about short-circuiting
4078 with impure function as second operand. */
4080 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4085 /* Logical ops on integers become bitwise ops with -fdec. */
4087 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4089 e
->ts
.type
= BT_INTEGER
;
4090 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4091 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4092 gfc_convert_type (op1
, &e
->ts
, 1);
4093 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4094 gfc_convert_type (op2
, &e
->ts
, 1);
4095 e
= logical_to_bitwise (e
);
4099 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4100 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4101 gfc_typename (op2
));
4106 /* Logical ops on integers become bitwise ops with -fdec. */
4107 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4109 e
->ts
.type
= BT_INTEGER
;
4110 e
->ts
.kind
= op1
->ts
.kind
;
4111 e
= logical_to_bitwise (e
);
4115 if (op1
->ts
.type
== BT_LOGICAL
)
4117 e
->ts
.type
= BT_LOGICAL
;
4118 e
->ts
.kind
= op1
->ts
.kind
;
4122 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4123 gfc_typename (op1
));
4127 case INTRINSIC_GT_OS
:
4129 case INTRINSIC_GE_OS
:
4131 case INTRINSIC_LT_OS
:
4133 case INTRINSIC_LE_OS
:
4134 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4136 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4143 case INTRINSIC_EQ_OS
:
4145 case INTRINSIC_NE_OS
:
4148 && is_character_based (op1
->ts
.type
)
4149 && is_character_based (op2
->ts
.type
))
4151 convert_hollerith_to_character (op1
);
4152 convert_hollerith_to_character (op2
);
4155 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4156 && op1
->ts
.kind
== op2
->ts
.kind
)
4158 e
->ts
.type
= BT_LOGICAL
;
4159 e
->ts
.kind
= gfc_default_logical_kind
;
4163 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4164 if (op1
->ts
.type
== BT_BOZ
)
4166 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4167 "an operand of a relational operator",
4171 if (op2
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op1
, op2
->ts
.kind
))
4174 if (op2
->ts
.type
== BT_REAL
&& !gfc_boz2real (op1
, op2
->ts
.kind
))
4178 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4179 if (op2
->ts
.type
== BT_BOZ
)
4181 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4182 "an operand of a relational operator",
4186 if (op1
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op2
, op1
->ts
.kind
))
4189 if (op1
->ts
.type
== BT_REAL
&& !gfc_boz2real (op2
, op1
->ts
.kind
))
4193 && op1
->ts
.type
== BT_HOLLERITH
&& gfc_numeric_ts (&op2
->ts
))
4194 convert_to_numeric (op1
, op2
);
4197 && gfc_numeric_ts (&op1
->ts
) && op2
->ts
.type
== BT_HOLLERITH
)
4198 convert_to_numeric (op2
, op1
);
4200 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4202 gfc_type_convert_binary (e
, 1);
4204 e
->ts
.type
= BT_LOGICAL
;
4205 e
->ts
.kind
= gfc_default_logical_kind
;
4207 if (warn_compare_reals
)
4209 gfc_intrinsic_op op
= e
->value
.op
.op
;
4211 /* Type conversion has made sure that the types of op1 and op2
4212 agree, so it is only necessary to check the first one. */
4213 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4214 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4215 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4219 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4220 msg
= "Equality comparison for %s at %L";
4222 msg
= "Inequality comparison for %s at %L";
4224 gfc_warning (OPT_Wcompare_reals
, msg
,
4225 gfc_typename (op1
), &op1
->where
);
4232 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4234 _("Logicals at %%L must be compared with %s instead of %s"),
4235 (e
->value
.op
.op
== INTRINSIC_EQ
4236 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4237 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4240 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4241 gfc_op2string (e
->value
.op
.op
), gfc_typename (op1
),
4242 gfc_typename (op2
));
4246 case INTRINSIC_USER
:
4247 if (e
->value
.op
.uop
->op
== NULL
)
4249 const char *name
= e
->value
.op
.uop
->name
;
4250 const char *guessed
;
4251 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4253 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4256 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4258 else if (op2
== NULL
)
4259 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4260 e
->value
.op
.uop
->name
, gfc_typename (op1
));
4263 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4264 e
->value
.op
.uop
->name
, gfc_typename (op1
),
4265 gfc_typename (op2
));
4266 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4271 case INTRINSIC_PARENTHESES
:
4273 if (e
->ts
.type
== BT_CHARACTER
)
4274 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4278 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4281 /* Deal with arrayness of an operand through an operator. */
4283 switch (e
->value
.op
.op
)
4285 case INTRINSIC_PLUS
:
4286 case INTRINSIC_MINUS
:
4287 case INTRINSIC_TIMES
:
4288 case INTRINSIC_DIVIDE
:
4289 case INTRINSIC_POWER
:
4290 case INTRINSIC_CONCAT
:
4294 case INTRINSIC_NEQV
:
4296 case INTRINSIC_EQ_OS
:
4298 case INTRINSIC_NE_OS
:
4300 case INTRINSIC_GT_OS
:
4302 case INTRINSIC_GE_OS
:
4304 case INTRINSIC_LT_OS
:
4306 case INTRINSIC_LE_OS
:
4308 if (op1
->rank
== 0 && op2
->rank
== 0)
4311 if (op1
->rank
== 0 && op2
->rank
!= 0)
4313 e
->rank
= op2
->rank
;
4315 if (e
->shape
== NULL
)
4316 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4319 if (op1
->rank
!= 0 && op2
->rank
== 0)
4321 e
->rank
= op1
->rank
;
4323 if (e
->shape
== NULL
)
4324 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4327 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4329 if (op1
->rank
== op2
->rank
)
4331 e
->rank
= op1
->rank
;
4332 if (e
->shape
== NULL
)
4334 t
= compare_shapes (op1
, op2
);
4338 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4343 /* Allow higher level expressions to work. */
4346 /* Try user-defined operators, and otherwise throw an error. */
4347 dual_locus_error
= true;
4349 _("Inconsistent ranks for operator at %%L and %%L"));
4356 case INTRINSIC_PARENTHESES
:
4358 case INTRINSIC_UPLUS
:
4359 case INTRINSIC_UMINUS
:
4360 /* Simply copy arrayness attribute */
4361 e
->rank
= op1
->rank
;
4363 if (e
->shape
== NULL
)
4364 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4374 /* Attempt to simplify the expression. */
4377 t
= gfc_simplify_expr (e
, 0);
4378 /* Some calls do not succeed in simplification and return false
4379 even though there is no error; e.g. variable references to
4380 PARAMETER arrays. */
4381 if (!gfc_is_constant_expr (e
))
4389 match m
= gfc_extend_expr (e
);
4392 if (m
== MATCH_ERROR
)
4396 if (dual_locus_error
)
4397 gfc_error (msg
, &op1
->where
, &op2
->where
);
4399 gfc_error (msg
, &e
->where
);
4405 /************** Array resolution subroutines **************/
4408 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4410 /* Compare two integer expressions. */
4412 static compare_result
4413 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4417 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4418 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4421 /* If either of the types isn't INTEGER, we must have
4422 raised an error earlier. */
4424 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4427 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4437 /* Compare an integer expression with an integer. */
4439 static compare_result
4440 compare_bound_int (gfc_expr
*a
, int b
)
4444 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4447 if (a
->ts
.type
!= BT_INTEGER
)
4448 gfc_internal_error ("compare_bound_int(): Bad expression");
4450 i
= mpz_cmp_si (a
->value
.integer
, b
);
4460 /* Compare an integer expression with a mpz_t. */
4462 static compare_result
4463 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4467 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4470 if (a
->ts
.type
!= BT_INTEGER
)
4471 gfc_internal_error ("compare_bound_int(): Bad expression");
4473 i
= mpz_cmp (a
->value
.integer
, b
);
4483 /* Compute the last value of a sequence given by a triplet.
4484 Return 0 if it wasn't able to compute the last value, or if the
4485 sequence if empty, and 1 otherwise. */
4488 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4489 gfc_expr
*stride
, mpz_t last
)
4493 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4494 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4495 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4498 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4499 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4502 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4504 if (compare_bound (start
, end
) == CMP_GT
)
4506 mpz_set (last
, end
->value
.integer
);
4510 if (compare_bound_int (stride
, 0) == CMP_GT
)
4512 /* Stride is positive */
4513 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4518 /* Stride is negative */
4519 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4524 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4525 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4526 mpz_sub (last
, end
->value
.integer
, rem
);
4533 /* Compare a single dimension of an array reference to the array
4537 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4541 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4543 gcc_assert (ar
->stride
[i
] == NULL
);
4544 /* This implies [*] as [*:] and [*:3] are not possible. */
4545 if (ar
->start
[i
] == NULL
)
4547 gcc_assert (ar
->end
[i
] == NULL
);
4552 /* Given start, end and stride values, calculate the minimum and
4553 maximum referenced indexes. */
4555 switch (ar
->dimen_type
[i
])
4558 case DIMEN_THIS_IMAGE
:
4563 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4566 gfc_warning (0, "Array reference at %L is out of bounds "
4567 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4568 mpz_get_si (ar
->start
[i
]->value
.integer
),
4569 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4571 gfc_warning (0, "Array reference at %L is out of bounds "
4572 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4573 mpz_get_si (ar
->start
[i
]->value
.integer
),
4574 mpz_get_si (as
->lower
[i
]->value
.integer
),
4578 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4581 gfc_warning (0, "Array reference at %L is out of bounds "
4582 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4583 mpz_get_si (ar
->start
[i
]->value
.integer
),
4584 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4586 gfc_warning (0, "Array reference at %L is out of bounds "
4587 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4588 mpz_get_si (ar
->start
[i
]->value
.integer
),
4589 mpz_get_si (as
->upper
[i
]->value
.integer
),
4598 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4599 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4601 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4603 /* Check for zero stride, which is not allowed. */
4604 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4606 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4610 /* if start == len || (stride > 0 && start < len)
4611 || (stride < 0 && start > len),
4612 then the array section contains at least one element. In this
4613 case, there is an out-of-bounds access if
4614 (start < lower || start > upper). */
4615 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4616 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4617 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4618 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4619 && comp_start_end
== CMP_GT
))
4621 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4623 gfc_warning (0, "Lower array reference at %L is out of bounds "
4624 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4625 mpz_get_si (AR_START
->value
.integer
),
4626 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4629 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4631 gfc_warning (0, "Lower array reference at %L is out of bounds "
4632 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4633 mpz_get_si (AR_START
->value
.integer
),
4634 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4639 /* If we can compute the highest index of the array section,
4640 then it also has to be between lower and upper. */
4641 mpz_init (last_value
);
4642 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4645 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4647 gfc_warning (0, "Upper array reference at %L is out of bounds "
4648 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4649 mpz_get_si (last_value
),
4650 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4651 mpz_clear (last_value
);
4654 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4656 gfc_warning (0, "Upper array reference at %L is out of bounds "
4657 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4658 mpz_get_si (last_value
),
4659 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4660 mpz_clear (last_value
);
4664 mpz_clear (last_value
);
4672 gfc_internal_error ("check_dimension(): Bad array reference");
4679 /* Compare an array reference with an array specification. */
4682 compare_spec_to_ref (gfc_array_ref
*ar
)
4689 /* TODO: Full array sections are only allowed as actual parameters. */
4690 if (as
->type
== AS_ASSUMED_SIZE
4691 && (/*ar->type == AR_FULL
4692 ||*/ (ar
->type
== AR_SECTION
4693 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4695 gfc_error ("Rightmost upper bound of assumed size array section "
4696 "not specified at %L", &ar
->where
);
4700 if (ar
->type
== AR_FULL
)
4703 if (as
->rank
!= ar
->dimen
)
4705 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4706 &ar
->where
, ar
->dimen
, as
->rank
);
4710 /* ar->codimen == 0 is a local array. */
4711 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4713 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4714 &ar
->where
, ar
->codimen
, as
->corank
);
4718 for (i
= 0; i
< as
->rank
; i
++)
4719 if (!check_dimension (i
, ar
, as
))
4722 /* Local access has no coarray spec. */
4723 if (ar
->codimen
!= 0)
4724 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4726 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4727 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4729 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4730 i
+ 1 - as
->rank
, &ar
->where
);
4733 if (!check_dimension (i
, ar
, as
))
4741 /* Resolve one part of an array index. */
4744 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4745 int force_index_integer_kind
)
4752 if (!gfc_resolve_expr (index
))
4755 if (check_scalar
&& index
->rank
!= 0)
4757 gfc_error ("Array index at %L must be scalar", &index
->where
);
4761 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4763 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4764 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4768 if (index
->ts
.type
== BT_REAL
)
4769 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4773 if ((index
->ts
.kind
!= gfc_index_integer_kind
4774 && force_index_integer_kind
)
4775 || index
->ts
.type
!= BT_INTEGER
)
4778 ts
.type
= BT_INTEGER
;
4779 ts
.kind
= gfc_index_integer_kind
;
4781 gfc_convert_type_warn (index
, &ts
, 2, 0);
4787 /* Resolve one part of an array index. */
4790 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4792 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4795 /* Resolve a dim argument to an intrinsic function. */
4798 gfc_resolve_dim_arg (gfc_expr
*dim
)
4803 if (!gfc_resolve_expr (dim
))
4808 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4813 if (dim
->ts
.type
!= BT_INTEGER
)
4815 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4819 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4824 ts
.type
= BT_INTEGER
;
4825 ts
.kind
= gfc_index_integer_kind
;
4827 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4833 /* Given an expression that contains array references, update those array
4834 references to point to the right array specifications. While this is
4835 filled in during matching, this information is difficult to save and load
4836 in a module, so we take care of it here.
4838 The idea here is that the original array reference comes from the
4839 base symbol. We traverse the list of reference structures, setting
4840 the stored reference to references. Component references can
4841 provide an additional array specification. */
4844 find_array_spec (gfc_expr
*e
)
4849 bool class_as
= false;
4851 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4853 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4857 as
= e
->symtree
->n
.sym
->as
;
4859 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4864 gfc_internal_error ("find_array_spec(): Missing spec");
4871 c
= ref
->u
.c
.component
;
4872 if (c
->attr
.dimension
)
4874 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
4875 gfc_internal_error ("find_array_spec(): unused as(1)");
4887 gfc_internal_error ("find_array_spec(): unused as(2)");
4891 /* Resolve an array reference. */
4894 resolve_array_ref (gfc_array_ref
*ar
)
4896 int i
, check_scalar
;
4899 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4901 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4903 /* Do not force gfc_index_integer_kind for the start. We can
4904 do fine with any integer kind. This avoids temporary arrays
4905 created for indexing with a vector. */
4906 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4908 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4910 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4915 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4919 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4923 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4924 if (e
->expr_type
== EXPR_VARIABLE
4925 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4926 ar
->start
[i
] = gfc_get_parentheses (e
);
4930 gfc_error ("Array index at %L is an array of rank %d",
4931 &ar
->c_where
[i
], e
->rank
);
4935 /* Fill in the upper bound, which may be lower than the
4936 specified one for something like a(2:10:5), which is
4937 identical to a(2:7:5). Only relevant for strides not equal
4938 to one. Don't try a division by zero. */
4939 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4940 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4941 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4942 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4946 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4948 if (ar
->end
[i
] == NULL
)
4951 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4953 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4955 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4956 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4958 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4969 if (ar
->type
== AR_FULL
)
4971 if (ar
->as
->rank
== 0)
4972 ar
->type
= AR_ELEMENT
;
4974 /* Make sure array is the same as array(:,:), this way
4975 we don't need to special case all the time. */
4976 ar
->dimen
= ar
->as
->rank
;
4977 for (i
= 0; i
< ar
->dimen
; i
++)
4979 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4981 gcc_assert (ar
->start
[i
] == NULL
);
4982 gcc_assert (ar
->end
[i
] == NULL
);
4983 gcc_assert (ar
->stride
[i
] == NULL
);
4987 /* If the reference type is unknown, figure out what kind it is. */
4989 if (ar
->type
== AR_UNKNOWN
)
4991 ar
->type
= AR_ELEMENT
;
4992 for (i
= 0; i
< ar
->dimen
; i
++)
4993 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4994 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4996 ar
->type
= AR_SECTION
;
5001 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
5004 if (ar
->as
->corank
&& ar
->codimen
== 0)
5007 ar
->codimen
= ar
->as
->corank
;
5008 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
5009 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
5017 resolve_substring (gfc_ref
*ref
, bool *equal_length
)
5019 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5021 if (ref
->u
.ss
.start
!= NULL
)
5023 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
5026 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
5028 gfc_error ("Substring start index at %L must be of type INTEGER",
5029 &ref
->u
.ss
.start
->where
);
5033 if (ref
->u
.ss
.start
->rank
!= 0)
5035 gfc_error ("Substring start index at %L must be scalar",
5036 &ref
->u
.ss
.start
->where
);
5040 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
5041 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5042 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5044 gfc_error ("Substring start index at %L is less than one",
5045 &ref
->u
.ss
.start
->where
);
5050 if (ref
->u
.ss
.end
!= NULL
)
5052 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
5055 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
5057 gfc_error ("Substring end index at %L must be of type INTEGER",
5058 &ref
->u
.ss
.end
->where
);
5062 if (ref
->u
.ss
.end
->rank
!= 0)
5064 gfc_error ("Substring end index at %L must be scalar",
5065 &ref
->u
.ss
.end
->where
);
5069 if (ref
->u
.ss
.length
!= NULL
5070 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
5071 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5072 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5074 gfc_error ("Substring end index at %L exceeds the string length",
5075 &ref
->u
.ss
.start
->where
);
5079 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
5080 gfc_integer_kinds
[k
].huge
) == CMP_GT
5081 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5082 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5084 gfc_error ("Substring end index at %L is too large",
5085 &ref
->u
.ss
.end
->where
);
5088 /* If the substring has the same length as the original
5089 variable, the reference itself can be deleted. */
5091 if (ref
->u
.ss
.length
!= NULL
5092 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
5093 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
5094 *equal_length
= true;
5101 /* This function supplies missing substring charlens. */
5104 gfc_resolve_substring_charlen (gfc_expr
*e
)
5107 gfc_expr
*start
, *end
;
5108 gfc_typespec
*ts
= NULL
;
5111 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5113 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5115 if (char_ref
->type
== REF_COMPONENT
)
5116 ts
= &char_ref
->u
.c
.component
->ts
;
5119 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5122 gcc_assert (char_ref
->next
== NULL
);
5126 if (e
->ts
.u
.cl
->length
)
5127 gfc_free_expr (e
->ts
.u
.cl
->length
);
5128 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5132 e
->ts
.type
= BT_CHARACTER
;
5133 e
->ts
.kind
= gfc_default_character_kind
;
5136 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5138 if (char_ref
->u
.ss
.start
)
5139 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5141 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5143 if (char_ref
->u
.ss
.end
)
5144 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5145 else if (e
->expr_type
== EXPR_VARIABLE
)
5148 ts
= &e
->symtree
->n
.sym
->ts
;
5149 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5156 gfc_free_expr (start
);
5157 gfc_free_expr (end
);
5161 /* Length = (end - start + 1).
5162 Check first whether it has a constant length. */
5163 if (gfc_dep_difference (end
, start
, &diff
))
5165 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5168 mpz_add_ui (len
->value
.integer
, diff
, 1);
5170 e
->ts
.u
.cl
->length
= len
;
5171 /* The check for length < 0 is handled below */
5175 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5176 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5177 gfc_get_int_expr (gfc_charlen_int_kind
,
5181 /* F2008, 6.4.1: Both the starting point and the ending point shall
5182 be within the range 1, 2, ..., n unless the starting point exceeds
5183 the ending point, in which case the substring has length zero. */
5185 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5186 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5188 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5189 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5191 /* Make sure that the length is simplified. */
5192 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5193 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5197 /* Resolve subtype references. */
5200 gfc_resolve_ref (gfc_expr
*expr
)
5202 int current_part_dimension
, n_components
, seen_part_dimension
;
5203 gfc_ref
*ref
, **prev
;
5206 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5207 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5209 find_array_spec (expr
);
5213 for (prev
= &expr
->ref
; *prev
!= NULL
;
5214 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5215 switch ((*prev
)->type
)
5218 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5227 equal_length
= false;
5228 if (!resolve_substring (*prev
, &equal_length
))
5231 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5233 /* Remove the reference and move the charlen, if any. */
5237 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5238 ref
->u
.ss
.length
= NULL
;
5239 gfc_free_ref_list (ref
);
5244 /* Check constraints on part references. */
5246 current_part_dimension
= 0;
5247 seen_part_dimension
= 0;
5250 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5255 switch (ref
->u
.ar
.type
)
5258 /* Coarray scalar. */
5259 if (ref
->u
.ar
.as
->rank
== 0)
5261 current_part_dimension
= 0;
5266 current_part_dimension
= 1;
5270 current_part_dimension
= 0;
5274 gfc_internal_error ("resolve_ref(): Bad array reference");
5280 if (current_part_dimension
|| seen_part_dimension
)
5283 if (ref
->u
.c
.component
->attr
.pointer
5284 || ref
->u
.c
.component
->attr
.proc_pointer
5285 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5286 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5288 gfc_error ("Component to the right of a part reference "
5289 "with nonzero rank must not have the POINTER "
5290 "attribute at %L", &expr
->where
);
5293 else if (ref
->u
.c
.component
->attr
.allocatable
5294 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5295 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5298 gfc_error ("Component to the right of a part reference "
5299 "with nonzero rank must not have the ALLOCATABLE "
5300 "attribute at %L", &expr
->where
);
5313 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5314 || ref
->next
== NULL
)
5315 && current_part_dimension
5316 && seen_part_dimension
)
5318 gfc_error ("Two or more part references with nonzero rank must "
5319 "not be specified at %L", &expr
->where
);
5323 if (ref
->type
== REF_COMPONENT
)
5325 if (current_part_dimension
)
5326 seen_part_dimension
= 1;
5328 /* reset to make sure */
5329 current_part_dimension
= 0;
5337 /* Given an expression, determine its shape. This is easier than it sounds.
5338 Leaves the shape array NULL if it is not possible to determine the shape. */
5341 expression_shape (gfc_expr
*e
)
5343 mpz_t array
[GFC_MAX_DIMENSIONS
];
5346 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5349 for (i
= 0; i
< e
->rank
; i
++)
5350 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5353 e
->shape
= gfc_get_shape (e
->rank
);
5355 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5360 for (i
--; i
>= 0; i
--)
5361 mpz_clear (array
[i
]);
5365 /* Given a variable expression node, compute the rank of the expression by
5366 examining the base symbol and any reference structures it may have. */
5369 gfc_expression_rank (gfc_expr
*e
)
5374 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5375 could lead to serious confusion... */
5376 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5380 if (e
->expr_type
== EXPR_ARRAY
)
5382 /* Constructors can have a rank different from one via RESHAPE(). */
5384 e
->rank
= ((e
->symtree
== NULL
|| e
->symtree
->n
.sym
->as
== NULL
)
5385 ? 0 : e
->symtree
->n
.sym
->as
->rank
);
5391 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5393 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5394 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5395 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5397 if (ref
->type
!= REF_ARRAY
)
5400 if (ref
->u
.ar
.type
== AR_FULL
)
5402 rank
= ref
->u
.ar
.as
->rank
;
5406 if (ref
->u
.ar
.type
== AR_SECTION
)
5408 /* Figure out the rank of the section. */
5410 gfc_internal_error ("gfc_expression_rank(): Two array specs");
5412 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5413 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5414 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5424 expression_shape (e
);
5429 add_caf_get_intrinsic (gfc_expr
*e
)
5431 gfc_expr
*wrapper
, *tmp_expr
;
5435 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5436 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5441 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5442 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5445 tmp_expr
= XCNEW (gfc_expr
);
5447 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5448 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5449 wrapper
->ts
= e
->ts
;
5450 wrapper
->rank
= e
->rank
;
5452 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5459 remove_caf_get_intrinsic (gfc_expr
*e
)
5461 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5462 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5463 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5464 e
->value
.function
.actual
->expr
= NULL
;
5465 gfc_free_actual_arglist (e
->value
.function
.actual
);
5466 gfc_free_shape (&e
->shape
, e
->rank
);
5472 /* Resolve a variable expression. */
5475 resolve_variable (gfc_expr
*e
)
5482 if (e
->symtree
== NULL
)
5484 sym
= e
->symtree
->n
.sym
;
5486 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5487 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5488 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5490 if (!actual_arg
|| inquiry_argument
)
5492 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5493 "be used as actual argument", sym
->name
, &e
->where
);
5497 /* TS 29113, 407b. */
5498 else if (e
->ts
.type
== BT_ASSUMED
)
5502 gfc_error ("Assumed-type variable %s at %L may only be used "
5503 "as actual argument", sym
->name
, &e
->where
);
5506 else if (inquiry_argument
&& !first_actual_arg
)
5508 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5509 for all inquiry functions in resolve_function; the reason is
5510 that the function-name resolution happens too late in that
5512 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5513 "an inquiry function shall be the first argument",
5514 sym
->name
, &e
->where
);
5518 /* TS 29113, C535b. */
5519 else if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5520 && CLASS_DATA (sym
)->as
5521 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5522 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5523 && sym
->as
->type
== AS_ASSUMED_RANK
))
5524 && !sym
->attr
.select_rank_temporary
)
5527 && !(cs_base
&& cs_base
->current
5528 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
5530 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5531 "actual argument", sym
->name
, &e
->where
);
5534 else if (inquiry_argument
&& !first_actual_arg
)
5536 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5537 for all inquiry functions in resolve_function; the reason is
5538 that the function-name resolution happens too late in that
5540 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5541 "to an inquiry function shall be the first argument",
5542 sym
->name
, &e
->where
);
5547 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5548 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5549 && e
->ref
->next
== NULL
))
5551 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5552 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5555 /* TS 29113, 407b. */
5556 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5557 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5558 && e
->ref
->next
== NULL
))
5560 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5561 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5565 /* TS 29113, C535b. */
5566 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5567 && CLASS_DATA (sym
)->as
5568 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5569 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5570 && sym
->as
->type
== AS_ASSUMED_RANK
))
5572 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5573 && e
->ref
->next
== NULL
))
5575 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5576 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5580 /* For variables that are used in an associate (target => object) where
5581 the object's basetype is array valued while the target is scalar,
5582 the ts' type of the component refs is still array valued, which
5583 can't be translated that way. */
5584 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5585 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5586 && CLASS_DATA (sym
->assoc
->target
)->as
)
5588 gfc_ref
*ref
= e
->ref
;
5594 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5595 /* Stop the loop. */
5605 /* If this is an associate-name, it may be parsed with an array reference
5606 in error even though the target is scalar. Fail directly in this case.
5607 TODO Understand why class scalar expressions must be excluded. */
5608 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5610 if (sym
->ts
.type
== BT_CLASS
)
5611 gfc_fix_class_refs (e
);
5612 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5614 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5616 /* This can happen because the parser did not detect that the
5617 associate name is an array and the expression had no array
5619 gfc_ref
*ref
= gfc_get_ref ();
5620 ref
->type
= REF_ARRAY
;
5621 ref
->u
.ar
= *gfc_get_array_ref();
5622 ref
->u
.ar
.type
= AR_FULL
;
5625 ref
->u
.ar
.as
= sym
->as
;
5626 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5634 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5635 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5637 /* On the other hand, the parser may not have known this is an array;
5638 in this case, we have to add a FULL reference. */
5639 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5641 e
->ref
= gfc_get_ref ();
5642 e
->ref
->type
= REF_ARRAY
;
5643 e
->ref
->u
.ar
.type
= AR_FULL
;
5644 e
->ref
->u
.ar
.dimen
= 0;
5647 /* Like above, but for class types, where the checking whether an array
5648 ref is present is more complicated. Furthermore make sure not to add
5649 the full array ref to _vptr or _len refs. */
5650 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5651 && CLASS_DATA (sym
)->attr
.dimension
5652 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5654 gfc_ref
*ref
, *newref
;
5656 newref
= gfc_get_ref ();
5657 newref
->type
= REF_ARRAY
;
5658 newref
->u
.ar
.type
= AR_FULL
;
5659 newref
->u
.ar
.dimen
= 0;
5660 /* Because this is an associate var and the first ref either is a ref to
5661 the _data component or not, no traversal of the ref chain is
5662 needed. The array ref needs to be inserted after the _data ref,
5663 or when that is not present, which may happend for polymorphic
5664 types, then at the first position. */
5668 else if (ref
->type
== REF_COMPONENT
5669 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5671 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5673 newref
->next
= ref
->next
;
5677 /* Array ref present already. */
5678 gfc_free_ref_list (newref
);
5680 else if (ref
->type
== REF_ARRAY
)
5681 /* Array ref present already. */
5682 gfc_free_ref_list (newref
);
5690 if (e
->ref
&& !gfc_resolve_ref (e
))
5693 if (sym
->attr
.flavor
== FL_PROCEDURE
5694 && (!sym
->attr
.function
5695 || (sym
->attr
.function
&& sym
->result
5696 && sym
->result
->attr
.proc_pointer
5697 && !sym
->result
->attr
.function
)))
5699 e
->ts
.type
= BT_PROCEDURE
;
5700 goto resolve_procedure
;
5703 if (sym
->ts
.type
!= BT_UNKNOWN
)
5704 gfc_variable_attr (e
, &e
->ts
);
5705 else if (sym
->attr
.flavor
== FL_PROCEDURE
5706 && sym
->attr
.function
&& sym
->result
5707 && sym
->result
->ts
.type
!= BT_UNKNOWN
5708 && sym
->result
->attr
.proc_pointer
)
5709 e
->ts
= sym
->result
->ts
;
5712 /* Must be a simple variable reference. */
5713 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5718 if (check_assumed_size_reference (sym
, e
))
5721 /* Deal with forward references to entries during gfc_resolve_code, to
5722 satisfy, at least partially, 12.5.2.5. */
5723 if (gfc_current_ns
->entries
5724 && current_entry_id
== sym
->entry_id
5727 && cs_base
->current
->op
!= EXEC_ENTRY
)
5729 gfc_entry_list
*entry
;
5730 gfc_formal_arglist
*formal
;
5732 bool seen
, saved_specification_expr
;
5734 /* If the symbol is a dummy... */
5735 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5737 entry
= gfc_current_ns
->entries
;
5740 /* ...test if the symbol is a parameter of previous entries. */
5741 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5742 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5744 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5751 /* If it has not been seen as a dummy, this is an error. */
5754 if (specification_expr
)
5755 gfc_error ("Variable %qs, used in a specification expression"
5756 ", is referenced at %L before the ENTRY statement "
5757 "in which it is a parameter",
5758 sym
->name
, &cs_base
->current
->loc
);
5760 gfc_error ("Variable %qs is used at %L before the ENTRY "
5761 "statement in which it is a parameter",
5762 sym
->name
, &cs_base
->current
->loc
);
5767 /* Now do the same check on the specification expressions. */
5768 saved_specification_expr
= specification_expr
;
5769 specification_expr
= true;
5770 if (sym
->ts
.type
== BT_CHARACTER
5771 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5775 for (n
= 0; n
< sym
->as
->rank
; n
++)
5777 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5779 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5782 specification_expr
= saved_specification_expr
;
5785 /* Update the symbol's entry level. */
5786 sym
->entry_id
= current_entry_id
+ 1;
5789 /* If a symbol has been host_associated mark it. This is used latter,
5790 to identify if aliasing is possible via host association. */
5791 if (sym
->attr
.flavor
== FL_VARIABLE
5792 && gfc_current_ns
->parent
5793 && (gfc_current_ns
->parent
== sym
->ns
5794 || (gfc_current_ns
->parent
->parent
5795 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5796 sym
->attr
.host_assoc
= 1;
5798 if (gfc_current_ns
->proc_name
5799 && sym
->attr
.dimension
5800 && (sym
->ns
!= gfc_current_ns
5801 || sym
->attr
.use_assoc
5802 || sym
->attr
.in_common
))
5803 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5806 if (t
&& !resolve_procedure_expression (e
))
5809 /* F2008, C617 and C1229. */
5810 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5811 && gfc_is_coindexed (e
))
5813 gfc_ref
*ref
, *ref2
= NULL
;
5815 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5817 if (ref
->type
== REF_COMPONENT
)
5819 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5823 for ( ; ref
; ref
= ref
->next
)
5824 if (ref
->type
== REF_COMPONENT
)
5827 /* Expression itself is not coindexed object. */
5828 if (ref
&& e
->ts
.type
== BT_CLASS
)
5830 gfc_error ("Polymorphic subobject of coindexed object at %L",
5835 /* Expression itself is coindexed object. */
5839 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5840 for ( ; c
; c
= c
->next
)
5841 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5843 gfc_error ("Coindexed object with polymorphic allocatable "
5844 "subcomponent at %L", &e
->where
);
5852 gfc_expression_rank (e
);
5854 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5855 add_caf_get_intrinsic (e
);
5857 /* Simplify cases where access to a parameter array results in a
5858 single constant. Suppress errors since those will have been
5859 issued before, as warnings. */
5860 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5862 gfc_push_suppress_errors ();
5863 gfc_simplify_expr (e
, 1);
5864 gfc_pop_suppress_errors ();
5871 /* Checks to see that the correct symbol has been host associated.
5872 The only situation where this arises is that in which a twice
5873 contained function is parsed after the host association is made.
5874 Therefore, on detecting this, change the symbol in the expression
5875 and convert the array reference into an actual arglist if the old
5876 symbol is a variable. */
5878 check_host_association (gfc_expr
*e
)
5880 gfc_symbol
*sym
, *old_sym
;
5884 gfc_actual_arglist
*arg
, *tail
= NULL
;
5885 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5887 /* If the expression is the result of substitution in
5888 interface.c(gfc_extend_expr) because there is no way in
5889 which the host association can be wrong. */
5890 if (e
->symtree
== NULL
5891 || e
->symtree
->n
.sym
== NULL
5892 || e
->user_operator
)
5895 old_sym
= e
->symtree
->n
.sym
;
5897 if (gfc_current_ns
->parent
5898 && old_sym
->ns
!= gfc_current_ns
)
5900 /* Use the 'USE' name so that renamed module symbols are
5901 correctly handled. */
5902 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5904 if (sym
&& old_sym
!= sym
5905 && sym
->ts
.type
== old_sym
->ts
.type
5906 && sym
->attr
.flavor
== FL_PROCEDURE
5907 && sym
->attr
.contained
)
5909 /* Clear the shape, since it might not be valid. */
5910 gfc_free_shape (&e
->shape
, e
->rank
);
5912 /* Give the expression the right symtree! */
5913 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5914 gcc_assert (st
!= NULL
);
5916 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5917 || e
->expr_type
== EXPR_FUNCTION
)
5919 /* Original was function so point to the new symbol, since
5920 the actual argument list is already attached to the
5922 e
->value
.function
.esym
= NULL
;
5927 /* Original was variable so convert array references into
5928 an actual arglist. This does not need any checking now
5929 since resolve_function will take care of it. */
5930 e
->value
.function
.actual
= NULL
;
5931 e
->expr_type
= EXPR_FUNCTION
;
5934 /* Ambiguity will not arise if the array reference is not
5935 the last reference. */
5936 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5937 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5940 gcc_assert (ref
->type
== REF_ARRAY
);
5942 /* Grab the start expressions from the array ref and
5943 copy them into actual arguments. */
5944 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5946 arg
= gfc_get_actual_arglist ();
5947 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5948 if (e
->value
.function
.actual
== NULL
)
5949 tail
= e
->value
.function
.actual
= arg
;
5957 /* Dump the reference list and set the rank. */
5958 gfc_free_ref_list (e
->ref
);
5960 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5963 gfc_resolve_expr (e
);
5967 /* This might have changed! */
5968 return e
->expr_type
== EXPR_FUNCTION
;
5973 gfc_resolve_character_operator (gfc_expr
*e
)
5975 gfc_expr
*op1
= e
->value
.op
.op1
;
5976 gfc_expr
*op2
= e
->value
.op
.op2
;
5977 gfc_expr
*e1
= NULL
;
5978 gfc_expr
*e2
= NULL
;
5980 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5982 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5983 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5984 else if (op1
->expr_type
== EXPR_CONSTANT
)
5985 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5986 op1
->value
.character
.length
);
5988 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5989 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5990 else if (op2
->expr_type
== EXPR_CONSTANT
)
5991 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5992 op2
->value
.character
.length
);
5994 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6004 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
6005 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
6006 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
6007 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
6008 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
6014 /* Ensure that an character expression has a charlen and, if possible, a
6015 length expression. */
6018 fixup_charlen (gfc_expr
*e
)
6020 /* The cases fall through so that changes in expression type and the need
6021 for multiple fixes are picked up. In all circumstances, a charlen should
6022 be available for the middle end to hang a backend_decl on. */
6023 switch (e
->expr_type
)
6026 gfc_resolve_character_operator (e
);
6030 if (e
->expr_type
== EXPR_ARRAY
)
6031 gfc_resolve_character_array_constructor (e
);
6034 case EXPR_SUBSTRING
:
6035 if (!e
->ts
.u
.cl
&& e
->ref
)
6036 gfc_resolve_substring_charlen (e
);
6041 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6048 /* Update an actual argument to include the passed-object for type-bound
6049 procedures at the right position. */
6051 static gfc_actual_arglist
*
6052 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
6055 gcc_assert (argpos
> 0);
6059 gfc_actual_arglist
* result
;
6061 result
= gfc_get_actual_arglist ();
6065 result
->name
= name
;
6071 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
6073 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
6078 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6081 extract_compcall_passed_object (gfc_expr
* e
)
6085 if (e
->expr_type
== EXPR_UNKNOWN
)
6087 gfc_error ("Error in typebound call at %L",
6092 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6094 if (e
->value
.compcall
.base_object
)
6095 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
6098 po
= gfc_get_expr ();
6099 po
->expr_type
= EXPR_VARIABLE
;
6100 po
->symtree
= e
->symtree
;
6101 po
->ref
= gfc_copy_ref (e
->ref
);
6102 po
->where
= e
->where
;
6105 if (!gfc_resolve_expr (po
))
6112 /* Update the arglist of an EXPR_COMPCALL expression to include the
6116 update_compcall_arglist (gfc_expr
* e
)
6119 gfc_typebound_proc
* tbp
;
6121 tbp
= e
->value
.compcall
.tbp
;
6126 po
= extract_compcall_passed_object (e
);
6130 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6136 if (tbp
->pass_arg_num
<= 0)
6139 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6147 /* Extract the passed object from a PPC call (a copy of it). */
6150 extract_ppc_passed_object (gfc_expr
*e
)
6155 po
= gfc_get_expr ();
6156 po
->expr_type
= EXPR_VARIABLE
;
6157 po
->symtree
= e
->symtree
;
6158 po
->ref
= gfc_copy_ref (e
->ref
);
6159 po
->where
= e
->where
;
6161 /* Remove PPC reference. */
6163 while ((*ref
)->next
)
6164 ref
= &(*ref
)->next
;
6165 gfc_free_ref_list (*ref
);
6168 if (!gfc_resolve_expr (po
))
6175 /* Update the actual arglist of a procedure pointer component to include the
6179 update_ppc_arglist (gfc_expr
* e
)
6183 gfc_typebound_proc
* tb
;
6185 ppc
= gfc_get_proc_ptr_comp (e
);
6193 else if (tb
->nopass
)
6196 po
= extract_ppc_passed_object (e
);
6203 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6208 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6210 gfc_error ("Base object for procedure-pointer component call at %L is of"
6211 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6215 gcc_assert (tb
->pass_arg_num
> 0);
6216 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6224 /* Check that the object a TBP is called on is valid, i.e. it must not be
6225 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6228 check_typebound_baseobject (gfc_expr
* e
)
6231 bool return_value
= false;
6233 base
= extract_compcall_passed_object (e
);
6237 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6239 gfc_error ("Error in typebound call at %L", &e
->where
);
6243 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6247 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6249 gfc_error ("Base object for type-bound procedure call at %L is of"
6250 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6254 /* F08:C1230. If the procedure called is NOPASS,
6255 the base object must be scalar. */
6256 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6258 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6259 " be scalar", &e
->where
);
6263 return_value
= true;
6266 gfc_free_expr (base
);
6267 return return_value
;
6271 /* Resolve a call to a type-bound procedure, either function or subroutine,
6272 statically from the data in an EXPR_COMPCALL expression. The adapted
6273 arglist and the target-procedure symtree are returned. */
6276 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6277 gfc_actual_arglist
** actual
)
6279 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6280 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6282 /* Update the actual arglist for PASS. */
6283 if (!update_compcall_arglist (e
))
6286 *actual
= e
->value
.compcall
.actual
;
6287 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6289 gfc_free_ref_list (e
->ref
);
6291 e
->value
.compcall
.actual
= NULL
;
6293 /* If we find a deferred typebound procedure, check for derived types
6294 that an overriding typebound procedure has not been missed. */
6295 if (e
->value
.compcall
.name
6296 && !e
->value
.compcall
.tbp
->non_overridable
6297 && e
->value
.compcall
.base_object
6298 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6301 gfc_symbol
*derived
;
6303 /* Use the derived type of the base_object. */
6304 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6307 /* If necessary, go through the inheritance chain. */
6308 while (!st
&& derived
)
6310 /* Look for the typebound procedure 'name'. */
6311 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6312 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6313 e
->value
.compcall
.name
);
6315 derived
= gfc_get_derived_super_type (derived
);
6318 /* Now find the specific name in the derived type namespace. */
6319 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6320 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6321 derived
->ns
, 1, &st
);
6329 /* Get the ultimate declared type from an expression. In addition,
6330 return the last class/derived type reference and the copy of the
6331 reference list. If check_types is set true, derived types are
6332 identified as well as class references. */
6334 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6335 gfc_expr
*e
, bool check_types
)
6337 gfc_symbol
*declared
;
6344 *new_ref
= gfc_copy_ref (e
->ref
);
6346 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6348 if (ref
->type
!= REF_COMPONENT
)
6351 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6352 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6353 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6355 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6361 if (declared
== NULL
)
6362 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6368 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6369 which of the specific bindings (if any) matches the arglist and transform
6370 the expression into a call of that binding. */
6373 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6375 gfc_typebound_proc
* genproc
;
6376 const char* genname
;
6378 gfc_symbol
*derived
;
6380 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6381 genname
= e
->value
.compcall
.name
;
6382 genproc
= e
->value
.compcall
.tbp
;
6384 if (!genproc
->is_generic
)
6387 /* Try the bindings on this type and in the inheritance hierarchy. */
6388 for (; genproc
; genproc
= genproc
->overridden
)
6392 gcc_assert (genproc
->is_generic
);
6393 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6396 gfc_actual_arglist
* args
;
6399 gcc_assert (g
->specific
);
6401 if (g
->specific
->error
)
6404 target
= g
->specific
->u
.specific
->n
.sym
;
6406 /* Get the right arglist by handling PASS/NOPASS. */
6407 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6408 if (!g
->specific
->nopass
)
6411 po
= extract_compcall_passed_object (e
);
6414 gfc_free_actual_arglist (args
);
6418 gcc_assert (g
->specific
->pass_arg_num
> 0);
6419 gcc_assert (!g
->specific
->error
);
6420 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6421 g
->specific
->pass_arg
);
6423 resolve_actual_arglist (args
, target
->attr
.proc
,
6424 is_external_proc (target
)
6425 && gfc_sym_get_dummy_args (target
) == NULL
);
6427 /* Check if this arglist matches the formal. */
6428 matches
= gfc_arglist_matches_symbol (&args
, target
);
6430 /* Clean up and break out of the loop if we've found it. */
6431 gfc_free_actual_arglist (args
);
6434 e
->value
.compcall
.tbp
= g
->specific
;
6435 genname
= g
->specific_st
->name
;
6436 /* Pass along the name for CLASS methods, where the vtab
6437 procedure pointer component has to be referenced. */
6445 /* Nothing matching found! */
6446 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6447 " %qs at %L", genname
, &e
->where
);
6451 /* Make sure that we have the right specific instance for the name. */
6452 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6454 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6456 e
->value
.compcall
.tbp
= st
->n
.tb
;
6462 /* Resolve a call to a type-bound subroutine. */
6465 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6467 gfc_actual_arglist
* newactual
;
6468 gfc_symtree
* target
;
6470 /* Check that's really a SUBROUTINE. */
6471 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6473 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6474 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6475 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6476 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6477 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6480 gfc_error ("%qs at %L should be a SUBROUTINE",
6481 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6486 if (!check_typebound_baseobject (c
->expr1
))
6489 /* Pass along the name for CLASS methods, where the vtab
6490 procedure pointer component has to be referenced. */
6492 *name
= c
->expr1
->value
.compcall
.name
;
6494 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6497 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6499 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6501 /* Transform into an ordinary EXEC_CALL for now. */
6503 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6506 c
->ext
.actual
= newactual
;
6507 c
->symtree
= target
;
6508 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6510 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6512 gfc_free_expr (c
->expr1
);
6513 c
->expr1
= gfc_get_expr ();
6514 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6515 c
->expr1
->symtree
= target
;
6516 c
->expr1
->where
= c
->loc
;
6518 return resolve_call (c
);
6522 /* Resolve a component-call expression. */
6524 resolve_compcall (gfc_expr
* e
, const char **name
)
6526 gfc_actual_arglist
* newactual
;
6527 gfc_symtree
* target
;
6529 /* Check that's really a FUNCTION. */
6530 if (!e
->value
.compcall
.tbp
->function
)
6532 gfc_error ("%qs at %L should be a FUNCTION",
6533 e
->value
.compcall
.name
, &e
->where
);
6538 /* These must not be assign-calls! */
6539 gcc_assert (!e
->value
.compcall
.assign
);
6541 if (!check_typebound_baseobject (e
))
6544 /* Pass along the name for CLASS methods, where the vtab
6545 procedure pointer component has to be referenced. */
6547 *name
= e
->value
.compcall
.name
;
6549 if (!resolve_typebound_generic_call (e
, name
))
6551 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6553 /* Take the rank from the function's symbol. */
6554 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6555 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6557 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6558 arglist to the TBP's binding target. */
6560 if (!resolve_typebound_static (e
, &target
, &newactual
))
6563 e
->value
.function
.actual
= newactual
;
6564 e
->value
.function
.name
= NULL
;
6565 e
->value
.function
.esym
= target
->n
.sym
;
6566 e
->value
.function
.isym
= NULL
;
6567 e
->symtree
= target
;
6568 e
->ts
= target
->n
.sym
->ts
;
6569 e
->expr_type
= EXPR_FUNCTION
;
6571 /* Resolution is not necessary if this is a class subroutine; this
6572 function only has to identify the specific proc. Resolution of
6573 the call will be done next in resolve_typebound_call. */
6574 return gfc_resolve_expr (e
);
6578 static bool resolve_fl_derived (gfc_symbol
*sym
);
6581 /* Resolve a typebound function, or 'method'. First separate all
6582 the non-CLASS references by calling resolve_compcall directly. */
6585 resolve_typebound_function (gfc_expr
* e
)
6587 gfc_symbol
*declared
;
6599 /* Deal with typebound operators for CLASS objects. */
6600 expr
= e
->value
.compcall
.base_object
;
6601 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6602 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6604 /* Since the typebound operators are generic, we have to ensure
6605 that any delays in resolution are corrected and that the vtab
6608 declared
= ts
.u
.derived
;
6609 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6610 if (c
->ts
.u
.derived
== NULL
)
6611 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6613 if (!resolve_compcall (e
, &name
))
6616 /* Use the generic name if it is there. */
6617 name
= name
? name
: e
->value
.function
.esym
->name
;
6618 e
->symtree
= expr
->symtree
;
6619 e
->ref
= gfc_copy_ref (expr
->ref
);
6620 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6622 /* Trim away the extraneous references that emerge from nested
6623 use of interface.c (extend_expr). */
6624 if (class_ref
&& class_ref
->next
)
6626 gfc_free_ref_list (class_ref
->next
);
6627 class_ref
->next
= NULL
;
6629 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6631 gfc_free_ref_list (e
->ref
);
6635 gfc_add_vptr_component (e
);
6636 gfc_add_component_ref (e
, name
);
6637 e
->value
.function
.esym
= NULL
;
6638 if (expr
->expr_type
!= EXPR_VARIABLE
)
6639 e
->base_expr
= expr
;
6644 return resolve_compcall (e
, NULL
);
6646 if (!gfc_resolve_ref (e
))
6649 /* Get the CLASS declared type. */
6650 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6652 if (!resolve_fl_derived (declared
))
6655 /* Weed out cases of the ultimate component being a derived type. */
6656 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6657 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6659 gfc_free_ref_list (new_ref
);
6660 return resolve_compcall (e
, NULL
);
6663 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6665 /* Treat the call as if it is a typebound procedure, in order to roll
6666 out the correct name for the specific function. */
6667 if (!resolve_compcall (e
, &name
))
6669 gfc_free_ref_list (new_ref
);
6676 /* Convert the expression to a procedure pointer component call. */
6677 e
->value
.function
.esym
= NULL
;
6683 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6684 gfc_add_vptr_component (e
);
6685 gfc_add_component_ref (e
, name
);
6687 /* Recover the typespec for the expression. This is really only
6688 necessary for generic procedures, where the additional call
6689 to gfc_add_component_ref seems to throw the collection of the
6690 correct typespec. */
6694 gfc_free_ref_list (new_ref
);
6699 /* Resolve a typebound subroutine, or 'method'. First separate all
6700 the non-CLASS references by calling resolve_typebound_call
6704 resolve_typebound_subroutine (gfc_code
*code
)
6706 gfc_symbol
*declared
;
6716 st
= code
->expr1
->symtree
;
6718 /* Deal with typebound operators for CLASS objects. */
6719 expr
= code
->expr1
->value
.compcall
.base_object
;
6720 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6721 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6723 /* If the base_object is not a variable, the corresponding actual
6724 argument expression must be stored in e->base_expression so
6725 that the corresponding tree temporary can be used as the base
6726 object in gfc_conv_procedure_call. */
6727 if (expr
->expr_type
!= EXPR_VARIABLE
)
6729 gfc_actual_arglist
*args
;
6731 args
= code
->expr1
->value
.function
.actual
;
6732 for (; args
; args
= args
->next
)
6733 if (expr
== args
->expr
)
6737 /* Since the typebound operators are generic, we have to ensure
6738 that any delays in resolution are corrected and that the vtab
6740 declared
= expr
->ts
.u
.derived
;
6741 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6742 if (c
->ts
.u
.derived
== NULL
)
6743 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6745 if (!resolve_typebound_call (code
, &name
, NULL
))
6748 /* Use the generic name if it is there. */
6749 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6750 code
->expr1
->symtree
= expr
->symtree
;
6751 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6753 /* Trim away the extraneous references that emerge from nested
6754 use of interface.c (extend_expr). */
6755 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6756 if (class_ref
&& class_ref
->next
)
6758 gfc_free_ref_list (class_ref
->next
);
6759 class_ref
->next
= NULL
;
6761 else if (code
->expr1
->ref
&& !class_ref
)
6763 gfc_free_ref_list (code
->expr1
->ref
);
6764 code
->expr1
->ref
= NULL
;
6767 /* Now use the procedure in the vtable. */
6768 gfc_add_vptr_component (code
->expr1
);
6769 gfc_add_component_ref (code
->expr1
, name
);
6770 code
->expr1
->value
.function
.esym
= NULL
;
6771 if (expr
->expr_type
!= EXPR_VARIABLE
)
6772 code
->expr1
->base_expr
= expr
;
6777 return resolve_typebound_call (code
, NULL
, NULL
);
6779 if (!gfc_resolve_ref (code
->expr1
))
6782 /* Get the CLASS declared type. */
6783 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6785 /* Weed out cases of the ultimate component being a derived type. */
6786 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6787 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6789 gfc_free_ref_list (new_ref
);
6790 return resolve_typebound_call (code
, NULL
, NULL
);
6793 if (!resolve_typebound_call (code
, &name
, &overridable
))
6795 gfc_free_ref_list (new_ref
);
6798 ts
= code
->expr1
->ts
;
6802 /* Convert the expression to a procedure pointer component call. */
6803 code
->expr1
->value
.function
.esym
= NULL
;
6804 code
->expr1
->symtree
= st
;
6807 code
->expr1
->ref
= new_ref
;
6809 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6810 gfc_add_vptr_component (code
->expr1
);
6811 gfc_add_component_ref (code
->expr1
, name
);
6813 /* Recover the typespec for the expression. This is really only
6814 necessary for generic procedures, where the additional call
6815 to gfc_add_component_ref seems to throw the collection of the
6816 correct typespec. */
6817 code
->expr1
->ts
= ts
;
6820 gfc_free_ref_list (new_ref
);
6826 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6829 resolve_ppc_call (gfc_code
* c
)
6831 gfc_component
*comp
;
6833 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6834 gcc_assert (comp
!= NULL
);
6836 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6837 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6839 if (!comp
->attr
.subroutine
)
6840 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6842 if (!gfc_resolve_ref (c
->expr1
))
6845 if (!update_ppc_arglist (c
->expr1
))
6848 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6850 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6851 !(comp
->ts
.interface
6852 && comp
->ts
.interface
->formal
)))
6855 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6858 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6864 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6867 resolve_expr_ppc (gfc_expr
* e
)
6869 gfc_component
*comp
;
6871 comp
= gfc_get_proc_ptr_comp (e
);
6872 gcc_assert (comp
!= NULL
);
6874 /* Convert to EXPR_FUNCTION. */
6875 e
->expr_type
= EXPR_FUNCTION
;
6876 e
->value
.function
.isym
= NULL
;
6877 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6879 if (comp
->as
!= NULL
)
6880 e
->rank
= comp
->as
->rank
;
6882 if (!comp
->attr
.function
)
6883 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6885 if (!gfc_resolve_ref (e
))
6888 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6889 !(comp
->ts
.interface
6890 && comp
->ts
.interface
->formal
)))
6893 if (!update_ppc_arglist (e
))
6896 if (!check_pure_function(e
))
6899 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6906 gfc_is_expandable_expr (gfc_expr
*e
)
6908 gfc_constructor
*con
;
6910 if (e
->expr_type
== EXPR_ARRAY
)
6912 /* Traverse the constructor looking for variables that are flavor
6913 parameter. Parameters must be expanded since they are fully used at
6915 con
= gfc_constructor_first (e
->value
.constructor
);
6916 for (; con
; con
= gfc_constructor_next (con
))
6918 if (con
->expr
->expr_type
== EXPR_VARIABLE
6919 && con
->expr
->symtree
6920 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6921 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6923 if (con
->expr
->expr_type
== EXPR_ARRAY
6924 && gfc_is_expandable_expr (con
->expr
))
6933 /* Sometimes variables in specification expressions of the result
6934 of module procedures in submodules wind up not being the 'real'
6935 dummy. Find this, if possible, in the namespace of the first
6939 fixup_unique_dummy (gfc_expr
*e
)
6941 gfc_symtree
*st
= NULL
;
6942 gfc_symbol
*s
= NULL
;
6944 if (e
->symtree
->n
.sym
->ns
->proc_name
6945 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6946 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6949 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6952 && st
->n
.sym
!= NULL
6953 && st
->n
.sym
->attr
.dummy
)
6957 /* Resolve an expression. That is, make sure that types of operands agree
6958 with their operators, intrinsic operators are converted to function calls
6959 for overloaded types and unresolved function references are resolved. */
6962 gfc_resolve_expr (gfc_expr
*e
)
6965 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6967 if (e
== NULL
|| e
->do_not_resolve_again
)
6970 /* inquiry_argument only applies to variables. */
6971 inquiry_save
= inquiry_argument
;
6972 actual_arg_save
= actual_arg
;
6973 first_actual_arg_save
= first_actual_arg
;
6975 if (e
->expr_type
!= EXPR_VARIABLE
)
6977 inquiry_argument
= false;
6979 first_actual_arg
= false;
6981 else if (e
->symtree
!= NULL
6982 && *e
->symtree
->name
== '@'
6983 && e
->symtree
->n
.sym
->attr
.dummy
)
6985 /* Deal with submodule specification expressions that are not
6986 found to be referenced in module.c(read_cleanup). */
6987 fixup_unique_dummy (e
);
6990 switch (e
->expr_type
)
6993 t
= resolve_operator (e
);
6999 if (check_host_association (e
))
7000 t
= resolve_function (e
);
7002 t
= resolve_variable (e
);
7004 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
7005 && e
->ref
->type
!= REF_SUBSTRING
)
7006 gfc_resolve_substring_charlen (e
);
7011 t
= resolve_typebound_function (e
);
7014 case EXPR_SUBSTRING
:
7015 t
= gfc_resolve_ref (e
);
7024 t
= resolve_expr_ppc (e
);
7029 if (!gfc_resolve_ref (e
))
7032 t
= gfc_resolve_array_constructor (e
);
7033 /* Also try to expand a constructor. */
7036 gfc_expression_rank (e
);
7037 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
7038 gfc_expand_constructor (e
, false);
7041 /* This provides the opportunity for the length of constructors with
7042 character valued function elements to propagate the string length
7043 to the expression. */
7044 if (t
&& e
->ts
.type
== BT_CHARACTER
)
7046 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
7047 here rather then add a duplicate test for it above. */
7048 gfc_expand_constructor (e
, false);
7049 t
= gfc_resolve_character_array_constructor (e
);
7054 case EXPR_STRUCTURE
:
7055 t
= gfc_resolve_ref (e
);
7059 t
= resolve_structure_cons (e
, 0);
7063 t
= gfc_simplify_expr (e
, 0);
7067 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7070 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
7073 inquiry_argument
= inquiry_save
;
7074 actual_arg
= actual_arg_save
;
7075 first_actual_arg
= first_actual_arg_save
;
7077 /* For some reason, resolving these expressions a second time mangles
7078 the typespec of the expression itself. */
7079 if (t
&& e
->expr_type
== EXPR_VARIABLE
7080 && e
->symtree
->n
.sym
->attr
.select_rank_temporary
7081 && UNLIMITED_POLY (e
->symtree
->n
.sym
))
7082 e
->do_not_resolve_again
= 1;
7088 /* Resolve an expression from an iterator. They must be scalar and have
7089 INTEGER or (optionally) REAL type. */
7092 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
7093 const char *name_msgid
)
7095 if (!gfc_resolve_expr (expr
))
7098 if (expr
->rank
!= 0)
7100 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7104 if (expr
->ts
.type
!= BT_INTEGER
)
7106 if (expr
->ts
.type
== BT_REAL
)
7109 return gfc_notify_std (GFC_STD_F95_DEL
,
7110 "%s at %L must be integer",
7111 _(name_msgid
), &expr
->where
);
7114 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7121 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7129 /* Resolve the expressions in an iterator structure. If REAL_OK is
7130 false allow only INTEGER type iterators, otherwise allow REAL types.
7131 Set own_scope to true for ac-implied-do and data-implied-do as those
7132 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7135 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7137 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7140 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7141 _("iterator variable")))
7144 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7145 "Start expression in DO loop"))
7148 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7149 "End expression in DO loop"))
7152 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7153 "Step expression in DO loop"))
7156 /* Convert start, end, and step to the same type as var. */
7157 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7158 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7159 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7161 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7162 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7163 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7165 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7166 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7167 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7169 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7171 if ((iter
->step
->ts
.type
== BT_INTEGER
7172 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7173 || (iter
->step
->ts
.type
== BT_REAL
7174 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7176 gfc_error ("Step expression in DO loop at %L cannot be zero",
7177 &iter
->step
->where
);
7182 if (iter
->start
->expr_type
== EXPR_CONSTANT
7183 && iter
->end
->expr_type
== EXPR_CONSTANT
7184 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7187 if (iter
->start
->ts
.type
== BT_INTEGER
)
7189 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7190 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7194 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7195 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7197 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7198 gfc_warning (OPT_Wzerotrip
,
7199 "DO loop at %L will be executed zero times",
7200 &iter
->step
->where
);
7203 if (iter
->end
->expr_type
== EXPR_CONSTANT
7204 && iter
->end
->ts
.type
== BT_INTEGER
7205 && iter
->step
->expr_type
== EXPR_CONSTANT
7206 && iter
->step
->ts
.type
== BT_INTEGER
7207 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7208 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7210 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7211 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7213 if (is_step_positive
7214 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7215 gfc_warning (OPT_Wundefined_do_loop
,
7216 "DO loop at %L is undefined as it overflows",
7217 &iter
->step
->where
);
7218 else if (!is_step_positive
7219 && mpz_cmp (iter
->end
->value
.integer
,
7220 gfc_integer_kinds
[k
].min_int
) == 0)
7221 gfc_warning (OPT_Wundefined_do_loop
,
7222 "DO loop at %L is undefined as it underflows",
7223 &iter
->step
->where
);
7230 /* Traversal function for find_forall_index. f == 2 signals that
7231 that variable itself is not to be checked - only the references. */
7234 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7236 if (expr
->expr_type
!= EXPR_VARIABLE
)
7239 /* A scalar assignment */
7240 if (!expr
->ref
|| *f
== 1)
7242 if (expr
->symtree
->n
.sym
== sym
)
7254 /* Check whether the FORALL index appears in the expression or not.
7255 Returns true if SYM is found in EXPR. */
7258 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7260 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7267 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7268 to be a scalar INTEGER variable. The subscripts and stride are scalar
7269 INTEGERs, and if stride is a constant it must be nonzero.
7270 Furthermore "A subscript or stride in a forall-triplet-spec shall
7271 not contain a reference to any index-name in the
7272 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7275 resolve_forall_iterators (gfc_forall_iterator
*it
)
7277 gfc_forall_iterator
*iter
, *iter2
;
7279 for (iter
= it
; iter
; iter
= iter
->next
)
7281 if (gfc_resolve_expr (iter
->var
)
7282 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7283 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7286 if (gfc_resolve_expr (iter
->start
)
7287 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7288 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7289 &iter
->start
->where
);
7290 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7291 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7293 if (gfc_resolve_expr (iter
->end
)
7294 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7295 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7297 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7298 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7300 if (gfc_resolve_expr (iter
->stride
))
7302 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7303 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7304 &iter
->stride
->where
, "INTEGER");
7306 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7307 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7308 gfc_error ("FORALL stride expression at %L cannot be zero",
7309 &iter
->stride
->where
);
7311 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7312 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7315 for (iter
= it
; iter
; iter
= iter
->next
)
7316 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7318 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7319 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7320 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7321 gfc_error ("FORALL index %qs may not appear in triplet "
7322 "specification at %L", iter
->var
->symtree
->name
,
7323 &iter2
->start
->where
);
7328 /* Given a pointer to a symbol that is a derived type, see if it's
7329 inaccessible, i.e. if it's defined in another module and the components are
7330 PRIVATE. The search is recursive if necessary. Returns zero if no
7331 inaccessible components are found, nonzero otherwise. */
7334 derived_inaccessible (gfc_symbol
*sym
)
7338 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7341 for (c
= sym
->components
; c
; c
= c
->next
)
7343 /* Prevent an infinite loop through this function. */
7344 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7345 && sym
== c
->ts
.u
.derived
)
7348 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7356 /* Resolve the argument of a deallocate expression. The expression must be
7357 a pointer or a full array. */
7360 resolve_deallocate_expr (gfc_expr
*e
)
7362 symbol_attribute attr
;
7363 int allocatable
, pointer
;
7369 if (!gfc_resolve_expr (e
))
7372 if (e
->expr_type
!= EXPR_VARIABLE
)
7375 sym
= e
->symtree
->n
.sym
;
7376 unlimited
= UNLIMITED_POLY(sym
);
7378 if (sym
->ts
.type
== BT_CLASS
)
7380 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7381 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7385 allocatable
= sym
->attr
.allocatable
;
7386 pointer
= sym
->attr
.pointer
;
7388 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7393 if (ref
->u
.ar
.type
!= AR_FULL
7394 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7395 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7400 c
= ref
->u
.c
.component
;
7401 if (c
->ts
.type
== BT_CLASS
)
7403 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7404 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7408 allocatable
= c
->attr
.allocatable
;
7409 pointer
= c
->attr
.pointer
;
7420 attr
= gfc_expr_attr (e
);
7422 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7425 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7431 if (gfc_is_coindexed (e
))
7433 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7438 && !gfc_check_vardef_context (e
, true, true, false,
7439 _("DEALLOCATE object")))
7441 if (!gfc_check_vardef_context (e
, false, true, false,
7442 _("DEALLOCATE object")))
7449 /* Returns true if the expression e contains a reference to the symbol sym. */
7451 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7453 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7460 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7462 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7466 /* Given the expression node e for an allocatable/pointer of derived type to be
7467 allocated, get the expression node to be initialized afterwards (needed for
7468 derived types with default initializers, and derived types with allocatable
7469 components that need nullification.) */
7472 gfc_expr_to_initialize (gfc_expr
*e
)
7478 result
= gfc_copy_expr (e
);
7480 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7481 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7482 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7484 if (ref
->u
.ar
.dimen
== 0
7485 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->corank
)
7488 ref
->u
.ar
.type
= AR_FULL
;
7490 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7491 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7496 gfc_free_shape (&result
->shape
, result
->rank
);
7498 /* Recalculate rank, shape, etc. */
7499 gfc_resolve_expr (result
);
7504 /* If the last ref of an expression is an array ref, return a copy of the
7505 expression with that one removed. Otherwise, a copy of the original
7506 expression. This is used for allocate-expressions and pointer assignment
7507 LHS, where there may be an array specification that needs to be stripped
7508 off when using gfc_check_vardef_context. */
7511 remove_last_array_ref (gfc_expr
* e
)
7516 e2
= gfc_copy_expr (e
);
7517 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7518 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7520 gfc_free_ref_list (*r
);
7529 /* Used in resolve_allocate_expr to check that a allocation-object and
7530 a source-expr are conformable. This does not catch all possible
7531 cases; in particular a runtime checking is needed. */
7534 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7537 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7539 /* First compare rank. */
7540 if ((tail
&& (!tail
->u
.ar
.as
|| e1
->rank
!= tail
->u
.ar
.as
->rank
))
7541 || (!tail
&& e1
->rank
!= e2
->rank
))
7543 gfc_error ("Source-expr at %L must be scalar or have the "
7544 "same rank as the allocate-object at %L",
7545 &e1
->where
, &e2
->where
);
7556 for (i
= 0; i
< e1
->rank
; i
++)
7558 if (tail
->u
.ar
.start
[i
] == NULL
)
7561 if (tail
->u
.ar
.end
[i
])
7563 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7564 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7565 mpz_add_ui (s
, s
, 1);
7569 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7572 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7574 gfc_error ("Source-expr at %L and allocate-object at %L must "
7575 "have the same shape", &e1
->where
, &e2
->where
);
7588 /* Resolve the expression in an ALLOCATE statement, doing the additional
7589 checks to see whether the expression is OK or not. The expression must
7590 have a trailing array reference that gives the size of the array. */
7593 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7595 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7599 symbol_attribute attr
;
7600 gfc_ref
*ref
, *ref2
;
7603 gfc_symbol
*sym
= NULL
;
7608 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7609 checking of coarrays. */
7610 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7611 if (ref
->next
== NULL
)
7614 if (ref
&& ref
->type
== REF_ARRAY
)
7615 ref
->u
.ar
.in_allocate
= true;
7617 if (!gfc_resolve_expr (e
))
7620 /* Make sure the expression is allocatable or a pointer. If it is
7621 pointer, the next-to-last reference must be a pointer. */
7625 sym
= e
->symtree
->n
.sym
;
7627 /* Check whether ultimate component is abstract and CLASS. */
7630 /* Is the allocate-object unlimited polymorphic? */
7631 unlimited
= UNLIMITED_POLY(e
);
7633 if (e
->expr_type
!= EXPR_VARIABLE
)
7636 attr
= gfc_expr_attr (e
);
7637 pointer
= attr
.pointer
;
7638 dimension
= attr
.dimension
;
7639 codimension
= attr
.codimension
;
7643 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7645 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7646 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7647 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7648 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7649 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7653 allocatable
= sym
->attr
.allocatable
;
7654 pointer
= sym
->attr
.pointer
;
7655 dimension
= sym
->attr
.dimension
;
7656 codimension
= sym
->attr
.codimension
;
7661 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7666 if (ref
->u
.ar
.codimen
> 0)
7669 for (n
= ref
->u
.ar
.dimen
;
7670 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7671 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7678 if (ref
->next
!= NULL
)
7686 gfc_error ("Coindexed allocatable object at %L",
7691 c
= ref
->u
.c
.component
;
7692 if (c
->ts
.type
== BT_CLASS
)
7694 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7695 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7696 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7697 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7698 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7702 allocatable
= c
->attr
.allocatable
;
7703 pointer
= c
->attr
.pointer
;
7704 dimension
= c
->attr
.dimension
;
7705 codimension
= c
->attr
.codimension
;
7706 is_abstract
= c
->attr
.abstract
;
7719 /* Check for F08:C628. */
7720 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7722 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7727 /* Some checks for the SOURCE tag. */
7730 /* Check F03:C631. */
7731 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7733 gfc_error ("Type of entity at %L is type incompatible with "
7734 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7738 /* Check F03:C632 and restriction following Note 6.18. */
7739 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7742 /* Check F03:C633. */
7743 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7745 gfc_error ("The allocate-object at %L and the source-expr at %L "
7746 "shall have the same kind type parameter",
7747 &e
->where
, &code
->expr3
->where
);
7751 /* Check F2008, C642. */
7752 if (code
->expr3
->ts
.type
== BT_DERIVED
7753 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7754 || (code
->expr3
->ts
.u
.derived
->from_intmod
7755 == INTMOD_ISO_FORTRAN_ENV
7756 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7757 == ISOFORTRAN_LOCK_TYPE
)))
7759 gfc_error ("The source-expr at %L shall neither be of type "
7760 "LOCK_TYPE nor have a LOCK_TYPE component if "
7761 "allocate-object at %L is a coarray",
7762 &code
->expr3
->where
, &e
->where
);
7766 /* Check TS18508, C702/C703. */
7767 if (code
->expr3
->ts
.type
== BT_DERIVED
7768 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7769 || (code
->expr3
->ts
.u
.derived
->from_intmod
7770 == INTMOD_ISO_FORTRAN_ENV
7771 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7772 == ISOFORTRAN_EVENT_TYPE
)))
7774 gfc_error ("The source-expr at %L shall neither be of type "
7775 "EVENT_TYPE nor have a EVENT_TYPE component if "
7776 "allocate-object at %L is a coarray",
7777 &code
->expr3
->where
, &e
->where
);
7782 /* Check F08:C629. */
7783 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7786 gcc_assert (e
->ts
.type
== BT_CLASS
);
7787 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7788 "type-spec or source-expr", sym
->name
, &e
->where
);
7792 /* Check F08:C632. */
7793 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7794 && !UNLIMITED_POLY (e
))
7798 if (!e
->ts
.u
.cl
->length
)
7801 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7802 code
->ext
.alloc
.ts
.u
.cl
->length
);
7803 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7805 gfc_error ("Allocating %s at %L with type-spec requires the same "
7806 "character-length parameter as in the declaration",
7807 sym
->name
, &e
->where
);
7812 /* In the variable definition context checks, gfc_expr_attr is used
7813 on the expression. This is fooled by the array specification
7814 present in e, thus we have to eliminate that one temporarily. */
7815 e2
= remove_last_array_ref (e
);
7818 t
= gfc_check_vardef_context (e2
, true, true, false,
7819 _("ALLOCATE object"));
7821 t
= gfc_check_vardef_context (e2
, false, true, false,
7822 _("ALLOCATE object"));
7827 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7828 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7830 /* For class arrays, the initialization with SOURCE is done
7831 using _copy and trans_call. It is convenient to exploit that
7832 when the allocated type is different from the declared type but
7833 no SOURCE exists by setting expr3. */
7834 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7836 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7837 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7838 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7840 /* We have to zero initialize the integer variable. */
7841 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7844 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7846 /* Make sure the vtab symbol is present when
7847 the module variables are generated. */
7848 gfc_typespec ts
= e
->ts
;
7850 ts
= code
->expr3
->ts
;
7851 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7852 ts
= code
->ext
.alloc
.ts
;
7854 /* Finding the vtab also publishes the type's symbol. Therefore this
7855 statement is necessary. */
7856 gfc_find_derived_vtab (ts
.u
.derived
);
7858 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7860 /* Again, make sure the vtab symbol is present when
7861 the module variables are generated. */
7862 gfc_typespec
*ts
= NULL
;
7864 ts
= &code
->expr3
->ts
;
7866 ts
= &code
->ext
.alloc
.ts
;
7870 /* Finding the vtab also publishes the type's symbol. Therefore this
7871 statement is necessary. */
7875 if (dimension
== 0 && codimension
== 0)
7878 /* Make sure the last reference node is an array specification. */
7880 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7881 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7886 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7887 "in ALLOCATE statement at %L", &e
->where
))
7889 if (code
->expr3
->rank
!= 0)
7890 *array_alloc_wo_spec
= true;
7893 gfc_error ("Array specification or array-valued SOURCE= "
7894 "expression required in ALLOCATE statement at %L",
7901 gfc_error ("Array specification required in ALLOCATE statement "
7902 "at %L", &e
->where
);
7907 /* Make sure that the array section reference makes sense in the
7908 context of an ALLOCATE specification. */
7913 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7915 switch (ar
->dimen_type
[i
])
7917 case DIMEN_THIS_IMAGE
:
7918 gfc_error ("Coarray specification required in ALLOCATE statement "
7919 "at %L", &e
->where
);
7923 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0)
7925 /* If ar->stride[i] is NULL, we issued a previous error. */
7926 if (ar
->stride
[i
] == NULL
)
7927 gfc_error ("Bad array specification in ALLOCATE statement "
7928 "at %L", &e
->where
);
7931 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
7933 gfc_error ("Upper cobound is less than lower cobound at %L",
7934 &ar
->start
[i
]->where
);
7940 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
7942 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
7943 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
7945 gfc_error ("Upper cobound is less than lower cobound "
7946 "of 1 at %L", &ar
->start
[i
]->where
);
7956 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7962 for (i
= 0; i
< ar
->dimen
; i
++)
7964 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7967 switch (ar
->dimen_type
[i
])
7973 if (ar
->start
[i
] != NULL
7974 && ar
->end
[i
] != NULL
7975 && ar
->stride
[i
] == NULL
)
7983 case DIMEN_THIS_IMAGE
:
7984 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7990 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7992 sym
= a
->expr
->symtree
->n
.sym
;
7994 /* TODO - check derived type components. */
7995 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7998 if ((ar
->start
[i
] != NULL
7999 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
8000 || (ar
->end
[i
] != NULL
8001 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
8003 gfc_error ("%qs must not appear in the array specification at "
8004 "%L in the same ALLOCATE statement where it is "
8005 "itself allocated", sym
->name
, &ar
->where
);
8011 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
8013 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
8014 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
8016 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
8018 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
8019 "statement at %L", &e
->where
);
8025 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
8026 && ar
->stride
[i
] == NULL
)
8029 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
8043 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
8045 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
8046 gfc_alloc
*a
, *p
, *q
;
8049 errmsg
= code
->expr2
;
8051 /* Check the stat variable. */
8054 gfc_check_vardef_context (stat
, false, false, false,
8055 _("STAT variable"));
8057 if ((stat
->ts
.type
!= BT_INTEGER
8058 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
8059 || stat
->ref
->type
== REF_COMPONENT
)))
8061 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8062 "variable", &stat
->where
);
8064 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8065 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
8067 gfc_ref
*ref1
, *ref2
;
8070 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
8071 ref1
= ref1
->next
, ref2
= ref2
->next
)
8073 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8075 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8084 gfc_error ("Stat-variable at %L shall not be %sd within "
8085 "the same %s statement", &stat
->where
, fcn
, fcn
);
8091 /* Check the errmsg variable. */
8095 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8098 gfc_check_vardef_context (errmsg
, false, false, false,
8099 _("ERRMSG variable"));
8101 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8102 F18:R930 errmsg-variable is scalar-default-char-variable
8103 F18:R906 default-char-variable is variable
8104 F18:C906 default-char-variable shall be default character. */
8105 if ((errmsg
->ts
.type
!= BT_CHARACTER
8107 && (errmsg
->ref
->type
== REF_ARRAY
8108 || errmsg
->ref
->type
== REF_COMPONENT
)))
8110 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8111 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8112 "variable", &errmsg
->where
);
8114 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8115 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8117 gfc_ref
*ref1
, *ref2
;
8120 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
8121 ref1
= ref1
->next
, ref2
= ref2
->next
)
8123 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8125 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8134 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8135 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8141 /* Check that an allocate-object appears only once in the statement. */
8143 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8146 for (q
= p
->next
; q
; q
= q
->next
)
8149 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8151 /* This is a potential collision. */
8152 gfc_ref
*pr
= pe
->ref
;
8153 gfc_ref
*qr
= qe
->ref
;
8155 /* Follow the references until
8156 a) They start to differ, in which case there is no error;
8157 you can deallocate a%b and a%c in a single statement
8158 b) Both of them stop, which is an error
8159 c) One of them stops, which is also an error. */
8162 if (pr
== NULL
&& qr
== NULL
)
8164 gfc_error ("Allocate-object at %L also appears at %L",
8165 &pe
->where
, &qe
->where
);
8168 else if (pr
!= NULL
&& qr
== NULL
)
8170 gfc_error ("Allocate-object at %L is subobject of"
8171 " object at %L", &pe
->where
, &qe
->where
);
8174 else if (pr
== NULL
&& qr
!= NULL
)
8176 gfc_error ("Allocate-object at %L is subobject of"
8177 " object at %L", &qe
->where
, &pe
->where
);
8180 /* Here, pr != NULL && qr != NULL */
8181 gcc_assert(pr
->type
== qr
->type
);
8182 if (pr
->type
== REF_ARRAY
)
8184 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8186 gcc_assert (qr
->type
== REF_ARRAY
);
8188 if (pr
->next
&& qr
->next
)
8191 gfc_array_ref
*par
= &(pr
->u
.ar
);
8192 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8194 for (i
=0; i
<par
->dimen
; i
++)
8196 if ((par
->start
[i
] != NULL
8197 || qar
->start
[i
] != NULL
)
8198 && gfc_dep_compare_expr (par
->start
[i
],
8199 qar
->start
[i
]) != 0)
8206 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8219 if (strcmp (fcn
, "ALLOCATE") == 0)
8221 bool arr_alloc_wo_spec
= false;
8223 /* Resolving the expr3 in the loop over all objects to allocate would
8224 execute loop invariant code for each loop item. Therefore do it just
8226 if (code
->expr3
&& code
->expr3
->mold
8227 && code
->expr3
->ts
.type
== BT_DERIVED
)
8229 /* Default initialization via MOLD (non-polymorphic). */
8230 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8233 gfc_resolve_expr (rhs
);
8234 gfc_free_expr (code
->expr3
);
8238 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8239 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8241 if (arr_alloc_wo_spec
&& code
->expr3
)
8243 /* Mark the allocate to have to take the array specification
8245 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8250 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8251 resolve_deallocate_expr (a
->expr
);
8256 /************ SELECT CASE resolution subroutines ************/
8258 /* Callback function for our mergesort variant. Determines interval
8259 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8260 op1 > op2. Assumes we're not dealing with the default case.
8261 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8262 There are nine situations to check. */
8265 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8269 if (op1
->low
== NULL
) /* op1 = (:L) */
8271 /* op2 = (:N), so overlap. */
8273 /* op2 = (M:) or (M:N), L < M */
8274 if (op2
->low
!= NULL
8275 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8278 else if (op1
->high
== NULL
) /* op1 = (K:) */
8280 /* op2 = (M:), so overlap. */
8282 /* op2 = (:N) or (M:N), K > N */
8283 if (op2
->high
!= NULL
8284 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8287 else /* op1 = (K:L) */
8289 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8290 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8292 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8293 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8295 else /* op2 = (M:N) */
8299 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8302 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8311 /* Merge-sort a double linked case list, detecting overlap in the
8312 process. LIST is the head of the double linked case list before it
8313 is sorted. Returns the head of the sorted list if we don't see any
8314 overlap, or NULL otherwise. */
8317 check_case_overlap (gfc_case
*list
)
8319 gfc_case
*p
, *q
, *e
, *tail
;
8320 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8322 /* If the passed list was empty, return immediately. */
8329 /* Loop unconditionally. The only exit from this loop is a return
8330 statement, when we've finished sorting the case list. */
8337 /* Count the number of merges we do in this pass. */
8340 /* Loop while there exists a merge to be done. */
8345 /* Count this merge. */
8348 /* Cut the list in two pieces by stepping INSIZE places
8349 forward in the list, starting from P. */
8352 for (i
= 0; i
< insize
; i
++)
8361 /* Now we have two lists. Merge them! */
8362 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8364 /* See from which the next case to merge comes from. */
8367 /* P is empty so the next case must come from Q. */
8372 else if (qsize
== 0 || q
== NULL
)
8381 cmp
= compare_cases (p
, q
);
8384 /* The whole case range for P is less than the
8392 /* The whole case range for Q is greater than
8393 the case range for P. */
8400 /* The cases overlap, or they are the same
8401 element in the list. Either way, we must
8402 issue an error and get the next case from P. */
8403 /* FIXME: Sort P and Q by line number. */
8404 gfc_error ("CASE label at %L overlaps with CASE "
8405 "label at %L", &p
->where
, &q
->where
);
8413 /* Add the next element to the merged list. */
8422 /* P has now stepped INSIZE places along, and so has Q. So
8423 they're the same. */
8428 /* If we have done only one merge or none at all, we've
8429 finished sorting the cases. */
8438 /* Otherwise repeat, merging lists twice the size. */
8444 /* Check to see if an expression is suitable for use in a CASE statement.
8445 Makes sure that all case expressions are scalar constants of the same
8446 type. Return false if anything is wrong. */
8449 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8451 if (e
== NULL
) return true;
8453 if (e
->ts
.type
!= case_expr
->ts
.type
)
8455 gfc_error ("Expression in CASE statement at %L must be of type %s",
8456 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8460 /* C805 (R808) For a given case-construct, each case-value shall be of
8461 the same type as case-expr. For character type, length differences
8462 are allowed, but the kind type parameters shall be the same. */
8464 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8466 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8467 &e
->where
, case_expr
->ts
.kind
);
8471 /* Convert the case value kind to that of case expression kind,
8474 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8475 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8479 gfc_error ("Expression in CASE statement at %L must be scalar",
8488 /* Given a completely parsed select statement, we:
8490 - Validate all expressions and code within the SELECT.
8491 - Make sure that the selection expression is not of the wrong type.
8492 - Make sure that no case ranges overlap.
8493 - Eliminate unreachable cases and unreachable code resulting from
8494 removing case labels.
8496 The standard does allow unreachable cases, e.g. CASE (5:3). But
8497 they are a hassle for code generation, and to prevent that, we just
8498 cut them out here. This is not necessary for overlapping cases
8499 because they are illegal and we never even try to generate code.
8501 We have the additional caveat that a SELECT construct could have
8502 been a computed GOTO in the source code. Fortunately we can fairly
8503 easily work around that here: The case_expr for a "real" SELECT CASE
8504 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8505 we have to do is make sure that the case_expr is a scalar integer
8509 resolve_select (gfc_code
*code
, bool select_type
)
8512 gfc_expr
*case_expr
;
8513 gfc_case
*cp
, *default_case
, *tail
, *head
;
8514 int seen_unreachable
;
8520 if (code
->expr1
== NULL
)
8522 /* This was actually a computed GOTO statement. */
8523 case_expr
= code
->expr2
;
8524 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8525 gfc_error ("Selection expression in computed GOTO statement "
8526 "at %L must be a scalar integer expression",
8529 /* Further checking is not necessary because this SELECT was built
8530 by the compiler, so it should always be OK. Just move the
8531 case_expr from expr2 to expr so that we can handle computed
8532 GOTOs as normal SELECTs from here on. */
8533 code
->expr1
= code
->expr2
;
8538 case_expr
= code
->expr1
;
8539 type
= case_expr
->ts
.type
;
8542 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8544 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8545 &case_expr
->where
, gfc_typename (case_expr
));
8547 /* Punt. Going on here just produce more garbage error messages. */
8552 if (!select_type
&& case_expr
->rank
!= 0)
8554 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8555 "expression", &case_expr
->where
);
8561 /* Raise a warning if an INTEGER case value exceeds the range of
8562 the case-expr. Later, all expressions will be promoted to the
8563 largest kind of all case-labels. */
8565 if (type
== BT_INTEGER
)
8566 for (body
= code
->block
; body
; body
= body
->block
)
8567 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8570 && gfc_check_integer_range (cp
->low
->value
.integer
,
8571 case_expr
->ts
.kind
) != ARITH_OK
)
8572 gfc_warning (0, "Expression in CASE statement at %L is "
8573 "not in the range of %s", &cp
->low
->where
,
8574 gfc_typename (case_expr
));
8577 && cp
->low
!= cp
->high
8578 && gfc_check_integer_range (cp
->high
->value
.integer
,
8579 case_expr
->ts
.kind
) != ARITH_OK
)
8580 gfc_warning (0, "Expression in CASE statement at %L is "
8581 "not in the range of %s", &cp
->high
->where
,
8582 gfc_typename (case_expr
));
8585 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8586 of the SELECT CASE expression and its CASE values. Walk the lists
8587 of case values, and if we find a mismatch, promote case_expr to
8588 the appropriate kind. */
8590 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8592 for (body
= code
->block
; body
; body
= body
->block
)
8594 /* Walk the case label list. */
8595 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8597 /* Intercept the DEFAULT case. It does not have a kind. */
8598 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8601 /* Unreachable case ranges are discarded, so ignore. */
8602 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8603 && cp
->low
!= cp
->high
8604 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8608 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8609 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8611 if (cp
->high
!= NULL
8612 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8613 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8618 /* Assume there is no DEFAULT case. */
8619 default_case
= NULL
;
8624 for (body
= code
->block
; body
; body
= body
->block
)
8626 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8628 seen_unreachable
= 0;
8630 /* Walk the case label list, making sure that all case labels
8632 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8634 /* Count the number of cases in the whole construct. */
8637 /* Intercept the DEFAULT case. */
8638 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8640 if (default_case
!= NULL
)
8642 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8643 "by a second DEFAULT CASE at %L",
8644 &default_case
->where
, &cp
->where
);
8655 /* Deal with single value cases and case ranges. Errors are
8656 issued from the validation function. */
8657 if (!validate_case_label_expr (cp
->low
, case_expr
)
8658 || !validate_case_label_expr (cp
->high
, case_expr
))
8664 if (type
== BT_LOGICAL
8665 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8666 || cp
->low
!= cp
->high
))
8668 gfc_error ("Logical range in CASE statement at %L is not "
8669 "allowed", &cp
->low
->where
);
8674 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8677 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8678 if (value
& seen_logical
)
8680 gfc_error ("Constant logical value in CASE statement "
8681 "is repeated at %L",
8686 seen_logical
|= value
;
8689 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8690 && cp
->low
!= cp
->high
8691 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8693 if (warn_surprising
)
8694 gfc_warning (OPT_Wsurprising
,
8695 "Range specification at %L can never be matched",
8698 cp
->unreachable
= 1;
8699 seen_unreachable
= 1;
8703 /* If the case range can be matched, it can also overlap with
8704 other cases. To make sure it does not, we put it in a
8705 double linked list here. We sort that with a merge sort
8706 later on to detect any overlapping cases. */
8710 head
->right
= head
->left
= NULL
;
8715 tail
->right
->left
= tail
;
8722 /* It there was a failure in the previous case label, give up
8723 for this case label list. Continue with the next block. */
8727 /* See if any case labels that are unreachable have been seen.
8728 If so, we eliminate them. This is a bit of a kludge because
8729 the case lists for a single case statement (label) is a
8730 single forward linked lists. */
8731 if (seen_unreachable
)
8733 /* Advance until the first case in the list is reachable. */
8734 while (body
->ext
.block
.case_list
!= NULL
8735 && body
->ext
.block
.case_list
->unreachable
)
8737 gfc_case
*n
= body
->ext
.block
.case_list
;
8738 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8740 gfc_free_case_list (n
);
8743 /* Strip all other unreachable cases. */
8744 if (body
->ext
.block
.case_list
)
8746 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8748 if (cp
->next
->unreachable
)
8750 gfc_case
*n
= cp
->next
;
8751 cp
->next
= cp
->next
->next
;
8753 gfc_free_case_list (n
);
8760 /* See if there were overlapping cases. If the check returns NULL,
8761 there was overlap. In that case we don't do anything. If head
8762 is non-NULL, we prepend the DEFAULT case. The sorted list can
8763 then used during code generation for SELECT CASE constructs with
8764 a case expression of a CHARACTER type. */
8767 head
= check_case_overlap (head
);
8769 /* Prepend the default_case if it is there. */
8770 if (head
!= NULL
&& default_case
)
8772 default_case
->left
= NULL
;
8773 default_case
->right
= head
;
8774 head
->left
= default_case
;
8778 /* Eliminate dead blocks that may be the result if we've seen
8779 unreachable case labels for a block. */
8780 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8782 if (body
->block
->ext
.block
.case_list
== NULL
)
8784 /* Cut the unreachable block from the code chain. */
8785 gfc_code
*c
= body
->block
;
8786 body
->block
= c
->block
;
8788 /* Kill the dead block, but not the blocks below it. */
8790 gfc_free_statements (c
);
8794 /* More than two cases is legal but insane for logical selects.
8795 Issue a warning for it. */
8796 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8797 gfc_warning (OPT_Wsurprising
,
8798 "Logical SELECT CASE block at %L has more that two cases",
8803 /* Check if a derived type is extensible. */
8806 gfc_type_is_extensible (gfc_symbol
*sym
)
8808 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8809 || (sym
->attr
.is_class
8810 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8815 resolve_types (gfc_namespace
*ns
);
8817 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8818 correct as well as possibly the array-spec. */
8821 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8825 gcc_assert (sym
->assoc
);
8826 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8828 /* If this is for SELECT TYPE, the target may not yet be set. In that
8829 case, return. Resolution will be called later manually again when
8831 target
= sym
->assoc
->target
;
8834 gcc_assert (!sym
->assoc
->dangling
);
8836 if (resolve_target
&& !gfc_resolve_expr (target
))
8839 /* For variable targets, we get some attributes from the target. */
8840 if (target
->expr_type
== EXPR_VARIABLE
)
8844 gcc_assert (target
->symtree
);
8845 tsym
= target
->symtree
->n
.sym
;
8847 if (tsym
->attr
.subroutine
8848 || tsym
->attr
.external
8849 || (tsym
->attr
.function
&& tsym
->result
!= tsym
))
8851 gfc_error ("Associating entity %qs at %L is a procedure name",
8852 tsym
->name
, &target
->where
);
8856 if (gfc_expr_attr (target
).proc_pointer
)
8858 gfc_error ("Associating entity %qs at %L is a procedure pointer",
8859 tsym
->name
, &target
->where
);
8863 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8864 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8866 sym
->attr
.target
= tsym
->attr
.target
8867 || gfc_expr_attr (target
).pointer
;
8868 if (is_subref_array (target
))
8869 sym
->attr
.subref_array_pointer
= 1;
8871 else if (target
->ts
.type
== BT_PROCEDURE
)
8873 gfc_error ("Associating selector-expression at %L yields a procedure",
8878 if (target
->expr_type
== EXPR_NULL
)
8880 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8883 else if (target
->ts
.type
== BT_UNKNOWN
)
8885 gfc_error ("Selector at %L has no type", &target
->where
);
8889 /* Get type if this was not already set. Note that it can be
8890 some other type than the target in case this is a SELECT TYPE
8891 selector! So we must not update when the type is already there. */
8892 if (sym
->ts
.type
== BT_UNKNOWN
)
8893 sym
->ts
= target
->ts
;
8895 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8897 /* See if this is a valid association-to-variable. */
8898 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8899 && !gfc_has_vector_subscript (target
));
8901 /* Finally resolve if this is an array or not. */
8902 if (sym
->attr
.dimension
&& target
->rank
== 0)
8904 /* primary.c makes the assumption that a reference to an associate
8905 name followed by a left parenthesis is an array reference. */
8906 if (sym
->ts
.type
!= BT_CHARACTER
)
8907 gfc_error ("Associate-name %qs at %L is used as array",
8908 sym
->name
, &sym
->declared_at
);
8909 sym
->attr
.dimension
= 0;
8914 /* We cannot deal with class selectors that need temporaries. */
8915 if (target
->ts
.type
== BT_CLASS
8916 && gfc_ref_needs_temporary_p (target
->ref
))
8918 gfc_error ("CLASS selector at %L needs a temporary which is not "
8919 "yet implemented", &target
->where
);
8923 if (target
->ts
.type
== BT_CLASS
)
8924 gfc_fix_class_refs (target
);
8926 if (target
->rank
!= 0 && !sym
->attr
.select_rank_temporary
)
8929 /* The rank may be incorrectly guessed at parsing, therefore make sure
8930 it is corrected now. */
8931 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8934 sym
->as
= gfc_get_array_spec ();
8936 as
->rank
= target
->rank
;
8937 as
->type
= AS_DEFERRED
;
8938 as
->corank
= gfc_get_corank (target
);
8939 sym
->attr
.dimension
= 1;
8940 if (as
->corank
!= 0)
8941 sym
->attr
.codimension
= 1;
8943 else if (sym
->ts
.type
== BT_CLASS
&& (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
8945 if (!CLASS_DATA (sym
)->as
)
8946 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
8947 as
= CLASS_DATA (sym
)->as
;
8948 as
->rank
= target
->rank
;
8949 as
->type
= AS_DEFERRED
;
8950 as
->corank
= gfc_get_corank (target
);
8951 CLASS_DATA (sym
)->attr
.dimension
= 1;
8952 if (as
->corank
!= 0)
8953 CLASS_DATA (sym
)->attr
.codimension
= 1;
8956 else if (!sym
->attr
.select_rank_temporary
)
8958 /* target's rank is 0, but the type of the sym is still array valued,
8959 which has to be corrected. */
8960 if (sym
->ts
.type
== BT_CLASS
8961 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
8964 symbol_attribute attr
;
8965 /* The associated variable's type is still the array type
8966 correct this now. */
8967 gfc_typespec
*ts
= &target
->ts
;
8970 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8975 ts
= &ref
->u
.c
.component
->ts
;
8978 if (ts
->type
== BT_CLASS
)
8979 ts
= &ts
->u
.derived
->components
->ts
;
8985 /* Create a scalar instance of the current class type. Because the
8986 rank of a class array goes into its name, the type has to be
8987 rebuild. The alternative of (re-)setting just the attributes
8988 and as in the current type, destroys the type also in other
8992 sym
->ts
.type
= BT_CLASS
;
8993 attr
= CLASS_DATA (sym
)->attr
;
8995 attr
.associate_var
= 1;
8996 attr
.dimension
= attr
.codimension
= 0;
8997 attr
.class_pointer
= 1;
8998 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
9000 /* Make sure the _vptr is set. */
9001 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
9002 if (c
->ts
.u
.derived
== NULL
)
9003 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
9004 CLASS_DATA (sym
)->attr
.pointer
= 1;
9005 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
9006 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
9007 gfc_commit_symbol (sym
->ts
.u
.derived
);
9008 /* _vptr now has the _vtab in it, change it to the _vtype. */
9009 if (c
->ts
.u
.derived
->attr
.vtab
)
9010 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
9011 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
9012 resolve_types (c
->ts
.u
.derived
->ns
);
9016 /* Mark this as an associate variable. */
9017 sym
->attr
.associate_var
= 1;
9019 /* Fix up the type-spec for CHARACTER types. */
9020 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
9023 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
9025 if (sym
->ts
.deferred
&& target
->expr_type
== EXPR_VARIABLE
9026 && target
->symtree
->n
.sym
->attr
.dummy
9027 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
9029 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
9030 sym
->ts
.deferred
= 1;
9033 if (!sym
->ts
.u
.cl
->length
9034 && !sym
->ts
.deferred
9035 && target
->expr_type
== EXPR_CONSTANT
)
9037 sym
->ts
.u
.cl
->length
=
9038 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
9039 target
->value
.character
.length
);
9041 else if ((!sym
->ts
.u
.cl
->length
9042 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9043 && target
->expr_type
!= EXPR_VARIABLE
)
9045 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
9046 sym
->ts
.deferred
= 1;
9048 /* This is reset in trans-stmt.c after the assignment
9049 of the target expression to the associate name. */
9050 sym
->attr
.allocatable
= 1;
9054 /* If the target is a good class object, so is the associate variable. */
9055 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
9056 sym
->attr
.class_ok
= 1;
9060 /* Ensure that SELECT TYPE expressions have the correct rank and a full
9061 array reference, where necessary. The symbols are artificial and so
9062 the dimension attribute and arrayspec can also be set. In addition,
9063 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
9064 This is corrected here as well.*/
9067 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
9068 int rank
, gfc_ref
*ref
)
9070 gfc_ref
*nref
= (*expr1
)->ref
;
9071 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
9072 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
9073 (*expr1
)->rank
= rank
;
9074 if (sym1
->ts
.type
== BT_CLASS
)
9076 if ((*expr1
)->ts
.type
!= BT_CLASS
)
9077 (*expr1
)->ts
= sym1
->ts
;
9079 CLASS_DATA (sym1
)->attr
.dimension
= 1;
9080 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
9081 CLASS_DATA (sym1
)->as
9082 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
9086 sym1
->attr
.dimension
= 1;
9087 if (sym1
->as
== NULL
&& sym2
)
9088 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
9091 for (; nref
; nref
= nref
->next
)
9092 if (nref
->next
== NULL
)
9095 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
9096 nref
->next
= gfc_copy_ref (ref
);
9097 else if (ref
&& !nref
)
9098 (*expr1
)->ref
= gfc_copy_ref (ref
);
9103 build_loc_call (gfc_expr
*sym_expr
)
9106 loc_call
= gfc_get_expr ();
9107 loc_call
->expr_type
= EXPR_FUNCTION
;
9108 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
9109 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
9110 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
9111 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
9112 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
9113 loc_call
->ts
.type
= BT_INTEGER
;
9114 loc_call
->ts
.kind
= gfc_index_integer_kind
;
9115 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
9116 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
9117 loc_call
->value
.function
.actual
->expr
= sym_expr
;
9118 loc_call
->where
= sym_expr
->where
;
9122 /* Resolve a SELECT TYPE statement. */
9125 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9127 gfc_symbol
*selector_type
;
9128 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9129 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9132 char name
[GFC_MAX_SYMBOL_LEN
];
9136 gfc_ref
* ref
= NULL
;
9137 gfc_expr
*selector_expr
= NULL
;
9139 ns
= code
->ext
.block
.ns
;
9142 /* Check for F03:C813. */
9143 if (code
->expr1
->ts
.type
!= BT_CLASS
9144 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9146 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9147 "at %L", &code
->loc
);
9151 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9156 gfc_ref
*ref2
= NULL
;
9157 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9158 if (ref
->type
== REF_COMPONENT
9159 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9164 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9165 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9166 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9170 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9171 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9172 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
9175 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
9176 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9178 /* F2008: C803 The selector expression must not be coindexed. */
9179 if (gfc_is_coindexed (code
->expr2
))
9181 gfc_error ("Selector at %L must not be coindexed",
9182 &code
->expr2
->where
);
9189 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9191 if (gfc_is_coindexed (code
->expr1
))
9193 gfc_error ("Selector at %L must not be coindexed",
9194 &code
->expr1
->where
);
9199 /* Loop over TYPE IS / CLASS IS cases. */
9200 for (body
= code
->block
; body
; body
= body
->block
)
9202 c
= body
->ext
.block
.case_list
;
9206 /* Check for repeated cases. */
9207 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9209 gfc_case
*d
= tail
->ext
.block
.case_list
;
9213 if (c
->ts
.type
== d
->ts
.type
9214 && ((c
->ts
.type
== BT_DERIVED
9215 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9216 && !strcmp (c
->ts
.u
.derived
->name
,
9217 d
->ts
.u
.derived
->name
))
9218 || c
->ts
.type
== BT_UNKNOWN
9219 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9220 && c
->ts
.kind
== d
->ts
.kind
)))
9222 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9223 &c
->where
, &d
->where
);
9229 /* Check F03:C815. */
9230 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9231 && !selector_type
->attr
.unlimited_polymorphic
9232 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9234 gfc_error ("Derived type %qs at %L must be extensible",
9235 c
->ts
.u
.derived
->name
, &c
->where
);
9240 /* Check F03:C816. */
9241 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
9242 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9243 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9245 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9246 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9247 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9249 gfc_error ("Unexpected intrinsic type %qs at %L",
9250 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9255 /* Check F03:C814. */
9256 if (c
->ts
.type
== BT_CHARACTER
9257 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9259 gfc_error ("The type-spec at %L shall specify that each length "
9260 "type parameter is assumed", &c
->where
);
9265 /* Intercept the DEFAULT case. */
9266 if (c
->ts
.type
== BT_UNKNOWN
)
9268 /* Check F03:C818. */
9271 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9272 "by a second DEFAULT CASE at %L",
9273 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9278 default_case
= body
;
9285 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9286 target if present. If there are any EXIT statements referring to the
9287 SELECT TYPE construct, this is no problem because the gfc_code
9288 reference stays the same and EXIT is equally possible from the BLOCK
9289 it is changed to. */
9290 code
->op
= EXEC_BLOCK
;
9293 gfc_association_list
* assoc
;
9295 assoc
= gfc_get_association_list ();
9296 assoc
->st
= code
->expr1
->symtree
;
9297 assoc
->target
= gfc_copy_expr (code
->expr2
);
9298 assoc
->target
->where
= code
->expr2
->where
;
9299 /* assoc->variable will be set by resolve_assoc_var. */
9301 code
->ext
.block
.assoc
= assoc
;
9302 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9304 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9307 code
->ext
.block
.assoc
= NULL
;
9309 /* Ensure that the selector rank and arrayspec are available to
9310 correct expressions in which they might be missing. */
9311 if (code
->expr2
&& code
->expr2
->rank
)
9313 rank
= code
->expr2
->rank
;
9314 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9315 if (ref
->next
== NULL
)
9317 if (ref
&& ref
->type
== REF_ARRAY
)
9318 ref
= gfc_copy_ref (ref
);
9320 /* Fixup expr1 if necessary. */
9322 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9324 else if (code
->expr1
->rank
)
9326 rank
= code
->expr1
->rank
;
9327 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9328 if (ref
->next
== NULL
)
9330 if (ref
&& ref
->type
== REF_ARRAY
)
9331 ref
= gfc_copy_ref (ref
);
9334 /* Add EXEC_SELECT to switch on type. */
9335 new_st
= gfc_get_code (code
->op
);
9336 new_st
->expr1
= code
->expr1
;
9337 new_st
->expr2
= code
->expr2
;
9338 new_st
->block
= code
->block
;
9339 code
->expr1
= code
->expr2
= NULL
;
9344 ns
->code
->next
= new_st
;
9346 code
->op
= EXEC_SELECT_TYPE
;
9348 /* Use the intrinsic LOC function to generate an integer expression
9349 for the vtable of the selector. Note that the rank of the selector
9350 expression has to be set to zero. */
9351 gfc_add_vptr_component (code
->expr1
);
9352 code
->expr1
->rank
= 0;
9353 code
->expr1
= build_loc_call (code
->expr1
);
9354 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9356 /* Loop over TYPE IS / CLASS IS cases. */
9357 for (body
= code
->block
; body
; body
= body
->block
)
9361 c
= body
->ext
.block
.case_list
;
9363 /* Generate an index integer expression for address of the
9364 TYPE/CLASS vtable and store it in c->low. The hash expression
9365 is stored in c->high and is used to resolve intrinsic cases. */
9366 if (c
->ts
.type
!= BT_UNKNOWN
)
9368 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9370 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9372 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9373 c
->ts
.u
.derived
->hash_value
);
9377 vtab
= gfc_find_vtab (&c
->ts
);
9378 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9379 e
= CLASS_DATA (vtab
)->initializer
;
9380 c
->high
= gfc_copy_expr (e
);
9381 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9384 ts
.kind
= gfc_integer_4_kind
;
9385 ts
.type
= BT_INTEGER
;
9386 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9390 e
= gfc_lval_expr_from_sym (vtab
);
9391 c
->low
= build_loc_call (e
);
9396 /* Associate temporary to selector. This should only be done
9397 when this case is actually true, so build a new ASSOCIATE
9398 that does precisely this here (instead of using the
9401 if (c
->ts
.type
== BT_CLASS
)
9402 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9403 else if (c
->ts
.type
== BT_DERIVED
)
9404 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9405 else if (c
->ts
.type
== BT_CHARACTER
)
9407 HOST_WIDE_INT charlen
= 0;
9408 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9409 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9410 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9411 snprintf (name
, sizeof (name
),
9412 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9413 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9416 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9419 st
= gfc_find_symtree (ns
->sym_root
, name
);
9420 gcc_assert (st
->n
.sym
->assoc
);
9421 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9422 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9423 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9425 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9426 /* Fixup the target expression if necessary. */
9428 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9431 new_st
= gfc_get_code (EXEC_BLOCK
);
9432 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9433 new_st
->ext
.block
.ns
->code
= body
->next
;
9434 body
->next
= new_st
;
9436 /* Chain in the new list only if it is marked as dangling. Otherwise
9437 there is a CASE label overlap and this is already used. Just ignore,
9438 the error is diagnosed elsewhere. */
9439 if (st
->n
.sym
->assoc
->dangling
)
9441 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9442 st
->n
.sym
->assoc
->dangling
= 0;
9445 resolve_assoc_var (st
->n
.sym
, false);
9448 /* Take out CLASS IS cases for separate treatment. */
9450 while (body
&& body
->block
)
9452 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9454 /* Add to class_is list. */
9455 if (class_is
== NULL
)
9457 class_is
= body
->block
;
9462 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9463 tail
->block
= body
->block
;
9466 /* Remove from EXEC_SELECT list. */
9467 body
->block
= body
->block
->block
;
9480 /* Add a default case to hold the CLASS IS cases. */
9481 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9482 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9484 tail
->ext
.block
.case_list
= gfc_get_case ();
9485 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9487 default_case
= tail
;
9490 /* More than one CLASS IS block? */
9491 if (class_is
->block
)
9495 /* Sort CLASS IS blocks by extension level. */
9499 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9502 /* F03:C817 (check for doubles). */
9503 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9504 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9506 gfc_error ("Double CLASS IS block in SELECT TYPE "
9508 &c2
->ext
.block
.case_list
->where
);
9511 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9512 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9515 (*c1
)->block
= c2
->block
;
9525 /* Generate IF chain. */
9526 if_st
= gfc_get_code (EXEC_IF
);
9528 for (body
= class_is
; body
; body
= body
->block
)
9530 new_st
->block
= gfc_get_code (EXEC_IF
);
9531 new_st
= new_st
->block
;
9532 /* Set up IF condition: Call _gfortran_is_extension_of. */
9533 new_st
->expr1
= gfc_get_expr ();
9534 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9535 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9536 new_st
->expr1
->ts
.kind
= 4;
9537 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9538 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9539 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9540 /* Set up arguments. */
9541 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9542 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9543 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9544 new_st
->expr1
->where
= code
->loc
;
9545 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9546 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9547 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9548 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9549 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9550 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9551 new_st
->next
= body
->next
;
9553 if (default_case
->next
)
9555 new_st
->block
= gfc_get_code (EXEC_IF
);
9556 new_st
= new_st
->block
;
9557 new_st
->next
= default_case
->next
;
9560 /* Replace CLASS DEFAULT code by the IF chain. */
9561 default_case
->next
= if_st
;
9564 /* Resolve the internal code. This cannot be done earlier because
9565 it requires that the sym->assoc of selectors is set already. */
9566 gfc_current_ns
= ns
;
9567 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9568 gfc_current_ns
= old_ns
;
9575 /* Resolve a SELECT RANK statement. */
9578 resolve_select_rank (gfc_code
*code
, gfc_namespace
*old_ns
)
9581 gfc_code
*body
, *new_st
, *tail
;
9583 char tname
[GFC_MAX_SYMBOL_LEN
];
9584 char name
[2 * GFC_MAX_SYMBOL_LEN
];
9586 gfc_expr
*selector_expr
= NULL
;
9588 HOST_WIDE_INT charlen
= 0;
9590 ns
= code
->ext
.block
.ns
;
9593 code
->op
= EXEC_BLOCK
;
9596 gfc_association_list
* assoc
;
9598 assoc
= gfc_get_association_list ();
9599 assoc
->st
= code
->expr1
->symtree
;
9600 assoc
->target
= gfc_copy_expr (code
->expr2
);
9601 assoc
->target
->where
= code
->expr2
->where
;
9602 /* assoc->variable will be set by resolve_assoc_var. */
9604 code
->ext
.block
.assoc
= assoc
;
9605 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9607 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9610 code
->ext
.block
.assoc
= NULL
;
9612 /* Loop over RANK cases. Note that returning on the errors causes a
9613 cascade of further errors because the case blocks do not compile
9615 for (body
= code
->block
; body
; body
= body
->block
)
9617 c
= body
->ext
.block
.case_list
;
9619 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9623 /* Check for repeated cases. */
9624 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9626 gfc_case
*d
= tail
->ext
.block
.case_list
;
9632 /* Check F2018: C1153. */
9633 if (!c
->low
&& !d
->low
)
9634 gfc_error ("RANK DEFAULT at %L is repeated at %L",
9635 &c
->where
, &d
->where
);
9637 if (!c
->low
|| !d
->low
)
9640 /* Check F2018: C1153. */
9641 case_value2
= (int) mpz_get_si (d
->low
->value
.integer
);
9642 if ((case_value
== case_value2
) && case_value
== -1)
9643 gfc_error ("RANK (*) at %L is repeated at %L",
9644 &c
->where
, &d
->where
);
9645 else if (case_value
== case_value2
)
9646 gfc_error ("RANK (%i) at %L is repeated at %L",
9647 case_value
, &c
->where
, &d
->where
);
9653 /* Check F2018: C1155. */
9654 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9655 || gfc_expr_attr (code
->expr1
).pointer
))
9656 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9657 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9659 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9660 || gfc_expr_attr (code
->expr1
).pointer
))
9661 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9662 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9665 /* Add EXEC_SELECT to switch on rank. */
9666 new_st
= gfc_get_code (code
->op
);
9667 new_st
->expr1
= code
->expr1
;
9668 new_st
->expr2
= code
->expr2
;
9669 new_st
->block
= code
->block
;
9670 code
->expr1
= code
->expr2
= NULL
;
9675 ns
->code
->next
= new_st
;
9677 code
->op
= EXEC_SELECT_RANK
;
9679 selector_expr
= code
->expr1
;
9681 /* Loop over SELECT RANK cases. */
9682 for (body
= code
->block
; body
; body
= body
->block
)
9684 c
= body
->ext
.block
.case_list
;
9687 /* Pass on the default case. */
9691 /* Associate temporary to selector. This should only be done
9692 when this case is actually true, so build a new ASSOCIATE
9693 that does precisely this here (instead of using the
9695 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9696 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9697 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9699 if (c
->ts
.type
== BT_CLASS
)
9700 sprintf (tname
, "class_%s", c
->ts
.u
.derived
->name
);
9701 else if (c
->ts
.type
== BT_DERIVED
)
9702 sprintf (tname
, "type_%s", c
->ts
.u
.derived
->name
);
9703 else if (c
->ts
.type
!= BT_CHARACTER
)
9704 sprintf (tname
, "%s_%d", gfc_basic_typename (c
->ts
.type
), c
->ts
.kind
);
9706 sprintf (tname
, "%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9707 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9709 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9710 if (case_value
>= 0)
9711 sprintf (name
, "__tmp_%s_rank_%d", tname
, case_value
);
9713 sprintf (name
, "__tmp_%s_rank_m%d", tname
, -case_value
);
9715 st
= gfc_find_symtree (ns
->sym_root
, name
);
9716 gcc_assert (st
->n
.sym
->assoc
);
9718 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9719 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9721 new_st
= gfc_get_code (EXEC_BLOCK
);
9722 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9723 new_st
->ext
.block
.ns
->code
= body
->next
;
9724 body
->next
= new_st
;
9726 /* Chain in the new list only if it is marked as dangling. Otherwise
9727 there is a CASE label overlap and this is already used. Just ignore,
9728 the error is diagnosed elsewhere. */
9729 if (st
->n
.sym
->assoc
->dangling
)
9731 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9732 st
->n
.sym
->assoc
->dangling
= 0;
9735 resolve_assoc_var (st
->n
.sym
, false);
9738 gfc_current_ns
= ns
;
9739 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9740 gfc_current_ns
= old_ns
;
9744 /* Resolve a transfer statement. This is making sure that:
9745 -- a derived type being transferred has only non-pointer components
9746 -- a derived type being transferred doesn't have private components, unless
9747 it's being transferred from the module where the type was defined
9748 -- we're not trying to transfer a whole assumed size array. */
9751 resolve_transfer (gfc_code
*code
)
9753 gfc_symbol
*sym
, *derived
;
9757 bool formatted
= false;
9758 gfc_dt
*dt
= code
->ext
.dt
;
9759 gfc_symbol
*dtio_sub
= NULL
;
9763 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9764 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9765 exp
= exp
->value
.op
.op1
;
9767 if (exp
&& exp
->expr_type
== EXPR_NULL
9770 gfc_error ("Invalid context for NULL () intrinsic at %L",
9775 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9776 && exp
->expr_type
!= EXPR_FUNCTION
9777 && exp
->expr_type
!= EXPR_STRUCTURE
))
9780 /* If we are reading, the variable will be changed. Note that
9781 code->ext.dt may be NULL if the TRANSFER is related to
9782 an INQUIRE statement -- but in this case, we are not reading, either. */
9783 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9784 && !gfc_check_vardef_context (exp
, false, false, false,
9788 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
9789 || exp
->expr_type
== EXPR_FUNCTION
9790 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9792 /* Go to actual component transferred. */
9793 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9794 if (ref
->type
== REF_COMPONENT
)
9795 ts
= &ref
->u
.c
.component
->ts
;
9797 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9798 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9800 derived
= ts
->u
.derived
;
9802 /* Determine when to use the formatted DTIO procedure. */
9803 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9806 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9807 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9808 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9810 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9813 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9814 /* Check to see if this is a nested DTIO call, with the
9815 dummy as the io-list object. */
9816 if (sym
&& sym
== dtio_sub
&& sym
->formal
9817 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9818 && exp
->ref
== NULL
)
9820 if (!sym
->attr
.recursive
)
9822 gfc_error ("DTIO %s procedure at %L must be recursive",
9823 sym
->name
, &sym
->declared_at
);
9830 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9832 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9833 "it is processed by a defined input/output procedure",
9838 if (ts
->type
== BT_DERIVED
)
9840 /* Check that transferred derived type doesn't contain POINTER
9841 components unless it is processed by a defined input/output
9843 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9845 gfc_error ("Data transfer element at %L cannot have POINTER "
9846 "components unless it is processed by a defined "
9847 "input/output procedure", &code
->loc
);
9852 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9854 gfc_error ("Data transfer element at %L cannot have "
9855 "procedure pointer components", &code
->loc
);
9859 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9861 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9862 "components unless it is processed by a defined "
9863 "input/output procedure", &code
->loc
);
9867 /* C_PTR and C_FUNPTR have private components which means they cannot
9868 be printed. However, if -std=gnu and not -pedantic, allow
9869 the component to be printed to help debugging. */
9870 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9872 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9873 "cannot have PRIVATE components", &code
->loc
))
9876 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9878 gfc_error ("Data transfer element at %L cannot have "
9879 "PRIVATE components unless it is processed by "
9880 "a defined input/output procedure", &code
->loc
);
9885 if (exp
->expr_type
== EXPR_STRUCTURE
)
9888 sym
= exp
->symtree
->n
.sym
;
9890 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9891 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9893 gfc_error ("Data transfer element at %L cannot be a full reference to "
9894 "an assumed-size array", &code
->loc
);
9898 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9899 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9903 /*********** Toplevel code resolution subroutines ***********/
9905 /* Find the set of labels that are reachable from this block. We also
9906 record the last statement in each block. */
9909 find_reachable_labels (gfc_code
*block
)
9916 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9918 /* Collect labels in this block. We don't keep those corresponding
9919 to END {IF|SELECT}, these are checked in resolve_branch by going
9920 up through the code_stack. */
9921 for (c
= block
; c
; c
= c
->next
)
9923 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9924 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9927 /* Merge with labels from parent block. */
9930 gcc_assert (cs_base
->prev
->reachable_labels
);
9931 bitmap_ior_into (cs_base
->reachable_labels
,
9932 cs_base
->prev
->reachable_labels
);
9938 resolve_lock_unlock_event (gfc_code
*code
)
9940 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9941 && code
->expr1
->value
.function
.isym
9942 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9943 remove_caf_get_intrinsic (code
->expr1
);
9945 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9946 && (code
->expr1
->ts
.type
!= BT_DERIVED
9947 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9948 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9949 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9950 || code
->expr1
->rank
!= 0
9951 || (!gfc_is_coarray (code
->expr1
) &&
9952 !gfc_is_coindexed (code
->expr1
))))
9953 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9954 &code
->expr1
->where
);
9955 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9956 && (code
->expr1
->ts
.type
!= BT_DERIVED
9957 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9958 || code
->expr1
->ts
.u
.derived
->from_intmod
9959 != INTMOD_ISO_FORTRAN_ENV
9960 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9961 != ISOFORTRAN_EVENT_TYPE
9962 || code
->expr1
->rank
!= 0))
9963 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9964 &code
->expr1
->where
);
9965 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9966 && !gfc_is_coindexed (code
->expr1
))
9967 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9968 &code
->expr1
->where
);
9969 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9970 gfc_error ("Event variable argument at %L must be a coarray but not "
9971 "coindexed", &code
->expr1
->where
);
9975 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9976 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9977 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9978 &code
->expr2
->where
);
9981 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9982 _("STAT variable")))
9987 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9988 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9989 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9990 &code
->expr3
->where
);
9993 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9994 _("ERRMSG variable")))
9997 /* Check for LOCK the ACQUIRED_LOCK. */
9998 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9999 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
10000 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
10001 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
10002 "variable", &code
->expr4
->where
);
10004 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
10005 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
10006 _("ACQUIRED_LOCK variable")))
10009 /* Check for EVENT WAIT the UNTIL_COUNT. */
10010 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
10012 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
10013 || code
->expr4
->rank
!= 0)
10014 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
10015 "expression", &code
->expr4
->where
);
10021 resolve_critical (gfc_code
*code
)
10023 gfc_symtree
*symtree
;
10024 gfc_symbol
*lock_type
;
10025 char name
[GFC_MAX_SYMBOL_LEN
];
10026 static int serial
= 0;
10028 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
10031 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
10032 GFC_PREFIX ("lock_type"));
10034 lock_type
= symtree
->n
.sym
;
10037 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
10039 gcc_unreachable ();
10040 lock_type
= symtree
->n
.sym
;
10041 lock_type
->attr
.flavor
= FL_DERIVED
;
10042 lock_type
->attr
.zero_comp
= 1;
10043 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
10044 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
10047 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
10048 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
10049 gcc_unreachable ();
10051 code
->resolved_sym
= symtree
->n
.sym
;
10052 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10053 symtree
->n
.sym
->attr
.referenced
= 1;
10054 symtree
->n
.sym
->attr
.artificial
= 1;
10055 symtree
->n
.sym
->attr
.codimension
= 1;
10056 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
10057 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
10058 symtree
->n
.sym
->as
= gfc_get_array_spec ();
10059 symtree
->n
.sym
->as
->corank
= 1;
10060 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
10061 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
10062 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
10064 gfc_commit_symbols();
10069 resolve_sync (gfc_code
*code
)
10071 /* Check imageset. The * case matches expr1 == NULL. */
10074 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
10075 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
10076 "INTEGER expression", &code
->expr1
->where
);
10077 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
10078 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
10079 gfc_error ("Imageset argument at %L must between 1 and num_images()",
10080 &code
->expr1
->where
);
10081 else if (code
->expr1
->expr_type
== EXPR_ARRAY
10082 && gfc_simplify_expr (code
->expr1
, 0))
10084 gfc_constructor
*cons
;
10085 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
10086 for (; cons
; cons
= gfc_constructor_next (cons
))
10087 if (cons
->expr
->expr_type
== EXPR_CONSTANT
10088 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
10089 gfc_error ("Imageset argument at %L must between 1 and "
10090 "num_images()", &cons
->expr
->where
);
10095 gfc_resolve_expr (code
->expr2
);
10097 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
10098 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
10099 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10100 &code
->expr2
->where
);
10102 /* Check ERRMSG. */
10103 gfc_resolve_expr (code
->expr3
);
10105 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
10106 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
10107 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10108 &code
->expr3
->where
);
10112 /* Given a branch to a label, see if the branch is conforming.
10113 The code node describes where the branch is located. */
10116 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
10123 /* Step one: is this a valid branching target? */
10125 if (label
->defined
== ST_LABEL_UNKNOWN
)
10127 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
10132 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
10134 gfc_error ("Statement at %L is not a valid branch target statement "
10135 "for the branch statement at %L", &label
->where
, &code
->loc
);
10139 /* Step two: make sure this branch is not a branch to itself ;-) */
10141 if (code
->here
== label
)
10144 "Branch at %L may result in an infinite loop", &code
->loc
);
10148 /* Step three: See if the label is in the same block as the
10149 branching statement. The hard work has been done by setting up
10150 the bitmap reachable_labels. */
10152 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
10154 /* Check now whether there is a CRITICAL construct; if so, check
10155 whether the label is still visible outside of the CRITICAL block,
10156 which is invalid. */
10157 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10159 if (stack
->current
->op
== EXEC_CRITICAL
10160 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10161 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
10162 "label at %L", &code
->loc
, &label
->where
);
10163 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
10164 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10165 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
10166 "for label at %L", &code
->loc
, &label
->where
);
10172 /* Step four: If we haven't found the label in the bitmap, it may
10173 still be the label of the END of the enclosing block, in which
10174 case we find it by going up the code_stack. */
10176 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10178 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
10180 if (stack
->current
->op
== EXEC_CRITICAL
)
10182 /* Note: A label at END CRITICAL does not leave the CRITICAL
10183 construct as END CRITICAL is still part of it. */
10184 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
10185 " at %L", &code
->loc
, &label
->where
);
10188 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
10190 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
10191 "label at %L", &code
->loc
, &label
->where
);
10198 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
10202 /* The label is not in an enclosing block, so illegal. This was
10203 allowed in Fortran 66, so we allow it as extension. No
10204 further checks are necessary in this case. */
10205 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
10206 "as the GOTO statement at %L", &label
->where
,
10212 /* Check whether EXPR1 has the same shape as EXPR2. */
10215 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
10217 mpz_t shape
[GFC_MAX_DIMENSIONS
];
10218 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
10219 bool result
= false;
10222 /* Compare the rank. */
10223 if (expr1
->rank
!= expr2
->rank
)
10226 /* Compare the size of each dimension. */
10227 for (i
=0; i
<expr1
->rank
; i
++)
10229 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
10232 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
10235 if (mpz_cmp (shape
[i
], shape2
[i
]))
10239 /* When either of the two expression is an assumed size array, we
10240 ignore the comparison of dimension sizes. */
10245 gfc_clear_shape (shape
, i
);
10246 gfc_clear_shape (shape2
, i
);
10251 /* Check whether a WHERE assignment target or a WHERE mask expression
10252 has the same shape as the outmost WHERE mask expression. */
10255 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
10259 gfc_expr
*e
= NULL
;
10261 cblock
= code
->block
;
10263 /* Store the first WHERE mask-expr of the WHERE statement or construct.
10264 In case of nested WHERE, only the outmost one is stored. */
10265 if (mask
== NULL
) /* outmost WHERE */
10267 else /* inner WHERE */
10274 /* Check if the mask-expr has a consistent shape with the
10275 outmost WHERE mask-expr. */
10276 if (!resolve_where_shape (cblock
->expr1
, e
))
10277 gfc_error ("WHERE mask at %L has inconsistent shape",
10278 &cblock
->expr1
->where
);
10281 /* the assignment statement of a WHERE statement, or the first
10282 statement in where-body-construct of a WHERE construct */
10283 cnext
= cblock
->next
;
10288 /* WHERE assignment statement */
10291 /* Check shape consistent for WHERE assignment target. */
10292 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10293 gfc_error ("WHERE assignment target at %L has "
10294 "inconsistent shape", &cnext
->expr1
->where
);
10298 case EXEC_ASSIGN_CALL
:
10299 resolve_call (cnext
);
10300 if (!cnext
->resolved_sym
->attr
.elemental
)
10301 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10302 &cnext
->ext
.actual
->expr
->where
);
10305 /* WHERE or WHERE construct is part of a where-body-construct */
10307 resolve_where (cnext
, e
);
10311 gfc_error ("Unsupported statement inside WHERE at %L",
10314 /* the next statement within the same where-body-construct */
10315 cnext
= cnext
->next
;
10317 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10318 cblock
= cblock
->block
;
10323 /* Resolve assignment in FORALL construct.
10324 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10325 FORALL index variables. */
10328 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10332 for (n
= 0; n
< nvar
; n
++)
10334 gfc_symbol
*forall_index
;
10336 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10338 /* Check whether the assignment target is one of the FORALL index
10340 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10341 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10342 gfc_error ("Assignment to a FORALL index variable at %L",
10343 &code
->expr1
->where
);
10346 /* If one of the FORALL index variables doesn't appear in the
10347 assignment variable, then there could be a many-to-one
10348 assignment. Emit a warning rather than an error because the
10349 mask could be resolving this problem. */
10350 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10351 gfc_warning (0, "The FORALL with index %qs is not used on the "
10352 "left side of the assignment at %L and so might "
10353 "cause multiple assignment to this object",
10354 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10360 /* Resolve WHERE statement in FORALL construct. */
10363 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10364 gfc_expr
**var_expr
)
10369 cblock
= code
->block
;
10372 /* the assignment statement of a WHERE statement, or the first
10373 statement in where-body-construct of a WHERE construct */
10374 cnext
= cblock
->next
;
10379 /* WHERE assignment statement */
10381 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10384 /* WHERE operator assignment statement */
10385 case EXEC_ASSIGN_CALL
:
10386 resolve_call (cnext
);
10387 if (!cnext
->resolved_sym
->attr
.elemental
)
10388 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10389 &cnext
->ext
.actual
->expr
->where
);
10392 /* WHERE or WHERE construct is part of a where-body-construct */
10394 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10398 gfc_error ("Unsupported statement inside WHERE at %L",
10401 /* the next statement within the same where-body-construct */
10402 cnext
= cnext
->next
;
10404 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10405 cblock
= cblock
->block
;
10410 /* Traverse the FORALL body to check whether the following errors exist:
10411 1. For assignment, check if a many-to-one assignment happens.
10412 2. For WHERE statement, check the WHERE body to see if there is any
10413 many-to-one assignment. */
10416 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10420 c
= code
->block
->next
;
10426 case EXEC_POINTER_ASSIGN
:
10427 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10430 case EXEC_ASSIGN_CALL
:
10434 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10435 there is no need to handle it here. */
10439 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10444 /* The next statement in the FORALL body. */
10450 /* Counts the number of iterators needed inside a forall construct, including
10451 nested forall constructs. This is used to allocate the needed memory
10452 in gfc_resolve_forall. */
10455 gfc_count_forall_iterators (gfc_code
*code
)
10457 int max_iters
, sub_iters
, current_iters
;
10458 gfc_forall_iterator
*fa
;
10460 gcc_assert(code
->op
== EXEC_FORALL
);
10464 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10467 code
= code
->block
->next
;
10471 if (code
->op
== EXEC_FORALL
)
10473 sub_iters
= gfc_count_forall_iterators (code
);
10474 if (sub_iters
> max_iters
)
10475 max_iters
= sub_iters
;
10480 return current_iters
+ max_iters
;
10484 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10485 gfc_resolve_forall_body to resolve the FORALL body. */
10488 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10490 static gfc_expr
**var_expr
;
10491 static int total_var
= 0;
10492 static int nvar
= 0;
10493 int i
, old_nvar
, tmp
;
10494 gfc_forall_iterator
*fa
;
10498 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10501 /* Start to resolve a FORALL construct */
10502 if (forall_save
== 0)
10504 /* Count the total number of FORALL indices in the nested FORALL
10505 construct in order to allocate the VAR_EXPR with proper size. */
10506 total_var
= gfc_count_forall_iterators (code
);
10508 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10509 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10512 /* The information about FORALL iterator, including FORALL indices start, end
10513 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10514 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10516 /* Fortran 20008: C738 (R753). */
10517 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10519 gfc_error ("FORALL index-name at %L must be a scalar variable "
10520 "of type integer", &fa
->var
->where
);
10524 /* Check if any outer FORALL index name is the same as the current
10526 for (i
= 0; i
< nvar
; i
++)
10528 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10529 gfc_error ("An outer FORALL construct already has an index "
10530 "with this name %L", &fa
->var
->where
);
10533 /* Record the current FORALL index. */
10534 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10538 /* No memory leak. */
10539 gcc_assert (nvar
<= total_var
);
10542 /* Resolve the FORALL body. */
10543 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10545 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10546 gfc_resolve_blocks (code
->block
, ns
);
10550 /* Free only the VAR_EXPRs allocated in this frame. */
10551 for (i
= nvar
; i
< tmp
; i
++)
10552 gfc_free_expr (var_expr
[i
]);
10556 /* We are in the outermost FORALL construct. */
10557 gcc_assert (forall_save
== 0);
10559 /* VAR_EXPR is not needed any more. */
10566 /* Resolve a BLOCK construct statement. */
10569 resolve_block_construct (gfc_code
* code
)
10571 /* Resolve the BLOCK's namespace. */
10572 gfc_resolve (code
->ext
.block
.ns
);
10574 /* For an ASSOCIATE block, the associations (and their targets) are already
10575 resolved during resolve_symbol. */
10579 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10583 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10587 for (; b
; b
= b
->block
)
10589 t
= gfc_resolve_expr (b
->expr1
);
10590 if (!gfc_resolve_expr (b
->expr2
))
10596 if (t
&& b
->expr1
!= NULL
10597 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10598 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10604 && b
->expr1
!= NULL
10605 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10606 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10611 resolve_branch (b
->label1
, b
);
10615 resolve_block_construct (b
);
10619 case EXEC_SELECT_TYPE
:
10620 case EXEC_SELECT_RANK
:
10623 case EXEC_DO_WHILE
:
10624 case EXEC_DO_CONCURRENT
:
10625 case EXEC_CRITICAL
:
10628 case EXEC_IOLENGTH
:
10632 case EXEC_OMP_ATOMIC
:
10633 case EXEC_OACC_ATOMIC
:
10635 gfc_omp_atomic_op aop
10636 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10638 /* Verify this before calling gfc_resolve_code, which might
10640 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10641 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10642 && b
->next
->next
== NULL
)
10643 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10644 && b
->next
->next
!= NULL
10645 && b
->next
->next
->op
== EXEC_ASSIGN
10646 && b
->next
->next
->next
== NULL
));
10650 case EXEC_OACC_PARALLEL_LOOP
:
10651 case EXEC_OACC_PARALLEL
:
10652 case EXEC_OACC_KERNELS_LOOP
:
10653 case EXEC_OACC_KERNELS
:
10654 case EXEC_OACC_SERIAL_LOOP
:
10655 case EXEC_OACC_SERIAL
:
10656 case EXEC_OACC_DATA
:
10657 case EXEC_OACC_HOST_DATA
:
10658 case EXEC_OACC_LOOP
:
10659 case EXEC_OACC_UPDATE
:
10660 case EXEC_OACC_WAIT
:
10661 case EXEC_OACC_CACHE
:
10662 case EXEC_OACC_ENTER_DATA
:
10663 case EXEC_OACC_EXIT_DATA
:
10664 case EXEC_OACC_ROUTINE
:
10665 case EXEC_OMP_CRITICAL
:
10666 case EXEC_OMP_DISTRIBUTE
:
10667 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10668 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10669 case EXEC_OMP_DISTRIBUTE_SIMD
:
10671 case EXEC_OMP_DO_SIMD
:
10672 case EXEC_OMP_MASTER
:
10673 case EXEC_OMP_ORDERED
:
10674 case EXEC_OMP_PARALLEL
:
10675 case EXEC_OMP_PARALLEL_DO
:
10676 case EXEC_OMP_PARALLEL_DO_SIMD
:
10677 case EXEC_OMP_PARALLEL_SECTIONS
:
10678 case EXEC_OMP_PARALLEL_WORKSHARE
:
10679 case EXEC_OMP_SECTIONS
:
10680 case EXEC_OMP_SIMD
:
10681 case EXEC_OMP_SINGLE
:
10682 case EXEC_OMP_TARGET
:
10683 case EXEC_OMP_TARGET_DATA
:
10684 case EXEC_OMP_TARGET_ENTER_DATA
:
10685 case EXEC_OMP_TARGET_EXIT_DATA
:
10686 case EXEC_OMP_TARGET_PARALLEL
:
10687 case EXEC_OMP_TARGET_PARALLEL_DO
:
10688 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10689 case EXEC_OMP_TARGET_SIMD
:
10690 case EXEC_OMP_TARGET_TEAMS
:
10691 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10692 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10693 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10694 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10695 case EXEC_OMP_TARGET_UPDATE
:
10696 case EXEC_OMP_TASK
:
10697 case EXEC_OMP_TASKGROUP
:
10698 case EXEC_OMP_TASKLOOP
:
10699 case EXEC_OMP_TASKLOOP_SIMD
:
10700 case EXEC_OMP_TASKWAIT
:
10701 case EXEC_OMP_TASKYIELD
:
10702 case EXEC_OMP_TEAMS
:
10703 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10704 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10705 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10706 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10707 case EXEC_OMP_WORKSHARE
:
10711 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10714 gfc_resolve_code (b
->next
, ns
);
10719 /* Does everything to resolve an ordinary assignment. Returns true
10720 if this is an interface assignment. */
10722 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10729 symbol_attribute attr
;
10731 if (gfc_extend_assign (code
, ns
))
10735 if (code
->op
== EXEC_ASSIGN_CALL
)
10737 lhs
= code
->ext
.actual
->expr
;
10738 rhsptr
= &code
->ext
.actual
->next
->expr
;
10742 gfc_actual_arglist
* args
;
10743 gfc_typebound_proc
* tbp
;
10745 gcc_assert (code
->op
== EXEC_COMPCALL
);
10747 args
= code
->expr1
->value
.compcall
.actual
;
10749 rhsptr
= &args
->next
->expr
;
10751 tbp
= code
->expr1
->value
.compcall
.tbp
;
10752 gcc_assert (!tbp
->is_generic
);
10755 /* Make a temporary rhs when there is a default initializer
10756 and rhs is the same symbol as the lhs. */
10757 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10758 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10759 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10760 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10761 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10769 if ((gfc_numeric_ts (&lhs
->ts
) || lhs
->ts
.type
== BT_LOGICAL
)
10770 && rhs
->ts
.type
== BT_CHARACTER
10771 && (rhs
->expr_type
!= EXPR_CONSTANT
|| !flag_dec_char_conversions
))
10773 /* Use of -fdec-char-conversions allows assignment of character data
10774 to non-character variables. This not permited for nonconstant
10776 gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs
),
10777 gfc_typename (lhs
), &rhs
->where
);
10781 /* Handle the case of a BOZ literal on the RHS. */
10782 if (rhs
->ts
.type
== BT_BOZ
)
10784 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
10785 "statement value nor an actual argument of "
10786 "INT/REAL/DBLE/CMPLX intrinsic subprogram",
10790 switch (lhs
->ts
.type
)
10793 if (!gfc_boz2int (rhs
, lhs
->ts
.kind
))
10797 if (!gfc_boz2real (rhs
, lhs
->ts
.kind
))
10801 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs
->where
);
10806 if (lhs
->ts
.type
== BT_CHARACTER
&& warn_character_truncation
)
10808 HOST_WIDE_INT llen
= 0, rlen
= 0;
10809 if (lhs
->ts
.u
.cl
!= NULL
10810 && lhs
->ts
.u
.cl
->length
!= NULL
10811 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10812 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10814 if (rhs
->expr_type
== EXPR_CONSTANT
)
10815 rlen
= rhs
->value
.character
.length
;
10817 else if (rhs
->ts
.u
.cl
!= NULL
10818 && rhs
->ts
.u
.cl
->length
!= NULL
10819 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10820 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10822 if (rlen
&& llen
&& rlen
> llen
)
10823 gfc_warning_now (OPT_Wcharacter_truncation
,
10824 "CHARACTER expression will be truncated "
10825 "in assignment (%ld/%ld) at %L",
10826 (long) llen
, (long) rlen
, &code
->loc
);
10829 /* Ensure that a vector index expression for the lvalue is evaluated
10830 to a temporary if the lvalue symbol is referenced in it. */
10833 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10834 if (ref
->type
== REF_ARRAY
)
10836 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10837 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10838 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10839 ref
->u
.ar
.start
[n
]))
10841 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10845 if (gfc_pure (NULL
))
10847 if (lhs
->ts
.type
== BT_DERIVED
10848 && lhs
->expr_type
== EXPR_VARIABLE
10849 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10850 && rhs
->expr_type
== EXPR_VARIABLE
10851 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10852 || gfc_is_coindexed (rhs
)))
10854 /* F2008, C1283. */
10855 if (gfc_is_coindexed (rhs
))
10856 gfc_error ("Coindexed expression at %L is assigned to "
10857 "a derived type variable with a POINTER "
10858 "component in a PURE procedure",
10861 /* F2008, C1283 (4). */
10862 gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
10863 "shall not be used as the expr at %L of an intrinsic "
10864 "assignment statement in which the variable is of a "
10865 "derived type if the derived type has a pointer "
10866 "component at any level of component selection.",
10871 /* Fortran 2008, C1283. */
10872 if (gfc_is_coindexed (lhs
))
10874 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10875 "procedure", &rhs
->where
);
10880 if (gfc_implicit_pure (NULL
))
10882 if (lhs
->expr_type
== EXPR_VARIABLE
10883 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10884 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10885 gfc_unset_implicit_pure (NULL
);
10887 if (lhs
->ts
.type
== BT_DERIVED
10888 && lhs
->expr_type
== EXPR_VARIABLE
10889 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10890 && rhs
->expr_type
== EXPR_VARIABLE
10891 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10892 || gfc_is_coindexed (rhs
)))
10893 gfc_unset_implicit_pure (NULL
);
10895 /* Fortran 2008, C1283. */
10896 if (gfc_is_coindexed (lhs
))
10897 gfc_unset_implicit_pure (NULL
);
10900 /* F2008, 7.2.1.2. */
10901 attr
= gfc_expr_attr (lhs
);
10902 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10904 if (attr
.codimension
)
10906 gfc_error ("Assignment to polymorphic coarray at %L is not "
10907 "permitted", &lhs
->where
);
10910 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10911 "polymorphic variable at %L", &lhs
->where
))
10913 if (!flag_realloc_lhs
)
10915 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10916 "requires %<-frealloc-lhs%>", &lhs
->where
);
10920 else if (lhs
->ts
.type
== BT_CLASS
)
10922 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10923 "assignment at %L - check that there is a matching specific "
10924 "subroutine for '=' operator", &lhs
->where
);
10928 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10930 /* F2008, Section 7.2.1.2. */
10931 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10933 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10934 "component in assignment at %L", &lhs
->where
);
10938 /* Assign the 'data' of a class object to a derived type. */
10939 if (lhs
->ts
.type
== BT_DERIVED
10940 && rhs
->ts
.type
== BT_CLASS
10941 && rhs
->expr_type
!= EXPR_ARRAY
)
10942 gfc_add_data_component (rhs
);
10944 /* Make sure there is a vtable and, in particular, a _copy for the
10946 if (UNLIMITED_POLY (lhs
) && lhs
->rank
&& rhs
->ts
.type
!= BT_CLASS
)
10947 gfc_find_vtab (&rhs
->ts
);
10949 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10951 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10952 && code
->expr2
->value
.function
.isym
10953 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10954 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10955 && !gfc_expr_attr (rhs
).allocatable
10956 && !gfc_has_vector_subscript (rhs
)));
10958 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10960 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10961 Additionally, insert this code when the RHS is a CAF as we then use the
10962 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10963 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10964 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10966 if (caf_convert_to_send
)
10968 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10969 && code
->expr2
->value
.function
.isym
10970 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10971 remove_caf_get_intrinsic (code
->expr2
);
10972 code
->op
= EXEC_CALL
;
10973 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10974 code
->resolved_sym
= code
->symtree
->n
.sym
;
10975 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10976 code
->resolved_sym
->attr
.intrinsic
= 1;
10977 code
->resolved_sym
->attr
.subroutine
= 1;
10978 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10979 gfc_commit_symbol (code
->resolved_sym
);
10980 code
->ext
.actual
= gfc_get_actual_arglist ();
10981 code
->ext
.actual
->expr
= lhs
;
10982 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10983 code
->ext
.actual
->next
->expr
= rhs
;
10984 code
->expr1
= NULL
;
10985 code
->expr2
= NULL
;
10992 /* Add a component reference onto an expression. */
10995 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
11000 ref
= &((*ref
)->next
);
11001 *ref
= gfc_get_ref ();
11002 (*ref
)->type
= REF_COMPONENT
;
11003 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
11004 (*ref
)->u
.c
.component
= c
;
11007 /* Add a full array ref, as necessary. */
11010 gfc_add_full_array_ref (e
, c
->as
);
11011 e
->rank
= c
->as
->rank
;
11016 /* Build an assignment. Keep the argument 'op' for future use, so that
11017 pointer assignments can be made. */
11020 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
11021 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
11023 gfc_code
*this_code
;
11025 this_code
= gfc_get_code (op
);
11026 this_code
->next
= NULL
;
11027 this_code
->expr1
= gfc_copy_expr (expr1
);
11028 this_code
->expr2
= gfc_copy_expr (expr2
);
11029 this_code
->loc
= loc
;
11030 if (comp1
&& comp2
)
11032 add_comp_ref (this_code
->expr1
, comp1
);
11033 add_comp_ref (this_code
->expr2
, comp2
);
11040 /* Makes a temporary variable expression based on the characteristics of
11041 a given variable expression. */
11044 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
11046 static int serial
= 0;
11047 char name
[GFC_MAX_SYMBOL_LEN
];
11049 gfc_array_spec
*as
;
11050 gfc_array_ref
*aref
;
11053 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
11054 gfc_get_sym_tree (name
, ns
, &tmp
, false);
11055 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
11057 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
11058 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
11060 e
->value
.character
.length
);
11066 /* Obtain the arrayspec for the temporary. */
11067 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
11068 && e
->expr_type
!= EXPR_FUNCTION
11069 && e
->expr_type
!= EXPR_OP
)
11071 aref
= gfc_find_array_ref (e
);
11072 if (e
->expr_type
== EXPR_VARIABLE
11073 && e
->symtree
->n
.sym
->as
== aref
->as
)
11077 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
11078 if (ref
->type
== REF_COMPONENT
11079 && ref
->u
.c
.component
->as
== aref
->as
)
11087 /* Add the attributes and the arrayspec to the temporary. */
11088 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
11089 tmp
->n
.sym
->attr
.function
= 0;
11090 tmp
->n
.sym
->attr
.result
= 0;
11091 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
11092 tmp
->n
.sym
->attr
.dummy
= 0;
11093 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
11097 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
11100 if (as
->type
== AS_DEFERRED
)
11101 tmp
->n
.sym
->attr
.allocatable
= 1;
11103 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
11104 || e
->expr_type
== EXPR_FUNCTION
11105 || e
->expr_type
== EXPR_OP
))
11107 tmp
->n
.sym
->as
= gfc_get_array_spec ();
11108 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
11109 tmp
->n
.sym
->as
->rank
= e
->rank
;
11110 tmp
->n
.sym
->attr
.allocatable
= 1;
11111 tmp
->n
.sym
->attr
.dimension
= 1;
11114 tmp
->n
.sym
->attr
.dimension
= 0;
11116 gfc_set_sym_referenced (tmp
->n
.sym
);
11117 gfc_commit_symbol (tmp
->n
.sym
);
11118 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
11120 /* Should the lhs be a section, use its array ref for the
11121 temporary expression. */
11122 if (aref
&& aref
->type
!= AR_FULL
)
11124 gfc_free_ref_list (e
->ref
);
11125 e
->ref
= gfc_copy_ref (ref
);
11131 /* Add one line of code to the code chain, making sure that 'head' and
11132 'tail' are appropriately updated. */
11135 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
11137 gcc_assert (this_code
);
11139 *head
= *tail
= *this_code
;
11141 *tail
= gfc_append_code (*tail
, *this_code
);
11146 /* Counts the potential number of part array references that would
11147 result from resolution of typebound defined assignments. */
11150 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
11153 int c_depth
= 0, t_depth
;
11155 for (c
= derived
->components
; c
; c
= c
->next
)
11157 if ((!gfc_bt_struct (c
->ts
.type
)
11159 || c
->attr
.allocatable
11160 || c
->attr
.proc_pointer_comp
11161 || c
->attr
.class_pointer
11162 || c
->attr
.proc_pointer
)
11163 && !c
->attr
.defined_assign_comp
)
11166 if (c
->as
&& c_depth
== 0)
11169 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
11170 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
11175 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
11177 return depth
+ c_depth
;
11181 /* Implement 7.2.1.3 of the F08 standard:
11182 "An intrinsic assignment where the variable is of derived type is
11183 performed as if each component of the variable were assigned from the
11184 corresponding component of expr using pointer assignment (7.2.2) for
11185 each pointer component, defined assignment for each nonpointer
11186 nonallocatable component of a type that has a type-bound defined
11187 assignment consistent with the component, intrinsic assignment for
11188 each other nonpointer nonallocatable component, ..."
11190 The pointer assignments are taken care of by the intrinsic
11191 assignment of the structure itself. This function recursively adds
11192 defined assignments where required. The recursion is accomplished
11193 by calling gfc_resolve_code.
11195 When the lhs in a defined assignment has intent INOUT, we need a
11196 temporary for the lhs. In pseudo-code:
11198 ! Only call function lhs once.
11199 if (lhs is not a constant or an variable)
11202 ! Do the intrinsic assignment
11204 ! Now do the defined assignments
11205 do over components with typebound defined assignment [%cmp]
11206 #if one component's assignment procedure is INOUT
11208 #if expr2 non-variable
11214 t1%cmp {defined=} expr2%cmp
11220 expr1%cmp {defined=} expr2%cmp
11224 /* The temporary assignments have to be put on top of the additional
11225 code to avoid the result being changed by the intrinsic assignment.
11227 static int component_assignment_level
= 0;
11228 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
11231 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
11233 gfc_component
*comp1
, *comp2
;
11234 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
11236 int error_count
, depth
;
11238 gfc_get_errors (NULL
, &error_count
);
11240 /* Filter out continuing processing after an error. */
11242 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
11243 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
11246 /* TODO: Handle more than one part array reference in assignments. */
11247 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
11248 (*code
)->expr1
->rank
? 1 : 0);
11251 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
11252 "done because multiple part array references would "
11253 "occur in intermediate expressions.", &(*code
)->loc
);
11257 component_assignment_level
++;
11259 /* Create a temporary so that functions get called only once. */
11260 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
11261 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
11263 gfc_expr
*tmp_expr
;
11265 /* Assign the rhs to the temporary. */
11266 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11267 this_code
= build_assignment (EXEC_ASSIGN
,
11268 tmp_expr
, (*code
)->expr2
,
11269 NULL
, NULL
, (*code
)->loc
);
11270 /* Add the code and substitute the rhs expression. */
11271 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
11272 gfc_free_expr ((*code
)->expr2
);
11273 (*code
)->expr2
= tmp_expr
;
11276 /* Do the intrinsic assignment. This is not needed if the lhs is one
11277 of the temporaries generated here, since the intrinsic assignment
11278 to the final result already does this. */
11279 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
11281 this_code
= build_assignment (EXEC_ASSIGN
,
11282 (*code
)->expr1
, (*code
)->expr2
,
11283 NULL
, NULL
, (*code
)->loc
);
11284 add_code_to_chain (&this_code
, &head
, &tail
);
11287 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
11288 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
11291 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
11293 bool inout
= false;
11295 /* The intrinsic assignment does the right thing for pointers
11296 of all kinds and allocatable components. */
11297 if (!gfc_bt_struct (comp1
->ts
.type
)
11298 || comp1
->attr
.pointer
11299 || comp1
->attr
.allocatable
11300 || comp1
->attr
.proc_pointer_comp
11301 || comp1
->attr
.class_pointer
11302 || comp1
->attr
.proc_pointer
)
11305 /* Make an assigment for this component. */
11306 this_code
= build_assignment (EXEC_ASSIGN
,
11307 (*code
)->expr1
, (*code
)->expr2
,
11308 comp1
, comp2
, (*code
)->loc
);
11310 /* Convert the assignment if there is a defined assignment for
11311 this type. Otherwise, using the call from gfc_resolve_code,
11312 recurse into its components. */
11313 gfc_resolve_code (this_code
, ns
);
11315 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11317 gfc_formal_arglist
*dummy_args
;
11319 /* Check that there is a typebound defined assignment. If not,
11320 then this must be a module defined assignment. We cannot
11321 use the defined_assign_comp attribute here because it must
11322 be this derived type that has the defined assignment and not
11324 if (!(comp1
->ts
.u
.derived
->f2k_derived
11325 && comp1
->ts
.u
.derived
->f2k_derived
11326 ->tb_op
[INTRINSIC_ASSIGN
]))
11328 gfc_free_statements (this_code
);
11333 /* If the first argument of the subroutine has intent INOUT
11334 a temporary must be generated and used instead. */
11335 rsym
= this_code
->resolved_sym
;
11336 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11338 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
11340 gfc_code
*temp_code
;
11343 /* Build the temporary required for the assignment and put
11344 it at the head of the generated code. */
11347 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
11348 temp_code
= build_assignment (EXEC_ASSIGN
,
11349 t1
, (*code
)->expr1
,
11350 NULL
, NULL
, (*code
)->loc
);
11352 /* For allocatable LHS, check whether it is allocated. Note
11353 that allocatable components with defined assignment are
11354 not yet support. See PR 57696. */
11355 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11359 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11360 block
= gfc_get_code (EXEC_IF
);
11361 block
->block
= gfc_get_code (EXEC_IF
);
11362 block
->block
->expr1
11363 = gfc_build_intrinsic_call (ns
,
11364 GFC_ISYM_ALLOCATED
, "allocated",
11365 (*code
)->loc
, 1, e
);
11366 block
->block
->next
= temp_code
;
11369 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11372 /* Replace the first actual arg with the component of the
11374 gfc_free_expr (this_code
->ext
.actual
->expr
);
11375 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11376 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11378 /* If the LHS variable is allocatable and wasn't allocated and
11379 the temporary is allocatable, pointer assign the address of
11380 the freshly allocated LHS to the temporary. */
11381 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11382 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11387 cond
= gfc_get_expr ();
11388 cond
->ts
.type
= BT_LOGICAL
;
11389 cond
->ts
.kind
= gfc_default_logical_kind
;
11390 cond
->expr_type
= EXPR_OP
;
11391 cond
->where
= (*code
)->loc
;
11392 cond
->value
.op
.op
= INTRINSIC_NOT
;
11393 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11394 GFC_ISYM_ALLOCATED
, "allocated",
11395 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11396 block
= gfc_get_code (EXEC_IF
);
11397 block
->block
= gfc_get_code (EXEC_IF
);
11398 block
->block
->expr1
= cond
;
11399 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11400 t1
, (*code
)->expr1
,
11401 NULL
, NULL
, (*code
)->loc
);
11402 add_code_to_chain (&block
, &head
, &tail
);
11406 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11408 /* Don't add intrinsic assignments since they are already
11409 effected by the intrinsic assignment of the structure. */
11410 gfc_free_statements (this_code
);
11415 add_code_to_chain (&this_code
, &head
, &tail
);
11419 /* Transfer the value to the final result. */
11420 this_code
= build_assignment (EXEC_ASSIGN
,
11421 (*code
)->expr1
, t1
,
11422 comp1
, comp2
, (*code
)->loc
);
11423 add_code_to_chain (&this_code
, &head
, &tail
);
11427 /* Put the temporary assignments at the top of the generated code. */
11428 if (tmp_head
&& component_assignment_level
== 1)
11430 gfc_append_code (tmp_head
, head
);
11432 tmp_head
= tmp_tail
= NULL
;
11435 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11436 // not accidentally deallocated. Hence, nullify t1.
11437 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11438 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11444 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11445 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11446 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11447 block
= gfc_get_code (EXEC_IF
);
11448 block
->block
= gfc_get_code (EXEC_IF
);
11449 block
->block
->expr1
= cond
;
11450 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11451 t1
, gfc_get_null_expr (&(*code
)->loc
),
11452 NULL
, NULL
, (*code
)->loc
);
11453 gfc_append_code (tail
, block
);
11457 /* Now attach the remaining code chain to the input code. Step on
11458 to the end of the new code since resolution is complete. */
11459 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11460 tail
->next
= (*code
)->next
;
11461 /* Overwrite 'code' because this would place the intrinsic assignment
11462 before the temporary for the lhs is created. */
11463 gfc_free_expr ((*code
)->expr1
);
11464 gfc_free_expr ((*code
)->expr2
);
11470 component_assignment_level
--;
11474 /* F2008: Pointer function assignments are of the form:
11475 ptr_fcn (args) = expr
11476 This function breaks these assignments into two statements:
11477 temporary_pointer => ptr_fcn(args)
11478 temporary_pointer = expr */
11481 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11483 gfc_expr
*tmp_ptr_expr
;
11484 gfc_code
*this_code
;
11485 gfc_component
*comp
;
11488 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11491 /* Even if standard does not support this feature, continue to build
11492 the two statements to avoid upsetting frontend_passes.c. */
11493 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11494 "%L", &(*code
)->loc
);
11496 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11499 s
= comp
->ts
.interface
;
11501 s
= (*code
)->expr1
->symtree
->n
.sym
;
11503 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11505 gfc_error ("The function result on the lhs of the assignment at "
11506 "%L must have the pointer attribute.",
11507 &(*code
)->expr1
->where
);
11508 (*code
)->op
= EXEC_NOP
;
11512 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
11514 /* get_temp_from_expression is set up for ordinary assignments. To that
11515 end, where array bounds are not known, arrays are made allocatable.
11516 Change the temporary to a pointer here. */
11517 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11518 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11519 tmp_ptr_expr
->where
= (*code
)->loc
;
11521 this_code
= build_assignment (EXEC_ASSIGN
,
11522 tmp_ptr_expr
, (*code
)->expr2
,
11523 NULL
, NULL
, (*code
)->loc
);
11524 this_code
->next
= (*code
)->next
;
11525 (*code
)->next
= this_code
;
11526 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11527 (*code
)->expr2
= (*code
)->expr1
;
11528 (*code
)->expr1
= tmp_ptr_expr
;
11534 /* Deferred character length assignments from an operator expression
11535 require a temporary because the character length of the lhs can
11536 change in the course of the assignment. */
11539 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11541 gfc_expr
*tmp_expr
;
11542 gfc_code
*this_code
;
11544 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11545 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11546 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11549 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11552 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
11555 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11556 tmp_expr
->where
= (*code
)->loc
;
11558 /* A new charlen is required to ensure that the variable string
11559 length is different to that of the original lhs. */
11560 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11561 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11562 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11563 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11565 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11567 this_code
= build_assignment (EXEC_ASSIGN
,
11569 gfc_copy_expr (tmp_expr
),
11570 NULL
, NULL
, (*code
)->loc
);
11572 (*code
)->expr1
= tmp_expr
;
11574 this_code
->next
= (*code
)->next
;
11575 (*code
)->next
= this_code
;
11581 /* Given a block of code, recursively resolve everything pointed to by this
11585 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11587 int omp_workshare_save
;
11588 int forall_save
, do_concurrent_save
;
11592 frame
.prev
= cs_base
;
11596 find_reachable_labels (code
);
11598 for (; code
; code
= code
->next
)
11600 frame
.current
= code
;
11601 forall_save
= forall_flag
;
11602 do_concurrent_save
= gfc_do_concurrent_flag
;
11604 if (code
->op
== EXEC_FORALL
)
11607 gfc_resolve_forall (code
, ns
, forall_save
);
11610 else if (code
->block
)
11612 omp_workshare_save
= -1;
11615 case EXEC_OACC_PARALLEL_LOOP
:
11616 case EXEC_OACC_PARALLEL
:
11617 case EXEC_OACC_KERNELS_LOOP
:
11618 case EXEC_OACC_KERNELS
:
11619 case EXEC_OACC_SERIAL_LOOP
:
11620 case EXEC_OACC_SERIAL
:
11621 case EXEC_OACC_DATA
:
11622 case EXEC_OACC_HOST_DATA
:
11623 case EXEC_OACC_LOOP
:
11624 gfc_resolve_oacc_blocks (code
, ns
);
11626 case EXEC_OMP_PARALLEL_WORKSHARE
:
11627 omp_workshare_save
= omp_workshare_flag
;
11628 omp_workshare_flag
= 1;
11629 gfc_resolve_omp_parallel_blocks (code
, ns
);
11631 case EXEC_OMP_PARALLEL
:
11632 case EXEC_OMP_PARALLEL_DO
:
11633 case EXEC_OMP_PARALLEL_DO_SIMD
:
11634 case EXEC_OMP_PARALLEL_SECTIONS
:
11635 case EXEC_OMP_TARGET_PARALLEL
:
11636 case EXEC_OMP_TARGET_PARALLEL_DO
:
11637 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11638 case EXEC_OMP_TARGET_TEAMS
:
11639 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11640 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11641 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11642 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11643 case EXEC_OMP_TASK
:
11644 case EXEC_OMP_TASKLOOP
:
11645 case EXEC_OMP_TASKLOOP_SIMD
:
11646 case EXEC_OMP_TEAMS
:
11647 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11648 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11649 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11650 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11651 omp_workshare_save
= omp_workshare_flag
;
11652 omp_workshare_flag
= 0;
11653 gfc_resolve_omp_parallel_blocks (code
, ns
);
11655 case EXEC_OMP_DISTRIBUTE
:
11656 case EXEC_OMP_DISTRIBUTE_SIMD
:
11658 case EXEC_OMP_DO_SIMD
:
11659 case EXEC_OMP_SIMD
:
11660 case EXEC_OMP_TARGET_SIMD
:
11661 gfc_resolve_omp_do_blocks (code
, ns
);
11663 case EXEC_SELECT_TYPE
:
11664 /* Blocks are handled in resolve_select_type because we have
11665 to transform the SELECT TYPE into ASSOCIATE first. */
11667 case EXEC_DO_CONCURRENT
:
11668 gfc_do_concurrent_flag
= 1;
11669 gfc_resolve_blocks (code
->block
, ns
);
11670 gfc_do_concurrent_flag
= 2;
11672 case EXEC_OMP_WORKSHARE
:
11673 omp_workshare_save
= omp_workshare_flag
;
11674 omp_workshare_flag
= 1;
11677 gfc_resolve_blocks (code
->block
, ns
);
11681 if (omp_workshare_save
!= -1)
11682 omp_workshare_flag
= omp_workshare_save
;
11686 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11687 t
= gfc_resolve_expr (code
->expr1
);
11688 forall_flag
= forall_save
;
11689 gfc_do_concurrent_flag
= do_concurrent_save
;
11691 if (!gfc_resolve_expr (code
->expr2
))
11694 if (code
->op
== EXEC_ALLOCATE
11695 && !gfc_resolve_expr (code
->expr3
))
11701 case EXEC_END_BLOCK
:
11702 case EXEC_END_NESTED_BLOCK
:
11706 case EXEC_ERROR_STOP
:
11708 case EXEC_CONTINUE
:
11710 case EXEC_ASSIGN_CALL
:
11713 case EXEC_CRITICAL
:
11714 resolve_critical (code
);
11717 case EXEC_SYNC_ALL
:
11718 case EXEC_SYNC_IMAGES
:
11719 case EXEC_SYNC_MEMORY
:
11720 resolve_sync (code
);
11725 case EXEC_EVENT_POST
:
11726 case EXEC_EVENT_WAIT
:
11727 resolve_lock_unlock_event (code
);
11730 case EXEC_FAIL_IMAGE
:
11731 case EXEC_FORM_TEAM
:
11732 case EXEC_CHANGE_TEAM
:
11733 case EXEC_END_TEAM
:
11734 case EXEC_SYNC_TEAM
:
11738 /* Keep track of which entry we are up to. */
11739 current_entry_id
= code
->ext
.entry
->id
;
11743 resolve_where (code
, NULL
);
11747 if (code
->expr1
!= NULL
)
11749 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11750 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11751 "INTEGER variable", &code
->expr1
->where
);
11752 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11753 gfc_error ("Variable %qs has not been assigned a target "
11754 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11755 &code
->expr1
->where
);
11758 resolve_branch (code
->label1
, code
);
11762 if (code
->expr1
!= NULL
11763 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11764 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11765 "INTEGER return specifier", &code
->expr1
->where
);
11768 case EXEC_INIT_ASSIGN
:
11769 case EXEC_END_PROCEDURE
:
11776 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11778 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11779 && code
->expr1
->value
.function
.isym
11780 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11781 remove_caf_get_intrinsic (code
->expr1
);
11783 /* If this is a pointer function in an lvalue variable context,
11784 the new code will have to be resolved afresh. This is also the
11785 case with an error, where the code is transformed into NOP to
11786 prevent ICEs downstream. */
11787 if (resolve_ptr_fcn_assign (&code
, ns
)
11788 || code
->op
== EXEC_NOP
)
11791 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11795 if (resolve_ordinary_assign (code
, ns
))
11797 if (code
->op
== EXEC_COMPCALL
)
11803 /* Check for dependencies in deferred character length array
11804 assignments and generate a temporary, if necessary. */
11805 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11808 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11809 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11810 && code
->expr1
->ts
.u
.derived
11811 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11812 generate_component_assignments (&code
, ns
);
11816 case EXEC_LABEL_ASSIGN
:
11817 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11818 gfc_error ("Label %d referenced at %L is never defined",
11819 code
->label1
->value
, &code
->label1
->where
);
11821 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11822 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11823 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11824 != gfc_default_integer_kind
11825 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11826 gfc_error ("ASSIGN statement at %L requires a scalar "
11827 "default INTEGER variable", &code
->expr1
->where
);
11830 case EXEC_POINTER_ASSIGN
:
11837 /* This is both a variable definition and pointer assignment
11838 context, so check both of them. For rank remapping, a final
11839 array ref may be present on the LHS and fool gfc_expr_attr
11840 used in gfc_check_vardef_context. Remove it. */
11841 e
= remove_last_array_ref (code
->expr1
);
11842 t
= gfc_check_vardef_context (e
, true, false, false,
11843 _("pointer assignment"));
11845 t
= gfc_check_vardef_context (e
, false, false, false,
11846 _("pointer assignment"));
11849 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
11854 /* Assigning a class object always is a regular assign. */
11855 if (code
->expr2
->ts
.type
== BT_CLASS
11856 && code
->expr1
->ts
.type
== BT_CLASS
11857 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11858 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11859 && code
->expr2
->expr_type
== EXPR_VARIABLE
11860 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11862 code
->op
= EXEC_ASSIGN
;
11866 case EXEC_ARITHMETIC_IF
:
11868 gfc_expr
*e
= code
->expr1
;
11870 gfc_resolve_expr (e
);
11871 if (e
->expr_type
== EXPR_NULL
)
11872 gfc_error ("Invalid NULL at %L", &e
->where
);
11874 if (t
&& (e
->rank
> 0
11875 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11876 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11877 "REAL or INTEGER expression", &e
->where
);
11879 resolve_branch (code
->label1
, code
);
11880 resolve_branch (code
->label2
, code
);
11881 resolve_branch (code
->label3
, code
);
11886 if (t
&& code
->expr1
!= NULL
11887 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11888 || code
->expr1
->rank
!= 0))
11889 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11890 &code
->expr1
->where
);
11895 resolve_call (code
);
11898 case EXEC_COMPCALL
:
11900 resolve_typebound_subroutine (code
);
11903 case EXEC_CALL_PPC
:
11904 resolve_ppc_call (code
);
11908 /* Select is complicated. Also, a SELECT construct could be
11909 a transformed computed GOTO. */
11910 resolve_select (code
, false);
11913 case EXEC_SELECT_TYPE
:
11914 resolve_select_type (code
, ns
);
11917 case EXEC_SELECT_RANK
:
11918 resolve_select_rank (code
, ns
);
11922 resolve_block_construct (code
);
11926 if (code
->ext
.iterator
!= NULL
)
11928 gfc_iterator
*iter
= code
->ext
.iterator
;
11929 if (gfc_resolve_iterator (iter
, true, false))
11930 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11935 case EXEC_DO_WHILE
:
11936 if (code
->expr1
== NULL
)
11937 gfc_internal_error ("gfc_resolve_code(): No expression on "
11940 && (code
->expr1
->rank
!= 0
11941 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11942 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11943 "a scalar LOGICAL expression", &code
->expr1
->where
);
11946 case EXEC_ALLOCATE
:
11948 resolve_allocate_deallocate (code
, "ALLOCATE");
11952 case EXEC_DEALLOCATE
:
11954 resolve_allocate_deallocate (code
, "DEALLOCATE");
11959 if (!gfc_resolve_open (code
->ext
.open
))
11962 resolve_branch (code
->ext
.open
->err
, code
);
11966 if (!gfc_resolve_close (code
->ext
.close
))
11969 resolve_branch (code
->ext
.close
->err
, code
);
11972 case EXEC_BACKSPACE
:
11976 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
11979 resolve_branch (code
->ext
.filepos
->err
, code
);
11983 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11986 resolve_branch (code
->ext
.inquire
->err
, code
);
11989 case EXEC_IOLENGTH
:
11990 gcc_assert (code
->ext
.inquire
!= NULL
);
11991 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11994 resolve_branch (code
->ext
.inquire
->err
, code
);
11998 if (!gfc_resolve_wait (code
->ext
.wait
))
12001 resolve_branch (code
->ext
.wait
->err
, code
);
12002 resolve_branch (code
->ext
.wait
->end
, code
);
12003 resolve_branch (code
->ext
.wait
->eor
, code
);
12008 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
12011 resolve_branch (code
->ext
.dt
->err
, code
);
12012 resolve_branch (code
->ext
.dt
->end
, code
);
12013 resolve_branch (code
->ext
.dt
->eor
, code
);
12016 case EXEC_TRANSFER
:
12017 resolve_transfer (code
);
12020 case EXEC_DO_CONCURRENT
:
12022 resolve_forall_iterators (code
->ext
.forall_iterator
);
12024 if (code
->expr1
!= NULL
12025 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
12026 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
12027 "expression", &code
->expr1
->where
);
12030 case EXEC_OACC_PARALLEL_LOOP
:
12031 case EXEC_OACC_PARALLEL
:
12032 case EXEC_OACC_KERNELS_LOOP
:
12033 case EXEC_OACC_KERNELS
:
12034 case EXEC_OACC_SERIAL_LOOP
:
12035 case EXEC_OACC_SERIAL
:
12036 case EXEC_OACC_DATA
:
12037 case EXEC_OACC_HOST_DATA
:
12038 case EXEC_OACC_LOOP
:
12039 case EXEC_OACC_UPDATE
:
12040 case EXEC_OACC_WAIT
:
12041 case EXEC_OACC_CACHE
:
12042 case EXEC_OACC_ENTER_DATA
:
12043 case EXEC_OACC_EXIT_DATA
:
12044 case EXEC_OACC_ATOMIC
:
12045 case EXEC_OACC_DECLARE
:
12046 gfc_resolve_oacc_directive (code
, ns
);
12049 case EXEC_OMP_ATOMIC
:
12050 case EXEC_OMP_BARRIER
:
12051 case EXEC_OMP_CANCEL
:
12052 case EXEC_OMP_CANCELLATION_POINT
:
12053 case EXEC_OMP_CRITICAL
:
12054 case EXEC_OMP_FLUSH
:
12055 case EXEC_OMP_DISTRIBUTE
:
12056 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
12057 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
12058 case EXEC_OMP_DISTRIBUTE_SIMD
:
12060 case EXEC_OMP_DO_SIMD
:
12061 case EXEC_OMP_MASTER
:
12062 case EXEC_OMP_ORDERED
:
12063 case EXEC_OMP_SECTIONS
:
12064 case EXEC_OMP_SIMD
:
12065 case EXEC_OMP_SINGLE
:
12066 case EXEC_OMP_TARGET
:
12067 case EXEC_OMP_TARGET_DATA
:
12068 case EXEC_OMP_TARGET_ENTER_DATA
:
12069 case EXEC_OMP_TARGET_EXIT_DATA
:
12070 case EXEC_OMP_TARGET_PARALLEL
:
12071 case EXEC_OMP_TARGET_PARALLEL_DO
:
12072 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
12073 case EXEC_OMP_TARGET_SIMD
:
12074 case EXEC_OMP_TARGET_TEAMS
:
12075 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
12076 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12077 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12078 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
12079 case EXEC_OMP_TARGET_UPDATE
:
12080 case EXEC_OMP_TASK
:
12081 case EXEC_OMP_TASKGROUP
:
12082 case EXEC_OMP_TASKLOOP
:
12083 case EXEC_OMP_TASKLOOP_SIMD
:
12084 case EXEC_OMP_TASKWAIT
:
12085 case EXEC_OMP_TASKYIELD
:
12086 case EXEC_OMP_TEAMS
:
12087 case EXEC_OMP_TEAMS_DISTRIBUTE
:
12088 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12089 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12090 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
12091 case EXEC_OMP_WORKSHARE
:
12092 gfc_resolve_omp_directive (code
, ns
);
12095 case EXEC_OMP_PARALLEL
:
12096 case EXEC_OMP_PARALLEL_DO
:
12097 case EXEC_OMP_PARALLEL_DO_SIMD
:
12098 case EXEC_OMP_PARALLEL_SECTIONS
:
12099 case EXEC_OMP_PARALLEL_WORKSHARE
:
12100 omp_workshare_save
= omp_workshare_flag
;
12101 omp_workshare_flag
= 0;
12102 gfc_resolve_omp_directive (code
, ns
);
12103 omp_workshare_flag
= omp_workshare_save
;
12107 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
12111 cs_base
= frame
.prev
;
12115 /* Resolve initial values and make sure they are compatible with
12119 resolve_values (gfc_symbol
*sym
)
12123 if (sym
->value
== NULL
)
12126 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
12127 t
= resolve_structure_cons (sym
->value
, 1);
12129 t
= gfc_resolve_expr (sym
->value
);
12134 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
12138 /* Verify any BIND(C) derived types in the namespace so we can report errors
12139 for them once, rather than for each variable declared of that type. */
12142 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
12144 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
12145 && derived_sym
->attr
.is_bind_c
== 1)
12146 verify_bind_c_derived_type (derived_sym
);
12152 /* Check the interfaces of DTIO procedures associated with derived
12153 type 'sym'. These procedures can either have typebound bindings or
12154 can appear in DTIO generic interfaces. */
12157 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
12159 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
12162 gfc_check_dtio_interfaces (sym
);
12167 /* Verify that any binding labels used in a given namespace do not collide
12168 with the names or binding labels of any global symbols. Multiple INTERFACE
12169 for the same procedure are permitted. */
12172 gfc_verify_binding_labels (gfc_symbol
*sym
)
12175 const char *module
;
12177 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
12178 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
12181 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
12184 module
= sym
->module
;
12185 else if (sym
->ns
&& sym
->ns
->proc_name
12186 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
12187 module
= sym
->ns
->proc_name
->name
;
12188 else if (sym
->ns
&& sym
->ns
->parent
12189 && sym
->ns
&& sym
->ns
->parent
->proc_name
12190 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12191 module
= sym
->ns
->parent
->proc_name
->name
;
12197 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
12200 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
12201 gsym
->where
= sym
->declared_at
;
12202 gsym
->sym_name
= sym
->name
;
12203 gsym
->binding_label
= sym
->binding_label
;
12204 gsym
->ns
= sym
->ns
;
12205 gsym
->mod_name
= module
;
12206 if (sym
->attr
.function
)
12207 gsym
->type
= GSYM_FUNCTION
;
12208 else if (sym
->attr
.subroutine
)
12209 gsym
->type
= GSYM_SUBROUTINE
;
12210 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
12211 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
12215 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
12217 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
12218 "identifier as entity at %L", sym
->name
,
12219 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12220 /* Clear the binding label to prevent checking multiple times. */
12221 sym
->binding_label
= NULL
;
12225 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
12226 && (strcmp (module
, gsym
->mod_name
) != 0
12227 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
12229 /* This can only happen if the variable is defined in a module - if it
12230 isn't the same module, reject it. */
12231 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
12232 "uses the same global identifier as entity at %L from module %qs",
12233 sym
->name
, module
, sym
->binding_label
,
12234 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
12235 sym
->binding_label
= NULL
;
12239 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
12240 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
12241 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
12242 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
12243 && (module
!= gsym
->mod_name
12244 || strcmp (gsym
->sym_name
, sym
->name
) != 0
12245 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
12247 /* Print an error if the procedure is defined multiple times; we have to
12248 exclude references to the same procedure via module association or
12249 multiple checks for the same procedure. */
12250 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
12251 "global identifier as entity at %L", sym
->name
,
12252 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12253 sym
->binding_label
= NULL
;
12258 /* Resolve an index expression. */
12261 resolve_index_expr (gfc_expr
*e
)
12263 if (!gfc_resolve_expr (e
))
12266 if (!gfc_simplify_expr (e
, 0))
12269 if (!gfc_specification_expr (e
))
12276 /* Resolve a charlen structure. */
12279 resolve_charlen (gfc_charlen
*cl
)
12282 bool saved_specification_expr
;
12288 saved_specification_expr
= specification_expr
;
12289 specification_expr
= true;
12291 if (cl
->length_from_typespec
)
12293 if (!gfc_resolve_expr (cl
->length
))
12295 specification_expr
= saved_specification_expr
;
12299 if (!gfc_simplify_expr (cl
->length
, 0))
12301 specification_expr
= saved_specification_expr
;
12305 /* cl->length has been resolved. It should have an integer type. */
12306 if (cl
->length
->ts
.type
!= BT_INTEGER
)
12308 gfc_error ("Scalar INTEGER expression expected at %L",
12309 &cl
->length
->where
);
12315 if (!resolve_index_expr (cl
->length
))
12317 specification_expr
= saved_specification_expr
;
12322 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12323 a negative value, the length of character entities declared is zero. */
12324 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12325 && mpz_sgn (cl
->length
->value
.integer
) < 0)
12326 gfc_replace_expr (cl
->length
,
12327 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
12329 /* Check that the character length is not too large. */
12330 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
12331 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12332 && cl
->length
->ts
.type
== BT_INTEGER
12333 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
12335 gfc_error ("String length at %L is too large", &cl
->length
->where
);
12336 specification_expr
= saved_specification_expr
;
12340 specification_expr
= saved_specification_expr
;
12345 /* Test for non-constant shape arrays. */
12348 is_non_constant_shape_array (gfc_symbol
*sym
)
12354 not_constant
= false;
12355 if (sym
->as
!= NULL
)
12357 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12358 has not been simplified; parameter array references. Do the
12359 simplification now. */
12360 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12362 if (i
== GFC_MAX_DIMENSIONS
)
12365 e
= sym
->as
->lower
[i
];
12366 if (e
&& (!resolve_index_expr(e
)
12367 || !gfc_is_constant_expr (e
)))
12368 not_constant
= true;
12369 e
= sym
->as
->upper
[i
];
12370 if (e
&& (!resolve_index_expr(e
)
12371 || !gfc_is_constant_expr (e
)))
12372 not_constant
= true;
12375 return not_constant
;
12378 /* Given a symbol and an initialization expression, add code to initialize
12379 the symbol to the function entry. */
12381 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12385 gfc_namespace
*ns
= sym
->ns
;
12387 /* Search for the function namespace if this is a contained
12388 function without an explicit result. */
12389 if (sym
->attr
.function
&& sym
== sym
->result
12390 && sym
->name
!= sym
->ns
->proc_name
->name
)
12392 ns
= ns
->contained
;
12393 for (;ns
; ns
= ns
->sibling
)
12394 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12400 gfc_free_expr (init
);
12404 /* Build an l-value expression for the result. */
12405 lval
= gfc_lval_expr_from_sym (sym
);
12407 /* Add the code at scope entry. */
12408 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
12409 init_st
->next
= ns
->code
;
12410 ns
->code
= init_st
;
12412 /* Assign the default initializer to the l-value. */
12413 init_st
->loc
= sym
->declared_at
;
12414 init_st
->expr1
= lval
;
12415 init_st
->expr2
= init
;
12419 /* Whether or not we can generate a default initializer for a symbol. */
12422 can_generate_init (gfc_symbol
*sym
)
12424 symbol_attribute
*a
;
12429 /* These symbols should never have a default initialization. */
12434 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
12435 && (CLASS_DATA (sym
)->attr
.class_pointer
12436 || CLASS_DATA (sym
)->attr
.proc_pointer
))
12437 || a
->in_equivalence
12444 || (!a
->referenced
&& !a
->result
)
12445 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
12446 || (a
->function
&& sym
!= sym
->result
)
12451 /* Assign the default initializer to a derived type variable or result. */
12454 apply_default_init (gfc_symbol
*sym
)
12456 gfc_expr
*init
= NULL
;
12458 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12461 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12462 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12464 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12467 build_init_assign (sym
, init
);
12468 sym
->attr
.referenced
= 1;
12472 /* Build an initializer for a local. Returns null if the symbol should not have
12473 a default initialization. */
12476 build_default_init_expr (gfc_symbol
*sym
)
12478 /* These symbols should never have a default initialization. */
12479 if (sym
->attr
.allocatable
12480 || sym
->attr
.external
12482 || sym
->attr
.pointer
12483 || sym
->attr
.in_equivalence
12484 || sym
->attr
.in_common
12487 || sym
->attr
.cray_pointee
12488 || sym
->attr
.cray_pointer
12492 /* Get the appropriate init expression. */
12493 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12496 /* Add an initialization expression to a local variable. */
12498 apply_default_init_local (gfc_symbol
*sym
)
12500 gfc_expr
*init
= NULL
;
12502 /* The symbol should be a variable or a function return value. */
12503 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12504 || (sym
->attr
.function
&& sym
->result
!= sym
))
12507 /* Try to build the initializer expression. If we can't initialize
12508 this symbol, then init will be NULL. */
12509 init
= build_default_init_expr (sym
);
12513 /* For saved variables, we don't want to add an initializer at function
12514 entry, so we just add a static initializer. Note that automatic variables
12515 are stack allocated even with -fno-automatic; we have also to exclude
12516 result variable, which are also nonstatic. */
12517 if (!sym
->attr
.automatic
12518 && (sym
->attr
.save
|| sym
->ns
->save_all
12519 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12520 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12521 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12523 /* Don't clobber an existing initializer! */
12524 gcc_assert (sym
->value
== NULL
);
12529 build_init_assign (sym
, init
);
12533 /* Resolution of common features of flavors variable and procedure. */
12536 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12538 gfc_array_spec
*as
;
12540 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12541 as
= CLASS_DATA (sym
)->as
;
12545 /* Constraints on deferred shape variable. */
12546 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12548 bool pointer
, allocatable
, dimension
;
12550 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12552 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12553 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12554 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12558 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12559 allocatable
= sym
->attr
.allocatable
;
12560 dimension
= sym
->attr
.dimension
;
12565 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12567 gfc_error ("Allocatable array %qs at %L must have a deferred "
12568 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12571 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12572 "%qs at %L may not be ALLOCATABLE",
12573 sym
->name
, &sym
->declared_at
))
12577 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12579 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12580 "assumed rank", sym
->name
, &sym
->declared_at
);
12586 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12587 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12589 gfc_error ("Array %qs at %L cannot have a deferred shape",
12590 sym
->name
, &sym
->declared_at
);
12595 /* Constraints on polymorphic variables. */
12596 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12599 if (sym
->attr
.class_ok
12600 && !sym
->attr
.select_type_temporary
12601 && !UNLIMITED_POLY (sym
)
12602 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12604 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12605 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12606 &sym
->declared_at
);
12611 /* Assume that use associated symbols were checked in the module ns.
12612 Class-variables that are associate-names are also something special
12613 and excepted from the test. */
12614 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12616 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12617 "or pointer", sym
->name
, &sym
->declared_at
);
12626 /* Additional checks for symbols with flavor variable and derived
12627 type. To be called from resolve_fl_variable. */
12630 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12632 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12634 /* Check to see if a derived type is blocked from being host
12635 associated by the presence of another class I symbol in the same
12636 namespace. 14.6.1.3 of the standard and the discussion on
12637 comp.lang.fortran. */
12638 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12639 && !sym
->ts
.u
.derived
->attr
.use_assoc
12640 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12643 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12644 if (s
&& s
->attr
.generic
)
12645 s
= gfc_find_dt_in_generic (s
);
12646 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12648 gfc_error ("The type %qs cannot be host associated at %L "
12649 "because it is blocked by an incompatible object "
12650 "of the same name declared at %L",
12651 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12657 /* 4th constraint in section 11.3: "If an object of a type for which
12658 component-initialization is specified (R429) appears in the
12659 specification-part of a module and does not have the ALLOCATABLE
12660 or POINTER attribute, the object shall have the SAVE attribute."
12662 The check for initializers is performed with
12663 gfc_has_default_initializer because gfc_default_initializer generates
12664 a hidden default for allocatable components. */
12665 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12666 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12667 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12668 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12669 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12670 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12671 "%qs at %L, needed due to the default "
12672 "initialization", sym
->name
, &sym
->declared_at
))
12675 /* Assign default initializer. */
12676 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12677 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12678 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12684 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12685 except in the declaration of an entity or component that has the POINTER
12686 or ALLOCATABLE attribute. */
12689 deferred_requirements (gfc_symbol
*sym
)
12691 if (sym
->ts
.deferred
12692 && !(sym
->attr
.pointer
12693 || sym
->attr
.allocatable
12694 || sym
->attr
.associate_var
12695 || sym
->attr
.omp_udr_artificial_var
))
12697 /* If a function has a result variable, only check the variable. */
12698 if (sym
->result
&& sym
->name
!= sym
->result
->name
)
12701 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12702 "requires either the POINTER or ALLOCATABLE attribute",
12703 sym
->name
, &sym
->declared_at
);
12710 /* Resolve symbols with flavor variable. */
12713 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12715 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
12718 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12721 /* Set this flag to check that variables are parameters of all entries.
12722 This check is effected by the call to gfc_resolve_expr through
12723 is_non_constant_shape_array. */
12724 bool saved_specification_expr
= specification_expr
;
12725 specification_expr
= true;
12727 if (sym
->ns
->proc_name
12728 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12729 || sym
->ns
->proc_name
->attr
.is_main_program
)
12730 && !sym
->attr
.use_assoc
12731 && !sym
->attr
.allocatable
12732 && !sym
->attr
.pointer
12733 && is_non_constant_shape_array (sym
))
12735 /* F08:C541. The shape of an array defined in a main program or module
12736 * needs to be constant. */
12737 gfc_error ("The module or main program array %qs at %L must "
12738 "have constant shape", sym
->name
, &sym
->declared_at
);
12739 specification_expr
= saved_specification_expr
;
12743 /* Constraints on deferred type parameter. */
12744 if (!deferred_requirements (sym
))
12747 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12749 /* Make sure that character string variables with assumed length are
12750 dummy arguments. */
12751 gfc_expr
*e
= NULL
;
12754 e
= sym
->ts
.u
.cl
->length
;
12758 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12759 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12760 && !sym
->attr
.omp_udr_artificial_var
)
12762 gfc_error ("Entity with assumed character length at %L must be a "
12763 "dummy argument or a PARAMETER", &sym
->declared_at
);
12764 specification_expr
= saved_specification_expr
;
12768 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12770 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12771 specification_expr
= saved_specification_expr
;
12775 if (!gfc_is_constant_expr (e
)
12776 && !(e
->expr_type
== EXPR_VARIABLE
12777 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12779 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12780 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12781 || sym
->ns
->proc_name
->attr
.is_main_program
))
12783 gfc_error ("%qs at %L must have constant character length "
12784 "in this context", sym
->name
, &sym
->declared_at
);
12785 specification_expr
= saved_specification_expr
;
12788 if (sym
->attr
.in_common
)
12790 gfc_error ("COMMON variable %qs at %L must have constant "
12791 "character length", sym
->name
, &sym
->declared_at
);
12792 specification_expr
= saved_specification_expr
;
12798 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12799 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12801 /* Determine if the symbol may not have an initializer. */
12802 int no_init_flag
= 0, automatic_flag
= 0;
12803 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12804 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12806 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12807 && is_non_constant_shape_array (sym
))
12809 no_init_flag
= automatic_flag
= 1;
12811 /* Also, they must not have the SAVE attribute.
12812 SAVE_IMPLICIT is checked below. */
12813 if (sym
->as
&& sym
->attr
.codimension
)
12815 int corank
= sym
->as
->corank
;
12816 sym
->as
->corank
= 0;
12817 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12818 sym
->as
->corank
= corank
;
12820 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12822 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12823 specification_expr
= saved_specification_expr
;
12828 /* Ensure that any initializer is simplified. */
12830 gfc_simplify_expr (sym
->value
, 1);
12832 /* Reject illegal initializers. */
12833 if (!sym
->mark
&& sym
->value
)
12835 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12836 && CLASS_DATA (sym
)->attr
.allocatable
))
12837 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12838 sym
->name
, &sym
->declared_at
);
12839 else if (sym
->attr
.external
)
12840 gfc_error ("External %qs at %L cannot have an initializer",
12841 sym
->name
, &sym
->declared_at
);
12842 else if (sym
->attr
.dummy
12843 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12844 gfc_error ("Dummy %qs at %L cannot have an initializer",
12845 sym
->name
, &sym
->declared_at
);
12846 else if (sym
->attr
.intrinsic
)
12847 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12848 sym
->name
, &sym
->declared_at
);
12849 else if (sym
->attr
.result
)
12850 gfc_error ("Function result %qs at %L cannot have an initializer",
12851 sym
->name
, &sym
->declared_at
);
12852 else if (automatic_flag
)
12853 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12854 sym
->name
, &sym
->declared_at
);
12856 goto no_init_error
;
12857 specification_expr
= saved_specification_expr
;
12862 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12864 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12865 specification_expr
= saved_specification_expr
;
12869 specification_expr
= saved_specification_expr
;
12874 /* Compare the dummy characteristics of a module procedure interface
12875 declaration with the corresponding declaration in a submodule. */
12876 static gfc_formal_arglist
*new_formal
;
12877 static char errmsg
[200];
12880 compare_fsyms (gfc_symbol
*sym
)
12884 if (sym
== NULL
|| new_formal
== NULL
)
12887 fsym
= new_formal
->sym
;
12892 if (strcmp (sym
->name
, fsym
->name
) == 0)
12894 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12895 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12900 /* Resolve a procedure. */
12903 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12905 gfc_formal_arglist
*arg
;
12907 if (sym
->attr
.function
12908 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12911 /* Constraints on deferred type parameter. */
12912 if (!deferred_requirements (sym
))
12915 if (sym
->ts
.type
== BT_CHARACTER
)
12917 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12919 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12920 && !resolve_charlen (cl
))
12923 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12924 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12926 gfc_error ("Character-valued statement function %qs at %L must "
12927 "have constant length", sym
->name
, &sym
->declared_at
);
12932 /* Ensure that derived type for are not of a private type. Internal
12933 module procedures are excluded by 2.2.3.3 - i.e., they are not
12934 externally accessible and can access all the objects accessible in
12936 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
12937 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12938 && gfc_check_symbol_access (sym
))
12940 gfc_interface
*iface
;
12942 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12945 && arg
->sym
->ts
.type
== BT_DERIVED
12946 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12947 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12948 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12949 "and cannot be a dummy argument"
12950 " of %qs, which is PUBLIC at %L",
12951 arg
->sym
->name
, sym
->name
,
12952 &sym
->declared_at
))
12954 /* Stop this message from recurring. */
12955 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12960 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12961 PRIVATE to the containing module. */
12962 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12964 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12967 && arg
->sym
->ts
.type
== BT_DERIVED
12968 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12969 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12970 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12971 "PUBLIC interface %qs at %L "
12972 "takes dummy arguments of %qs which "
12973 "is PRIVATE", iface
->sym
->name
,
12974 sym
->name
, &iface
->sym
->declared_at
,
12975 gfc_typename(&arg
->sym
->ts
)))
12977 /* Stop this message from recurring. */
12978 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12985 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12986 && !sym
->attr
.proc_pointer
)
12988 gfc_error ("Function %qs at %L cannot have an initializer",
12989 sym
->name
, &sym
->declared_at
);
12991 /* Make sure no second error is issued for this. */
12992 sym
->value
->error
= 1;
12996 /* An external symbol may not have an initializer because it is taken to be
12997 a procedure. Exception: Procedure Pointers. */
12998 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
13000 gfc_error ("External object %qs at %L may not have an initializer",
13001 sym
->name
, &sym
->declared_at
);
13005 /* An elemental function is required to return a scalar 12.7.1 */
13006 if (sym
->attr
.elemental
&& sym
->attr
.function
13007 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)))
13009 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
13010 "result", sym
->name
, &sym
->declared_at
);
13011 /* Reset so that the error only occurs once. */
13012 sym
->attr
.elemental
= 0;
13016 if (sym
->attr
.proc
== PROC_ST_FUNCTION
13017 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
13019 gfc_error ("Statement function %qs at %L may not have pointer or "
13020 "allocatable attribute", sym
->name
, &sym
->declared_at
);
13024 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
13025 char-len-param shall not be array-valued, pointer-valued, recursive
13026 or pure. ....snip... A character value of * may only be used in the
13027 following ways: (i) Dummy arg of procedure - dummy associates with
13028 actual length; (ii) To declare a named constant; or (iii) External
13029 function - but length must be declared in calling scoping unit. */
13030 if (sym
->attr
.function
13031 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
13032 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
13034 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
13035 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
13037 if (sym
->as
&& sym
->as
->rank
)
13038 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13039 "array-valued", sym
->name
, &sym
->declared_at
);
13041 if (sym
->attr
.pointer
)
13042 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13043 "pointer-valued", sym
->name
, &sym
->declared_at
);
13045 if (sym
->attr
.pure
)
13046 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13047 "pure", sym
->name
, &sym
->declared_at
);
13049 if (sym
->attr
.recursive
)
13050 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13051 "recursive", sym
->name
, &sym
->declared_at
);
13056 /* Appendix B.2 of the standard. Contained functions give an
13057 error anyway. Deferred character length is an F2003 feature.
13058 Don't warn on intrinsic conversion functions, which start
13059 with two underscores. */
13060 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
13061 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
13062 gfc_notify_std (GFC_STD_F95_OBS
,
13063 "CHARACTER(*) function %qs at %L",
13064 sym
->name
, &sym
->declared_at
);
13067 /* F2008, C1218. */
13068 if (sym
->attr
.elemental
)
13070 if (sym
->attr
.proc_pointer
)
13072 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
13073 sym
->name
, &sym
->declared_at
);
13076 if (sym
->attr
.dummy
)
13078 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
13079 sym
->name
, &sym
->declared_at
);
13084 /* F2018, C15100: "The result of an elemental function shall be scalar,
13085 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
13086 pointer is tested and caught elsewhere. */
13087 if (sym
->attr
.elemental
&& sym
->result
13088 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
13090 gfc_error ("Function result variable %qs at %L of elemental "
13091 "function %qs shall not have an ALLOCATABLE or POINTER "
13092 "attribute", sym
->result
->name
,
13093 &sym
->result
->declared_at
, sym
->name
);
13097 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
13099 gfc_formal_arglist
*curr_arg
;
13100 int has_non_interop_arg
= 0;
13102 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13103 sym
->common_block
))
13105 /* Clear these to prevent looking at them again if there was an
13107 sym
->attr
.is_bind_c
= 0;
13108 sym
->attr
.is_c_interop
= 0;
13109 sym
->ts
.is_c_interop
= 0;
13113 /* So far, no errors have been found. */
13114 sym
->attr
.is_c_interop
= 1;
13115 sym
->ts
.is_c_interop
= 1;
13118 curr_arg
= gfc_sym_get_dummy_args (sym
);
13119 while (curr_arg
!= NULL
)
13121 /* Skip implicitly typed dummy args here. */
13122 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
13123 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
13124 /* If something is found to fail, record the fact so we
13125 can mark the symbol for the procedure as not being
13126 BIND(C) to try and prevent multiple errors being
13128 has_non_interop_arg
= 1;
13130 curr_arg
= curr_arg
->next
;
13133 /* See if any of the arguments were not interoperable and if so, clear
13134 the procedure symbol to prevent duplicate error messages. */
13135 if (has_non_interop_arg
!= 0)
13137 sym
->attr
.is_c_interop
= 0;
13138 sym
->ts
.is_c_interop
= 0;
13139 sym
->attr
.is_bind_c
= 0;
13143 if (!sym
->attr
.proc_pointer
)
13145 if (sym
->attr
.save
== SAVE_EXPLICIT
)
13147 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
13148 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13151 if (sym
->attr
.intent
)
13153 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
13154 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13157 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
13159 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
13160 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13163 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
13164 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
13165 || sym
->attr
.contained
))
13167 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
13168 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13171 if (strcmp ("ppr@", sym
->name
) == 0)
13173 gfc_error ("Procedure pointer result %qs at %L "
13174 "is missing the pointer attribute",
13175 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
13180 /* Assume that a procedure whose body is not known has references
13181 to external arrays. */
13182 if (sym
->attr
.if_source
!= IFSRC_DECL
)
13183 sym
->attr
.array_outer_dependency
= 1;
13185 /* Compare the characteristics of a module procedure with the
13186 interface declaration. Ideally this would be done with
13187 gfc_compare_interfaces but, at present, the formal interface
13188 cannot be copied to the ts.interface. */
13189 if (sym
->attr
.module_procedure
13190 && sym
->attr
.if_source
== IFSRC_DECL
)
13193 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
13195 char *submodule_name
;
13196 strcpy (name
, sym
->ns
->proc_name
->name
);
13197 module_name
= strtok (name
, ".");
13198 submodule_name
= strtok (NULL
, ".");
13200 iface
= sym
->tlink
;
13203 /* Make sure that the result uses the correct charlen for deferred
13205 if (iface
&& sym
->result
13206 && iface
->ts
.type
== BT_CHARACTER
13207 && iface
->ts
.deferred
)
13208 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
13213 /* Check the procedure characteristics. */
13214 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
13216 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
13217 "PROCEDURE at %L and its interface in %s",
13218 &sym
->declared_at
, module_name
);
13222 if (sym
->attr
.pure
!= iface
->attr
.pure
)
13224 gfc_error ("Mismatch in PURE attribute between MODULE "
13225 "PROCEDURE at %L and its interface in %s",
13226 &sym
->declared_at
, module_name
);
13230 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
13232 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
13233 "PROCEDURE at %L and its interface in %s",
13234 &sym
->declared_at
, module_name
);
13238 /* Check the result characteristics. */
13239 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
13241 gfc_error ("%s between the MODULE PROCEDURE declaration "
13242 "in MODULE %qs and the declaration at %L in "
13244 errmsg
, module_name
, &sym
->declared_at
,
13245 submodule_name
? submodule_name
: module_name
);
13250 /* Check the characteristics of the formal arguments. */
13251 if (sym
->formal
&& sym
->formal_ns
)
13253 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
13256 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
13264 /* Resolve a list of finalizer procedures. That is, after they have hopefully
13265 been defined and we now know their defined arguments, check that they fulfill
13266 the requirements of the standard for procedures used as finalizers. */
13269 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
13271 gfc_finalizer
* list
;
13272 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
13273 bool result
= true;
13274 bool seen_scalar
= false;
13277 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
13280 gfc_resolve_finalizers (parent
, finalizable
);
13282 /* Ensure that derived-type components have a their finalizers resolved. */
13283 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
13284 for (c
= derived
->components
; c
; c
= c
->next
)
13285 if (c
->ts
.type
== BT_DERIVED
13286 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
13288 bool has_final2
= false;
13289 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
13290 return false; /* Error. */
13291 has_final
= has_final
|| has_final2
;
13293 /* Return early if not finalizable. */
13297 *finalizable
= false;
13301 /* Walk over the list of finalizer-procedures, check them, and if any one
13302 does not fit in with the standard's definition, print an error and remove
13303 it from the list. */
13304 prev_link
= &derived
->f2k_derived
->finalizers
;
13305 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
13307 gfc_formal_arglist
*dummy_args
;
13312 /* Skip this finalizer if we already resolved it. */
13313 if (list
->proc_tree
)
13315 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
13316 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
13317 seen_scalar
= true;
13318 prev_link
= &(list
->next
);
13322 /* Check this exists and is a SUBROUTINE. */
13323 if (!list
->proc_sym
->attr
.subroutine
)
13325 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
13326 list
->proc_sym
->name
, &list
->where
);
13330 /* We should have exactly one argument. */
13331 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
13332 if (!dummy_args
|| dummy_args
->next
)
13334 gfc_error ("FINAL procedure at %L must have exactly one argument",
13338 arg
= dummy_args
->sym
;
13340 /* This argument must be of our type. */
13341 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
13343 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
13344 &arg
->declared_at
, derived
->name
);
13348 /* It must neither be a pointer nor allocatable nor optional. */
13349 if (arg
->attr
.pointer
)
13351 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13352 &arg
->declared_at
);
13355 if (arg
->attr
.allocatable
)
13357 gfc_error ("Argument of FINAL procedure at %L must not be"
13358 " ALLOCATABLE", &arg
->declared_at
);
13361 if (arg
->attr
.optional
)
13363 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13364 &arg
->declared_at
);
13368 /* It must not be INTENT(OUT). */
13369 if (arg
->attr
.intent
== INTENT_OUT
)
13371 gfc_error ("Argument of FINAL procedure at %L must not be"
13372 " INTENT(OUT)", &arg
->declared_at
);
13376 /* Warn if the procedure is non-scalar and not assumed shape. */
13377 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
13378 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
13379 gfc_warning (OPT_Wsurprising
,
13380 "Non-scalar FINAL procedure at %L should have assumed"
13381 " shape argument", &arg
->declared_at
);
13383 /* Check that it does not match in kind and rank with a FINAL procedure
13384 defined earlier. To really loop over the *earlier* declarations,
13385 we need to walk the tail of the list as new ones were pushed at the
13387 /* TODO: Handle kind parameters once they are implemented. */
13388 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
13389 for (i
= list
->next
; i
; i
= i
->next
)
13391 gfc_formal_arglist
*dummy_args
;
13393 /* Argument list might be empty; that is an error signalled earlier,
13394 but we nevertheless continued resolving. */
13395 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
13398 gfc_symbol
* i_arg
= dummy_args
->sym
;
13399 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
13400 if (i_rank
== my_rank
)
13402 gfc_error ("FINAL procedure %qs declared at %L has the same"
13403 " rank (%d) as %qs",
13404 list
->proc_sym
->name
, &list
->where
, my_rank
,
13405 i
->proc_sym
->name
);
13411 /* Is this the/a scalar finalizer procedure? */
13413 seen_scalar
= true;
13415 /* Find the symtree for this procedure. */
13416 gcc_assert (!list
->proc_tree
);
13417 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
13419 prev_link
= &list
->next
;
13422 /* Remove wrong nodes immediately from the list so we don't risk any
13423 troubles in the future when they might fail later expectations. */
13426 *prev_link
= list
->next
;
13427 gfc_free_finalizer (i
);
13431 if (result
== false)
13434 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13435 were nodes in the list, must have been for arrays. It is surely a good
13436 idea to have a scalar version there if there's something to finalize. */
13437 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
13438 gfc_warning (OPT_Wsurprising
,
13439 "Only array FINAL procedures declared for derived type %qs"
13440 " defined at %L, suggest also scalar one",
13441 derived
->name
, &derived
->declared_at
);
13443 vtab
= gfc_find_derived_vtab (derived
);
13444 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
13445 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
13448 *finalizable
= true;
13454 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13457 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13458 const char* generic_name
, locus where
)
13460 gfc_symbol
*sym1
, *sym2
;
13461 const char *pass1
, *pass2
;
13462 gfc_formal_arglist
*dummy_args
;
13464 gcc_assert (t1
->specific
&& t2
->specific
);
13465 gcc_assert (!t1
->specific
->is_generic
);
13466 gcc_assert (!t2
->specific
->is_generic
);
13467 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13469 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13470 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13475 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13476 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13477 || sym1
->attr
.function
!= sym2
->attr
.function
)
13479 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
13480 " GENERIC %qs at %L",
13481 sym1
->name
, sym2
->name
, generic_name
, &where
);
13485 /* Determine PASS arguments. */
13486 if (t1
->specific
->nopass
)
13488 else if (t1
->specific
->pass_arg
)
13489 pass1
= t1
->specific
->pass_arg
;
13492 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13494 pass1
= dummy_args
->sym
->name
;
13498 if (t2
->specific
->nopass
)
13500 else if (t2
->specific
->pass_arg
)
13501 pass2
= t2
->specific
->pass_arg
;
13504 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13506 pass2
= dummy_args
->sym
->name
;
13511 /* Compare the interfaces. */
13512 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13513 NULL
, 0, pass1
, pass2
))
13515 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13516 sym1
->name
, sym2
->name
, generic_name
, &where
);
13524 /* Worker function for resolving a generic procedure binding; this is used to
13525 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13527 The difference between those cases is finding possible inherited bindings
13528 that are overridden, as one has to look for them in tb_sym_root,
13529 tb_uop_root or tb_op, respectively. Thus the caller must already find
13530 the super-type and set p->overridden correctly. */
13533 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13534 gfc_typebound_proc
* p
, const char* name
)
13536 gfc_tbp_generic
* target
;
13537 gfc_symtree
* first_target
;
13538 gfc_symtree
* inherited
;
13540 gcc_assert (p
&& p
->is_generic
);
13542 /* Try to find the specific bindings for the symtrees in our target-list. */
13543 gcc_assert (p
->u
.generic
);
13544 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13545 if (!target
->specific
)
13547 gfc_typebound_proc
* overridden_tbp
;
13548 gfc_tbp_generic
* g
;
13549 const char* target_name
;
13551 target_name
= target
->specific_st
->name
;
13553 /* Defined for this type directly. */
13554 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13556 target
->specific
= target
->specific_st
->n
.tb
;
13557 goto specific_found
;
13560 /* Look for an inherited specific binding. */
13563 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13568 gcc_assert (inherited
->n
.tb
);
13569 target
->specific
= inherited
->n
.tb
;
13570 goto specific_found
;
13574 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13575 " at %L", target_name
, name
, &p
->where
);
13578 /* Once we've found the specific binding, check it is not ambiguous with
13579 other specifics already found or inherited for the same GENERIC. */
13581 gcc_assert (target
->specific
);
13583 /* This must really be a specific binding! */
13584 if (target
->specific
->is_generic
)
13586 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13587 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13591 /* Check those already resolved on this type directly. */
13592 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13593 if (g
!= target
&& g
->specific
13594 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13597 /* Check for ambiguity with inherited specific targets. */
13598 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13599 overridden_tbp
= overridden_tbp
->overridden
)
13600 if (overridden_tbp
->is_generic
)
13602 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13604 gcc_assert (g
->specific
);
13605 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13611 /* If we attempt to "overwrite" a specific binding, this is an error. */
13612 if (p
->overridden
&& !p
->overridden
->is_generic
)
13614 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
13615 " the same name", name
, &p
->where
);
13619 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13620 all must have the same attributes here. */
13621 first_target
= p
->u
.generic
->specific
->u
.specific
;
13622 gcc_assert (first_target
);
13623 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13624 p
->function
= first_target
->n
.sym
->attr
.function
;
13630 /* Resolve a GENERIC procedure binding for a derived type. */
13633 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13635 gfc_symbol
* super_type
;
13637 /* Find the overridden binding if any. */
13638 st
->n
.tb
->overridden
= NULL
;
13639 super_type
= gfc_get_derived_super_type (derived
);
13642 gfc_symtree
* overridden
;
13643 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13646 if (overridden
&& overridden
->n
.tb
)
13647 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13650 /* Resolve using worker function. */
13651 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13655 /* Retrieve the target-procedure of an operator binding and do some checks in
13656 common for intrinsic and user-defined type-bound operators. */
13659 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13661 gfc_symbol
* target_proc
;
13663 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13664 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13665 gcc_assert (target_proc
);
13667 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13668 if (target
->specific
->nopass
)
13670 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
13674 return target_proc
;
13678 /* Resolve a type-bound intrinsic operator. */
13681 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13682 gfc_typebound_proc
* p
)
13684 gfc_symbol
* super_type
;
13685 gfc_tbp_generic
* target
;
13687 /* If there's already an error here, do nothing (but don't fail again). */
13691 /* Operators should always be GENERIC bindings. */
13692 gcc_assert (p
->is_generic
);
13694 /* Look for an overridden binding. */
13695 super_type
= gfc_get_derived_super_type (derived
);
13696 if (super_type
&& super_type
->f2k_derived
)
13697 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13700 p
->overridden
= NULL
;
13702 /* Resolve general GENERIC properties using worker function. */
13703 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13706 /* Check the targets to be procedures of correct interface. */
13707 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13709 gfc_symbol
* target_proc
;
13711 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13715 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13718 /* Add target to non-typebound operator list. */
13719 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13720 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13722 gfc_interface
*head
, *intr
;
13724 /* Preempt 'gfc_check_new_interface' for submodules, where the
13725 mechanism for handling module procedures winds up resolving
13726 operator interfaces twice and would otherwise cause an error. */
13727 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13728 if (intr
->sym
== target_proc
13729 && target_proc
->attr
.used_in_submodule
)
13732 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13733 target_proc
, p
->where
))
13735 head
= derived
->ns
->op
[op
];
13736 intr
= gfc_get_interface ();
13737 intr
->sym
= target_proc
;
13738 intr
->where
= p
->where
;
13740 derived
->ns
->op
[op
] = intr
;
13752 /* Resolve a type-bound user operator (tree-walker callback). */
13754 static gfc_symbol
* resolve_bindings_derived
;
13755 static bool resolve_bindings_result
;
13757 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13760 resolve_typebound_user_op (gfc_symtree
* stree
)
13762 gfc_symbol
* super_type
;
13763 gfc_tbp_generic
* target
;
13765 gcc_assert (stree
&& stree
->n
.tb
);
13767 if (stree
->n
.tb
->error
)
13770 /* Operators should always be GENERIC bindings. */
13771 gcc_assert (stree
->n
.tb
->is_generic
);
13773 /* Find overridden procedure, if any. */
13774 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13775 if (super_type
&& super_type
->f2k_derived
)
13777 gfc_symtree
* overridden
;
13778 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13779 stree
->name
, true, NULL
);
13781 if (overridden
&& overridden
->n
.tb
)
13782 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13785 stree
->n
.tb
->overridden
= NULL
;
13787 /* Resolve basically using worker function. */
13788 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13791 /* Check the targets to be functions of correct interface. */
13792 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13794 gfc_symbol
* target_proc
;
13796 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13800 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13807 resolve_bindings_result
= false;
13808 stree
->n
.tb
->error
= 1;
13812 /* Resolve the type-bound procedures for a derived type. */
13815 resolve_typebound_procedure (gfc_symtree
* stree
)
13819 gfc_symbol
* me_arg
;
13820 gfc_symbol
* super_type
;
13821 gfc_component
* comp
;
13823 gcc_assert (stree
);
13825 /* Undefined specific symbol from GENERIC target definition. */
13829 if (stree
->n
.tb
->error
)
13832 /* If this is a GENERIC binding, use that routine. */
13833 if (stree
->n
.tb
->is_generic
)
13835 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13840 /* Get the target-procedure to check it. */
13841 gcc_assert (!stree
->n
.tb
->is_generic
);
13842 gcc_assert (stree
->n
.tb
->u
.specific
);
13843 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13844 where
= stree
->n
.tb
->where
;
13846 /* Default access should already be resolved from the parser. */
13847 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13849 if (stree
->n
.tb
->deferred
)
13851 if (!check_proc_interface (proc
, &where
))
13856 /* If proc has not been resolved at this point, proc->name may
13857 actually be a USE associated entity. See PR fortran/89647. */
13858 if (!proc
->resolved
13859 && proc
->attr
.function
== 0 && proc
->attr
.subroutine
== 0)
13862 gfc_find_symbol (proc
->name
, gfc_current_ns
->parent
, 1, &tmp
);
13863 if (tmp
&& tmp
->attr
.use_assoc
)
13865 proc
->module
= tmp
->module
;
13866 proc
->attr
.proc
= tmp
->attr
.proc
;
13867 proc
->attr
.function
= tmp
->attr
.function
;
13868 proc
->attr
.subroutine
= tmp
->attr
.subroutine
;
13869 proc
->attr
.use_assoc
= tmp
->attr
.use_assoc
;
13870 proc
->ts
= tmp
->ts
;
13871 proc
->result
= tmp
->result
;
13875 /* Check for F08:C465. */
13876 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13877 || (proc
->attr
.proc
!= PROC_MODULE
13878 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13879 || proc
->attr
.abstract
)
13881 gfc_error ("%qs must be a module procedure or an external "
13882 "procedure with an explicit interface at %L",
13883 proc
->name
, &where
);
13888 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13889 stree
->n
.tb
->function
= proc
->attr
.function
;
13891 /* Find the super-type of the current derived type. We could do this once and
13892 store in a global if speed is needed, but as long as not I believe this is
13893 more readable and clearer. */
13894 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13896 /* If PASS, resolve and check arguments if not already resolved / loaded
13897 from a .mod file. */
13898 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13900 gfc_formal_arglist
*dummy_args
;
13902 dummy_args
= gfc_sym_get_dummy_args (proc
);
13903 if (stree
->n
.tb
->pass_arg
)
13905 gfc_formal_arglist
*i
;
13907 /* If an explicit passing argument name is given, walk the arg-list
13908 and look for it. */
13911 stree
->n
.tb
->pass_arg_num
= 1;
13912 for (i
= dummy_args
; i
; i
= i
->next
)
13914 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13919 ++stree
->n
.tb
->pass_arg_num
;
13924 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13926 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13927 stree
->n
.tb
->pass_arg
);
13933 /* Otherwise, take the first one; there should in fact be at least
13935 stree
->n
.tb
->pass_arg_num
= 1;
13938 gfc_error ("Procedure %qs with PASS at %L must have at"
13939 " least one argument", proc
->name
, &where
);
13942 me_arg
= dummy_args
->sym
;
13945 /* Now check that the argument-type matches and the passed-object
13946 dummy argument is generally fine. */
13948 gcc_assert (me_arg
);
13950 if (me_arg
->ts
.type
!= BT_CLASS
)
13952 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13953 " at %L", proc
->name
, &where
);
13957 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13958 != resolve_bindings_derived
)
13960 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13961 " the derived-type %qs", me_arg
->name
, proc
->name
,
13962 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13966 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13967 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13969 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13970 " scalar", proc
->name
, &where
);
13973 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13975 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13976 " be ALLOCATABLE", proc
->name
, &where
);
13979 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13981 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13982 " be POINTER", proc
->name
, &where
);
13987 /* If we are extending some type, check that we don't override a procedure
13988 flagged NON_OVERRIDABLE. */
13989 stree
->n
.tb
->overridden
= NULL
;
13992 gfc_symtree
* overridden
;
13993 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13994 stree
->name
, true, NULL
);
13998 if (overridden
->n
.tb
)
13999 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
14001 if (!gfc_check_typebound_override (stree
, overridden
))
14006 /* See if there's a name collision with a component directly in this type. */
14007 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
14008 if (!strcmp (comp
->name
, stree
->name
))
14010 gfc_error ("Procedure %qs at %L has the same name as a component of"
14012 stree
->name
, &where
, resolve_bindings_derived
->name
);
14016 /* Try to find a name collision with an inherited component. */
14017 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
14020 gfc_error ("Procedure %qs at %L has the same name as an inherited"
14021 " component of %qs",
14022 stree
->name
, &where
, resolve_bindings_derived
->name
);
14026 stree
->n
.tb
->error
= 0;
14030 resolve_bindings_result
= false;
14031 stree
->n
.tb
->error
= 1;
14036 resolve_typebound_procedures (gfc_symbol
* derived
)
14039 gfc_symbol
* super_type
;
14041 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
14044 super_type
= gfc_get_derived_super_type (derived
);
14046 resolve_symbol (super_type
);
14048 resolve_bindings_derived
= derived
;
14049 resolve_bindings_result
= true;
14051 if (derived
->f2k_derived
->tb_sym_root
)
14052 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
14053 &resolve_typebound_procedure
);
14055 if (derived
->f2k_derived
->tb_uop_root
)
14056 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
14057 &resolve_typebound_user_op
);
14059 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
14061 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
14062 if (p
&& !resolve_typebound_intrinsic_op (derived
,
14063 (gfc_intrinsic_op
)op
, p
))
14064 resolve_bindings_result
= false;
14067 return resolve_bindings_result
;
14071 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
14072 to give all identical derived types the same backend_decl. */
14074 add_dt_to_dt_list (gfc_symbol
*derived
)
14076 if (!derived
->dt_next
)
14078 if (gfc_derived_types
)
14080 derived
->dt_next
= gfc_derived_types
->dt_next
;
14081 gfc_derived_types
->dt_next
= derived
;
14085 derived
->dt_next
= derived
;
14087 gfc_derived_types
= derived
;
14092 /* Ensure that a derived-type is really not abstract, meaning that every
14093 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
14096 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
14101 if (!ensure_not_abstract_walker (sub
, st
->left
))
14103 if (!ensure_not_abstract_walker (sub
, st
->right
))
14106 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
14108 gfc_symtree
* overriding
;
14109 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
14112 gcc_assert (overriding
->n
.tb
);
14113 if (overriding
->n
.tb
->deferred
)
14115 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
14116 " %qs is DEFERRED and not overridden",
14117 sub
->name
, &sub
->declared_at
, st
->name
);
14126 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
14128 /* The algorithm used here is to recursively travel up the ancestry of sub
14129 and for each ancestor-type, check all bindings. If any of them is
14130 DEFERRED, look it up starting from sub and see if the found (overriding)
14131 binding is not DEFERRED.
14132 This is not the most efficient way to do this, but it should be ok and is
14133 clearer than something sophisticated. */
14135 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
14137 if (!ancestor
->attr
.abstract
)
14140 /* Walk bindings of this ancestor. */
14141 if (ancestor
->f2k_derived
)
14144 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
14149 /* Find next ancestor type and recurse on it. */
14150 ancestor
= gfc_get_derived_super_type (ancestor
);
14152 return ensure_not_abstract (sub
, ancestor
);
14158 /* This check for typebound defined assignments is done recursively
14159 since the order in which derived types are resolved is not always in
14160 order of the declarations. */
14163 check_defined_assignments (gfc_symbol
*derived
)
14167 for (c
= derived
->components
; c
; c
= c
->next
)
14169 if (!gfc_bt_struct (c
->ts
.type
)
14171 || c
->attr
.allocatable
14172 || c
->attr
.proc_pointer_comp
14173 || c
->attr
.class_pointer
14174 || c
->attr
.proc_pointer
)
14177 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
14178 || (c
->ts
.u
.derived
->f2k_derived
14179 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
14181 derived
->attr
.defined_assign_comp
= 1;
14185 check_defined_assignments (c
->ts
.u
.derived
);
14186 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
14188 derived
->attr
.defined_assign_comp
= 1;
14195 /* Resolve a single component of a derived type or structure. */
14198 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
14200 gfc_symbol
*super_type
;
14201 symbol_attribute
*attr
;
14203 if (c
->attr
.artificial
)
14206 /* Do not allow vtype components to be resolved in nameless namespaces
14207 such as block data because the procedure pointers will cause ICEs
14208 and vtables are not needed in these contexts. */
14209 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
14210 && sym
->ns
->proc_name
== NULL
)
14214 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
14215 && c
->attr
.codimension
14216 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
14218 gfc_error ("Coarray component %qs at %L must be allocatable with "
14219 "deferred shape", c
->name
, &c
->loc
);
14224 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
14225 && c
->ts
.u
.derived
->ts
.is_iso_c
)
14227 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14228 "shall not be a coarray", c
->name
, &c
->loc
);
14233 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
14234 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
14235 || c
->attr
.allocatable
))
14237 gfc_error ("Component %qs at %L with coarray component "
14238 "shall be a nonpointer, nonallocatable scalar",
14244 if (c
->ts
.type
== BT_CLASS
)
14246 if (CLASS_DATA (c
))
14248 attr
= &(CLASS_DATA (c
)->attr
);
14250 /* Fix up contiguous attribute. */
14251 if (c
->attr
.contiguous
)
14252 attr
->contiguous
= 1;
14260 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
14262 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
14263 "is not an array pointer", c
->name
, &c
->loc
);
14267 /* F2003, 15.2.1 - length has to be one. */
14268 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
14269 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
14270 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
14271 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
14273 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
14278 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
14280 gfc_symbol
*ifc
= c
->ts
.interface
;
14282 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
14288 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
14290 /* Resolve interface and copy attributes. */
14291 if (ifc
->formal
&& !ifc
->formal_ns
)
14292 resolve_symbol (ifc
);
14293 if (ifc
->attr
.intrinsic
)
14294 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
14298 c
->ts
= ifc
->result
->ts
;
14299 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
14300 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
14301 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
14302 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
14303 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
14308 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
14309 c
->attr
.pointer
= ifc
->attr
.pointer
;
14310 c
->attr
.dimension
= ifc
->attr
.dimension
;
14311 c
->as
= gfc_copy_array_spec (ifc
->as
);
14312 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
14314 c
->ts
.interface
= ifc
;
14315 c
->attr
.function
= ifc
->attr
.function
;
14316 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
14318 c
->attr
.pure
= ifc
->attr
.pure
;
14319 c
->attr
.elemental
= ifc
->attr
.elemental
;
14320 c
->attr
.recursive
= ifc
->attr
.recursive
;
14321 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
14322 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
14323 /* Copy char length. */
14324 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
14326 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
14327 if (cl
->length
&& !cl
->resolved
14328 && !gfc_resolve_expr (cl
->length
))
14337 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
14339 /* Since PPCs are not implicitly typed, a PPC without an explicit
14340 interface must be a subroutine. */
14341 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
14344 /* Procedure pointer components: Check PASS arg. */
14345 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
14346 && !sym
->attr
.vtype
)
14348 gfc_symbol
* me_arg
;
14350 if (c
->tb
->pass_arg
)
14352 gfc_formal_arglist
* i
;
14354 /* If an explicit passing argument name is given, walk the arg-list
14355 and look for it. */
14358 c
->tb
->pass_arg_num
= 1;
14359 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
14361 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
14366 c
->tb
->pass_arg_num
++;
14371 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14372 "at %L has no argument %qs", c
->name
,
14373 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
14380 /* Otherwise, take the first one; there should in fact be at least
14382 c
->tb
->pass_arg_num
= 1;
14383 if (!c
->ts
.interface
->formal
)
14385 gfc_error ("Procedure pointer component %qs with PASS at %L "
14386 "must have at least one argument",
14391 me_arg
= c
->ts
.interface
->formal
->sym
;
14394 /* Now check that the argument-type matches. */
14395 gcc_assert (me_arg
);
14396 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
14397 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
14398 || (me_arg
->ts
.type
== BT_CLASS
14399 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
14401 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14402 " the derived type %qs", me_arg
->name
, c
->name
,
14403 me_arg
->name
, &c
->loc
, sym
->name
);
14408 /* Check for F03:C453. */
14409 if (CLASS_DATA (me_arg
)->attr
.dimension
)
14411 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14412 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
14418 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14420 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14421 "may not have the POINTER attribute", me_arg
->name
,
14422 c
->name
, me_arg
->name
, &c
->loc
);
14427 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14429 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14430 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
14431 me_arg
->name
, &c
->loc
);
14436 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
14438 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14439 " at %L", c
->name
, &c
->loc
);
14445 /* Check type-spec if this is not the parent-type component. */
14446 if (((sym
->attr
.is_class
14447 && (!sym
->components
->ts
.u
.derived
->attr
.extension
14448 || c
!= sym
->components
->ts
.u
.derived
->components
))
14449 || (!sym
->attr
.is_class
14450 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
14451 && !sym
->attr
.vtype
14452 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
14455 super_type
= gfc_get_derived_super_type (sym
);
14457 /* If this type is an extension, set the accessibility of the parent
14460 && ((sym
->attr
.is_class
14461 && c
== sym
->components
->ts
.u
.derived
->components
)
14462 || (!sym
->attr
.is_class
&& c
== sym
->components
))
14463 && strcmp (super_type
->name
, c
->name
) == 0)
14464 c
->attr
.access
= super_type
->attr
.access
;
14466 /* If this type is an extension, see if this component has the same name
14467 as an inherited type-bound procedure. */
14468 if (super_type
&& !sym
->attr
.is_class
14469 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
14471 gfc_error ("Component %qs of %qs at %L has the same name as an"
14472 " inherited type-bound procedure",
14473 c
->name
, sym
->name
, &c
->loc
);
14477 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
14478 && !c
->ts
.deferred
)
14480 if (c
->ts
.u
.cl
->length
== NULL
14481 || (!resolve_charlen(c
->ts
.u
.cl
))
14482 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
14484 gfc_error ("Character length of component %qs needs to "
14485 "be a constant specification expression at %L",
14487 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14492 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14493 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14495 gfc_error ("Character component %qs of %qs at %L with deferred "
14496 "length must be a POINTER or ALLOCATABLE",
14497 c
->name
, sym
->name
, &c
->loc
);
14501 /* Add the hidden deferred length field. */
14502 if (c
->ts
.type
== BT_CHARACTER
14503 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14504 && !c
->attr
.function
14505 && !sym
->attr
.is_class
)
14507 char name
[GFC_MAX_SYMBOL_LEN
+9];
14508 gfc_component
*strlen
;
14509 sprintf (name
, "_%s_length", c
->name
);
14510 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14511 if (strlen
== NULL
)
14513 if (!gfc_add_component (sym
, name
, &strlen
))
14515 strlen
->ts
.type
= BT_INTEGER
;
14516 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14517 strlen
->attr
.access
= ACCESS_PRIVATE
;
14518 strlen
->attr
.artificial
= 1;
14522 if (c
->ts
.type
== BT_DERIVED
14523 && sym
->component_access
!= ACCESS_PRIVATE
14524 && gfc_check_symbol_access (sym
)
14525 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14526 && !c
->ts
.u
.derived
->attr
.use_assoc
14527 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14528 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14529 "PRIVATE type and cannot be a component of "
14530 "%qs, which is PUBLIC at %L", c
->name
,
14531 sym
->name
, &sym
->declared_at
))
14534 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14536 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14537 "type %s", c
->name
, &c
->loc
, sym
->name
);
14541 if (sym
->attr
.sequence
)
14543 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14545 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14546 "not have the SEQUENCE attribute",
14547 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14552 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14553 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14554 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14555 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14556 CLASS_DATA (c
)->ts
.u
.derived
14557 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14559 /* If an allocatable component derived type is of the same type as
14560 the enclosing derived type, we need a vtable generating so that
14561 the __deallocate procedure is created. */
14562 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14563 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14564 gfc_find_vtab (&c
->ts
);
14566 /* Ensure that all the derived type components are put on the
14567 derived type list; even in formal namespaces, where derived type
14568 pointer components might not have been declared. */
14569 if (c
->ts
.type
== BT_DERIVED
14571 && c
->ts
.u
.derived
->components
14573 && sym
!= c
->ts
.u
.derived
)
14574 add_dt_to_dt_list (c
->ts
.u
.derived
);
14576 if (!gfc_resolve_array_spec (c
->as
,
14577 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
14578 || c
->attr
.allocatable
)))
14581 if (c
->initializer
&& !sym
->attr
.vtype
14582 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
14583 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
14590 /* Be nice about the locus for a structure expression - show the locus of the
14591 first non-null sub-expression if we can. */
14594 cons_where (gfc_expr
*struct_expr
)
14596 gfc_constructor
*cons
;
14598 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
14600 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
14601 for (; cons
; cons
= gfc_constructor_next (cons
))
14603 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
14604 return &cons
->expr
->where
;
14607 return &struct_expr
->where
;
14610 /* Resolve the components of a structure type. Much less work than derived
14614 resolve_fl_struct (gfc_symbol
*sym
)
14617 gfc_expr
*init
= NULL
;
14620 /* Make sure UNIONs do not have overlapping initializers. */
14621 if (sym
->attr
.flavor
== FL_UNION
)
14623 for (c
= sym
->components
; c
; c
= c
->next
)
14625 if (init
&& c
->initializer
)
14627 gfc_error ("Conflicting initializers in union at %L and %L",
14628 cons_where (init
), cons_where (c
->initializer
));
14629 gfc_free_expr (c
->initializer
);
14630 c
->initializer
= NULL
;
14633 init
= c
->initializer
;
14638 for (c
= sym
->components
; c
; c
= c
->next
)
14639 if (!resolve_component (c
, sym
))
14645 if (sym
->components
)
14646 add_dt_to_dt_list (sym
);
14652 /* Resolve the components of a derived type. This does not have to wait until
14653 resolution stage, but can be done as soon as the dt declaration has been
14657 resolve_fl_derived0 (gfc_symbol
*sym
)
14659 gfc_symbol
* super_type
;
14661 gfc_formal_arglist
*f
;
14664 if (sym
->attr
.unlimited_polymorphic
)
14667 super_type
= gfc_get_derived_super_type (sym
);
14670 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14672 gfc_error ("As extending type %qs at %L has a coarray component, "
14673 "parent type %qs shall also have one", sym
->name
,
14674 &sym
->declared_at
, super_type
->name
);
14678 /* Ensure the extended type gets resolved before we do. */
14679 if (super_type
&& !resolve_fl_derived0 (super_type
))
14682 /* An ABSTRACT type must be extensible. */
14683 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14685 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14686 sym
->name
, &sym
->declared_at
);
14690 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14694 for ( ; c
!= NULL
; c
= c
->next
)
14695 if (!resolve_component (c
, sym
))
14701 /* Now add the caf token field, where needed. */
14702 if (flag_coarray
!= GFC_FCOARRAY_NONE
14703 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14705 for (c
= sym
->components
; c
; c
= c
->next
)
14706 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14707 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14709 char name
[GFC_MAX_SYMBOL_LEN
+9];
14710 gfc_component
*token
;
14711 sprintf (name
, "_caf_%s", c
->name
);
14712 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14715 if (!gfc_add_component (sym
, name
, &token
))
14717 token
->ts
.type
= BT_VOID
;
14718 token
->ts
.kind
= gfc_default_integer_kind
;
14719 token
->attr
.access
= ACCESS_PRIVATE
;
14720 token
->attr
.artificial
= 1;
14721 token
->attr
.caf_token
= 1;
14726 check_defined_assignments (sym
);
14728 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14729 sym
->attr
.defined_assign_comp
14730 = super_type
->attr
.defined_assign_comp
;
14732 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14733 all DEFERRED bindings are overridden. */
14734 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14735 && !sym
->attr
.is_class
14736 && !ensure_not_abstract (sym
, super_type
))
14739 /* Check that there is a component for every PDT parameter. */
14740 if (sym
->attr
.pdt_template
)
14742 for (f
= sym
->formal
; f
; f
= f
->next
)
14746 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14749 gfc_error ("Parameterized type %qs does not have a component "
14750 "corresponding to parameter %qs at %L", sym
->name
,
14751 f
->sym
->name
, &sym
->declared_at
);
14757 /* Add derived type to the derived type list. */
14758 add_dt_to_dt_list (sym
);
14764 /* The following procedure does the full resolution of a derived type,
14765 including resolution of all type-bound procedures (if present). In contrast
14766 to 'resolve_fl_derived0' this can only be done after the module has been
14767 parsed completely. */
14770 resolve_fl_derived (gfc_symbol
*sym
)
14772 gfc_symbol
*gen_dt
= NULL
;
14774 if (sym
->attr
.unlimited_polymorphic
)
14777 if (!sym
->attr
.is_class
)
14778 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14779 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14780 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14781 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14782 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14783 "%qs at %L being the same name as derived "
14784 "type at %L", sym
->name
,
14785 gen_dt
->generic
->sym
== sym
14786 ? gen_dt
->generic
->next
->sym
->name
14787 : gen_dt
->generic
->sym
->name
,
14788 gen_dt
->generic
->sym
== sym
14789 ? &gen_dt
->generic
->next
->sym
->declared_at
14790 : &gen_dt
->generic
->sym
->declared_at
,
14791 &sym
->declared_at
))
14794 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
14796 gfc_error ("Derived type %qs at %L has not been declared",
14797 sym
->name
, &sym
->declared_at
);
14801 /* Resolve the finalizer procedures. */
14802 if (!gfc_resolve_finalizers (sym
, NULL
))
14805 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14807 /* Fix up incomplete CLASS symbols. */
14808 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14809 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14811 /* Nothing more to do for unlimited polymorphic entities. */
14812 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14814 else if (vptr
->ts
.u
.derived
== NULL
)
14816 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14818 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14819 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14824 if (!resolve_fl_derived0 (sym
))
14827 /* Resolve the type-bound procedures. */
14828 if (!resolve_typebound_procedures (sym
))
14831 /* Generate module vtables subject to their accessibility and their not
14832 being vtables or pdt templates. If this is not done class declarations
14833 in external procedures wind up with their own version and so SELECT TYPE
14834 fails because the vptrs do not have the same address. */
14835 if (gfc_option
.allow_std
& GFC_STD_F2003
14836 && sym
->ns
->proc_name
14837 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14838 && sym
->attr
.access
!= ACCESS_PRIVATE
14839 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14841 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14842 gfc_set_sym_referenced (vtab
);
14850 resolve_fl_namelist (gfc_symbol
*sym
)
14855 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14857 /* Check again, the check in match only works if NAMELIST comes
14859 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14861 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14862 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14866 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14867 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14868 "with assumed shape in namelist %qs at %L",
14869 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14872 if (is_non_constant_shape_array (nl
->sym
)
14873 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14874 "with nonconstant shape in namelist %qs at %L",
14875 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14878 if (nl
->sym
->ts
.type
== BT_CHARACTER
14879 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14880 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14881 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14882 "nonconstant character length in "
14883 "namelist %qs at %L", nl
->sym
->name
,
14884 sym
->name
, &sym
->declared_at
))
14889 /* Reject PRIVATE objects in a PUBLIC namelist. */
14890 if (gfc_check_symbol_access (sym
))
14892 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14894 if (!nl
->sym
->attr
.use_assoc
14895 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14896 && !gfc_check_symbol_access (nl
->sym
))
14898 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14899 "cannot be member of PUBLIC namelist %qs at %L",
14900 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14904 if (nl
->sym
->ts
.type
== BT_DERIVED
14905 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14906 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14908 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14909 "namelist %qs at %L with ALLOCATABLE "
14910 "or POINTER components", nl
->sym
->name
,
14911 sym
->name
, &sym
->declared_at
))
14916 /* Types with private components that came here by USE-association. */
14917 if (nl
->sym
->ts
.type
== BT_DERIVED
14918 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14920 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14921 "components and cannot be member of namelist %qs at %L",
14922 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14926 /* Types with private components that are defined in the same module. */
14927 if (nl
->sym
->ts
.type
== BT_DERIVED
14928 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14929 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14931 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14932 "cannot be a member of PUBLIC namelist %qs at %L",
14933 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14940 /* 14.1.2 A module or internal procedure represent local entities
14941 of the same type as a namelist member and so are not allowed. */
14942 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14944 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14947 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14948 if ((nl
->sym
== sym
->ns
->proc_name
)
14950 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14955 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14956 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14958 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14959 "attribute in %qs at %L", nlsym
->name
,
14960 &sym
->declared_at
);
14967 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14968 nl
->sym
->attr
.asynchronous
= 1;
14975 resolve_fl_parameter (gfc_symbol
*sym
)
14977 /* A parameter array's shape needs to be constant. */
14978 if (sym
->as
!= NULL
14979 && (sym
->as
->type
== AS_DEFERRED
14980 || is_non_constant_shape_array (sym
)))
14982 gfc_error ("Parameter array %qs at %L cannot be automatic "
14983 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14987 /* Constraints on deferred type parameter. */
14988 if (!deferred_requirements (sym
))
14991 /* Make sure a parameter that has been implicitly typed still
14992 matches the implicit type, since PARAMETER statements can precede
14993 IMPLICIT statements. */
14994 if (sym
->attr
.implicit_type
14995 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14998 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14999 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
15003 /* Make sure the types of derived parameters are consistent. This
15004 type checking is deferred until resolution because the type may
15005 refer to a derived type from the host. */
15006 if (sym
->ts
.type
== BT_DERIVED
15007 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
15009 gfc_error ("Incompatible derived type in PARAMETER at %L",
15010 &sym
->value
->where
);
15014 /* F03:C509,C514. */
15015 if (sym
->ts
.type
== BT_CLASS
)
15017 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
15018 sym
->name
, &sym
->declared_at
);
15026 /* Called by resolve_symbol to check PDTs. */
15029 resolve_pdt (gfc_symbol
* sym
)
15031 gfc_symbol
*derived
= NULL
;
15032 gfc_actual_arglist
*param
;
15034 bool const_len_exprs
= true;
15035 bool assumed_len_exprs
= false;
15036 symbol_attribute
*attr
;
15038 if (sym
->ts
.type
== BT_DERIVED
)
15040 derived
= sym
->ts
.u
.derived
;
15041 attr
= &(sym
->attr
);
15043 else if (sym
->ts
.type
== BT_CLASS
)
15045 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
15046 attr
= &(CLASS_DATA (sym
)->attr
);
15049 gcc_unreachable ();
15051 gcc_assert (derived
->attr
.pdt_type
);
15053 for (param
= sym
->param_list
; param
; param
= param
->next
)
15055 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
15057 if (c
->attr
.pdt_kind
)
15060 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
15061 && c
->attr
.pdt_len
)
15062 const_len_exprs
= false;
15063 else if (param
->spec_type
== SPEC_ASSUMED
)
15064 assumed_len_exprs
= true;
15066 if (param
->spec_type
== SPEC_DEFERRED
15067 && !attr
->allocatable
&& !attr
->pointer
)
15068 gfc_error ("The object %qs at %L has a deferred LEN "
15069 "parameter %qs and is neither allocatable "
15070 "nor a pointer", sym
->name
, &sym
->declared_at
,
15075 if (!const_len_exprs
15076 && (sym
->ns
->proc_name
->attr
.is_main_program
15077 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15078 || sym
->attr
.save
!= SAVE_NONE
))
15079 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
15080 "SAVE attribute or be a variable declared in the "
15081 "main program, a module or a submodule(F08/C513)",
15082 sym
->name
, &sym
->declared_at
);
15084 if (assumed_len_exprs
&& !(sym
->attr
.dummy
15085 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
15086 gfc_error ("The object %qs at %L with ASSUMED type parameters "
15087 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
15088 sym
->name
, &sym
->declared_at
);
15092 /* Do anything necessary to resolve a symbol. Right now, we just
15093 assume that an otherwise unknown symbol is a variable. This sort
15094 of thing commonly happens for symbols in module. */
15097 resolve_symbol (gfc_symbol
*sym
)
15099 int check_constant
, mp_flag
;
15100 gfc_symtree
*symtree
;
15101 gfc_symtree
*this_symtree
;
15104 symbol_attribute class_attr
;
15105 gfc_array_spec
*as
;
15106 bool saved_specification_expr
;
15112 /* No symbol will ever have union type; only components can be unions.
15113 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
15114 (just like derived type declaration symbols have flavor FL_DERIVED). */
15115 gcc_assert (sym
->ts
.type
!= BT_UNION
);
15117 /* Coarrayed polymorphic objects with allocatable or pointer components are
15118 yet unsupported for -fcoarray=lib. */
15119 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
15120 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
15121 && CLASS_DATA (sym
)->attr
.codimension
15122 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
15123 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
15125 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
15126 "type coarrays at %L are unsupported", &sym
->declared_at
);
15130 if (sym
->attr
.artificial
)
15133 if (sym
->attr
.unlimited_polymorphic
)
15136 if (sym
->attr
.flavor
== FL_UNKNOWN
15137 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
15138 && !sym
->attr
.generic
&& !sym
->attr
.external
15139 && sym
->attr
.if_source
== IFSRC_UNKNOWN
15140 && sym
->ts
.type
== BT_UNKNOWN
))
15143 /* If we find that a flavorless symbol is an interface in one of the
15144 parent namespaces, find its symtree in this namespace, free the
15145 symbol and set the symtree to point to the interface symbol. */
15146 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
15148 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
15149 if (symtree
&& (symtree
->n
.sym
->generic
||
15150 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
15151 && sym
->ns
->construct_entities
)))
15153 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
15155 if (this_symtree
->n
.sym
== sym
)
15157 symtree
->n
.sym
->refs
++;
15158 gfc_release_symbol (sym
);
15159 this_symtree
->n
.sym
= symtree
->n
.sym
;
15165 /* Otherwise give it a flavor according to such attributes as
15167 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
15168 && sym
->attr
.intrinsic
== 0)
15169 sym
->attr
.flavor
= FL_VARIABLE
;
15170 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
15172 sym
->attr
.flavor
= FL_PROCEDURE
;
15173 if (sym
->attr
.dimension
)
15174 sym
->attr
.function
= 1;
15178 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
15179 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15181 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
15182 && !resolve_procedure_interface (sym
))
15185 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
15186 && (sym
->attr
.procedure
|| sym
->attr
.external
))
15188 if (sym
->attr
.external
)
15189 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
15190 "at %L", &sym
->declared_at
);
15192 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
15193 "at %L", &sym
->declared_at
);
15198 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
15201 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
15202 && !resolve_fl_struct (sym
))
15205 /* Symbols that are module procedures with results (functions) have
15206 the types and array specification copied for type checking in
15207 procedures that call them, as well as for saving to a module
15208 file. These symbols can't stand the scrutiny that their results
15210 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
15212 /* Make sure that the intrinsic is consistent with its internal
15213 representation. This needs to be done before assigning a default
15214 type to avoid spurious warnings. */
15215 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
15216 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
15219 /* Resolve associate names. */
15221 resolve_assoc_var (sym
, true);
15223 /* Assign default type to symbols that need one and don't have one. */
15224 if (sym
->ts
.type
== BT_UNKNOWN
)
15226 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
15228 gfc_set_default_type (sym
, 1, NULL
);
15231 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
15232 && !sym
->attr
.function
&& !sym
->attr
.subroutine
15233 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
15234 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15236 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15238 /* The specific case of an external procedure should emit an error
15239 in the case that there is no implicit type. */
15242 if (!sym
->attr
.mixed_entry_master
)
15243 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
15247 /* Result may be in another namespace. */
15248 resolve_symbol (sym
->result
);
15250 if (!sym
->result
->attr
.proc_pointer
)
15252 sym
->ts
= sym
->result
->ts
;
15253 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
15254 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
15255 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
15256 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
15257 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
15262 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15264 bool saved_specification_expr
= specification_expr
;
15265 specification_expr
= true;
15266 gfc_resolve_array_spec (sym
->result
->as
, false);
15267 specification_expr
= saved_specification_expr
;
15270 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
15272 as
= CLASS_DATA (sym
)->as
;
15273 class_attr
= CLASS_DATA (sym
)->attr
;
15274 class_attr
.pointer
= class_attr
.class_pointer
;
15278 class_attr
= sym
->attr
;
15283 if (sym
->attr
.contiguous
15284 && (!class_attr
.dimension
15285 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
15286 && !class_attr
.pointer
)))
15288 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
15289 "array pointer or an assumed-shape or assumed-rank array",
15290 sym
->name
, &sym
->declared_at
);
15294 /* Assumed size arrays and assumed shape arrays must be dummy
15295 arguments. Array-spec's of implied-shape should have been resolved to
15296 AS_EXPLICIT already. */
15300 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
15301 specification expression. */
15302 if (as
->type
== AS_IMPLIED_SHAPE
)
15305 for (i
=0; i
<as
->rank
; i
++)
15307 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
15309 gfc_error ("Bad specification for assumed size array at %L",
15310 &as
->lower
[i
]->where
);
15317 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
15318 || as
->type
== AS_ASSUMED_SHAPE
)
15319 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
15321 if (as
->type
== AS_ASSUMED_SIZE
)
15322 gfc_error ("Assumed size array at %L must be a dummy argument",
15323 &sym
->declared_at
);
15325 gfc_error ("Assumed shape array at %L must be a dummy argument",
15326 &sym
->declared_at
);
15329 /* TS 29113, C535a. */
15330 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
15331 && !sym
->attr
.select_type_temporary
15332 && !(cs_base
&& cs_base
->current
15333 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
15335 gfc_error ("Assumed-rank array at %L must be a dummy argument",
15336 &sym
->declared_at
);
15339 if (as
->type
== AS_ASSUMED_RANK
15340 && (sym
->attr
.codimension
|| sym
->attr
.value
))
15342 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15343 "CODIMENSION attribute", &sym
->declared_at
);
15348 /* Make sure symbols with known intent or optional are really dummy
15349 variable. Because of ENTRY statement, this has to be deferred
15350 until resolution time. */
15352 if (!sym
->attr
.dummy
15353 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
15355 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
15359 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
15361 gfc_error ("%qs at %L cannot have the VALUE attribute because "
15362 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
15366 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
15368 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
15369 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
15371 gfc_error ("Character dummy variable %qs at %L with VALUE "
15372 "attribute must have constant length",
15373 sym
->name
, &sym
->declared_at
);
15377 if (sym
->ts
.is_c_interop
15378 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
15380 gfc_error ("C interoperable character dummy variable %qs at %L "
15381 "with VALUE attribute must have length one",
15382 sym
->name
, &sym
->declared_at
);
15387 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15388 && sym
->ts
.u
.derived
->attr
.generic
)
15390 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
15391 if (!sym
->ts
.u
.derived
)
15393 gfc_error ("The derived type %qs at %L is of type %qs, "
15394 "which has not been defined", sym
->name
,
15395 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15396 sym
->ts
.type
= BT_UNKNOWN
;
15401 /* Use the same constraints as TYPE(*), except for the type check
15402 and that only scalars and assumed-size arrays are permitted. */
15403 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
15405 if (!sym
->attr
.dummy
)
15407 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15408 "a dummy argument", sym
->name
, &sym
->declared_at
);
15412 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
15413 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
15414 && sym
->ts
.type
!= BT_COMPLEX
)
15416 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15417 "of type TYPE(*) or of an numeric intrinsic type",
15418 sym
->name
, &sym
->declared_at
);
15422 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15423 || sym
->attr
.pointer
|| sym
->attr
.value
)
15425 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15426 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15427 "attribute", sym
->name
, &sym
->declared_at
);
15431 if (sym
->attr
.intent
== INTENT_OUT
)
15433 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15434 "have the INTENT(OUT) attribute",
15435 sym
->name
, &sym
->declared_at
);
15438 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
15440 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15441 "either be a scalar or an assumed-size array",
15442 sym
->name
, &sym
->declared_at
);
15446 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15447 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15449 sym
->ts
.type
= BT_ASSUMED
;
15450 sym
->as
= gfc_get_array_spec ();
15451 sym
->as
->type
= AS_ASSUMED_SIZE
;
15453 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
15455 else if (sym
->ts
.type
== BT_ASSUMED
)
15457 /* TS 29113, C407a. */
15458 if (!sym
->attr
.dummy
)
15460 gfc_error ("Assumed type of variable %s at %L is only permitted "
15461 "for dummy variables", sym
->name
, &sym
->declared_at
);
15464 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15465 || sym
->attr
.pointer
|| sym
->attr
.value
)
15467 gfc_error ("Assumed-type variable %s at %L may not have the "
15468 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15469 sym
->name
, &sym
->declared_at
);
15472 if (sym
->attr
.intent
== INTENT_OUT
)
15474 gfc_error ("Assumed-type variable %s at %L may not have the "
15475 "INTENT(OUT) attribute",
15476 sym
->name
, &sym
->declared_at
);
15479 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
15481 gfc_error ("Assumed-type variable %s at %L shall not be an "
15482 "explicit-shape array", sym
->name
, &sym
->declared_at
);
15487 /* If the symbol is marked as bind(c), that it is declared at module level
15488 scope and verify its type and kind. Do not do the latter for symbols
15489 that are implicitly typed because that is handled in
15490 gfc_set_default_type. Handle dummy arguments and procedure definitions
15491 separately. Also, anything that is use associated is not handled here
15492 but instead is handled in the module it is declared in. Finally, derived
15493 type definitions are allowed to be BIND(C) since that only implies that
15494 they're interoperable, and they are checked fully for interoperability
15495 when a variable is declared of that type. */
15496 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15497 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15498 && sym
->attr
.flavor
!= FL_DERIVED
)
15502 /* First, make sure the variable is declared at the
15503 module-level scope (J3/04-007, Section 15.3). */
15504 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
15505 sym
->attr
.in_common
== 0)
15507 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15508 "is neither a COMMON block nor declared at the "
15509 "module level scope", sym
->name
, &(sym
->declared_at
));
15512 else if (sym
->ts
.type
== BT_CHARACTER
15513 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15514 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15515 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15517 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15518 sym
->name
, &sym
->declared_at
);
15521 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15523 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15525 else if (sym
->attr
.implicit_type
== 0)
15527 /* If type() declaration, we need to verify that the components
15528 of the given type are all C interoperable, etc. */
15529 if (sym
->ts
.type
== BT_DERIVED
&&
15530 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15532 /* Make sure the user marked the derived type as BIND(C). If
15533 not, call the verify routine. This could print an error
15534 for the derived type more than once if multiple variables
15535 of that type are declared. */
15536 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15537 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15541 /* Verify the variable itself as C interoperable if it
15542 is BIND(C). It is not possible for this to succeed if
15543 the verify_bind_c_derived_type failed, so don't have to handle
15544 any error returned by verify_bind_c_derived_type. */
15545 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15546 sym
->common_block
);
15551 /* clear the is_bind_c flag to prevent reporting errors more than
15552 once if something failed. */
15553 sym
->attr
.is_bind_c
= 0;
15558 /* If a derived type symbol has reached this point, without its
15559 type being declared, we have an error. Notice that most
15560 conditions that produce undefined derived types have already
15561 been dealt with. However, the likes of:
15562 implicit type(t) (t) ..... call foo (t) will get us here if
15563 the type is not declared in the scope of the implicit
15564 statement. Change the type to BT_UNKNOWN, both because it is so
15565 and to prevent an ICE. */
15566 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15567 && sym
->ts
.u
.derived
->components
== NULL
15568 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
15570 gfc_error ("The derived type %qs at %L is of type %qs, "
15571 "which has not been defined", sym
->name
,
15572 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15573 sym
->ts
.type
= BT_UNKNOWN
;
15577 /* Make sure that the derived type has been resolved and that the
15578 derived type is visible in the symbol's namespace, if it is a
15579 module function and is not PRIVATE. */
15580 if (sym
->ts
.type
== BT_DERIVED
15581 && sym
->ts
.u
.derived
->attr
.use_assoc
15582 && sym
->ns
->proc_name
15583 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15584 && !resolve_fl_derived (sym
->ts
.u
.derived
))
15587 /* Unless the derived-type declaration is use associated, Fortran 95
15588 does not allow public entries of private derived types.
15589 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15590 161 in 95-006r3. */
15591 if (sym
->ts
.type
== BT_DERIVED
15592 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15593 && !sym
->ts
.u
.derived
->attr
.use_assoc
15594 && gfc_check_symbol_access (sym
)
15595 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15596 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
15597 "derived type %qs",
15598 (sym
->attr
.flavor
== FL_PARAMETER
)
15599 ? "parameter" : "variable",
15600 sym
->name
, &sym
->declared_at
,
15601 sym
->ts
.u
.derived
->name
))
15604 /* F2008, C1302. */
15605 if (sym
->ts
.type
== BT_DERIVED
15606 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15607 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
15608 || sym
->ts
.u
.derived
->attr
.lock_comp
)
15609 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15611 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15612 "type LOCK_TYPE must be a coarray", sym
->name
,
15613 &sym
->declared_at
);
15617 /* TS18508, C702/C703. */
15618 if (sym
->ts
.type
== BT_DERIVED
15619 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15620 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
15621 || sym
->ts
.u
.derived
->attr
.event_comp
)
15622 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15624 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15625 "type EVENT_TYPE must be a coarray", sym
->name
,
15626 &sym
->declared_at
);
15630 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15631 default initialization is defined (5.1.2.4.4). */
15632 if (sym
->ts
.type
== BT_DERIVED
15634 && sym
->attr
.intent
== INTENT_OUT
15636 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15638 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15640 if (c
->initializer
)
15642 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15643 "ASSUMED SIZE and so cannot have a default initializer",
15644 sym
->name
, &sym
->declared_at
);
15651 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15652 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15654 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15655 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15660 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15661 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15663 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15664 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15669 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15670 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15671 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15672 || class_attr
.codimension
)
15673 && (sym
->attr
.result
|| sym
->result
== sym
))
15675 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15676 "a coarray component", sym
->name
, &sym
->declared_at
);
15681 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15682 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15684 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15685 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15690 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15691 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15692 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15693 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15694 || class_attr
.allocatable
))
15696 gfc_error ("Variable %qs at %L with coarray component shall be a "
15697 "nonpointer, nonallocatable scalar, which is not a coarray",
15698 sym
->name
, &sym
->declared_at
);
15702 /* F2008, C526. The function-result case was handled above. */
15703 if (class_attr
.codimension
15704 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15705 || sym
->attr
.select_type_temporary
15706 || sym
->attr
.associate_var
15707 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15708 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15709 || sym
->ns
->proc_name
->attr
.is_main_program
15710 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15712 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15713 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15717 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15718 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15720 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15721 "deferred shape", sym
->name
, &sym
->declared_at
);
15724 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15725 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15727 gfc_error ("Allocatable coarray variable %qs at %L must have "
15728 "deferred shape", sym
->name
, &sym
->declared_at
);
15733 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15734 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15735 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15736 || (class_attr
.codimension
&& class_attr
.allocatable
))
15737 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15739 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15740 "allocatable coarray or have coarray components",
15741 sym
->name
, &sym
->declared_at
);
15745 if (class_attr
.codimension
&& sym
->attr
.dummy
15746 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15748 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15749 "procedure %qs", sym
->name
, &sym
->declared_at
,
15750 sym
->ns
->proc_name
->name
);
15754 if (sym
->ts
.type
== BT_LOGICAL
15755 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15756 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15757 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15760 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15761 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15763 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15764 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15765 "%L with non-C_Bool kind in BIND(C) procedure "
15766 "%qs", sym
->name
, &sym
->declared_at
,
15767 sym
->ns
->proc_name
->name
))
15769 else if (!gfc_logical_kinds
[i
].c_bool
15770 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15771 "%qs at %L with non-C_Bool kind in "
15772 "BIND(C) procedure %qs", sym
->name
,
15774 sym
->attr
.function
? sym
->name
15775 : sym
->ns
->proc_name
->name
))
15779 switch (sym
->attr
.flavor
)
15782 if (!resolve_fl_variable (sym
, mp_flag
))
15787 if (sym
->formal
&& !sym
->formal_ns
)
15789 /* Check that none of the arguments are a namelist. */
15790 gfc_formal_arglist
*formal
= sym
->formal
;
15792 for (; formal
; formal
= formal
->next
)
15793 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15795 gfc_error ("Namelist %qs cannot be an argument to "
15796 "subroutine or function at %L",
15797 formal
->sym
->name
, &sym
->declared_at
);
15802 if (!resolve_fl_procedure (sym
, mp_flag
))
15807 if (!resolve_fl_namelist (sym
))
15812 if (!resolve_fl_parameter (sym
))
15820 /* Resolve array specifier. Check as well some constraints
15821 on COMMON blocks. */
15823 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15825 /* Set the formal_arg_flag so that check_conflict will not throw
15826 an error for host associated variables in the specification
15827 expression for an array_valued function. */
15828 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
15829 formal_arg_flag
= true;
15831 saved_specification_expr
= specification_expr
;
15832 specification_expr
= true;
15833 gfc_resolve_array_spec (sym
->as
, check_constant
);
15834 specification_expr
= saved_specification_expr
;
15836 formal_arg_flag
= false;
15838 /* Resolve formal namespaces. */
15839 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15840 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15841 gfc_resolve (sym
->formal_ns
);
15843 /* Make sure the formal namespace is present. */
15844 if (sym
->formal
&& !sym
->formal_ns
)
15846 gfc_formal_arglist
*formal
= sym
->formal
;
15847 while (formal
&& !formal
->sym
)
15848 formal
= formal
->next
;
15852 sym
->formal_ns
= formal
->sym
->ns
;
15853 if (sym
->ns
!= formal
->sym
->ns
)
15854 sym
->formal_ns
->refs
++;
15858 /* Check threadprivate restrictions. */
15859 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15860 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15861 && (!sym
->attr
.in_common
15862 && sym
->module
== NULL
15863 && (sym
->ns
->proc_name
== NULL
15864 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15865 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15867 /* Check omp declare target restrictions. */
15868 if (sym
->attr
.omp_declare_target
15869 && sym
->attr
.flavor
== FL_VARIABLE
15871 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15872 && (!sym
->attr
.in_common
15873 && sym
->module
== NULL
15874 && (sym
->ns
->proc_name
== NULL
15875 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15876 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15877 sym
->name
, &sym
->declared_at
);
15879 /* If we have come this far we can apply default-initializers, as
15880 described in 14.7.5, to those variables that have not already
15881 been assigned one. */
15882 if (sym
->ts
.type
== BT_DERIVED
15884 && !sym
->attr
.allocatable
15885 && !sym
->attr
.alloc_comp
)
15887 symbol_attribute
*a
= &sym
->attr
;
15889 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15890 && !a
->in_common
&& !a
->use_assoc
15892 && !((a
->function
|| a
->result
)
15894 || sym
->ts
.u
.derived
->attr
.alloc_comp
15895 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15896 && !(a
->function
&& sym
!= sym
->result
))
15897 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15898 apply_default_init (sym
);
15899 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15900 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15901 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15902 /* Mark the result symbol to be referenced, when it has allocatable
15904 sym
->result
->attr
.referenced
= 1;
15907 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15908 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15909 && !CLASS_DATA (sym
)->attr
.class_pointer
15910 && !CLASS_DATA (sym
)->attr
.allocatable
)
15911 apply_default_init (sym
);
15913 /* If this symbol has a type-spec, check it. */
15914 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15915 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15916 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15919 if (sym
->param_list
)
15924 /************* Resolve DATA statements *************/
15928 gfc_data_value
*vnode
;
15934 /* Advance the values structure to point to the next value in the data list. */
15937 next_data_value (void)
15939 while (mpz_cmp_ui (values
.left
, 0) == 0)
15942 if (values
.vnode
->next
== NULL
)
15945 values
.vnode
= values
.vnode
->next
;
15946 mpz_set (values
.left
, values
.vnode
->repeat
);
15954 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15960 ar_type mark
= AR_UNKNOWN
;
15962 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15968 if (!gfc_resolve_expr (var
->expr
))
15972 mpz_init_set_si (offset
, 0);
15975 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15976 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15977 e
= e
->value
.function
.actual
->expr
;
15979 if (e
->expr_type
!= EXPR_VARIABLE
)
15981 gfc_error ("Expecting definable entity near %L", where
);
15985 sym
= e
->symtree
->n
.sym
;
15987 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15989 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15990 sym
->name
, &sym
->declared_at
);
15994 if (e
->ref
== NULL
&& sym
->as
)
15996 gfc_error ("DATA array %qs at %L must be specified in a previous"
15997 " declaration", sym
->name
, where
);
16001 if (gfc_is_coindexed (e
))
16003 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
16008 has_pointer
= sym
->attr
.pointer
;
16010 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
16012 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
16017 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_FULL
)
16019 gfc_error ("DATA element %qs at %L is a pointer and so must "
16020 "be a full array", sym
->name
, where
);
16024 if (values
.vnode
->expr
->expr_type
== EXPR_CONSTANT
)
16026 gfc_error ("DATA object near %L has the pointer attribute "
16027 "and the corresponding DATA value is not a valid "
16028 "initial-data-target", where
);
16034 if (e
->rank
== 0 || has_pointer
)
16036 mpz_init_set_ui (size
, 1);
16043 /* Find the array section reference. */
16044 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
16046 if (ref
->type
!= REF_ARRAY
)
16048 if (ref
->u
.ar
.type
== AR_ELEMENT
)
16054 /* Set marks according to the reference pattern. */
16055 switch (ref
->u
.ar
.type
)
16063 /* Get the start position of array section. */
16064 gfc_get_section_index (ar
, section_index
, &offset
);
16069 gcc_unreachable ();
16072 if (!gfc_array_size (e
, &size
))
16074 gfc_error ("Nonconstant array section at %L in DATA statement",
16076 mpz_clear (offset
);
16083 while (mpz_cmp_ui (size
, 0) > 0)
16085 if (!next_data_value ())
16087 gfc_error ("DATA statement at %L has more variables than values",
16093 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
16097 /* If we have more than one element left in the repeat count,
16098 and we have more than one element left in the target variable,
16099 then create a range assignment. */
16100 /* FIXME: Only done for full arrays for now, since array sections
16102 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
16103 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
16107 if (mpz_cmp (size
, values
.left
) >= 0)
16109 mpz_init_set (range
, values
.left
);
16110 mpz_sub (size
, size
, values
.left
);
16111 mpz_set_ui (values
.left
, 0);
16115 mpz_init_set (range
, size
);
16116 mpz_sub (values
.left
, values
.left
, size
);
16117 mpz_set_ui (size
, 0);
16120 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16123 mpz_add (offset
, offset
, range
);
16130 /* Assign initial value to symbol. */
16133 mpz_sub_ui (values
.left
, values
.left
, 1);
16134 mpz_sub_ui (size
, size
, 1);
16136 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16141 if (mark
== AR_FULL
)
16142 mpz_add_ui (offset
, offset
, 1);
16144 /* Modify the array section indexes and recalculate the offset
16145 for next element. */
16146 else if (mark
== AR_SECTION
)
16147 gfc_advance_section (section_index
, ar
, &offset
);
16151 if (mark
== AR_SECTION
)
16153 for (i
= 0; i
< ar
->dimen
; i
++)
16154 mpz_clear (section_index
[i
]);
16158 mpz_clear (offset
);
16164 static bool traverse_data_var (gfc_data_variable
*, locus
*);
16166 /* Iterate over a list of elements in a DATA statement. */
16169 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
16172 iterator_stack frame
;
16173 gfc_expr
*e
, *start
, *end
, *step
;
16174 bool retval
= true;
16176 mpz_init (frame
.value
);
16179 start
= gfc_copy_expr (var
->iter
.start
);
16180 end
= gfc_copy_expr (var
->iter
.end
);
16181 step
= gfc_copy_expr (var
->iter
.step
);
16183 if (!gfc_simplify_expr (start
, 1)
16184 || start
->expr_type
!= EXPR_CONSTANT
)
16186 gfc_error ("start of implied-do loop at %L could not be "
16187 "simplified to a constant value", &start
->where
);
16191 if (!gfc_simplify_expr (end
, 1)
16192 || end
->expr_type
!= EXPR_CONSTANT
)
16194 gfc_error ("end of implied-do loop at %L could not be "
16195 "simplified to a constant value", &start
->where
);
16199 if (!gfc_simplify_expr (step
, 1)
16200 || step
->expr_type
!= EXPR_CONSTANT
)
16202 gfc_error ("step of implied-do loop at %L could not be "
16203 "simplified to a constant value", &start
->where
);
16208 mpz_set (trip
, end
->value
.integer
);
16209 mpz_sub (trip
, trip
, start
->value
.integer
);
16210 mpz_add (trip
, trip
, step
->value
.integer
);
16212 mpz_div (trip
, trip
, step
->value
.integer
);
16214 mpz_set (frame
.value
, start
->value
.integer
);
16216 frame
.prev
= iter_stack
;
16217 frame
.variable
= var
->iter
.var
->symtree
;
16218 iter_stack
= &frame
;
16220 while (mpz_cmp_ui (trip
, 0) > 0)
16222 if (!traverse_data_var (var
->list
, where
))
16228 e
= gfc_copy_expr (var
->expr
);
16229 if (!gfc_simplify_expr (e
, 1))
16236 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
16238 mpz_sub_ui (trip
, trip
, 1);
16242 mpz_clear (frame
.value
);
16245 gfc_free_expr (start
);
16246 gfc_free_expr (end
);
16247 gfc_free_expr (step
);
16249 iter_stack
= frame
.prev
;
16254 /* Type resolve variables in the variable list of a DATA statement. */
16257 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
16261 for (; var
; var
= var
->next
)
16263 if (var
->expr
== NULL
)
16264 t
= traverse_data_list (var
, where
);
16266 t
= check_data_variable (var
, where
);
16276 /* Resolve the expressions and iterators associated with a data statement.
16277 This is separate from the assignment checking because data lists should
16278 only be resolved once. */
16281 resolve_data_variables (gfc_data_variable
*d
)
16283 for (; d
; d
= d
->next
)
16285 if (d
->list
== NULL
)
16287 if (!gfc_resolve_expr (d
->expr
))
16292 if (!gfc_resolve_iterator (&d
->iter
, false, true))
16295 if (!resolve_data_variables (d
->list
))
16304 /* Resolve a single DATA statement. We implement this by storing a pointer to
16305 the value list into static variables, and then recursively traversing the
16306 variables list, expanding iterators and such. */
16309 resolve_data (gfc_data
*d
)
16312 if (!resolve_data_variables (d
->var
))
16315 values
.vnode
= d
->value
;
16316 if (d
->value
== NULL
)
16317 mpz_set_ui (values
.left
, 0);
16319 mpz_set (values
.left
, d
->value
->repeat
);
16321 if (!traverse_data_var (d
->var
, &d
->where
))
16324 /* At this point, we better not have any values left. */
16326 if (next_data_value ())
16327 gfc_error ("DATA statement at %L has more values than variables",
16332 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
16333 accessed by host or use association, is a dummy argument to a pure function,
16334 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
16335 is storage associated with any such variable, shall not be used in the
16336 following contexts: (clients of this function). */
16338 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
16339 procedure. Returns zero if assignment is OK, nonzero if there is a
16342 gfc_impure_variable (gfc_symbol
*sym
)
16347 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
16350 /* Check if the symbol's ns is inside the pure procedure. */
16351 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16355 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
16359 proc
= sym
->ns
->proc_name
;
16360 if (sym
->attr
.dummy
16361 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
16362 || proc
->attr
.function
))
16365 /* TODO: Sort out what can be storage associated, if anything, and include
16366 it here. In principle equivalences should be scanned but it does not
16367 seem to be possible to storage associate an impure variable this way. */
16372 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
16373 current namespace is inside a pure procedure. */
16376 gfc_pure (gfc_symbol
*sym
)
16378 symbol_attribute attr
;
16383 /* Check if the current namespace or one of its parents
16384 belongs to a pure procedure. */
16385 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16387 sym
= ns
->proc_name
;
16391 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
16399 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
16403 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16404 checks if the current namespace is implicitly pure. Note that this
16405 function returns false for a PURE procedure. */
16408 gfc_implicit_pure (gfc_symbol
*sym
)
16414 /* Check if the current procedure is implicit_pure. Walk up
16415 the procedure list until we find a procedure. */
16416 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16418 sym
= ns
->proc_name
;
16422 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16427 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
16428 && !sym
->attr
.pure
;
16433 gfc_unset_implicit_pure (gfc_symbol
*sym
)
16439 /* Check if the current procedure is implicit_pure. Walk up
16440 the procedure list until we find a procedure. */
16441 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16443 sym
= ns
->proc_name
;
16447 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16452 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16453 sym
->attr
.implicit_pure
= 0;
16455 sym
->attr
.pure
= 0;
16459 /* Test whether the current procedure is elemental or not. */
16462 gfc_elemental (gfc_symbol
*sym
)
16464 symbol_attribute attr
;
16467 sym
= gfc_current_ns
->proc_name
;
16472 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
16476 /* Warn about unused labels. */
16479 warn_unused_fortran_label (gfc_st_label
*label
)
16484 warn_unused_fortran_label (label
->left
);
16486 if (label
->defined
== ST_LABEL_UNKNOWN
)
16489 switch (label
->referenced
)
16491 case ST_LABEL_UNKNOWN
:
16492 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
16493 label
->value
, &label
->where
);
16496 case ST_LABEL_BAD_TARGET
:
16497 gfc_warning (OPT_Wunused_label
,
16498 "Label %d at %L defined but cannot be used",
16499 label
->value
, &label
->where
);
16506 warn_unused_fortran_label (label
->right
);
16510 /* Returns the sequence type of a symbol or sequence. */
16513 sequence_type (gfc_typespec ts
)
16522 if (ts
.u
.derived
->components
== NULL
)
16523 return SEQ_NONDEFAULT
;
16525 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16526 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16527 if (sequence_type (c
->ts
) != result
)
16533 if (ts
.kind
!= gfc_default_character_kind
)
16534 return SEQ_NONDEFAULT
;
16536 return SEQ_CHARACTER
;
16539 if (ts
.kind
!= gfc_default_integer_kind
)
16540 return SEQ_NONDEFAULT
;
16542 return SEQ_NUMERIC
;
16545 if (!(ts
.kind
== gfc_default_real_kind
16546 || ts
.kind
== gfc_default_double_kind
))
16547 return SEQ_NONDEFAULT
;
16549 return SEQ_NUMERIC
;
16552 if (ts
.kind
!= gfc_default_complex_kind
)
16553 return SEQ_NONDEFAULT
;
16555 return SEQ_NUMERIC
;
16558 if (ts
.kind
!= gfc_default_logical_kind
)
16559 return SEQ_NONDEFAULT
;
16561 return SEQ_NUMERIC
;
16564 return SEQ_NONDEFAULT
;
16569 /* Resolve derived type EQUIVALENCE object. */
16572 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
16574 gfc_component
*c
= derived
->components
;
16579 /* Shall not be an object of nonsequence derived type. */
16580 if (!derived
->attr
.sequence
)
16582 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16583 "attribute to be an EQUIVALENCE object", sym
->name
,
16588 /* Shall not have allocatable components. */
16589 if (derived
->attr
.alloc_comp
)
16591 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16592 "components to be an EQUIVALENCE object",sym
->name
,
16597 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
16599 gfc_error ("Derived type variable %qs at %L with default "
16600 "initialization cannot be in EQUIVALENCE with a variable "
16601 "in COMMON", sym
->name
, &e
->where
);
16605 for (; c
; c
= c
->next
)
16607 if (gfc_bt_struct (c
->ts
.type
)
16608 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
16611 /* Shall not be an object of sequence derived type containing a pointer
16612 in the structure. */
16613 if (c
->attr
.pointer
)
16615 gfc_error ("Derived type variable %qs at %L with pointer "
16616 "component(s) cannot be an EQUIVALENCE object",
16617 sym
->name
, &e
->where
);
16625 /* Resolve equivalence object.
16626 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16627 an allocatable array, an object of nonsequence derived type, an object of
16628 sequence derived type containing a pointer at any level of component
16629 selection, an automatic object, a function name, an entry name, a result
16630 name, a named constant, a structure component, or a subobject of any of
16631 the preceding objects. A substring shall not have length zero. A
16632 derived type shall not have components with default initialization nor
16633 shall two objects of an equivalence group be initialized.
16634 Either all or none of the objects shall have an protected attribute.
16635 The simple constraints are done in symbol.c(check_conflict) and the rest
16636 are implemented here. */
16639 resolve_equivalence (gfc_equiv
*eq
)
16642 gfc_symbol
*first_sym
;
16645 locus
*last_where
= NULL
;
16646 seq_type eq_type
, last_eq_type
;
16647 gfc_typespec
*last_ts
;
16648 int object
, cnt_protected
;
16651 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16653 first_sym
= eq
->expr
->symtree
->n
.sym
;
16657 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16661 e
->ts
= e
->symtree
->n
.sym
->ts
;
16662 /* match_varspec might not know yet if it is seeing
16663 array reference or substring reference, as it doesn't
16665 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16667 gfc_ref
*ref
= e
->ref
;
16668 sym
= e
->symtree
->n
.sym
;
16670 if (sym
->attr
.dimension
)
16672 ref
->u
.ar
.as
= sym
->as
;
16676 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16677 if (e
->ts
.type
== BT_CHARACTER
16679 && ref
->type
== REF_ARRAY
16680 && ref
->u
.ar
.dimen
== 1
16681 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16682 && ref
->u
.ar
.stride
[0] == NULL
)
16684 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16685 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16688 /* Optimize away the (:) reference. */
16689 if (start
== NULL
&& end
== NULL
)
16692 e
->ref
= ref
->next
;
16694 e
->ref
->next
= ref
->next
;
16699 ref
->type
= REF_SUBSTRING
;
16701 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16703 ref
->u
.ss
.start
= start
;
16704 if (end
== NULL
&& e
->ts
.u
.cl
)
16705 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16706 ref
->u
.ss
.end
= end
;
16707 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16714 /* Any further ref is an error. */
16717 gcc_assert (ref
->type
== REF_ARRAY
);
16718 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16724 if (!gfc_resolve_expr (e
))
16727 sym
= e
->symtree
->n
.sym
;
16729 if (sym
->attr
.is_protected
)
16731 if (cnt_protected
> 0 && cnt_protected
!= object
)
16733 gfc_error ("Either all or none of the objects in the "
16734 "EQUIVALENCE set at %L shall have the "
16735 "PROTECTED attribute",
16740 /* Shall not equivalence common block variables in a PURE procedure. */
16741 if (sym
->ns
->proc_name
16742 && sym
->ns
->proc_name
->attr
.pure
16743 && sym
->attr
.in_common
)
16745 /* Need to check for symbols that may have entered the pure
16746 procedure via a USE statement. */
16747 bool saw_sym
= false;
16748 if (sym
->ns
->use_stmts
)
16751 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16752 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16758 gfc_error ("COMMON block member %qs at %L cannot be an "
16759 "EQUIVALENCE object in the pure procedure %qs",
16760 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16764 /* Shall not be a named constant. */
16765 if (e
->expr_type
== EXPR_CONSTANT
)
16767 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16768 "object", sym
->name
, &e
->where
);
16772 if (e
->ts
.type
== BT_DERIVED
16773 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16776 /* Check that the types correspond correctly:
16778 A numeric sequence structure may be equivalenced to another sequence
16779 structure, an object of default integer type, default real type, double
16780 precision real type, default logical type such that components of the
16781 structure ultimately only become associated to objects of the same
16782 kind. A character sequence structure may be equivalenced to an object
16783 of default character kind or another character sequence structure.
16784 Other objects may be equivalenced only to objects of the same type and
16785 kind parameters. */
16787 /* Identical types are unconditionally OK. */
16788 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16789 goto identical_types
;
16791 last_eq_type
= sequence_type (*last_ts
);
16792 eq_type
= sequence_type (sym
->ts
);
16794 /* Since the pair of objects is not of the same type, mixed or
16795 non-default sequences can be rejected. */
16797 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16798 "statement at %L with different type objects";
16800 && last_eq_type
== SEQ_MIXED
16801 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16802 || (eq_type
== SEQ_MIXED
16803 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16806 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16807 "statement at %L with objects of different type";
16809 && last_eq_type
== SEQ_NONDEFAULT
16810 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16811 || (eq_type
== SEQ_NONDEFAULT
16812 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16815 msg
="Non-CHARACTER object %qs in default CHARACTER "
16816 "EQUIVALENCE statement at %L";
16817 if (last_eq_type
== SEQ_CHARACTER
16818 && eq_type
!= SEQ_CHARACTER
16819 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16822 msg
="Non-NUMERIC object %qs in default NUMERIC "
16823 "EQUIVALENCE statement at %L";
16824 if (last_eq_type
== SEQ_NUMERIC
16825 && eq_type
!= SEQ_NUMERIC
16826 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16831 last_where
= &e
->where
;
16836 /* Shall not be an automatic array. */
16837 if (e
->ref
->type
== REF_ARRAY
16838 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16840 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16841 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16848 /* Shall not be a structure component. */
16849 if (r
->type
== REF_COMPONENT
)
16851 gfc_error ("Structure component %qs at %L cannot be an "
16852 "EQUIVALENCE object",
16853 r
->u
.c
.component
->name
, &e
->where
);
16857 /* A substring shall not have length zero. */
16858 if (r
->type
== REF_SUBSTRING
)
16860 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16862 gfc_error ("Substring at %L has length zero",
16863 &r
->u
.ss
.start
->where
);
16873 /* Function called by resolve_fntype to flag other symbols used in the
16874 length type parameter specification of function results. */
16877 flag_fn_result_spec (gfc_expr
*expr
,
16879 int *f ATTRIBUTE_UNUSED
)
16884 if (expr
->expr_type
== EXPR_VARIABLE
)
16886 s
= expr
->symtree
->n
.sym
;
16887 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16893 gfc_error ("Self reference in character length expression "
16894 "for %qs at %L", sym
->name
, &expr
->where
);
16898 if (!s
->fn_result_spec
16899 && s
->attr
.flavor
== FL_PARAMETER
)
16901 /* Function contained in a module.... */
16902 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16905 s
->fn_result_spec
= 1;
16906 /* Make sure that this symbol is translated as a module
16908 st
= gfc_get_unique_symtree (ns
);
16912 /* ... which is use associated and called. */
16913 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16915 /* External function matched with an interface. */
16918 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16919 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16920 && s
->ns
->proc_name
->attr
.function
))
16921 s
->fn_result_spec
= 1;
16928 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16931 resolve_fntype (gfc_namespace
*ns
)
16933 gfc_entry_list
*el
;
16936 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16939 /* If there are any entries, ns->proc_name is the entry master
16940 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16942 sym
= ns
->entries
->sym
;
16944 sym
= ns
->proc_name
;
16945 if (sym
->result
== sym
16946 && sym
->ts
.type
== BT_UNKNOWN
16947 && !gfc_set_default_type (sym
, 0, NULL
)
16948 && !sym
->attr
.untyped
)
16950 gfc_error ("Function %qs at %L has no IMPLICIT type",
16951 sym
->name
, &sym
->declared_at
);
16952 sym
->attr
.untyped
= 1;
16955 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16956 && !sym
->attr
.contained
16957 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16958 && gfc_check_symbol_access (sym
))
16960 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16961 "%L of PRIVATE type %qs", sym
->name
,
16962 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16966 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16968 if (el
->sym
->result
== el
->sym
16969 && el
->sym
->ts
.type
== BT_UNKNOWN
16970 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16971 && !el
->sym
->attr
.untyped
)
16973 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16974 el
->sym
->name
, &el
->sym
->declared_at
);
16975 el
->sym
->attr
.untyped
= 1;
16979 if (sym
->ts
.type
== BT_CHARACTER
)
16980 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16984 /* 12.3.2.1.1 Defined operators. */
16987 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16989 gfc_formal_arglist
*formal
;
16991 if (!sym
->attr
.function
)
16993 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16994 sym
->name
, &where
);
16998 if (sym
->ts
.type
== BT_CHARACTER
16999 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
17000 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
17001 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
17003 gfc_error ("User operator procedure %qs at %L cannot be assumed "
17004 "character length", sym
->name
, &where
);
17008 formal
= gfc_sym_get_dummy_args (sym
);
17009 if (!formal
|| !formal
->sym
)
17011 gfc_error ("User operator procedure %qs at %L must have at least "
17012 "one argument", sym
->name
, &where
);
17016 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
17018 gfc_error ("First argument of operator interface at %L must be "
17019 "INTENT(IN)", &where
);
17023 if (formal
->sym
->attr
.optional
)
17025 gfc_error ("First argument of operator interface at %L cannot be "
17026 "optional", &where
);
17030 formal
= formal
->next
;
17031 if (!formal
|| !formal
->sym
)
17034 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
17036 gfc_error ("Second argument of operator interface at %L must be "
17037 "INTENT(IN)", &where
);
17041 if (formal
->sym
->attr
.optional
)
17043 gfc_error ("Second argument of operator interface at %L cannot be "
17044 "optional", &where
);
17050 gfc_error ("Operator interface at %L must have, at most, two "
17051 "arguments", &where
);
17059 gfc_resolve_uops (gfc_symtree
*symtree
)
17061 gfc_interface
*itr
;
17063 if (symtree
== NULL
)
17066 gfc_resolve_uops (symtree
->left
);
17067 gfc_resolve_uops (symtree
->right
);
17069 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
17070 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
17074 /* Examine all of the expressions associated with a program unit,
17075 assign types to all intermediate expressions, make sure that all
17076 assignments are to compatible types and figure out which names
17077 refer to which functions or subroutines. It doesn't check code
17078 block, which is handled by gfc_resolve_code. */
17081 resolve_types (gfc_namespace
*ns
)
17087 gfc_namespace
* old_ns
= gfc_current_ns
;
17088 bool recursive
= ns
->proc_name
&& ns
->proc_name
->attr
.recursive
;
17090 if (ns
->types_resolved
)
17093 /* Check that all IMPLICIT types are ok. */
17094 if (!ns
->seen_implicit_none
)
17097 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
17098 if (ns
->set_flag
[letter
]
17099 && !resolve_typespec_used (&ns
->default_type
[letter
],
17100 &ns
->implicit_loc
[letter
], NULL
))
17104 gfc_current_ns
= ns
;
17106 resolve_entries (ns
);
17108 resolve_common_vars (&ns
->blank_common
, false);
17109 resolve_common_blocks (ns
->common_root
);
17111 resolve_contained_functions (ns
);
17113 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
17114 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
17115 resolve_formal_arglist (ns
->proc_name
);
17117 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
17119 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
17120 resolve_charlen (cl
);
17122 gfc_traverse_ns (ns
, resolve_symbol
);
17124 resolve_fntype (ns
);
17126 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17128 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
17129 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
17130 "also be PURE", n
->proc_name
->name
,
17131 &n
->proc_name
->declared_at
);
17137 gfc_do_concurrent_flag
= 0;
17138 gfc_check_interfaces (ns
);
17140 gfc_traverse_ns (ns
, resolve_values
);
17142 if (ns
->save_all
|| (!flag_automatic
&& !recursive
))
17146 for (d
= ns
->data
; d
; d
= d
->next
)
17150 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
17152 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
17154 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
17155 resolve_equivalence (eq
);
17157 /* Warn about unused labels. */
17158 if (warn_unused_label
)
17159 warn_unused_fortran_label (ns
->st_labels
);
17161 gfc_resolve_uops (ns
->uop_root
);
17163 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
17165 gfc_resolve_omp_declare_simd (ns
);
17167 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
17169 ns
->types_resolved
= 1;
17171 gfc_current_ns
= old_ns
;
17175 /* Call gfc_resolve_code recursively. */
17178 resolve_codes (gfc_namespace
*ns
)
17181 bitmap_obstack old_obstack
;
17183 if (ns
->resolved
== 1)
17186 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17189 gfc_current_ns
= ns
;
17191 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
17192 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
17195 /* Set to an out of range value. */
17196 current_entry_id
= -1;
17198 old_obstack
= labels_obstack
;
17199 bitmap_obstack_initialize (&labels_obstack
);
17201 gfc_resolve_oacc_declare (ns
);
17202 gfc_resolve_oacc_routines (ns
);
17203 gfc_resolve_omp_local_vars (ns
);
17204 gfc_resolve_code (ns
->code
, ns
);
17206 bitmap_obstack_release (&labels_obstack
);
17207 labels_obstack
= old_obstack
;
17211 /* This function is called after a complete program unit has been compiled.
17212 Its purpose is to examine all of the expressions associated with a program
17213 unit, assign types to all intermediate expressions, make sure that all
17214 assignments are to compatible types and figure out which names refer to
17215 which functions or subroutines. */
17218 gfc_resolve (gfc_namespace
*ns
)
17220 gfc_namespace
*old_ns
;
17221 code_stack
*old_cs_base
;
17222 struct gfc_omp_saved_state old_omp_state
;
17228 old_ns
= gfc_current_ns
;
17229 old_cs_base
= cs_base
;
17231 /* As gfc_resolve can be called during resolution of an OpenMP construct
17232 body, we should clear any state associated to it, so that say NS's
17233 DO loops are not interpreted as OpenMP loops. */
17234 if (!ns
->construct_entities
)
17235 gfc_omp_save_and_clear_state (&old_omp_state
);
17237 resolve_types (ns
);
17238 component_assignment_level
= 0;
17239 resolve_codes (ns
);
17241 gfc_current_ns
= old_ns
;
17242 cs_base
= old_cs_base
;
17245 gfc_run_passes (ns
);
17247 if (!ns
->construct_entities
)
17248 gfc_omp_restore_state (&old_omp_state
);