1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2019 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 (OPT_Wargument_mismatch
,
1433 "Interface mismatch for procedure-pointer "
1434 "component %qs in structure constructor at %L:"
1435 " %s", comp
->name
, &cons
->expr
->where
, err
);
1440 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1441 || cons
->expr
->expr_type
== EXPR_NULL
)
1444 a
= gfc_expr_attr (cons
->expr
);
1446 if (!a
.pointer
&& !a
.target
)
1449 gfc_error ("The element in the structure constructor at %L, "
1450 "for pointer component %qs should be a POINTER or "
1451 "a TARGET", &cons
->expr
->where
, comp
->name
);
1456 /* F08:C461. Additional checks for pointer initialization. */
1460 gfc_error ("Pointer initialization target at %L "
1461 "must not be ALLOCATABLE", &cons
->expr
->where
);
1466 gfc_error ("Pointer initialization target at %L "
1467 "must have the SAVE attribute", &cons
->expr
->where
);
1471 /* F2003, C1272 (3). */
1472 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1473 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1474 || gfc_is_coindexed (cons
->expr
));
1475 if (impure
&& gfc_pure (NULL
))
1478 gfc_error ("Invalid expression in the structure constructor for "
1479 "pointer component %qs at %L in PURE procedure",
1480 comp
->name
, &cons
->expr
->where
);
1484 gfc_unset_implicit_pure (NULL
);
1491 /****************** Expression name resolution ******************/
1493 /* Returns 0 if a symbol was not declared with a type or
1494 attribute declaration statement, nonzero otherwise. */
1497 was_declared (gfc_symbol
*sym
)
1503 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1506 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1507 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1508 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1509 || a
.asynchronous
|| a
.codimension
)
1516 /* Determine if a symbol is generic or not. */
1519 generic_sym (gfc_symbol
*sym
)
1523 if (sym
->attr
.generic
||
1524 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1527 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1530 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1537 return generic_sym (s
);
1544 /* Determine if a symbol is specific or not. */
1547 specific_sym (gfc_symbol
*sym
)
1551 if (sym
->attr
.if_source
== IFSRC_IFBODY
1552 || sym
->attr
.proc
== PROC_MODULE
1553 || sym
->attr
.proc
== PROC_INTERNAL
1554 || sym
->attr
.proc
== PROC_ST_FUNCTION
1555 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1556 || sym
->attr
.external
)
1559 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1562 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1564 return (s
== NULL
) ? 0 : specific_sym (s
);
1568 /* Figure out if the procedure is specific, generic or unknown. */
1571 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1574 procedure_kind (gfc_symbol
*sym
)
1576 if (generic_sym (sym
))
1577 return PTYPE_GENERIC
;
1579 if (specific_sym (sym
))
1580 return PTYPE_SPECIFIC
;
1582 return PTYPE_UNKNOWN
;
1585 /* Check references to assumed size arrays. The flag need_full_assumed_size
1586 is nonzero when matching actual arguments. */
1588 static int need_full_assumed_size
= 0;
1591 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1593 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1596 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1597 What should it be? */
1598 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1599 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1600 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1602 gfc_error ("The upper bound in the last dimension must "
1603 "appear in the reference to the assumed size "
1604 "array %qs at %L", sym
->name
, &e
->where
);
1611 /* Look for bad assumed size array references in argument expressions
1612 of elemental and array valued intrinsic procedures. Since this is
1613 called from procedure resolution functions, it only recurses at
1617 resolve_assumed_size_actual (gfc_expr
*e
)
1622 switch (e
->expr_type
)
1625 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1630 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1631 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1642 /* Check a generic procedure, passed as an actual argument, to see if
1643 there is a matching specific name. If none, it is an error, and if
1644 more than one, the reference is ambiguous. */
1646 count_specific_procs (gfc_expr
*e
)
1653 sym
= e
->symtree
->n
.sym
;
1655 for (p
= sym
->generic
; p
; p
= p
->next
)
1656 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1658 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1664 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1668 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1669 "argument at %L", sym
->name
, &e
->where
);
1675 /* See if a call to sym could possibly be a not allowed RECURSION because of
1676 a missing RECURSIVE declaration. This means that either sym is the current
1677 context itself, or sym is the parent of a contained procedure calling its
1678 non-RECURSIVE containing procedure.
1679 This also works if sym is an ENTRY. */
1682 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1684 gfc_symbol
* proc_sym
;
1685 gfc_symbol
* context_proc
;
1686 gfc_namespace
* real_context
;
1688 if (sym
->attr
.flavor
== FL_PROGRAM
1689 || gfc_fl_struct (sym
->attr
.flavor
))
1692 /* If we've got an ENTRY, find real procedure. */
1693 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1694 proc_sym
= sym
->ns
->entries
->sym
;
1698 /* If sym is RECURSIVE, all is well of course. */
1699 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1702 /* Find the context procedure's "real" symbol if it has entries.
1703 We look for a procedure symbol, so recurse on the parents if we don't
1704 find one (like in case of a BLOCK construct). */
1705 for (real_context
= context
; ; real_context
= real_context
->parent
)
1707 /* We should find something, eventually! */
1708 gcc_assert (real_context
);
1710 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1711 : real_context
->proc_name
);
1713 /* In some special cases, there may not be a proc_name, like for this
1715 real(bad_kind()) function foo () ...
1716 when checking the call to bad_kind ().
1717 In these cases, we simply return here and assume that the
1722 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1726 /* A call from sym's body to itself is recursion, of course. */
1727 if (context_proc
== proc_sym
)
1730 /* The same is true if context is a contained procedure and sym the
1732 if (context_proc
->attr
.contained
)
1734 gfc_symbol
* parent_proc
;
1736 gcc_assert (context
->parent
);
1737 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1738 : context
->parent
->proc_name
);
1740 if (parent_proc
== proc_sym
)
1748 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1749 its typespec and formal argument list. */
1752 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1754 gfc_intrinsic_sym
* isym
= NULL
;
1760 /* Already resolved. */
1761 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1764 /* We already know this one is an intrinsic, so we don't call
1765 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1766 gfc_find_subroutine directly to check whether it is a function or
1769 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1771 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1772 isym
= gfc_intrinsic_subroutine_by_id (id
);
1774 else if (sym
->intmod_sym_id
)
1776 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1777 isym
= gfc_intrinsic_function_by_id (id
);
1779 else if (!sym
->attr
.subroutine
)
1780 isym
= gfc_find_function (sym
->name
);
1782 if (isym
&& !sym
->attr
.subroutine
)
1784 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1785 && !sym
->attr
.implicit_type
)
1786 gfc_warning (OPT_Wsurprising
,
1787 "Type specified for intrinsic function %qs at %L is"
1788 " ignored", sym
->name
, &sym
->declared_at
);
1790 if (!sym
->attr
.function
&&
1791 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1796 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1798 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1800 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1801 " specifier", sym
->name
, &sym
->declared_at
);
1805 if (!sym
->attr
.subroutine
&&
1806 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1811 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1816 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1818 sym
->attr
.pure
= isym
->pure
;
1819 sym
->attr
.elemental
= isym
->elemental
;
1821 /* Check it is actually available in the standard settings. */
1822 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1824 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1825 "available in the current standard settings but %s. Use "
1826 "an appropriate %<-std=*%> option or enable "
1827 "%<-fall-intrinsics%> in order to use it.",
1828 sym
->name
, &sym
->declared_at
, symstd
);
1836 /* Resolve a procedure expression, like passing it to a called procedure or as
1837 RHS for a procedure pointer assignment. */
1840 resolve_procedure_expression (gfc_expr
* expr
)
1844 if (expr
->expr_type
!= EXPR_VARIABLE
)
1846 gcc_assert (expr
->symtree
);
1848 sym
= expr
->symtree
->n
.sym
;
1850 if (sym
->attr
.intrinsic
)
1851 gfc_resolve_intrinsic (sym
, &expr
->where
);
1853 if (sym
->attr
.flavor
!= FL_PROCEDURE
1854 || (sym
->attr
.function
&& sym
->result
== sym
))
1857 /* A non-RECURSIVE procedure that is used as procedure expression within its
1858 own body is in danger of being called recursively. */
1859 if (is_illegal_recursion (sym
, gfc_current_ns
))
1860 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1861 " itself recursively. Declare it RECURSIVE or use"
1862 " %<-frecursive%>", sym
->name
, &expr
->where
);
1868 /* Check that name is not a derived type. */
1871 is_dt_name (const char *name
)
1873 gfc_symbol
*dt_list
, *dt_first
;
1875 dt_list
= dt_first
= gfc_derived_types
;
1876 for (; dt_list
; dt_list
= dt_list
->dt_next
)
1878 if (strcmp(dt_list
->name
, name
) == 0)
1880 if (dt_first
== dt_list
->dt_next
)
1887 /* Resolve an actual argument list. Most of the time, this is just
1888 resolving the expressions in the list.
1889 The exception is that we sometimes have to decide whether arguments
1890 that look like procedure arguments are really simple variable
1894 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1895 bool no_formal_args
)
1898 gfc_symtree
*parent_st
;
1900 gfc_component
*comp
;
1901 int save_need_full_assumed_size
;
1902 bool return_value
= false;
1903 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1906 first_actual_arg
= true;
1908 for (; arg
; arg
= arg
->next
)
1913 /* Check the label is a valid branching target. */
1916 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1918 gfc_error ("Label %d referenced at %L is never defined",
1919 arg
->label
->value
, &arg
->label
->where
);
1923 first_actual_arg
= false;
1927 if (e
->expr_type
== EXPR_VARIABLE
1928 && e
->symtree
->n
.sym
->attr
.generic
1930 && count_specific_procs (e
) != 1)
1933 if (e
->ts
.type
!= BT_PROCEDURE
)
1935 save_need_full_assumed_size
= need_full_assumed_size
;
1936 if (e
->expr_type
!= EXPR_VARIABLE
)
1937 need_full_assumed_size
= 0;
1938 if (!gfc_resolve_expr (e
))
1940 need_full_assumed_size
= save_need_full_assumed_size
;
1944 /* See if the expression node should really be a variable reference. */
1946 sym
= e
->symtree
->n
.sym
;
1948 if (sym
->attr
.flavor
== FL_PROCEDURE
&& is_dt_name (sym
->name
))
1950 gfc_error ("Derived type %qs is used as an actual "
1951 "argument at %L", sym
->name
, &e
->where
);
1955 if (sym
->attr
.flavor
== FL_PROCEDURE
1956 || sym
->attr
.intrinsic
1957 || sym
->attr
.external
)
1961 /* If a procedure is not already determined to be something else
1962 check if it is intrinsic. */
1963 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1964 sym
->attr
.intrinsic
= 1;
1966 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1968 gfc_error ("Statement function %qs at %L is not allowed as an "
1969 "actual argument", sym
->name
, &e
->where
);
1972 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1973 sym
->attr
.subroutine
);
1974 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1976 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1977 "actual argument", sym
->name
, &e
->where
);
1980 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1981 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1983 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1984 " used as actual argument at %L",
1985 sym
->name
, &e
->where
))
1989 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1991 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1992 "allowed as an actual argument at %L", sym
->name
,
1996 /* Check if a generic interface has a specific procedure
1997 with the same name before emitting an error. */
1998 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
2001 /* Just in case a specific was found for the expression. */
2002 sym
= e
->symtree
->n
.sym
;
2004 /* If the symbol is the function that names the current (or
2005 parent) scope, then we really have a variable reference. */
2007 if (gfc_is_function_return_value (sym
, sym
->ns
))
2010 /* If all else fails, see if we have a specific intrinsic. */
2011 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
2013 gfc_intrinsic_sym
*isym
;
2015 isym
= gfc_find_function (sym
->name
);
2016 if (isym
== NULL
|| !isym
->specific
)
2018 gfc_error ("Unable to find a specific INTRINSIC procedure "
2019 "for the reference %qs at %L", sym
->name
,
2024 sym
->attr
.intrinsic
= 1;
2025 sym
->attr
.function
= 1;
2028 if (!gfc_resolve_expr (e
))
2033 /* See if the name is a module procedure in a parent unit. */
2035 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2038 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2040 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2044 if (parent_st
== NULL
)
2047 sym
= parent_st
->n
.sym
;
2048 e
->symtree
= parent_st
; /* Point to the right thing. */
2050 if (sym
->attr
.flavor
== FL_PROCEDURE
2051 || sym
->attr
.intrinsic
2052 || sym
->attr
.external
)
2054 if (!gfc_resolve_expr (e
))
2060 e
->expr_type
= EXPR_VARIABLE
;
2062 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2063 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2064 && CLASS_DATA (sym
)->as
))
2066 e
->rank
= sym
->ts
.type
== BT_CLASS
2067 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2068 e
->ref
= gfc_get_ref ();
2069 e
->ref
->type
= REF_ARRAY
;
2070 e
->ref
->u
.ar
.type
= AR_FULL
;
2071 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2072 ? CLASS_DATA (sym
)->as
: sym
->as
;
2075 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2076 primary.c (match_actual_arg). If above code determines that it
2077 is a variable instead, it needs to be resolved as it was not
2078 done at the beginning of this function. */
2079 save_need_full_assumed_size
= need_full_assumed_size
;
2080 if (e
->expr_type
!= EXPR_VARIABLE
)
2081 need_full_assumed_size
= 0;
2082 if (!gfc_resolve_expr (e
))
2084 need_full_assumed_size
= save_need_full_assumed_size
;
2087 /* Check argument list functions %VAL, %LOC and %REF. There is
2088 nothing to do for %REF. */
2089 if (arg
->name
&& arg
->name
[0] == '%')
2091 if (strcmp ("%VAL", arg
->name
) == 0)
2093 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2095 gfc_error ("By-value argument at %L is not of numeric "
2102 gfc_error ("By-value argument at %L cannot be an array or "
2103 "an array section", &e
->where
);
2107 /* Intrinsics are still PROC_UNKNOWN here. However,
2108 since same file external procedures are not resolvable
2109 in gfortran, it is a good deal easier to leave them to
2111 if (ptype
!= PROC_UNKNOWN
2112 && ptype
!= PROC_DUMMY
2113 && ptype
!= PROC_EXTERNAL
2114 && ptype
!= PROC_MODULE
)
2116 gfc_error ("By-value argument at %L is not allowed "
2117 "in this context", &e
->where
);
2122 /* Statement functions have already been excluded above. */
2123 else if (strcmp ("%LOC", arg
->name
) == 0
2124 && e
->ts
.type
== BT_PROCEDURE
)
2126 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2128 gfc_error ("Passing internal procedure at %L by location "
2129 "not allowed", &e
->where
);
2135 comp
= gfc_get_proc_ptr_comp(e
);
2136 if (e
->expr_type
== EXPR_VARIABLE
2137 && comp
&& comp
->attr
.elemental
)
2139 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2140 "allowed as an actual argument at %L", comp
->name
,
2144 /* Fortran 2008, C1237. */
2145 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2146 && gfc_has_ultimate_pointer (e
))
2148 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2149 "component", &e
->where
);
2153 first_actual_arg
= false;
2156 return_value
= true;
2159 actual_arg
= actual_arg_sav
;
2160 first_actual_arg
= first_actual_arg_sav
;
2162 return return_value
;
2166 /* Do the checks of the actual argument list that are specific to elemental
2167 procedures. If called with c == NULL, we have a function, otherwise if
2168 expr == NULL, we have a subroutine. */
2171 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2173 gfc_actual_arglist
*arg0
;
2174 gfc_actual_arglist
*arg
;
2175 gfc_symbol
*esym
= NULL
;
2176 gfc_intrinsic_sym
*isym
= NULL
;
2178 gfc_intrinsic_arg
*iformal
= NULL
;
2179 gfc_formal_arglist
*eformal
= NULL
;
2180 bool formal_optional
= false;
2181 bool set_by_optional
= false;
2185 /* Is this an elemental procedure? */
2186 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2188 if (expr
->value
.function
.esym
!= NULL
2189 && expr
->value
.function
.esym
->attr
.elemental
)
2191 arg0
= expr
->value
.function
.actual
;
2192 esym
= expr
->value
.function
.esym
;
2194 else if (expr
->value
.function
.isym
!= NULL
2195 && expr
->value
.function
.isym
->elemental
)
2197 arg0
= expr
->value
.function
.actual
;
2198 isym
= expr
->value
.function
.isym
;
2203 else if (c
&& c
->ext
.actual
!= NULL
)
2205 arg0
= c
->ext
.actual
;
2207 if (c
->resolved_sym
)
2208 esym
= c
->resolved_sym
;
2210 esym
= c
->symtree
->n
.sym
;
2213 if (!esym
->attr
.elemental
)
2219 /* The rank of an elemental is the rank of its array argument(s). */
2220 for (arg
= arg0
; arg
; arg
= arg
->next
)
2222 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2224 rank
= arg
->expr
->rank
;
2225 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2226 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2227 set_by_optional
= true;
2229 /* Function specific; set the result rank and shape. */
2233 if (!expr
->shape
&& arg
->expr
->shape
)
2235 expr
->shape
= gfc_get_shape (rank
);
2236 for (i
= 0; i
< rank
; i
++)
2237 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2244 /* If it is an array, it shall not be supplied as an actual argument
2245 to an elemental procedure unless an array of the same rank is supplied
2246 as an actual argument corresponding to a nonoptional dummy argument of
2247 that elemental procedure(12.4.1.5). */
2248 formal_optional
= false;
2250 iformal
= isym
->formal
;
2252 eformal
= esym
->formal
;
2254 for (arg
= arg0
; arg
; arg
= arg
->next
)
2258 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2259 formal_optional
= true;
2260 eformal
= eformal
->next
;
2262 else if (isym
&& iformal
)
2264 if (iformal
->optional
)
2265 formal_optional
= true;
2266 iformal
= iformal
->next
;
2269 formal_optional
= true;
2271 if (pedantic
&& arg
->expr
!= NULL
2272 && arg
->expr
->expr_type
== EXPR_VARIABLE
2273 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2276 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2277 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2279 gfc_warning (OPT_Wpedantic
,
2280 "%qs at %L is an array and OPTIONAL; IF IT IS "
2281 "MISSING, it cannot be the actual argument of an "
2282 "ELEMENTAL procedure unless there is a non-optional "
2283 "argument with the same rank (12.4.1.5)",
2284 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2288 for (arg
= arg0
; arg
; arg
= arg
->next
)
2290 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2293 /* Being elemental, the last upper bound of an assumed size array
2294 argument must be present. */
2295 if (resolve_assumed_size_actual (arg
->expr
))
2298 /* Elemental procedure's array actual arguments must conform. */
2301 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2308 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2309 is an array, the intent inout/out variable needs to be also an array. */
2310 if (rank
> 0 && esym
&& expr
== NULL
)
2311 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2312 arg
= arg
->next
, eformal
= eformal
->next
)
2313 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2314 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2315 && arg
->expr
&& arg
->expr
->rank
== 0)
2317 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2318 "ELEMENTAL subroutine %qs is a scalar, but another "
2319 "actual argument is an array", &arg
->expr
->where
,
2320 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2321 : "INOUT", eformal
->sym
->name
, esym
->name
);
2328 /* This function does the checking of references to global procedures
2329 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2330 77 and 95 standards. It checks for a gsymbol for the name, making
2331 one if it does not already exist. If it already exists, then the
2332 reference being resolved must correspond to the type of gsymbol.
2333 Otherwise, the new symbol is equipped with the attributes of the
2334 reference. The corresponding code that is called in creating
2335 global entities is parse.c.
2337 In addition, for all but -std=legacy, the gsymbols are used to
2338 check the interfaces of external procedures from the same file.
2339 The namespace of the gsymbol is resolved and then, once this is
2340 done the interface is checked. */
2344 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2346 if (!gsym_ns
->proc_name
->attr
.recursive
)
2349 if (sym
->ns
== gsym_ns
)
2352 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2359 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2361 if (gsym_ns
->entries
)
2363 gfc_entry_list
*entry
= gsym_ns
->entries
;
2365 for (; entry
; entry
= entry
->next
)
2367 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2369 if (strcmp (gsym_ns
->proc_name
->name
,
2370 sym
->ns
->proc_name
->name
) == 0)
2374 && strcmp (gsym_ns
->proc_name
->name
,
2375 sym
->ns
->parent
->proc_name
->name
) == 0)
2384 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2387 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2389 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2391 for ( ; arg
; arg
= arg
->next
)
2396 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2398 strncpy (errmsg
, _("allocatable argument"), err_len
);
2401 else if (arg
->sym
->attr
.asynchronous
)
2403 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2406 else if (arg
->sym
->attr
.optional
)
2408 strncpy (errmsg
, _("optional argument"), err_len
);
2411 else if (arg
->sym
->attr
.pointer
)
2413 strncpy (errmsg
, _("pointer argument"), err_len
);
2416 else if (arg
->sym
->attr
.target
)
2418 strncpy (errmsg
, _("target argument"), err_len
);
2421 else if (arg
->sym
->attr
.value
)
2423 strncpy (errmsg
, _("value argument"), err_len
);
2426 else if (arg
->sym
->attr
.volatile_
)
2428 strncpy (errmsg
, _("volatile argument"), err_len
);
2431 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2433 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2436 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2438 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2441 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2443 strncpy (errmsg
, _("coarray argument"), err_len
);
2446 else if (false) /* (2d) TODO: parametrized derived type */
2448 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2451 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2453 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2456 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2458 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2461 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2463 /* As assumed-type is unlimited polymorphic (cf. above).
2464 See also TS 29113, Note 6.1. */
2465 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2470 if (sym
->attr
.function
)
2472 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2474 if (res
->attr
.dimension
) /* (3a) */
2476 strncpy (errmsg
, _("array result"), err_len
);
2479 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2481 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2484 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2485 && res
->ts
.u
.cl
->length
2486 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2488 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2493 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2495 strncpy (errmsg
, _("elemental procedure"), err_len
);
2498 else if (sym
->attr
.is_bind_c
) /* (5) */
2500 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2509 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2510 gfc_actual_arglist
**actual
, int sub
)
2514 enum gfc_symbol_type type
;
2517 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2519 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2520 sym
->binding_label
!= NULL
);
2522 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2523 gfc_global_used (gsym
, where
);
2525 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2526 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2527 && gsym
->type
!= GSYM_UNKNOWN
2528 && !gsym
->binding_label
2530 && gsym
->ns
->proc_name
2531 && not_in_recursive (sym
, gsym
->ns
)
2532 && not_entry_self_reference (sym
, gsym
->ns
))
2534 gfc_symbol
*def_sym
;
2535 def_sym
= gsym
->ns
->proc_name
;
2537 if (gsym
->ns
->resolved
!= -1)
2540 /* Resolve the gsymbol namespace if needed. */
2541 if (!gsym
->ns
->resolved
)
2543 gfc_symbol
*old_dt_list
;
2545 /* Stash away derived types so that the backend_decls
2546 do not get mixed up. */
2547 old_dt_list
= gfc_derived_types
;
2548 gfc_derived_types
= NULL
;
2550 gfc_resolve (gsym
->ns
);
2552 /* Store the new derived types with the global namespace. */
2553 if (gfc_derived_types
)
2554 gsym
->ns
->derived_types
= gfc_derived_types
;
2556 /* Restore the derived types of this namespace. */
2557 gfc_derived_types
= old_dt_list
;
2560 /* Make sure that translation for the gsymbol occurs before
2561 the procedure currently being resolved. */
2562 ns
= gfc_global_ns_list
;
2563 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2565 if (ns
->sibling
== gsym
->ns
)
2567 ns
->sibling
= gsym
->ns
->sibling
;
2568 gsym
->ns
->sibling
= gfc_global_ns_list
;
2569 gfc_global_ns_list
= gsym
->ns
;
2574 /* This can happen if a binding name has been specified. */
2575 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2576 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2578 if (def_sym
->attr
.entry_master
|| def_sym
->attr
.entry
)
2580 gfc_entry_list
*entry
;
2581 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2582 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2584 def_sym
= entry
->sym
;
2590 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2592 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2593 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2594 gfc_typename (&def_sym
->ts
));
2598 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2599 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2601 gfc_error ("Explicit interface required for %qs at %L: %s",
2602 sym
->name
, &sym
->declared_at
, reason
);
2606 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2607 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2608 gfc_errors_to_warnings (true);
2610 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2611 reason
, sizeof(reason
), NULL
, NULL
))
2613 gfc_error_opt (OPT_Wargument_mismatch
,
2614 "Interface mismatch in global procedure %qs at %L:"
2615 " %s", sym
->name
, &sym
->declared_at
, reason
);
2620 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2621 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2622 gfc_errors_to_warnings (true);
2624 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2625 gfc_procedure_use (def_sym
, actual
, where
);
2629 gfc_errors_to_warnings (false);
2631 if (gsym
->type
== GSYM_UNKNOWN
)
2634 gsym
->where
= *where
;
2641 /************* Function resolution *************/
2643 /* Resolve a function call known to be generic.
2644 Section 14.1.2.4.1. */
2647 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2651 if (sym
->attr
.generic
)
2653 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2656 expr
->value
.function
.name
= s
->name
;
2657 expr
->value
.function
.esym
= s
;
2659 if (s
->ts
.type
!= BT_UNKNOWN
)
2661 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2662 expr
->ts
= s
->result
->ts
;
2665 expr
->rank
= s
->as
->rank
;
2666 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2667 expr
->rank
= s
->result
->as
->rank
;
2669 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2674 /* TODO: Need to search for elemental references in generic
2678 if (sym
->attr
.intrinsic
)
2679 return gfc_intrinsic_func_interface (expr
, 0);
2686 resolve_generic_f (gfc_expr
*expr
)
2690 gfc_interface
*intr
= NULL
;
2692 sym
= expr
->symtree
->n
.sym
;
2696 m
= resolve_generic_f0 (expr
, sym
);
2699 else if (m
== MATCH_ERROR
)
2704 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2705 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2708 if (sym
->ns
->parent
== NULL
)
2710 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2714 if (!generic_sym (sym
))
2718 /* Last ditch attempt. See if the reference is to an intrinsic
2719 that possesses a matching interface. 14.1.2.4 */
2720 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2722 if (gfc_init_expr_flag
)
2723 gfc_error ("Function %qs in initialization expression at %L "
2724 "must be an intrinsic function",
2725 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2727 gfc_error ("There is no specific function for the generic %qs "
2728 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2734 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2737 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2739 return resolve_structure_cons (expr
, 0);
2742 m
= gfc_intrinsic_func_interface (expr
, 0);
2747 gfc_error ("Generic function %qs at %L is not consistent with a "
2748 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2755 /* Resolve a function call known to be specific. */
2758 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2762 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2764 if (sym
->attr
.dummy
)
2766 sym
->attr
.proc
= PROC_DUMMY
;
2770 sym
->attr
.proc
= PROC_EXTERNAL
;
2774 if (sym
->attr
.proc
== PROC_MODULE
2775 || sym
->attr
.proc
== PROC_ST_FUNCTION
2776 || sym
->attr
.proc
== PROC_INTERNAL
)
2779 if (sym
->attr
.intrinsic
)
2781 m
= gfc_intrinsic_func_interface (expr
, 1);
2785 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2786 "with an intrinsic", sym
->name
, &expr
->where
);
2794 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2797 expr
->ts
= sym
->result
->ts
;
2800 expr
->value
.function
.name
= sym
->name
;
2801 expr
->value
.function
.esym
= sym
;
2802 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2804 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2806 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2807 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2808 else if (sym
->as
!= NULL
)
2809 expr
->rank
= sym
->as
->rank
;
2816 resolve_specific_f (gfc_expr
*expr
)
2821 sym
= expr
->symtree
->n
.sym
;
2825 m
= resolve_specific_f0 (sym
, expr
);
2828 if (m
== MATCH_ERROR
)
2831 if (sym
->ns
->parent
== NULL
)
2834 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2840 gfc_error ("Unable to resolve the specific function %qs at %L",
2841 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2846 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2847 candidates in CANDIDATES_LEN. */
2850 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2852 size_t &candidates_len
)
2858 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2859 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2860 vec_push (candidates
, candidates_len
, sym
->name
);
2864 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2868 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2872 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2875 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2877 char **candidates
= NULL
;
2878 size_t candidates_len
= 0;
2879 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2880 return gfc_closest_fuzzy_match (fn
, candidates
);
2884 /* Resolve a procedure call not known to be generic nor specific. */
2887 resolve_unknown_f (gfc_expr
*expr
)
2892 sym
= expr
->symtree
->n
.sym
;
2894 if (sym
->attr
.dummy
)
2896 sym
->attr
.proc
= PROC_DUMMY
;
2897 expr
->value
.function
.name
= sym
->name
;
2901 /* See if we have an intrinsic function reference. */
2903 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2905 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2910 /* The reference is to an external name. */
2912 sym
->attr
.proc
= PROC_EXTERNAL
;
2913 expr
->value
.function
.name
= sym
->name
;
2914 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2916 if (sym
->as
!= NULL
)
2917 expr
->rank
= sym
->as
->rank
;
2919 /* Type of the expression is either the type of the symbol or the
2920 default type of the symbol. */
2923 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2925 if (sym
->ts
.type
!= BT_UNKNOWN
)
2929 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2931 if (ts
->type
== BT_UNKNOWN
)
2934 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2936 gfc_error ("Function %qs at %L has no IMPLICIT type"
2937 "; did you mean %qs?",
2938 sym
->name
, &expr
->where
, guessed
);
2940 gfc_error ("Function %qs at %L has no IMPLICIT type",
2941 sym
->name
, &expr
->where
);
2952 /* Return true, if the symbol is an external procedure. */
2954 is_external_proc (gfc_symbol
*sym
)
2956 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2957 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2958 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2959 && !sym
->attr
.proc_pointer
2960 && !sym
->attr
.use_assoc
2968 /* Figure out if a function reference is pure or not. Also set the name
2969 of the function for a potential error message. Return nonzero if the
2970 function is PURE, zero if not. */
2972 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2975 gfc_pure_function (gfc_expr
*e
, const char **name
)
2978 gfc_component
*comp
;
2982 if (e
->symtree
!= NULL
2983 && e
->symtree
->n
.sym
!= NULL
2984 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2985 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2987 comp
= gfc_get_proc_ptr_comp (e
);
2990 pure
= gfc_pure (comp
->ts
.interface
);
2993 else if (e
->value
.function
.esym
)
2995 pure
= gfc_pure (e
->value
.function
.esym
);
2996 *name
= e
->value
.function
.esym
->name
;
2998 else if (e
->value
.function
.isym
)
3000 pure
= e
->value
.function
.isym
->pure
3001 || e
->value
.function
.isym
->elemental
;
3002 *name
= e
->value
.function
.isym
->name
;
3006 /* Implicit functions are not pure. */
3008 *name
= e
->value
.function
.name
;
3015 /* Check if the expression is a reference to an implicitly pure function. */
3018 gfc_implicit_pure_function (gfc_expr
*e
)
3020 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
3022 return gfc_implicit_pure (comp
->ts
.interface
);
3023 else if (e
->value
.function
.esym
)
3024 return gfc_implicit_pure (e
->value
.function
.esym
);
3031 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3032 int *f ATTRIBUTE_UNUSED
)
3036 /* Don't bother recursing into other statement functions
3037 since they will be checked individually for purity. */
3038 if (e
->expr_type
!= EXPR_FUNCTION
3040 || e
->symtree
->n
.sym
== sym
3041 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3044 return gfc_pure_function (e
, &name
) ? false : true;
3049 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3051 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3055 /* Check if an impure function is allowed in the current context. */
3057 static bool check_pure_function (gfc_expr
*e
)
3059 const char *name
= NULL
;
3060 if (!gfc_pure_function (e
, &name
) && name
)
3064 gfc_error ("Reference to impure function %qs at %L inside a "
3065 "FORALL %s", name
, &e
->where
,
3066 forall_flag
== 2 ? "mask" : "block");
3069 else if (gfc_do_concurrent_flag
)
3071 gfc_error ("Reference to impure function %qs at %L inside a "
3072 "DO CONCURRENT %s", name
, &e
->where
,
3073 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3076 else if (gfc_pure (NULL
))
3078 gfc_error ("Reference to impure function %qs at %L "
3079 "within a PURE procedure", name
, &e
->where
);
3082 if (!gfc_implicit_pure_function (e
))
3083 gfc_unset_implicit_pure (NULL
);
3089 /* Update current procedure's array_outer_dependency flag, considering
3090 a call to procedure SYM. */
3093 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3095 /* Check to see if this is a sibling function that has not yet
3097 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3098 for (; sibling
; sibling
= sibling
->sibling
)
3100 if (sibling
->proc_name
== sym
)
3102 gfc_resolve (sibling
);
3107 /* If SYM has references to outer arrays, so has the procedure calling
3108 SYM. If SYM is a procedure pointer, we can assume the worst. */
3109 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3110 && gfc_current_ns
->proc_name
)
3111 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3115 /* Resolve a function call, which means resolving the arguments, then figuring
3116 out which entity the name refers to. */
3119 resolve_function (gfc_expr
*expr
)
3121 gfc_actual_arglist
*arg
;
3125 procedure_type p
= PROC_INTRINSIC
;
3126 bool no_formal_args
;
3130 sym
= expr
->symtree
->n
.sym
;
3132 /* If this is a procedure pointer component, it has already been resolved. */
3133 if (gfc_is_proc_ptr_comp (expr
))
3136 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3138 if (sym
&& sym
->attr
.intrinsic
3139 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3140 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3143 if (sym
&& sym
->attr
.intrinsic
3144 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3147 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3149 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3153 /* If this is a deferred TBP with an abstract interface (which may
3154 of course be referenced), expr->value.function.esym will be set. */
3155 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3157 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3158 sym
->name
, &expr
->where
);
3162 /* If this is a deferred TBP with an abstract interface, its result
3163 cannot be an assumed length character (F2003: C418). */
3164 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3165 && sym
->result
->ts
.u
.cl
3166 && sym
->result
->ts
.u
.cl
->length
== NULL
3167 && !sym
->result
->ts
.deferred
)
3169 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3170 "character length result (F2008: C418)", sym
->name
,
3175 /* Switch off assumed size checking and do this again for certain kinds
3176 of procedure, once the procedure itself is resolved. */
3177 need_full_assumed_size
++;
3179 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3180 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3182 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3183 inquiry_argument
= true;
3184 no_formal_args
= sym
&& is_external_proc (sym
)
3185 && gfc_sym_get_dummy_args (sym
) == NULL
;
3187 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3190 inquiry_argument
= false;
3194 inquiry_argument
= false;
3196 /* Resume assumed_size checking. */
3197 need_full_assumed_size
--;
3199 /* If the procedure is external, check for usage. */
3200 if (sym
&& is_external_proc (sym
))
3201 resolve_global_procedure (sym
, &expr
->where
,
3202 &expr
->value
.function
.actual
, 0);
3204 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3206 && sym
->ts
.u
.cl
->length
== NULL
3208 && !sym
->ts
.deferred
3209 && expr
->value
.function
.esym
== NULL
3210 && !sym
->attr
.contained
)
3212 /* Internal procedures are taken care of in resolve_contained_fntype. */
3213 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3214 "be used at %L since it is not a dummy argument",
3215 sym
->name
, &expr
->where
);
3219 /* See if function is already resolved. */
3221 if (expr
->value
.function
.name
!= NULL
3222 || expr
->value
.function
.isym
!= NULL
)
3224 if (expr
->ts
.type
== BT_UNKNOWN
)
3230 /* Apply the rules of section 14.1.2. */
3232 switch (procedure_kind (sym
))
3235 t
= resolve_generic_f (expr
);
3238 case PTYPE_SPECIFIC
:
3239 t
= resolve_specific_f (expr
);
3243 t
= resolve_unknown_f (expr
);
3247 gfc_internal_error ("resolve_function(): bad function type");
3251 /* If the expression is still a function (it might have simplified),
3252 then we check to see if we are calling an elemental function. */
3254 if (expr
->expr_type
!= EXPR_FUNCTION
)
3257 temp
= need_full_assumed_size
;
3258 need_full_assumed_size
= 0;
3260 if (!resolve_elemental_actual (expr
, NULL
))
3263 if (omp_workshare_flag
3264 && expr
->value
.function
.esym
3265 && ! gfc_elemental (expr
->value
.function
.esym
))
3267 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3268 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3273 #define GENERIC_ID expr->value.function.isym->id
3274 else if (expr
->value
.function
.actual
!= NULL
3275 && expr
->value
.function
.isym
!= NULL
3276 && GENERIC_ID
!= GFC_ISYM_LBOUND
3277 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3278 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3279 && GENERIC_ID
!= GFC_ISYM_LEN
3280 && GENERIC_ID
!= GFC_ISYM_LOC
3281 && GENERIC_ID
!= GFC_ISYM_C_LOC
3282 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3284 /* Array intrinsics must also have the last upper bound of an
3285 assumed size array argument. UBOUND and SIZE have to be
3286 excluded from the check if the second argument is anything
3289 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3291 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3292 && arg
== expr
->value
.function
.actual
3293 && arg
->next
!= NULL
&& arg
->next
->expr
)
3295 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3298 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3301 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3306 if (arg
->expr
!= NULL
3307 && arg
->expr
->rank
> 0
3308 && resolve_assumed_size_actual (arg
->expr
))
3314 need_full_assumed_size
= temp
;
3316 if (!check_pure_function(expr
))
3319 /* Functions without the RECURSIVE attribution are not allowed to
3320 * call themselves. */
3321 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3324 esym
= expr
->value
.function
.esym
;
3326 if (is_illegal_recursion (esym
, gfc_current_ns
))
3328 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3329 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3330 " function %qs is not RECURSIVE",
3331 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3333 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3334 " is not RECURSIVE", esym
->name
, &expr
->where
);
3340 /* Character lengths of use associated functions may contains references to
3341 symbols not referenced from the current program unit otherwise. Make sure
3342 those symbols are marked as referenced. */
3344 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3345 && expr
->value
.function
.esym
->attr
.use_assoc
)
3347 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3350 /* Make sure that the expression has a typespec that works. */
3351 if (expr
->ts
.type
== BT_UNKNOWN
)
3353 if (expr
->symtree
->n
.sym
->result
3354 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3355 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3356 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3359 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3361 if (expr
->value
.function
.esym
)
3362 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3364 update_current_proc_array_outer_dependency (sym
);
3367 /* typebound procedure: Assume the worst. */
3368 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3374 /************* Subroutine resolution *************/
3377 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3384 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3388 else if (gfc_do_concurrent_flag
)
3390 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3394 else if (gfc_pure (NULL
))
3396 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3400 gfc_unset_implicit_pure (NULL
);
3406 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3410 if (sym
->attr
.generic
)
3412 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3415 c
->resolved_sym
= s
;
3416 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3421 /* TODO: Need to search for elemental references in generic interface. */
3424 if (sym
->attr
.intrinsic
)
3425 return gfc_intrinsic_sub_interface (c
, 0);
3432 resolve_generic_s (gfc_code
*c
)
3437 sym
= c
->symtree
->n
.sym
;
3441 m
= resolve_generic_s0 (c
, sym
);
3444 else if (m
== MATCH_ERROR
)
3448 if (sym
->ns
->parent
== NULL
)
3450 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3454 if (!generic_sym (sym
))
3458 /* Last ditch attempt. See if the reference is to an intrinsic
3459 that possesses a matching interface. 14.1.2.4 */
3460 sym
= c
->symtree
->n
.sym
;
3462 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3464 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3465 sym
->name
, &c
->loc
);
3469 m
= gfc_intrinsic_sub_interface (c
, 0);
3473 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3474 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3480 /* Resolve a subroutine call known to be specific. */
3483 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3487 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3489 if (sym
->attr
.dummy
)
3491 sym
->attr
.proc
= PROC_DUMMY
;
3495 sym
->attr
.proc
= PROC_EXTERNAL
;
3499 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3502 if (sym
->attr
.intrinsic
)
3504 m
= gfc_intrinsic_sub_interface (c
, 1);
3508 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3509 "with an intrinsic", sym
->name
, &c
->loc
);
3517 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3519 c
->resolved_sym
= sym
;
3520 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3528 resolve_specific_s (gfc_code
*c
)
3533 sym
= c
->symtree
->n
.sym
;
3537 m
= resolve_specific_s0 (c
, sym
);
3540 if (m
== MATCH_ERROR
)
3543 if (sym
->ns
->parent
== NULL
)
3546 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3552 sym
= c
->symtree
->n
.sym
;
3553 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3554 sym
->name
, &c
->loc
);
3560 /* Resolve a subroutine call not known to be generic nor specific. */
3563 resolve_unknown_s (gfc_code
*c
)
3567 sym
= c
->symtree
->n
.sym
;
3569 if (sym
->attr
.dummy
)
3571 sym
->attr
.proc
= PROC_DUMMY
;
3575 /* See if we have an intrinsic function reference. */
3577 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3579 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3584 /* The reference is to an external name. */
3587 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3589 c
->resolved_sym
= sym
;
3591 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3595 /* Resolve a subroutine call. Although it was tempting to use the same code
3596 for functions, subroutines and functions are stored differently and this
3597 makes things awkward. */
3600 resolve_call (gfc_code
*c
)
3603 procedure_type ptype
= PROC_INTRINSIC
;
3604 gfc_symbol
*csym
, *sym
;
3605 bool no_formal_args
;
3607 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3609 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3611 gfc_error ("%qs at %L has a type, which is not consistent with "
3612 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3616 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3619 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3620 sym
= st
? st
->n
.sym
: NULL
;
3621 if (sym
&& csym
!= sym
3622 && sym
->ns
== gfc_current_ns
3623 && sym
->attr
.flavor
== FL_PROCEDURE
3624 && sym
->attr
.contained
)
3627 if (csym
->attr
.generic
)
3628 c
->symtree
->n
.sym
= sym
;
3631 csym
= c
->symtree
->n
.sym
;
3635 /* If this ia a deferred TBP, c->expr1 will be set. */
3636 if (!c
->expr1
&& csym
)
3638 if (csym
->attr
.abstract
)
3640 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3641 csym
->name
, &c
->loc
);
3645 /* Subroutines without the RECURSIVE attribution are not allowed to
3647 if (is_illegal_recursion (csym
, gfc_current_ns
))
3649 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3650 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3651 "as subroutine %qs is not RECURSIVE",
3652 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3654 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3655 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3661 /* Switch off assumed size checking and do this again for certain kinds
3662 of procedure, once the procedure itself is resolved. */
3663 need_full_assumed_size
++;
3666 ptype
= csym
->attr
.proc
;
3668 no_formal_args
= csym
&& is_external_proc (csym
)
3669 && gfc_sym_get_dummy_args (csym
) == NULL
;
3670 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3673 /* Resume assumed_size checking. */
3674 need_full_assumed_size
--;
3676 /* If external, check for usage. */
3677 if (csym
&& is_external_proc (csym
))
3678 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3681 if (c
->resolved_sym
== NULL
)
3683 c
->resolved_isym
= NULL
;
3684 switch (procedure_kind (csym
))
3687 t
= resolve_generic_s (c
);
3690 case PTYPE_SPECIFIC
:
3691 t
= resolve_specific_s (c
);
3695 t
= resolve_unknown_s (c
);
3699 gfc_internal_error ("resolve_subroutine(): bad function type");
3703 /* Some checks of elemental subroutine actual arguments. */
3704 if (!resolve_elemental_actual (NULL
, c
))
3708 update_current_proc_array_outer_dependency (csym
);
3710 /* Typebound procedure: Assume the worst. */
3711 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3717 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3718 op1->shape and op2->shape are non-NULL return true if their shapes
3719 match. If both op1->shape and op2->shape are non-NULL return false
3720 if their shapes do not match. If either op1->shape or op2->shape is
3721 NULL, return true. */
3724 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3731 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3733 for (i
= 0; i
< op1
->rank
; i
++)
3735 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3737 gfc_error ("Shapes for operands at %L and %L are not conformable",
3738 &op1
->where
, &op2
->where
);
3748 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3749 For example A .AND. B becomes IAND(A, B). */
3751 logical_to_bitwise (gfc_expr
*e
)
3753 gfc_expr
*tmp
, *op1
, *op2
;
3755 gfc_actual_arglist
*args
= NULL
;
3757 gcc_assert (e
->expr_type
== EXPR_OP
);
3759 isym
= GFC_ISYM_NONE
;
3760 op1
= e
->value
.op
.op1
;
3761 op2
= e
->value
.op
.op2
;
3763 switch (e
->value
.op
.op
)
3766 isym
= GFC_ISYM_NOT
;
3769 isym
= GFC_ISYM_IAND
;
3772 isym
= GFC_ISYM_IOR
;
3774 case INTRINSIC_NEQV
:
3775 isym
= GFC_ISYM_IEOR
;
3778 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3779 Change the old expression to NEQV, which will get replaced by IEOR,
3780 and wrap it in NOT. */
3781 tmp
= gfc_copy_expr (e
);
3782 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3783 tmp
= logical_to_bitwise (tmp
);
3784 isym
= GFC_ISYM_NOT
;
3789 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3792 /* Inherit the original operation's operands as arguments. */
3793 args
= gfc_get_actual_arglist ();
3797 args
->next
= gfc_get_actual_arglist ();
3798 args
->next
->expr
= op2
;
3801 /* Convert the expression to a function call. */
3802 e
->expr_type
= EXPR_FUNCTION
;
3803 e
->value
.function
.actual
= args
;
3804 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3805 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3806 e
->value
.function
.esym
= NULL
;
3808 /* Make up a pre-resolved function call symtree if we need to. */
3809 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3812 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3813 sym
= e
->symtree
->n
.sym
;
3815 sym
->attr
.flavor
= FL_PROCEDURE
;
3816 sym
->attr
.function
= 1;
3817 sym
->attr
.elemental
= 1;
3819 sym
->attr
.referenced
= 1;
3820 gfc_intrinsic_symbol (sym
);
3821 gfc_commit_symbol (sym
);
3824 args
->name
= e
->value
.function
.isym
->formal
->name
;
3825 if (e
->value
.function
.isym
->formal
->next
)
3826 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3831 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3832 candidates in CANDIDATES_LEN. */
3834 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3836 size_t &candidates_len
)
3843 /* Not sure how to properly filter here. Use all for a start.
3844 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3845 these as i suppose they don't make terribly sense. */
3847 if (uop
->n
.uop
->op
!= NULL
)
3848 vec_push (candidates
, candidates_len
, uop
->name
);
3852 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3856 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3859 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3862 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3864 char **candidates
= NULL
;
3865 size_t candidates_len
= 0;
3866 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3867 return gfc_closest_fuzzy_match (op
, candidates
);
3871 /* Callback finding an impure function as an operand to an .and. or
3872 .or. expression. Remember the last function warned about to
3873 avoid double warnings when recursing. */
3876 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3881 static gfc_expr
*last
= NULL
;
3882 bool *found
= (bool *) data
;
3884 if (f
->expr_type
== EXPR_FUNCTION
)
3887 if (f
!= last
&& !gfc_pure_function (f
, &name
)
3888 && !gfc_implicit_pure_function (f
))
3891 gfc_warning (OPT_Wfunction_elimination
,
3892 "Impure function %qs at %L might not be evaluated",
3895 gfc_warning (OPT_Wfunction_elimination
,
3896 "Impure function at %L might not be evaluated",
3906 /* Resolve an operator expression node. This can involve replacing the
3907 operation with a user defined function call. */
3910 resolve_operator (gfc_expr
*e
)
3912 gfc_expr
*op1
, *op2
;
3914 bool dual_locus_error
;
3917 /* Resolve all subnodes-- give them types. */
3919 switch (e
->value
.op
.op
)
3922 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3928 case INTRINSIC_UPLUS
:
3929 case INTRINSIC_UMINUS
:
3930 case INTRINSIC_PARENTHESES
:
3931 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3934 && e
->value
.op
.op1
->ts
.type
== BT_BOZ
&& !e
->value
.op
.op2
)
3936 gfc_error ("BOZ literal constant at %L cannot be an operand of "
3937 "unary operator %qs", &e
->value
.op
.op1
->where
,
3938 gfc_op2string (e
->value
.op
.op
));
3944 /* Typecheck the new node. */
3946 op1
= e
->value
.op
.op1
;
3947 op2
= e
->value
.op
.op2
;
3948 dual_locus_error
= false;
3950 /* op1 and op2 cannot both be BOZ. */
3951 if (op1
&& op1
->ts
.type
== BT_BOZ
3952 && op2
&& op2
->ts
.type
== BT_BOZ
)
3954 gfc_error ("Operands at %L and %L cannot appear as operands of "
3955 "binary operator %qs", &op1
->where
, &op2
->where
,
3956 gfc_op2string (e
->value
.op
.op
));
3960 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3961 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3963 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3967 switch (e
->value
.op
.op
)
3969 case INTRINSIC_UPLUS
:
3970 case INTRINSIC_UMINUS
:
3971 if (op1
->ts
.type
== BT_INTEGER
3972 || op1
->ts
.type
== BT_REAL
3973 || op1
->ts
.type
== BT_COMPLEX
)
3979 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3980 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3983 case INTRINSIC_PLUS
:
3984 case INTRINSIC_MINUS
:
3985 case INTRINSIC_TIMES
:
3986 case INTRINSIC_DIVIDE
:
3987 case INTRINSIC_POWER
:
3988 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3990 gfc_type_convert_binary (e
, 1);
3994 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
3996 _("Unexpected derived-type entities in binary intrinsic "
3997 "numeric operator %%<%s%%> at %%L"),
3998 gfc_op2string (e
->value
.op
.op
));
4001 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
4002 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4003 gfc_typename (&op2
->ts
));
4006 case INTRINSIC_CONCAT
:
4007 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4008 && op1
->ts
.kind
== op2
->ts
.kind
)
4010 e
->ts
.type
= BT_CHARACTER
;
4011 e
->ts
.kind
= op1
->ts
.kind
;
4016 _("Operands of string concatenation operator at %%L are %s/%s"),
4017 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
4023 case INTRINSIC_NEQV
:
4024 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4026 e
->ts
.type
= BT_LOGICAL
;
4027 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4028 if (op1
->ts
.kind
< e
->ts
.kind
)
4029 gfc_convert_type (op1
, &e
->ts
, 2);
4030 else if (op2
->ts
.kind
< e
->ts
.kind
)
4031 gfc_convert_type (op2
, &e
->ts
, 2);
4033 if (flag_frontend_optimize
&&
4034 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4036 /* Warn about short-circuiting
4037 with impure function as second operand. */
4039 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4044 /* Logical ops on integers become bitwise ops with -fdec. */
4046 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4048 e
->ts
.type
= BT_INTEGER
;
4049 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4050 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4051 gfc_convert_type (op1
, &e
->ts
, 1);
4052 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4053 gfc_convert_type (op2
, &e
->ts
, 1);
4054 e
= logical_to_bitwise (e
);
4058 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4059 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4060 gfc_typename (&op2
->ts
));
4065 /* Logical ops on integers become bitwise ops with -fdec. */
4066 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4068 e
->ts
.type
= BT_INTEGER
;
4069 e
->ts
.kind
= op1
->ts
.kind
;
4070 e
= logical_to_bitwise (e
);
4074 if (op1
->ts
.type
== BT_LOGICAL
)
4076 e
->ts
.type
= BT_LOGICAL
;
4077 e
->ts
.kind
= op1
->ts
.kind
;
4081 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4082 gfc_typename (&op1
->ts
));
4086 case INTRINSIC_GT_OS
:
4088 case INTRINSIC_GE_OS
:
4090 case INTRINSIC_LT_OS
:
4092 case INTRINSIC_LE_OS
:
4093 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4095 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4102 case INTRINSIC_EQ_OS
:
4104 case INTRINSIC_NE_OS
:
4105 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4106 && op1
->ts
.kind
== op2
->ts
.kind
)
4108 e
->ts
.type
= BT_LOGICAL
;
4109 e
->ts
.kind
= gfc_default_logical_kind
;
4113 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4114 if (op1
->ts
.type
== BT_BOZ
)
4116 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4117 "an operand of a relational operator",
4121 if (op2
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op1
, op2
->ts
.kind
))
4124 if (op2
->ts
.type
== BT_REAL
&& !gfc_boz2real (op1
, op2
->ts
.kind
))
4128 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4129 if (op2
->ts
.type
== BT_BOZ
)
4131 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4132 "an operand of a relational operator",
4136 if (op1
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op2
, op1
->ts
.kind
))
4139 if (op1
->ts
.type
== BT_REAL
&& !gfc_boz2real (op2
, op1
->ts
.kind
))
4143 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4145 gfc_type_convert_binary (e
, 1);
4147 e
->ts
.type
= BT_LOGICAL
;
4148 e
->ts
.kind
= gfc_default_logical_kind
;
4150 if (warn_compare_reals
)
4152 gfc_intrinsic_op op
= e
->value
.op
.op
;
4154 /* Type conversion has made sure that the types of op1 and op2
4155 agree, so it is only necessary to check the first one. */
4156 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4157 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4158 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4162 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4163 msg
= "Equality comparison for %s at %L";
4165 msg
= "Inequality comparison for %s at %L";
4167 gfc_warning (OPT_Wcompare_reals
, msg
,
4168 gfc_typename (&op1
->ts
), &op1
->where
);
4175 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4177 _("Logicals at %%L must be compared with %s instead of %s"),
4178 (e
->value
.op
.op
== INTRINSIC_EQ
4179 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4180 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4183 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4184 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4185 gfc_typename (&op2
->ts
));
4189 case INTRINSIC_USER
:
4190 if (e
->value
.op
.uop
->op
== NULL
)
4192 const char *name
= e
->value
.op
.uop
->name
;
4193 const char *guessed
;
4194 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4196 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4199 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4201 else if (op2
== NULL
)
4202 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4203 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4206 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4207 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4208 gfc_typename (&op2
->ts
));
4209 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4214 case INTRINSIC_PARENTHESES
:
4216 if (e
->ts
.type
== BT_CHARACTER
)
4217 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4221 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4224 /* Deal with arrayness of an operand through an operator. */
4226 switch (e
->value
.op
.op
)
4228 case INTRINSIC_PLUS
:
4229 case INTRINSIC_MINUS
:
4230 case INTRINSIC_TIMES
:
4231 case INTRINSIC_DIVIDE
:
4232 case INTRINSIC_POWER
:
4233 case INTRINSIC_CONCAT
:
4237 case INTRINSIC_NEQV
:
4239 case INTRINSIC_EQ_OS
:
4241 case INTRINSIC_NE_OS
:
4243 case INTRINSIC_GT_OS
:
4245 case INTRINSIC_GE_OS
:
4247 case INTRINSIC_LT_OS
:
4249 case INTRINSIC_LE_OS
:
4251 if (op1
->rank
== 0 && op2
->rank
== 0)
4254 if (op1
->rank
== 0 && op2
->rank
!= 0)
4256 e
->rank
= op2
->rank
;
4258 if (e
->shape
== NULL
)
4259 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4262 if (op1
->rank
!= 0 && op2
->rank
== 0)
4264 e
->rank
= op1
->rank
;
4266 if (e
->shape
== NULL
)
4267 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4270 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4272 if (op1
->rank
== op2
->rank
)
4274 e
->rank
= op1
->rank
;
4275 if (e
->shape
== NULL
)
4277 t
= compare_shapes (op1
, op2
);
4281 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4286 /* Allow higher level expressions to work. */
4289 /* Try user-defined operators, and otherwise throw an error. */
4290 dual_locus_error
= true;
4292 _("Inconsistent ranks for operator at %%L and %%L"));
4299 case INTRINSIC_PARENTHESES
:
4301 case INTRINSIC_UPLUS
:
4302 case INTRINSIC_UMINUS
:
4303 /* Simply copy arrayness attribute */
4304 e
->rank
= op1
->rank
;
4306 if (e
->shape
== NULL
)
4307 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4317 /* Attempt to simplify the expression. */
4320 t
= gfc_simplify_expr (e
, 0);
4321 /* Some calls do not succeed in simplification and return false
4322 even though there is no error; e.g. variable references to
4323 PARAMETER arrays. */
4324 if (!gfc_is_constant_expr (e
))
4332 match m
= gfc_extend_expr (e
);
4335 if (m
== MATCH_ERROR
)
4339 if (dual_locus_error
)
4340 gfc_error (msg
, &op1
->where
, &op2
->where
);
4342 gfc_error (msg
, &e
->where
);
4348 /************** Array resolution subroutines **************/
4351 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4353 /* Compare two integer expressions. */
4355 static compare_result
4356 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4360 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4361 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4364 /* If either of the types isn't INTEGER, we must have
4365 raised an error earlier. */
4367 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4370 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4380 /* Compare an integer expression with an integer. */
4382 static compare_result
4383 compare_bound_int (gfc_expr
*a
, int b
)
4387 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4390 if (a
->ts
.type
!= BT_INTEGER
)
4391 gfc_internal_error ("compare_bound_int(): Bad expression");
4393 i
= mpz_cmp_si (a
->value
.integer
, b
);
4403 /* Compare an integer expression with a mpz_t. */
4405 static compare_result
4406 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4410 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4413 if (a
->ts
.type
!= BT_INTEGER
)
4414 gfc_internal_error ("compare_bound_int(): Bad expression");
4416 i
= mpz_cmp (a
->value
.integer
, b
);
4426 /* Compute the last value of a sequence given by a triplet.
4427 Return 0 if it wasn't able to compute the last value, or if the
4428 sequence if empty, and 1 otherwise. */
4431 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4432 gfc_expr
*stride
, mpz_t last
)
4436 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4437 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4438 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4441 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4442 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4445 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4447 if (compare_bound (start
, end
) == CMP_GT
)
4449 mpz_set (last
, end
->value
.integer
);
4453 if (compare_bound_int (stride
, 0) == CMP_GT
)
4455 /* Stride is positive */
4456 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4461 /* Stride is negative */
4462 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4467 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4468 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4469 mpz_sub (last
, end
->value
.integer
, rem
);
4476 /* Compare a single dimension of an array reference to the array
4480 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4484 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4486 gcc_assert (ar
->stride
[i
] == NULL
);
4487 /* This implies [*] as [*:] and [*:3] are not possible. */
4488 if (ar
->start
[i
] == NULL
)
4490 gcc_assert (ar
->end
[i
] == NULL
);
4495 /* Given start, end and stride values, calculate the minimum and
4496 maximum referenced indexes. */
4498 switch (ar
->dimen_type
[i
])
4501 case DIMEN_THIS_IMAGE
:
4506 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4509 gfc_warning (0, "Array reference at %L is out of bounds "
4510 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4511 mpz_get_si (ar
->start
[i
]->value
.integer
),
4512 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4514 gfc_warning (0, "Array reference at %L is out of bounds "
4515 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4516 mpz_get_si (ar
->start
[i
]->value
.integer
),
4517 mpz_get_si (as
->lower
[i
]->value
.integer
),
4521 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4524 gfc_warning (0, "Array reference at %L is out of bounds "
4525 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4526 mpz_get_si (ar
->start
[i
]->value
.integer
),
4527 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4529 gfc_warning (0, "Array reference at %L is out of bounds "
4530 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4531 mpz_get_si (ar
->start
[i
]->value
.integer
),
4532 mpz_get_si (as
->upper
[i
]->value
.integer
),
4541 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4542 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4544 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4546 /* Check for zero stride, which is not allowed. */
4547 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4549 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4553 /* if start == len || (stride > 0 && start < len)
4554 || (stride < 0 && start > len),
4555 then the array section contains at least one element. In this
4556 case, there is an out-of-bounds access if
4557 (start < lower || start > upper). */
4558 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4559 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4560 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4561 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4562 && comp_start_end
== CMP_GT
))
4564 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4566 gfc_warning (0, "Lower array reference at %L is out of bounds "
4567 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4568 mpz_get_si (AR_START
->value
.integer
),
4569 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4572 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4574 gfc_warning (0, "Lower array reference at %L is out of bounds "
4575 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4576 mpz_get_si (AR_START
->value
.integer
),
4577 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4582 /* If we can compute the highest index of the array section,
4583 then it also has to be between lower and upper. */
4584 mpz_init (last_value
);
4585 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4588 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4590 gfc_warning (0, "Upper array reference at %L is out of bounds "
4591 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4592 mpz_get_si (last_value
),
4593 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4594 mpz_clear (last_value
);
4597 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4599 gfc_warning (0, "Upper array reference at %L is out of bounds "
4600 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4601 mpz_get_si (last_value
),
4602 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4603 mpz_clear (last_value
);
4607 mpz_clear (last_value
);
4615 gfc_internal_error ("check_dimension(): Bad array reference");
4622 /* Compare an array reference with an array specification. */
4625 compare_spec_to_ref (gfc_array_ref
*ar
)
4632 /* TODO: Full array sections are only allowed as actual parameters. */
4633 if (as
->type
== AS_ASSUMED_SIZE
4634 && (/*ar->type == AR_FULL
4635 ||*/ (ar
->type
== AR_SECTION
4636 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4638 gfc_error ("Rightmost upper bound of assumed size array section "
4639 "not specified at %L", &ar
->where
);
4643 if (ar
->type
== AR_FULL
)
4646 if (as
->rank
!= ar
->dimen
)
4648 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4649 &ar
->where
, ar
->dimen
, as
->rank
);
4653 /* ar->codimen == 0 is a local array. */
4654 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4656 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4657 &ar
->where
, ar
->codimen
, as
->corank
);
4661 for (i
= 0; i
< as
->rank
; i
++)
4662 if (!check_dimension (i
, ar
, as
))
4665 /* Local access has no coarray spec. */
4666 if (ar
->codimen
!= 0)
4667 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4669 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4670 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4672 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4673 i
+ 1 - as
->rank
, &ar
->where
);
4676 if (!check_dimension (i
, ar
, as
))
4684 /* Resolve one part of an array index. */
4687 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4688 int force_index_integer_kind
)
4695 if (!gfc_resolve_expr (index
))
4698 if (check_scalar
&& index
->rank
!= 0)
4700 gfc_error ("Array index at %L must be scalar", &index
->where
);
4704 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4706 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4707 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4711 if (index
->ts
.type
== BT_REAL
)
4712 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4716 if ((index
->ts
.kind
!= gfc_index_integer_kind
4717 && force_index_integer_kind
)
4718 || index
->ts
.type
!= BT_INTEGER
)
4721 ts
.type
= BT_INTEGER
;
4722 ts
.kind
= gfc_index_integer_kind
;
4724 gfc_convert_type_warn (index
, &ts
, 2, 0);
4730 /* Resolve one part of an array index. */
4733 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4735 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4738 /* Resolve a dim argument to an intrinsic function. */
4741 gfc_resolve_dim_arg (gfc_expr
*dim
)
4746 if (!gfc_resolve_expr (dim
))
4751 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4756 if (dim
->ts
.type
!= BT_INTEGER
)
4758 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4762 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4767 ts
.type
= BT_INTEGER
;
4768 ts
.kind
= gfc_index_integer_kind
;
4770 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4776 /* Given an expression that contains array references, update those array
4777 references to point to the right array specifications. While this is
4778 filled in during matching, this information is difficult to save and load
4779 in a module, so we take care of it here.
4781 The idea here is that the original array reference comes from the
4782 base symbol. We traverse the list of reference structures, setting
4783 the stored reference to references. Component references can
4784 provide an additional array specification. */
4787 find_array_spec (gfc_expr
*e
)
4792 bool class_as
= false;
4794 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4796 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4800 as
= e
->symtree
->n
.sym
->as
;
4802 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4807 gfc_internal_error ("find_array_spec(): Missing spec");
4814 c
= ref
->u
.c
.component
;
4815 if (c
->attr
.dimension
)
4817 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
4818 gfc_internal_error ("find_array_spec(): unused as(1)");
4830 gfc_internal_error ("find_array_spec(): unused as(2)");
4834 /* Resolve an array reference. */
4837 resolve_array_ref (gfc_array_ref
*ar
)
4839 int i
, check_scalar
;
4842 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4844 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4846 /* Do not force gfc_index_integer_kind for the start. We can
4847 do fine with any integer kind. This avoids temporary arrays
4848 created for indexing with a vector. */
4849 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4851 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4853 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4858 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4862 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4866 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4867 if (e
->expr_type
== EXPR_VARIABLE
4868 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4869 ar
->start
[i
] = gfc_get_parentheses (e
);
4873 gfc_error ("Array index at %L is an array of rank %d",
4874 &ar
->c_where
[i
], e
->rank
);
4878 /* Fill in the upper bound, which may be lower than the
4879 specified one for something like a(2:10:5), which is
4880 identical to a(2:7:5). Only relevant for strides not equal
4881 to one. Don't try a division by zero. */
4882 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4883 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4884 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4885 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4889 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4891 if (ar
->end
[i
] == NULL
)
4894 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4896 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4898 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4899 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4901 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4912 if (ar
->type
== AR_FULL
)
4914 if (ar
->as
->rank
== 0)
4915 ar
->type
= AR_ELEMENT
;
4917 /* Make sure array is the same as array(:,:), this way
4918 we don't need to special case all the time. */
4919 ar
->dimen
= ar
->as
->rank
;
4920 for (i
= 0; i
< ar
->dimen
; i
++)
4922 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4924 gcc_assert (ar
->start
[i
] == NULL
);
4925 gcc_assert (ar
->end
[i
] == NULL
);
4926 gcc_assert (ar
->stride
[i
] == NULL
);
4930 /* If the reference type is unknown, figure out what kind it is. */
4932 if (ar
->type
== AR_UNKNOWN
)
4934 ar
->type
= AR_ELEMENT
;
4935 for (i
= 0; i
< ar
->dimen
; i
++)
4936 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4937 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4939 ar
->type
= AR_SECTION
;
4944 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4947 if (ar
->as
->corank
&& ar
->codimen
== 0)
4950 ar
->codimen
= ar
->as
->corank
;
4951 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4952 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4960 resolve_substring (gfc_ref
*ref
, bool *equal_length
)
4962 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4964 if (ref
->u
.ss
.start
!= NULL
)
4966 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4969 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4971 gfc_error ("Substring start index at %L must be of type INTEGER",
4972 &ref
->u
.ss
.start
->where
);
4976 if (ref
->u
.ss
.start
->rank
!= 0)
4978 gfc_error ("Substring start index at %L must be scalar",
4979 &ref
->u
.ss
.start
->where
);
4983 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4984 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4985 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4987 gfc_error ("Substring start index at %L is less than one",
4988 &ref
->u
.ss
.start
->where
);
4993 if (ref
->u
.ss
.end
!= NULL
)
4995 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4998 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
5000 gfc_error ("Substring end index at %L must be of type INTEGER",
5001 &ref
->u
.ss
.end
->where
);
5005 if (ref
->u
.ss
.end
->rank
!= 0)
5007 gfc_error ("Substring end index at %L must be scalar",
5008 &ref
->u
.ss
.end
->where
);
5012 if (ref
->u
.ss
.length
!= NULL
5013 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
5014 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5015 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5017 gfc_error ("Substring end index at %L exceeds the string length",
5018 &ref
->u
.ss
.start
->where
);
5022 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
5023 gfc_integer_kinds
[k
].huge
) == CMP_GT
5024 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5025 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5027 gfc_error ("Substring end index at %L is too large",
5028 &ref
->u
.ss
.end
->where
);
5031 /* If the substring has the same length as the original
5032 variable, the reference itself can be deleted. */
5034 if (ref
->u
.ss
.length
!= NULL
5035 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
5036 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
5037 *equal_length
= true;
5044 /* This function supplies missing substring charlens. */
5047 gfc_resolve_substring_charlen (gfc_expr
*e
)
5050 gfc_expr
*start
, *end
;
5051 gfc_typespec
*ts
= NULL
;
5054 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5056 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5058 if (char_ref
->type
== REF_COMPONENT
)
5059 ts
= &char_ref
->u
.c
.component
->ts
;
5062 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5065 gcc_assert (char_ref
->next
== NULL
);
5069 if (e
->ts
.u
.cl
->length
)
5070 gfc_free_expr (e
->ts
.u
.cl
->length
);
5071 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5075 e
->ts
.type
= BT_CHARACTER
;
5076 e
->ts
.kind
= gfc_default_character_kind
;
5079 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5081 if (char_ref
->u
.ss
.start
)
5082 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5084 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5086 if (char_ref
->u
.ss
.end
)
5087 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5088 else if (e
->expr_type
== EXPR_VARIABLE
)
5091 ts
= &e
->symtree
->n
.sym
->ts
;
5092 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5099 gfc_free_expr (start
);
5100 gfc_free_expr (end
);
5104 /* Length = (end - start + 1).
5105 Check first whether it has a constant length. */
5106 if (gfc_dep_difference (end
, start
, &diff
))
5108 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5111 mpz_add_ui (len
->value
.integer
, diff
, 1);
5113 e
->ts
.u
.cl
->length
= len
;
5114 /* The check for length < 0 is handled below */
5118 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5119 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5120 gfc_get_int_expr (gfc_charlen_int_kind
,
5124 /* F2008, 6.4.1: Both the starting point and the ending point shall
5125 be within the range 1, 2, ..., n unless the starting point exceeds
5126 the ending point, in which case the substring has length zero. */
5128 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5129 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5131 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5132 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5134 /* Make sure that the length is simplified. */
5135 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5136 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5140 /* Resolve subtype references. */
5143 resolve_ref (gfc_expr
*expr
)
5145 int current_part_dimension
, n_components
, seen_part_dimension
;
5146 gfc_ref
*ref
, **prev
;
5149 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5150 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5152 find_array_spec (expr
);
5156 for (prev
= &expr
->ref
; *prev
!= NULL
;
5157 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5158 switch ((*prev
)->type
)
5161 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5170 equal_length
= false;
5171 if (!resolve_substring (*prev
, &equal_length
))
5174 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5176 /* Remove the reference and move the charlen, if any. */
5180 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5181 ref
->u
.ss
.length
= NULL
;
5182 gfc_free_ref_list (ref
);
5187 /* Check constraints on part references. */
5189 current_part_dimension
= 0;
5190 seen_part_dimension
= 0;
5193 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5198 switch (ref
->u
.ar
.type
)
5201 /* Coarray scalar. */
5202 if (ref
->u
.ar
.as
->rank
== 0)
5204 current_part_dimension
= 0;
5209 current_part_dimension
= 1;
5213 current_part_dimension
= 0;
5217 gfc_internal_error ("resolve_ref(): Bad array reference");
5223 if (current_part_dimension
|| seen_part_dimension
)
5226 if (ref
->u
.c
.component
->attr
.pointer
5227 || ref
->u
.c
.component
->attr
.proc_pointer
5228 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5229 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5231 gfc_error ("Component to the right of a part reference "
5232 "with nonzero rank must not have the POINTER "
5233 "attribute at %L", &expr
->where
);
5236 else if (ref
->u
.c
.component
->attr
.allocatable
5237 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5238 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5241 gfc_error ("Component to the right of a part reference "
5242 "with nonzero rank must not have the ALLOCATABLE "
5243 "attribute at %L", &expr
->where
);
5256 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5257 || ref
->next
== NULL
)
5258 && current_part_dimension
5259 && seen_part_dimension
)
5261 gfc_error ("Two or more part references with nonzero rank must "
5262 "not be specified at %L", &expr
->where
);
5266 if (ref
->type
== REF_COMPONENT
)
5268 if (current_part_dimension
)
5269 seen_part_dimension
= 1;
5271 /* reset to make sure */
5272 current_part_dimension
= 0;
5280 /* Given an expression, determine its shape. This is easier than it sounds.
5281 Leaves the shape array NULL if it is not possible to determine the shape. */
5284 expression_shape (gfc_expr
*e
)
5286 mpz_t array
[GFC_MAX_DIMENSIONS
];
5289 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5292 for (i
= 0; i
< e
->rank
; i
++)
5293 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5296 e
->shape
= gfc_get_shape (e
->rank
);
5298 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5303 for (i
--; i
>= 0; i
--)
5304 mpz_clear (array
[i
]);
5308 /* Given a variable expression node, compute the rank of the expression by
5309 examining the base symbol and any reference structures it may have. */
5312 expression_rank (gfc_expr
*e
)
5317 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5318 could lead to serious confusion... */
5319 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5323 if (e
->expr_type
== EXPR_ARRAY
)
5325 /* Constructors can have a rank different from one via RESHAPE(). */
5327 if (e
->symtree
== NULL
)
5333 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5334 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5340 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5342 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5343 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5344 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5346 if (ref
->type
!= REF_ARRAY
)
5349 if (ref
->u
.ar
.type
== AR_FULL
)
5351 rank
= ref
->u
.ar
.as
->rank
;
5355 if (ref
->u
.ar
.type
== AR_SECTION
)
5357 /* Figure out the rank of the section. */
5359 gfc_internal_error ("expression_rank(): Two array specs");
5361 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5362 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5363 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5373 expression_shape (e
);
5378 add_caf_get_intrinsic (gfc_expr
*e
)
5380 gfc_expr
*wrapper
, *tmp_expr
;
5384 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5385 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5390 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5391 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5394 tmp_expr
= XCNEW (gfc_expr
);
5396 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5397 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5398 wrapper
->ts
= e
->ts
;
5399 wrapper
->rank
= e
->rank
;
5401 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5408 remove_caf_get_intrinsic (gfc_expr
*e
)
5410 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5411 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5412 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5413 e
->value
.function
.actual
->expr
= NULL
;
5414 gfc_free_actual_arglist (e
->value
.function
.actual
);
5415 gfc_free_shape (&e
->shape
, e
->rank
);
5421 /* Resolve a variable expression. */
5424 resolve_variable (gfc_expr
*e
)
5431 if (e
->symtree
== NULL
)
5433 sym
= e
->symtree
->n
.sym
;
5435 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5436 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5437 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5439 if (!actual_arg
|| inquiry_argument
)
5441 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5442 "be used as actual argument", sym
->name
, &e
->where
);
5446 /* TS 29113, 407b. */
5447 else if (e
->ts
.type
== BT_ASSUMED
)
5451 gfc_error ("Assumed-type variable %s at %L may only be used "
5452 "as actual argument", sym
->name
, &e
->where
);
5455 else if (inquiry_argument
&& !first_actual_arg
)
5457 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5458 for all inquiry functions in resolve_function; the reason is
5459 that the function-name resolution happens too late in that
5461 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5462 "an inquiry function shall be the first argument",
5463 sym
->name
, &e
->where
);
5467 /* TS 29113, C535b. */
5468 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5469 && CLASS_DATA (sym
)->as
5470 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5471 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5472 && sym
->as
->type
== AS_ASSUMED_RANK
))
5476 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5477 "actual argument", sym
->name
, &e
->where
);
5480 else if (inquiry_argument
&& !first_actual_arg
)
5482 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5483 for all inquiry functions in resolve_function; the reason is
5484 that the function-name resolution happens too late in that
5486 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5487 "to an inquiry function shall be the first argument",
5488 sym
->name
, &e
->where
);
5493 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5494 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5495 && e
->ref
->next
== NULL
))
5497 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5498 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5501 /* TS 29113, 407b. */
5502 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5503 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5504 && e
->ref
->next
== NULL
))
5506 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5507 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5511 /* TS 29113, C535b. */
5512 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5513 && CLASS_DATA (sym
)->as
5514 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5515 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5516 && sym
->as
->type
== AS_ASSUMED_RANK
))
5518 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5519 && e
->ref
->next
== NULL
))
5521 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5522 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5526 /* For variables that are used in an associate (target => object) where
5527 the object's basetype is array valued while the target is scalar,
5528 the ts' type of the component refs is still array valued, which
5529 can't be translated that way. */
5530 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5531 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5532 && CLASS_DATA (sym
->assoc
->target
)->as
)
5534 gfc_ref
*ref
= e
->ref
;
5540 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5541 /* Stop the loop. */
5551 /* If this is an associate-name, it may be parsed with an array reference
5552 in error even though the target is scalar. Fail directly in this case.
5553 TODO Understand why class scalar expressions must be excluded. */
5554 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5556 if (sym
->ts
.type
== BT_CLASS
)
5557 gfc_fix_class_refs (e
);
5558 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5560 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5562 /* This can happen because the parser did not detect that the
5563 associate name is an array and the expression had no array
5565 gfc_ref
*ref
= gfc_get_ref ();
5566 ref
->type
= REF_ARRAY
;
5567 ref
->u
.ar
= *gfc_get_array_ref();
5568 ref
->u
.ar
.type
= AR_FULL
;
5571 ref
->u
.ar
.as
= sym
->as
;
5572 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5580 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5581 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5583 /* On the other hand, the parser may not have known this is an array;
5584 in this case, we have to add a FULL reference. */
5585 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5587 e
->ref
= gfc_get_ref ();
5588 e
->ref
->type
= REF_ARRAY
;
5589 e
->ref
->u
.ar
.type
= AR_FULL
;
5590 e
->ref
->u
.ar
.dimen
= 0;
5593 /* Like above, but for class types, where the checking whether an array
5594 ref is present is more complicated. Furthermore make sure not to add
5595 the full array ref to _vptr or _len refs. */
5596 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5597 && CLASS_DATA (sym
)->attr
.dimension
5598 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5600 gfc_ref
*ref
, *newref
;
5602 newref
= gfc_get_ref ();
5603 newref
->type
= REF_ARRAY
;
5604 newref
->u
.ar
.type
= AR_FULL
;
5605 newref
->u
.ar
.dimen
= 0;
5606 /* Because this is an associate var and the first ref either is a ref to
5607 the _data component or not, no traversal of the ref chain is
5608 needed. The array ref needs to be inserted after the _data ref,
5609 or when that is not present, which may happend for polymorphic
5610 types, then at the first position. */
5614 else if (ref
->type
== REF_COMPONENT
5615 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5617 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5619 newref
->next
= ref
->next
;
5623 /* Array ref present already. */
5624 gfc_free_ref_list (newref
);
5626 else if (ref
->type
== REF_ARRAY
)
5627 /* Array ref present already. */
5628 gfc_free_ref_list (newref
);
5636 if (e
->ref
&& !resolve_ref (e
))
5639 if (sym
->attr
.flavor
== FL_PROCEDURE
5640 && (!sym
->attr
.function
5641 || (sym
->attr
.function
&& sym
->result
5642 && sym
->result
->attr
.proc_pointer
5643 && !sym
->result
->attr
.function
)))
5645 e
->ts
.type
= BT_PROCEDURE
;
5646 goto resolve_procedure
;
5649 if (sym
->ts
.type
!= BT_UNKNOWN
)
5650 gfc_variable_attr (e
, &e
->ts
);
5651 else if (sym
->attr
.flavor
== FL_PROCEDURE
5652 && sym
->attr
.function
&& sym
->result
5653 && sym
->result
->ts
.type
!= BT_UNKNOWN
5654 && sym
->result
->attr
.proc_pointer
)
5655 e
->ts
= sym
->result
->ts
;
5658 /* Must be a simple variable reference. */
5659 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5664 if (check_assumed_size_reference (sym
, e
))
5667 /* Deal with forward references to entries during gfc_resolve_code, to
5668 satisfy, at least partially, 12.5.2.5. */
5669 if (gfc_current_ns
->entries
5670 && current_entry_id
== sym
->entry_id
5673 && cs_base
->current
->op
!= EXEC_ENTRY
)
5675 gfc_entry_list
*entry
;
5676 gfc_formal_arglist
*formal
;
5678 bool seen
, saved_specification_expr
;
5680 /* If the symbol is a dummy... */
5681 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5683 entry
= gfc_current_ns
->entries
;
5686 /* ...test if the symbol is a parameter of previous entries. */
5687 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5688 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5690 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5697 /* If it has not been seen as a dummy, this is an error. */
5700 if (specification_expr
)
5701 gfc_error ("Variable %qs, used in a specification expression"
5702 ", is referenced at %L before the ENTRY statement "
5703 "in which it is a parameter",
5704 sym
->name
, &cs_base
->current
->loc
);
5706 gfc_error ("Variable %qs is used at %L before the ENTRY "
5707 "statement in which it is a parameter",
5708 sym
->name
, &cs_base
->current
->loc
);
5713 /* Now do the same check on the specification expressions. */
5714 saved_specification_expr
= specification_expr
;
5715 specification_expr
= true;
5716 if (sym
->ts
.type
== BT_CHARACTER
5717 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5721 for (n
= 0; n
< sym
->as
->rank
; n
++)
5723 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5725 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5728 specification_expr
= saved_specification_expr
;
5731 /* Update the symbol's entry level. */
5732 sym
->entry_id
= current_entry_id
+ 1;
5735 /* If a symbol has been host_associated mark it. This is used latter,
5736 to identify if aliasing is possible via host association. */
5737 if (sym
->attr
.flavor
== FL_VARIABLE
5738 && gfc_current_ns
->parent
5739 && (gfc_current_ns
->parent
== sym
->ns
5740 || (gfc_current_ns
->parent
->parent
5741 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5742 sym
->attr
.host_assoc
= 1;
5744 if (gfc_current_ns
->proc_name
5745 && sym
->attr
.dimension
5746 && (sym
->ns
!= gfc_current_ns
5747 || sym
->attr
.use_assoc
5748 || sym
->attr
.in_common
))
5749 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5752 if (t
&& !resolve_procedure_expression (e
))
5755 /* F2008, C617 and C1229. */
5756 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5757 && gfc_is_coindexed (e
))
5759 gfc_ref
*ref
, *ref2
= NULL
;
5761 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5763 if (ref
->type
== REF_COMPONENT
)
5765 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5769 for ( ; ref
; ref
= ref
->next
)
5770 if (ref
->type
== REF_COMPONENT
)
5773 /* Expression itself is not coindexed object. */
5774 if (ref
&& e
->ts
.type
== BT_CLASS
)
5776 gfc_error ("Polymorphic subobject of coindexed object at %L",
5781 /* Expression itself is coindexed object. */
5785 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5786 for ( ; c
; c
= c
->next
)
5787 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5789 gfc_error ("Coindexed object with polymorphic allocatable "
5790 "subcomponent at %L", &e
->where
);
5798 expression_rank (e
);
5800 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5801 add_caf_get_intrinsic (e
);
5803 /* Simplify cases where access to a parameter array results in a
5804 single constant. Suppress errors since those will have been
5805 issued before, as warnings. */
5806 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5808 gfc_push_suppress_errors ();
5809 gfc_simplify_expr (e
, 1);
5810 gfc_pop_suppress_errors ();
5817 /* Checks to see that the correct symbol has been host associated.
5818 The only situation where this arises is that in which a twice
5819 contained function is parsed after the host association is made.
5820 Therefore, on detecting this, change the symbol in the expression
5821 and convert the array reference into an actual arglist if the old
5822 symbol is a variable. */
5824 check_host_association (gfc_expr
*e
)
5826 gfc_symbol
*sym
, *old_sym
;
5830 gfc_actual_arglist
*arg
, *tail
= NULL
;
5831 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5833 /* If the expression is the result of substitution in
5834 interface.c(gfc_extend_expr) because there is no way in
5835 which the host association can be wrong. */
5836 if (e
->symtree
== NULL
5837 || e
->symtree
->n
.sym
== NULL
5838 || e
->user_operator
)
5841 old_sym
= e
->symtree
->n
.sym
;
5843 if (gfc_current_ns
->parent
5844 && old_sym
->ns
!= gfc_current_ns
)
5846 /* Use the 'USE' name so that renamed module symbols are
5847 correctly handled. */
5848 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5850 if (sym
&& old_sym
!= sym
5851 && sym
->ts
.type
== old_sym
->ts
.type
5852 && sym
->attr
.flavor
== FL_PROCEDURE
5853 && sym
->attr
.contained
)
5855 /* Clear the shape, since it might not be valid. */
5856 gfc_free_shape (&e
->shape
, e
->rank
);
5858 /* Give the expression the right symtree! */
5859 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5860 gcc_assert (st
!= NULL
);
5862 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5863 || e
->expr_type
== EXPR_FUNCTION
)
5865 /* Original was function so point to the new symbol, since
5866 the actual argument list is already attached to the
5868 e
->value
.function
.esym
= NULL
;
5873 /* Original was variable so convert array references into
5874 an actual arglist. This does not need any checking now
5875 since resolve_function will take care of it. */
5876 e
->value
.function
.actual
= NULL
;
5877 e
->expr_type
= EXPR_FUNCTION
;
5880 /* Ambiguity will not arise if the array reference is not
5881 the last reference. */
5882 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5883 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5886 gcc_assert (ref
->type
== REF_ARRAY
);
5888 /* Grab the start expressions from the array ref and
5889 copy them into actual arguments. */
5890 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5892 arg
= gfc_get_actual_arglist ();
5893 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5894 if (e
->value
.function
.actual
== NULL
)
5895 tail
= e
->value
.function
.actual
= arg
;
5903 /* Dump the reference list and set the rank. */
5904 gfc_free_ref_list (e
->ref
);
5906 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5909 gfc_resolve_expr (e
);
5913 /* This might have changed! */
5914 return e
->expr_type
== EXPR_FUNCTION
;
5919 gfc_resolve_character_operator (gfc_expr
*e
)
5921 gfc_expr
*op1
= e
->value
.op
.op1
;
5922 gfc_expr
*op2
= e
->value
.op
.op2
;
5923 gfc_expr
*e1
= NULL
;
5924 gfc_expr
*e2
= NULL
;
5926 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5928 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5929 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5930 else if (op1
->expr_type
== EXPR_CONSTANT
)
5931 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5932 op1
->value
.character
.length
);
5934 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5935 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5936 else if (op2
->expr_type
== EXPR_CONSTANT
)
5937 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5938 op2
->value
.character
.length
);
5940 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5950 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5951 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5952 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5953 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5954 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5960 /* Ensure that an character expression has a charlen and, if possible, a
5961 length expression. */
5964 fixup_charlen (gfc_expr
*e
)
5966 /* The cases fall through so that changes in expression type and the need
5967 for multiple fixes are picked up. In all circumstances, a charlen should
5968 be available for the middle end to hang a backend_decl on. */
5969 switch (e
->expr_type
)
5972 gfc_resolve_character_operator (e
);
5976 if (e
->expr_type
== EXPR_ARRAY
)
5977 gfc_resolve_character_array_constructor (e
);
5980 case EXPR_SUBSTRING
:
5981 if (!e
->ts
.u
.cl
&& e
->ref
)
5982 gfc_resolve_substring_charlen (e
);
5987 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5994 /* Update an actual argument to include the passed-object for type-bound
5995 procedures at the right position. */
5997 static gfc_actual_arglist
*
5998 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
6001 gcc_assert (argpos
> 0);
6005 gfc_actual_arglist
* result
;
6007 result
= gfc_get_actual_arglist ();
6011 result
->name
= name
;
6017 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
6019 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
6024 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6027 extract_compcall_passed_object (gfc_expr
* e
)
6031 if (e
->expr_type
== EXPR_UNKNOWN
)
6033 gfc_error ("Error in typebound call at %L",
6038 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6040 if (e
->value
.compcall
.base_object
)
6041 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
6044 po
= gfc_get_expr ();
6045 po
->expr_type
= EXPR_VARIABLE
;
6046 po
->symtree
= e
->symtree
;
6047 po
->ref
= gfc_copy_ref (e
->ref
);
6048 po
->where
= e
->where
;
6051 if (!gfc_resolve_expr (po
))
6058 /* Update the arglist of an EXPR_COMPCALL expression to include the
6062 update_compcall_arglist (gfc_expr
* e
)
6065 gfc_typebound_proc
* tbp
;
6067 tbp
= e
->value
.compcall
.tbp
;
6072 po
= extract_compcall_passed_object (e
);
6076 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6082 if (tbp
->pass_arg_num
<= 0)
6085 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6093 /* Extract the passed object from a PPC call (a copy of it). */
6096 extract_ppc_passed_object (gfc_expr
*e
)
6101 po
= gfc_get_expr ();
6102 po
->expr_type
= EXPR_VARIABLE
;
6103 po
->symtree
= e
->symtree
;
6104 po
->ref
= gfc_copy_ref (e
->ref
);
6105 po
->where
= e
->where
;
6107 /* Remove PPC reference. */
6109 while ((*ref
)->next
)
6110 ref
= &(*ref
)->next
;
6111 gfc_free_ref_list (*ref
);
6114 if (!gfc_resolve_expr (po
))
6121 /* Update the actual arglist of a procedure pointer component to include the
6125 update_ppc_arglist (gfc_expr
* e
)
6129 gfc_typebound_proc
* tb
;
6131 ppc
= gfc_get_proc_ptr_comp (e
);
6139 else if (tb
->nopass
)
6142 po
= extract_ppc_passed_object (e
);
6149 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6154 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6156 gfc_error ("Base object for procedure-pointer component call at %L is of"
6157 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6161 gcc_assert (tb
->pass_arg_num
> 0);
6162 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6170 /* Check that the object a TBP is called on is valid, i.e. it must not be
6171 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6174 check_typebound_baseobject (gfc_expr
* e
)
6177 bool return_value
= false;
6179 base
= extract_compcall_passed_object (e
);
6183 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6185 gfc_error ("Error in typebound call at %L", &e
->where
);
6189 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6193 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6195 gfc_error ("Base object for type-bound procedure call at %L is of"
6196 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6200 /* F08:C1230. If the procedure called is NOPASS,
6201 the base object must be scalar. */
6202 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6204 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6205 " be scalar", &e
->where
);
6209 return_value
= true;
6212 gfc_free_expr (base
);
6213 return return_value
;
6217 /* Resolve a call to a type-bound procedure, either function or subroutine,
6218 statically from the data in an EXPR_COMPCALL expression. The adapted
6219 arglist and the target-procedure symtree are returned. */
6222 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6223 gfc_actual_arglist
** actual
)
6225 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6226 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6228 /* Update the actual arglist for PASS. */
6229 if (!update_compcall_arglist (e
))
6232 *actual
= e
->value
.compcall
.actual
;
6233 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6235 gfc_free_ref_list (e
->ref
);
6237 e
->value
.compcall
.actual
= NULL
;
6239 /* If we find a deferred typebound procedure, check for derived types
6240 that an overriding typebound procedure has not been missed. */
6241 if (e
->value
.compcall
.name
6242 && !e
->value
.compcall
.tbp
->non_overridable
6243 && e
->value
.compcall
.base_object
6244 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6247 gfc_symbol
*derived
;
6249 /* Use the derived type of the base_object. */
6250 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6253 /* If necessary, go through the inheritance chain. */
6254 while (!st
&& derived
)
6256 /* Look for the typebound procedure 'name'. */
6257 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6258 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6259 e
->value
.compcall
.name
);
6261 derived
= gfc_get_derived_super_type (derived
);
6264 /* Now find the specific name in the derived type namespace. */
6265 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6266 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6267 derived
->ns
, 1, &st
);
6275 /* Get the ultimate declared type from an expression. In addition,
6276 return the last class/derived type reference and the copy of the
6277 reference list. If check_types is set true, derived types are
6278 identified as well as class references. */
6280 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6281 gfc_expr
*e
, bool check_types
)
6283 gfc_symbol
*declared
;
6290 *new_ref
= gfc_copy_ref (e
->ref
);
6292 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6294 if (ref
->type
!= REF_COMPONENT
)
6297 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6298 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6299 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6301 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6307 if (declared
== NULL
)
6308 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6314 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6315 which of the specific bindings (if any) matches the arglist and transform
6316 the expression into a call of that binding. */
6319 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6321 gfc_typebound_proc
* genproc
;
6322 const char* genname
;
6324 gfc_symbol
*derived
;
6326 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6327 genname
= e
->value
.compcall
.name
;
6328 genproc
= e
->value
.compcall
.tbp
;
6330 if (!genproc
->is_generic
)
6333 /* Try the bindings on this type and in the inheritance hierarchy. */
6334 for (; genproc
; genproc
= genproc
->overridden
)
6338 gcc_assert (genproc
->is_generic
);
6339 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6342 gfc_actual_arglist
* args
;
6345 gcc_assert (g
->specific
);
6347 if (g
->specific
->error
)
6350 target
= g
->specific
->u
.specific
->n
.sym
;
6352 /* Get the right arglist by handling PASS/NOPASS. */
6353 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6354 if (!g
->specific
->nopass
)
6357 po
= extract_compcall_passed_object (e
);
6360 gfc_free_actual_arglist (args
);
6364 gcc_assert (g
->specific
->pass_arg_num
> 0);
6365 gcc_assert (!g
->specific
->error
);
6366 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6367 g
->specific
->pass_arg
);
6369 resolve_actual_arglist (args
, target
->attr
.proc
,
6370 is_external_proc (target
)
6371 && gfc_sym_get_dummy_args (target
) == NULL
);
6373 /* Check if this arglist matches the formal. */
6374 matches
= gfc_arglist_matches_symbol (&args
, target
);
6376 /* Clean up and break out of the loop if we've found it. */
6377 gfc_free_actual_arglist (args
);
6380 e
->value
.compcall
.tbp
= g
->specific
;
6381 genname
= g
->specific_st
->name
;
6382 /* Pass along the name for CLASS methods, where the vtab
6383 procedure pointer component has to be referenced. */
6391 /* Nothing matching found! */
6392 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6393 " %qs at %L", genname
, &e
->where
);
6397 /* Make sure that we have the right specific instance for the name. */
6398 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6400 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6402 e
->value
.compcall
.tbp
= st
->n
.tb
;
6408 /* Resolve a call to a type-bound subroutine. */
6411 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6413 gfc_actual_arglist
* newactual
;
6414 gfc_symtree
* target
;
6416 /* Check that's really a SUBROUTINE. */
6417 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6419 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6420 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6421 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6422 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6423 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6426 gfc_error ("%qs at %L should be a SUBROUTINE",
6427 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6432 if (!check_typebound_baseobject (c
->expr1
))
6435 /* Pass along the name for CLASS methods, where the vtab
6436 procedure pointer component has to be referenced. */
6438 *name
= c
->expr1
->value
.compcall
.name
;
6440 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6443 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6445 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6447 /* Transform into an ordinary EXEC_CALL for now. */
6449 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6452 c
->ext
.actual
= newactual
;
6453 c
->symtree
= target
;
6454 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6456 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6458 gfc_free_expr (c
->expr1
);
6459 c
->expr1
= gfc_get_expr ();
6460 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6461 c
->expr1
->symtree
= target
;
6462 c
->expr1
->where
= c
->loc
;
6464 return resolve_call (c
);
6468 /* Resolve a component-call expression. */
6470 resolve_compcall (gfc_expr
* e
, const char **name
)
6472 gfc_actual_arglist
* newactual
;
6473 gfc_symtree
* target
;
6475 /* Check that's really a FUNCTION. */
6476 if (!e
->value
.compcall
.tbp
->function
)
6478 gfc_error ("%qs at %L should be a FUNCTION",
6479 e
->value
.compcall
.name
, &e
->where
);
6484 /* These must not be assign-calls! */
6485 gcc_assert (!e
->value
.compcall
.assign
);
6487 if (!check_typebound_baseobject (e
))
6490 /* Pass along the name for CLASS methods, where the vtab
6491 procedure pointer component has to be referenced. */
6493 *name
= e
->value
.compcall
.name
;
6495 if (!resolve_typebound_generic_call (e
, name
))
6497 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6499 /* Take the rank from the function's symbol. */
6500 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6501 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6503 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6504 arglist to the TBP's binding target. */
6506 if (!resolve_typebound_static (e
, &target
, &newactual
))
6509 e
->value
.function
.actual
= newactual
;
6510 e
->value
.function
.name
= NULL
;
6511 e
->value
.function
.esym
= target
->n
.sym
;
6512 e
->value
.function
.isym
= NULL
;
6513 e
->symtree
= target
;
6514 e
->ts
= target
->n
.sym
->ts
;
6515 e
->expr_type
= EXPR_FUNCTION
;
6517 /* Resolution is not necessary if this is a class subroutine; this
6518 function only has to identify the specific proc. Resolution of
6519 the call will be done next in resolve_typebound_call. */
6520 return gfc_resolve_expr (e
);
6524 static bool resolve_fl_derived (gfc_symbol
*sym
);
6527 /* Resolve a typebound function, or 'method'. First separate all
6528 the non-CLASS references by calling resolve_compcall directly. */
6531 resolve_typebound_function (gfc_expr
* e
)
6533 gfc_symbol
*declared
;
6545 /* Deal with typebound operators for CLASS objects. */
6546 expr
= e
->value
.compcall
.base_object
;
6547 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6548 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6550 /* If the base_object is not a variable, the corresponding actual
6551 argument expression must be stored in e->base_expression so
6552 that the corresponding tree temporary can be used as the base
6553 object in gfc_conv_procedure_call. */
6554 if (expr
->expr_type
!= EXPR_VARIABLE
)
6556 gfc_actual_arglist
*args
;
6558 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6560 if (expr
== args
->expr
)
6565 /* Since the typebound operators are generic, we have to ensure
6566 that any delays in resolution are corrected and that the vtab
6569 declared
= ts
.u
.derived
;
6570 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6571 if (c
->ts
.u
.derived
== NULL
)
6572 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6574 if (!resolve_compcall (e
, &name
))
6577 /* Use the generic name if it is there. */
6578 name
= name
? name
: e
->value
.function
.esym
->name
;
6579 e
->symtree
= expr
->symtree
;
6580 e
->ref
= gfc_copy_ref (expr
->ref
);
6581 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6583 /* Trim away the extraneous references that emerge from nested
6584 use of interface.c (extend_expr). */
6585 if (class_ref
&& class_ref
->next
)
6587 gfc_free_ref_list (class_ref
->next
);
6588 class_ref
->next
= NULL
;
6590 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6592 gfc_free_ref_list (e
->ref
);
6596 gfc_add_vptr_component (e
);
6597 gfc_add_component_ref (e
, name
);
6598 e
->value
.function
.esym
= NULL
;
6599 if (expr
->expr_type
!= EXPR_VARIABLE
)
6600 e
->base_expr
= expr
;
6605 return resolve_compcall (e
, NULL
);
6607 if (!resolve_ref (e
))
6610 /* Get the CLASS declared type. */
6611 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6613 if (!resolve_fl_derived (declared
))
6616 /* Weed out cases of the ultimate component being a derived type. */
6617 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6618 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6620 gfc_free_ref_list (new_ref
);
6621 return resolve_compcall (e
, NULL
);
6624 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6626 /* Treat the call as if it is a typebound procedure, in order to roll
6627 out the correct name for the specific function. */
6628 if (!resolve_compcall (e
, &name
))
6630 gfc_free_ref_list (new_ref
);
6637 /* Convert the expression to a procedure pointer component call. */
6638 e
->value
.function
.esym
= NULL
;
6644 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6645 gfc_add_vptr_component (e
);
6646 gfc_add_component_ref (e
, name
);
6648 /* Recover the typespec for the expression. This is really only
6649 necessary for generic procedures, where the additional call
6650 to gfc_add_component_ref seems to throw the collection of the
6651 correct typespec. */
6655 gfc_free_ref_list (new_ref
);
6660 /* Resolve a typebound subroutine, or 'method'. First separate all
6661 the non-CLASS references by calling resolve_typebound_call
6665 resolve_typebound_subroutine (gfc_code
*code
)
6667 gfc_symbol
*declared
;
6677 st
= code
->expr1
->symtree
;
6679 /* Deal with typebound operators for CLASS objects. */
6680 expr
= code
->expr1
->value
.compcall
.base_object
;
6681 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6682 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6684 /* If the base_object is not a variable, the corresponding actual
6685 argument expression must be stored in e->base_expression so
6686 that the corresponding tree temporary can be used as the base
6687 object in gfc_conv_procedure_call. */
6688 if (expr
->expr_type
!= EXPR_VARIABLE
)
6690 gfc_actual_arglist
*args
;
6692 args
= code
->expr1
->value
.function
.actual
;
6693 for (; args
; args
= args
->next
)
6694 if (expr
== args
->expr
)
6698 /* Since the typebound operators are generic, we have to ensure
6699 that any delays in resolution are corrected and that the vtab
6701 declared
= expr
->ts
.u
.derived
;
6702 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6703 if (c
->ts
.u
.derived
== NULL
)
6704 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6706 if (!resolve_typebound_call (code
, &name
, NULL
))
6709 /* Use the generic name if it is there. */
6710 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6711 code
->expr1
->symtree
= expr
->symtree
;
6712 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6714 /* Trim away the extraneous references that emerge from nested
6715 use of interface.c (extend_expr). */
6716 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6717 if (class_ref
&& class_ref
->next
)
6719 gfc_free_ref_list (class_ref
->next
);
6720 class_ref
->next
= NULL
;
6722 else if (code
->expr1
->ref
&& !class_ref
)
6724 gfc_free_ref_list (code
->expr1
->ref
);
6725 code
->expr1
->ref
= NULL
;
6728 /* Now use the procedure in the vtable. */
6729 gfc_add_vptr_component (code
->expr1
);
6730 gfc_add_component_ref (code
->expr1
, name
);
6731 code
->expr1
->value
.function
.esym
= NULL
;
6732 if (expr
->expr_type
!= EXPR_VARIABLE
)
6733 code
->expr1
->base_expr
= expr
;
6738 return resolve_typebound_call (code
, NULL
, NULL
);
6740 if (!resolve_ref (code
->expr1
))
6743 /* Get the CLASS declared type. */
6744 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6746 /* Weed out cases of the ultimate component being a derived type. */
6747 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6748 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6750 gfc_free_ref_list (new_ref
);
6751 return resolve_typebound_call (code
, NULL
, NULL
);
6754 if (!resolve_typebound_call (code
, &name
, &overridable
))
6756 gfc_free_ref_list (new_ref
);
6759 ts
= code
->expr1
->ts
;
6763 /* Convert the expression to a procedure pointer component call. */
6764 code
->expr1
->value
.function
.esym
= NULL
;
6765 code
->expr1
->symtree
= st
;
6768 code
->expr1
->ref
= new_ref
;
6770 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6771 gfc_add_vptr_component (code
->expr1
);
6772 gfc_add_component_ref (code
->expr1
, name
);
6774 /* Recover the typespec for the expression. This is really only
6775 necessary for generic procedures, where the additional call
6776 to gfc_add_component_ref seems to throw the collection of the
6777 correct typespec. */
6778 code
->expr1
->ts
= ts
;
6781 gfc_free_ref_list (new_ref
);
6787 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6790 resolve_ppc_call (gfc_code
* c
)
6792 gfc_component
*comp
;
6794 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6795 gcc_assert (comp
!= NULL
);
6797 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6798 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6800 if (!comp
->attr
.subroutine
)
6801 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6803 if (!resolve_ref (c
->expr1
))
6806 if (!update_ppc_arglist (c
->expr1
))
6809 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6811 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6812 !(comp
->ts
.interface
6813 && comp
->ts
.interface
->formal
)))
6816 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6819 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6825 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6828 resolve_expr_ppc (gfc_expr
* e
)
6830 gfc_component
*comp
;
6832 comp
= gfc_get_proc_ptr_comp (e
);
6833 gcc_assert (comp
!= NULL
);
6835 /* Convert to EXPR_FUNCTION. */
6836 e
->expr_type
= EXPR_FUNCTION
;
6837 e
->value
.function
.isym
= NULL
;
6838 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6840 if (comp
->as
!= NULL
)
6841 e
->rank
= comp
->as
->rank
;
6843 if (!comp
->attr
.function
)
6844 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6846 if (!resolve_ref (e
))
6849 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6850 !(comp
->ts
.interface
6851 && comp
->ts
.interface
->formal
)))
6854 if (!update_ppc_arglist (e
))
6857 if (!check_pure_function(e
))
6860 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6867 gfc_is_expandable_expr (gfc_expr
*e
)
6869 gfc_constructor
*con
;
6871 if (e
->expr_type
== EXPR_ARRAY
)
6873 /* Traverse the constructor looking for variables that are flavor
6874 parameter. Parameters must be expanded since they are fully used at
6876 con
= gfc_constructor_first (e
->value
.constructor
);
6877 for (; con
; con
= gfc_constructor_next (con
))
6879 if (con
->expr
->expr_type
== EXPR_VARIABLE
6880 && con
->expr
->symtree
6881 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6882 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6884 if (con
->expr
->expr_type
== EXPR_ARRAY
6885 && gfc_is_expandable_expr (con
->expr
))
6894 /* Sometimes variables in specification expressions of the result
6895 of module procedures in submodules wind up not being the 'real'
6896 dummy. Find this, if possible, in the namespace of the first
6900 fixup_unique_dummy (gfc_expr
*e
)
6902 gfc_symtree
*st
= NULL
;
6903 gfc_symbol
*s
= NULL
;
6905 if (e
->symtree
->n
.sym
->ns
->proc_name
6906 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6907 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6910 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6913 && st
->n
.sym
!= NULL
6914 && st
->n
.sym
->attr
.dummy
)
6918 /* Resolve an expression. That is, make sure that types of operands agree
6919 with their operators, intrinsic operators are converted to function calls
6920 for overloaded types and unresolved function references are resolved. */
6923 gfc_resolve_expr (gfc_expr
*e
)
6926 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6931 /* inquiry_argument only applies to variables. */
6932 inquiry_save
= inquiry_argument
;
6933 actual_arg_save
= actual_arg
;
6934 first_actual_arg_save
= first_actual_arg
;
6936 if (e
->expr_type
!= EXPR_VARIABLE
)
6938 inquiry_argument
= false;
6940 first_actual_arg
= false;
6942 else if (e
->symtree
!= NULL
6943 && *e
->symtree
->name
== '@'
6944 && e
->symtree
->n
.sym
->attr
.dummy
)
6946 /* Deal with submodule specification expressions that are not
6947 found to be referenced in module.c(read_cleanup). */
6948 fixup_unique_dummy (e
);
6951 switch (e
->expr_type
)
6954 t
= resolve_operator (e
);
6960 if (check_host_association (e
))
6961 t
= resolve_function (e
);
6963 t
= resolve_variable (e
);
6965 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6966 && e
->ref
->type
!= REF_SUBSTRING
)
6967 gfc_resolve_substring_charlen (e
);
6972 t
= resolve_typebound_function (e
);
6975 case EXPR_SUBSTRING
:
6976 t
= resolve_ref (e
);
6985 t
= resolve_expr_ppc (e
);
6990 if (!resolve_ref (e
))
6993 t
= gfc_resolve_array_constructor (e
);
6994 /* Also try to expand a constructor. */
6997 expression_rank (e
);
6998 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6999 gfc_expand_constructor (e
, false);
7002 /* This provides the opportunity for the length of constructors with
7003 character valued function elements to propagate the string length
7004 to the expression. */
7005 if (t
&& e
->ts
.type
== BT_CHARACTER
)
7007 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
7008 here rather then add a duplicate test for it above. */
7009 gfc_expand_constructor (e
, false);
7010 t
= gfc_resolve_character_array_constructor (e
);
7015 case EXPR_STRUCTURE
:
7016 t
= resolve_ref (e
);
7020 t
= resolve_structure_cons (e
, 0);
7024 t
= gfc_simplify_expr (e
, 0);
7028 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7031 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
7034 inquiry_argument
= inquiry_save
;
7035 actual_arg
= actual_arg_save
;
7036 first_actual_arg
= first_actual_arg_save
;
7042 /* Resolve an expression from an iterator. They must be scalar and have
7043 INTEGER or (optionally) REAL type. */
7046 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
7047 const char *name_msgid
)
7049 if (!gfc_resolve_expr (expr
))
7052 if (expr
->rank
!= 0)
7054 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7058 if (expr
->ts
.type
!= BT_INTEGER
)
7060 if (expr
->ts
.type
== BT_REAL
)
7063 return gfc_notify_std (GFC_STD_F95_DEL
,
7064 "%s at %L must be integer",
7065 _(name_msgid
), &expr
->where
);
7068 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7075 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7083 /* Resolve the expressions in an iterator structure. If REAL_OK is
7084 false allow only INTEGER type iterators, otherwise allow REAL types.
7085 Set own_scope to true for ac-implied-do and data-implied-do as those
7086 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7089 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7091 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7094 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7095 _("iterator variable")))
7098 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7099 "Start expression in DO loop"))
7102 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7103 "End expression in DO loop"))
7106 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7107 "Step expression in DO loop"))
7110 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7112 if ((iter
->step
->ts
.type
== BT_INTEGER
7113 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7114 || (iter
->step
->ts
.type
== BT_REAL
7115 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7117 gfc_error ("Step expression in DO loop at %L cannot be zero",
7118 &iter
->step
->where
);
7123 /* Convert start, end, and step to the same type as var. */
7124 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7125 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7126 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7128 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7129 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7130 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7132 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7133 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7134 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7136 if (iter
->start
->expr_type
== EXPR_CONSTANT
7137 && iter
->end
->expr_type
== EXPR_CONSTANT
7138 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7141 if (iter
->start
->ts
.type
== BT_INTEGER
)
7143 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7144 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7148 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7149 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7151 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7152 gfc_warning (OPT_Wzerotrip
,
7153 "DO loop at %L will be executed zero times",
7154 &iter
->step
->where
);
7157 if (iter
->end
->expr_type
== EXPR_CONSTANT
7158 && iter
->end
->ts
.type
== BT_INTEGER
7159 && iter
->step
->expr_type
== EXPR_CONSTANT
7160 && iter
->step
->ts
.type
== BT_INTEGER
7161 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7162 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7164 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7165 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7167 if (is_step_positive
7168 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7169 gfc_warning (OPT_Wundefined_do_loop
,
7170 "DO loop at %L is undefined as it overflows",
7171 &iter
->step
->where
);
7172 else if (!is_step_positive
7173 && mpz_cmp (iter
->end
->value
.integer
,
7174 gfc_integer_kinds
[k
].min_int
) == 0)
7175 gfc_warning (OPT_Wundefined_do_loop
,
7176 "DO loop at %L is undefined as it underflows",
7177 &iter
->step
->where
);
7184 /* Traversal function for find_forall_index. f == 2 signals that
7185 that variable itself is not to be checked - only the references. */
7188 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7190 if (expr
->expr_type
!= EXPR_VARIABLE
)
7193 /* A scalar assignment */
7194 if (!expr
->ref
|| *f
== 1)
7196 if (expr
->symtree
->n
.sym
== sym
)
7208 /* Check whether the FORALL index appears in the expression or not.
7209 Returns true if SYM is found in EXPR. */
7212 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7214 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7221 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7222 to be a scalar INTEGER variable. The subscripts and stride are scalar
7223 INTEGERs, and if stride is a constant it must be nonzero.
7224 Furthermore "A subscript or stride in a forall-triplet-spec shall
7225 not contain a reference to any index-name in the
7226 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7229 resolve_forall_iterators (gfc_forall_iterator
*it
)
7231 gfc_forall_iterator
*iter
, *iter2
;
7233 for (iter
= it
; iter
; iter
= iter
->next
)
7235 if (gfc_resolve_expr (iter
->var
)
7236 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7237 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7240 if (gfc_resolve_expr (iter
->start
)
7241 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7242 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7243 &iter
->start
->where
);
7244 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7245 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7247 if (gfc_resolve_expr (iter
->end
)
7248 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7249 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7251 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7252 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7254 if (gfc_resolve_expr (iter
->stride
))
7256 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7257 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7258 &iter
->stride
->where
, "INTEGER");
7260 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7261 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7262 gfc_error ("FORALL stride expression at %L cannot be zero",
7263 &iter
->stride
->where
);
7265 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7266 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7269 for (iter
= it
; iter
; iter
= iter
->next
)
7270 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7272 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7273 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7274 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7275 gfc_error ("FORALL index %qs may not appear in triplet "
7276 "specification at %L", iter
->var
->symtree
->name
,
7277 &iter2
->start
->where
);
7282 /* Given a pointer to a symbol that is a derived type, see if it's
7283 inaccessible, i.e. if it's defined in another module and the components are
7284 PRIVATE. The search is recursive if necessary. Returns zero if no
7285 inaccessible components are found, nonzero otherwise. */
7288 derived_inaccessible (gfc_symbol
*sym
)
7292 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7295 for (c
= sym
->components
; c
; c
= c
->next
)
7297 /* Prevent an infinite loop through this function. */
7298 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7299 && sym
== c
->ts
.u
.derived
)
7302 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7310 /* Resolve the argument of a deallocate expression. The expression must be
7311 a pointer or a full array. */
7314 resolve_deallocate_expr (gfc_expr
*e
)
7316 symbol_attribute attr
;
7317 int allocatable
, pointer
;
7323 if (!gfc_resolve_expr (e
))
7326 if (e
->expr_type
!= EXPR_VARIABLE
)
7329 sym
= e
->symtree
->n
.sym
;
7330 unlimited
= UNLIMITED_POLY(sym
);
7332 if (sym
->ts
.type
== BT_CLASS
)
7334 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7335 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7339 allocatable
= sym
->attr
.allocatable
;
7340 pointer
= sym
->attr
.pointer
;
7342 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7347 if (ref
->u
.ar
.type
!= AR_FULL
7348 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7349 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7354 c
= ref
->u
.c
.component
;
7355 if (c
->ts
.type
== BT_CLASS
)
7357 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7358 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7362 allocatable
= c
->attr
.allocatable
;
7363 pointer
= c
->attr
.pointer
;
7374 attr
= gfc_expr_attr (e
);
7376 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7379 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7385 if (gfc_is_coindexed (e
))
7387 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7392 && !gfc_check_vardef_context (e
, true, true, false,
7393 _("DEALLOCATE object")))
7395 if (!gfc_check_vardef_context (e
, false, true, false,
7396 _("DEALLOCATE object")))
7403 /* Returns true if the expression e contains a reference to the symbol sym. */
7405 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7407 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7414 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7416 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7420 /* Given the expression node e for an allocatable/pointer of derived type to be
7421 allocated, get the expression node to be initialized afterwards (needed for
7422 derived types with default initializers, and derived types with allocatable
7423 components that need nullification.) */
7426 gfc_expr_to_initialize (gfc_expr
*e
)
7432 result
= gfc_copy_expr (e
);
7434 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7435 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7436 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7438 ref
->u
.ar
.type
= AR_FULL
;
7440 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7441 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7446 gfc_free_shape (&result
->shape
, result
->rank
);
7448 /* Recalculate rank, shape, etc. */
7449 gfc_resolve_expr (result
);
7454 /* If the last ref of an expression is an array ref, return a copy of the
7455 expression with that one removed. Otherwise, a copy of the original
7456 expression. This is used for allocate-expressions and pointer assignment
7457 LHS, where there may be an array specification that needs to be stripped
7458 off when using gfc_check_vardef_context. */
7461 remove_last_array_ref (gfc_expr
* e
)
7466 e2
= gfc_copy_expr (e
);
7467 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7468 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7470 gfc_free_ref_list (*r
);
7479 /* Used in resolve_allocate_expr to check that a allocation-object and
7480 a source-expr are conformable. This does not catch all possible
7481 cases; in particular a runtime checking is needed. */
7484 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7487 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7489 /* First compare rank. */
7490 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7491 || (!tail
&& e1
->rank
!= e2
->rank
))
7493 gfc_error ("Source-expr at %L must be scalar or have the "
7494 "same rank as the allocate-object at %L",
7495 &e1
->where
, &e2
->where
);
7506 for (i
= 0; i
< e1
->rank
; i
++)
7508 if (tail
->u
.ar
.start
[i
] == NULL
)
7511 if (tail
->u
.ar
.end
[i
])
7513 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7514 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7515 mpz_add_ui (s
, s
, 1);
7519 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7522 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7524 gfc_error ("Source-expr at %L and allocate-object at %L must "
7525 "have the same shape", &e1
->where
, &e2
->where
);
7538 /* Resolve the expression in an ALLOCATE statement, doing the additional
7539 checks to see whether the expression is OK or not. The expression must
7540 have a trailing array reference that gives the size of the array. */
7543 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7545 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7549 symbol_attribute attr
;
7550 gfc_ref
*ref
, *ref2
;
7553 gfc_symbol
*sym
= NULL
;
7558 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7559 checking of coarrays. */
7560 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7561 if (ref
->next
== NULL
)
7564 if (ref
&& ref
->type
== REF_ARRAY
)
7565 ref
->u
.ar
.in_allocate
= true;
7567 if (!gfc_resolve_expr (e
))
7570 /* Make sure the expression is allocatable or a pointer. If it is
7571 pointer, the next-to-last reference must be a pointer. */
7575 sym
= e
->symtree
->n
.sym
;
7577 /* Check whether ultimate component is abstract and CLASS. */
7580 /* Is the allocate-object unlimited polymorphic? */
7581 unlimited
= UNLIMITED_POLY(e
);
7583 if (e
->expr_type
!= EXPR_VARIABLE
)
7586 attr
= gfc_expr_attr (e
);
7587 pointer
= attr
.pointer
;
7588 dimension
= attr
.dimension
;
7589 codimension
= attr
.codimension
;
7593 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7595 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7596 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7597 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7598 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7599 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7603 allocatable
= sym
->attr
.allocatable
;
7604 pointer
= sym
->attr
.pointer
;
7605 dimension
= sym
->attr
.dimension
;
7606 codimension
= sym
->attr
.codimension
;
7611 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7616 if (ref
->u
.ar
.codimen
> 0)
7619 for (n
= ref
->u
.ar
.dimen
;
7620 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7621 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7628 if (ref
->next
!= NULL
)
7636 gfc_error ("Coindexed allocatable object at %L",
7641 c
= ref
->u
.c
.component
;
7642 if (c
->ts
.type
== BT_CLASS
)
7644 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7645 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7646 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7647 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7648 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7652 allocatable
= c
->attr
.allocatable
;
7653 pointer
= c
->attr
.pointer
;
7654 dimension
= c
->attr
.dimension
;
7655 codimension
= c
->attr
.codimension
;
7656 is_abstract
= c
->attr
.abstract
;
7669 /* Check for F08:C628. */
7670 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7672 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7677 /* Some checks for the SOURCE tag. */
7680 /* Check F03:C631. */
7681 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7683 gfc_error ("Type of entity at %L is type incompatible with "
7684 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7688 /* Check F03:C632 and restriction following Note 6.18. */
7689 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7692 /* Check F03:C633. */
7693 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7695 gfc_error ("The allocate-object at %L and the source-expr at %L "
7696 "shall have the same kind type parameter",
7697 &e
->where
, &code
->expr3
->where
);
7701 /* Check F2008, C642. */
7702 if (code
->expr3
->ts
.type
== BT_DERIVED
7703 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7704 || (code
->expr3
->ts
.u
.derived
->from_intmod
7705 == INTMOD_ISO_FORTRAN_ENV
7706 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7707 == ISOFORTRAN_LOCK_TYPE
)))
7709 gfc_error ("The source-expr at %L shall neither be of type "
7710 "LOCK_TYPE nor have a LOCK_TYPE component if "
7711 "allocate-object at %L is a coarray",
7712 &code
->expr3
->where
, &e
->where
);
7716 /* Check TS18508, C702/C703. */
7717 if (code
->expr3
->ts
.type
== BT_DERIVED
7718 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7719 || (code
->expr3
->ts
.u
.derived
->from_intmod
7720 == INTMOD_ISO_FORTRAN_ENV
7721 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7722 == ISOFORTRAN_EVENT_TYPE
)))
7724 gfc_error ("The source-expr at %L shall neither be of type "
7725 "EVENT_TYPE nor have a EVENT_TYPE component if "
7726 "allocate-object at %L is a coarray",
7727 &code
->expr3
->where
, &e
->where
);
7732 /* Check F08:C629. */
7733 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7736 gcc_assert (e
->ts
.type
== BT_CLASS
);
7737 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7738 "type-spec or source-expr", sym
->name
, &e
->where
);
7742 /* Check F08:C632. */
7743 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7744 && !UNLIMITED_POLY (e
))
7748 if (!e
->ts
.u
.cl
->length
)
7751 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7752 code
->ext
.alloc
.ts
.u
.cl
->length
);
7753 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7755 gfc_error ("Allocating %s at %L with type-spec requires the same "
7756 "character-length parameter as in the declaration",
7757 sym
->name
, &e
->where
);
7762 /* In the variable definition context checks, gfc_expr_attr is used
7763 on the expression. This is fooled by the array specification
7764 present in e, thus we have to eliminate that one temporarily. */
7765 e2
= remove_last_array_ref (e
);
7768 t
= gfc_check_vardef_context (e2
, true, true, false,
7769 _("ALLOCATE object"));
7771 t
= gfc_check_vardef_context (e2
, false, true, false,
7772 _("ALLOCATE object"));
7777 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7778 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7780 /* For class arrays, the initialization with SOURCE is done
7781 using _copy and trans_call. It is convenient to exploit that
7782 when the allocated type is different from the declared type but
7783 no SOURCE exists by setting expr3. */
7784 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7786 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7787 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7788 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7790 /* We have to zero initialize the integer variable. */
7791 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7794 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7796 /* Make sure the vtab symbol is present when
7797 the module variables are generated. */
7798 gfc_typespec ts
= e
->ts
;
7800 ts
= code
->expr3
->ts
;
7801 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7802 ts
= code
->ext
.alloc
.ts
;
7804 /* Finding the vtab also publishes the type's symbol. Therefore this
7805 statement is necessary. */
7806 gfc_find_derived_vtab (ts
.u
.derived
);
7808 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7810 /* Again, make sure the vtab symbol is present when
7811 the module variables are generated. */
7812 gfc_typespec
*ts
= NULL
;
7814 ts
= &code
->expr3
->ts
;
7816 ts
= &code
->ext
.alloc
.ts
;
7820 /* Finding the vtab also publishes the type's symbol. Therefore this
7821 statement is necessary. */
7825 if (dimension
== 0 && codimension
== 0)
7828 /* Make sure the last reference node is an array specification. */
7830 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7831 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7836 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7837 "in ALLOCATE statement at %L", &e
->where
))
7839 if (code
->expr3
->rank
!= 0)
7840 *array_alloc_wo_spec
= true;
7843 gfc_error ("Array specification or array-valued SOURCE= "
7844 "expression required in ALLOCATE statement at %L",
7851 gfc_error ("Array specification required in ALLOCATE statement "
7852 "at %L", &e
->where
);
7857 /* Make sure that the array section reference makes sense in the
7858 context of an ALLOCATE specification. */
7863 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7865 switch (ar
->dimen_type
[i
])
7867 case DIMEN_THIS_IMAGE
:
7868 gfc_error ("Coarray specification required in ALLOCATE statement "
7869 "at %L", &e
->where
);
7873 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0)
7875 /* If ar->stride[i] is NULL, we issued a previous error. */
7876 if (ar
->stride
[i
] == NULL
)
7877 gfc_error ("Bad array specification in ALLOCATE statement "
7878 "at %L", &e
->where
);
7881 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
7883 gfc_error ("Upper cobound is less than lower cobound at %L",
7884 &ar
->start
[i
]->where
);
7890 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
7892 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
7893 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
7895 gfc_error ("Upper cobound is less than lower cobound "
7896 "of 1 at %L", &ar
->start
[i
]->where
);
7906 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7912 for (i
= 0; i
< ar
->dimen
; i
++)
7914 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7917 switch (ar
->dimen_type
[i
])
7923 if (ar
->start
[i
] != NULL
7924 && ar
->end
[i
] != NULL
7925 && ar
->stride
[i
] == NULL
)
7933 case DIMEN_THIS_IMAGE
:
7934 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7940 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7942 sym
= a
->expr
->symtree
->n
.sym
;
7944 /* TODO - check derived type components. */
7945 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7948 if ((ar
->start
[i
] != NULL
7949 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7950 || (ar
->end
[i
] != NULL
7951 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7953 gfc_error ("%qs must not appear in the array specification at "
7954 "%L in the same ALLOCATE statement where it is "
7955 "itself allocated", sym
->name
, &ar
->where
);
7961 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7963 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7964 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7966 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7968 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7969 "statement at %L", &e
->where
);
7975 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7976 && ar
->stride
[i
] == NULL
)
7979 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7993 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7995 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7996 gfc_alloc
*a
, *p
, *q
;
7999 errmsg
= code
->expr2
;
8001 /* Check the stat variable. */
8004 gfc_check_vardef_context (stat
, false, false, false,
8005 _("STAT variable"));
8007 if ((stat
->ts
.type
!= BT_INTEGER
8008 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
8009 || stat
->ref
->type
== REF_COMPONENT
)))
8011 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8012 "variable", &stat
->where
);
8014 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8015 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
8017 gfc_ref
*ref1
, *ref2
;
8020 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
8021 ref1
= ref1
->next
, ref2
= ref2
->next
)
8023 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8025 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8034 gfc_error ("Stat-variable at %L shall not be %sd within "
8035 "the same %s statement", &stat
->where
, fcn
, fcn
);
8041 /* Check the errmsg variable. */
8045 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8048 gfc_check_vardef_context (errmsg
, false, false, false,
8049 _("ERRMSG variable"));
8051 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8052 F18:R930 errmsg-variable is scalar-default-char-variable
8053 F18:R906 default-char-variable is variable
8054 F18:C906 default-char-variable shall be default character. */
8055 if ((errmsg
->ts
.type
!= BT_CHARACTER
8057 && (errmsg
->ref
->type
== REF_ARRAY
8058 || errmsg
->ref
->type
== REF_COMPONENT
)))
8060 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8061 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8062 "variable", &errmsg
->where
);
8064 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8065 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8067 gfc_ref
*ref1
, *ref2
;
8070 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->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 ("Errmsg-variable at %L shall not be %sd within "
8085 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8091 /* Check that an allocate-object appears only once in the statement. */
8093 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8096 for (q
= p
->next
; q
; q
= q
->next
)
8099 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8101 /* This is a potential collision. */
8102 gfc_ref
*pr
= pe
->ref
;
8103 gfc_ref
*qr
= qe
->ref
;
8105 /* Follow the references until
8106 a) They start to differ, in which case there is no error;
8107 you can deallocate a%b and a%c in a single statement
8108 b) Both of them stop, which is an error
8109 c) One of them stops, which is also an error. */
8112 if (pr
== NULL
&& qr
== NULL
)
8114 gfc_error ("Allocate-object at %L also appears at %L",
8115 &pe
->where
, &qe
->where
);
8118 else if (pr
!= NULL
&& qr
== NULL
)
8120 gfc_error ("Allocate-object at %L is subobject of"
8121 " object at %L", &pe
->where
, &qe
->where
);
8124 else if (pr
== NULL
&& qr
!= NULL
)
8126 gfc_error ("Allocate-object at %L is subobject of"
8127 " object at %L", &qe
->where
, &pe
->where
);
8130 /* Here, pr != NULL && qr != NULL */
8131 gcc_assert(pr
->type
== qr
->type
);
8132 if (pr
->type
== REF_ARRAY
)
8134 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8136 gcc_assert (qr
->type
== REF_ARRAY
);
8138 if (pr
->next
&& qr
->next
)
8141 gfc_array_ref
*par
= &(pr
->u
.ar
);
8142 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8144 for (i
=0; i
<par
->dimen
; i
++)
8146 if ((par
->start
[i
] != NULL
8147 || qar
->start
[i
] != NULL
)
8148 && gfc_dep_compare_expr (par
->start
[i
],
8149 qar
->start
[i
]) != 0)
8156 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8169 if (strcmp (fcn
, "ALLOCATE") == 0)
8171 bool arr_alloc_wo_spec
= false;
8173 /* Resolving the expr3 in the loop over all objects to allocate would
8174 execute loop invariant code for each loop item. Therefore do it just
8176 if (code
->expr3
&& code
->expr3
->mold
8177 && code
->expr3
->ts
.type
== BT_DERIVED
)
8179 /* Default initialization via MOLD (non-polymorphic). */
8180 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8183 gfc_resolve_expr (rhs
);
8184 gfc_free_expr (code
->expr3
);
8188 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8189 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8191 if (arr_alloc_wo_spec
&& code
->expr3
)
8193 /* Mark the allocate to have to take the array specification
8195 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8200 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8201 resolve_deallocate_expr (a
->expr
);
8206 /************ SELECT CASE resolution subroutines ************/
8208 /* Callback function for our mergesort variant. Determines interval
8209 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8210 op1 > op2. Assumes we're not dealing with the default case.
8211 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8212 There are nine situations to check. */
8215 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8219 if (op1
->low
== NULL
) /* op1 = (:L) */
8221 /* op2 = (:N), so overlap. */
8223 /* op2 = (M:) or (M:N), L < M */
8224 if (op2
->low
!= NULL
8225 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8228 else if (op1
->high
== NULL
) /* op1 = (K:) */
8230 /* op2 = (M:), so overlap. */
8232 /* op2 = (:N) or (M:N), K > N */
8233 if (op2
->high
!= NULL
8234 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8237 else /* op1 = (K:L) */
8239 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8240 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8242 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8243 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8245 else /* op2 = (M:N) */
8249 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8252 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8261 /* Merge-sort a double linked case list, detecting overlap in the
8262 process. LIST is the head of the double linked case list before it
8263 is sorted. Returns the head of the sorted list if we don't see any
8264 overlap, or NULL otherwise. */
8267 check_case_overlap (gfc_case
*list
)
8269 gfc_case
*p
, *q
, *e
, *tail
;
8270 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8272 /* If the passed list was empty, return immediately. */
8279 /* Loop unconditionally. The only exit from this loop is a return
8280 statement, when we've finished sorting the case list. */
8287 /* Count the number of merges we do in this pass. */
8290 /* Loop while there exists a merge to be done. */
8295 /* Count this merge. */
8298 /* Cut the list in two pieces by stepping INSIZE places
8299 forward in the list, starting from P. */
8302 for (i
= 0; i
< insize
; i
++)
8311 /* Now we have two lists. Merge them! */
8312 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8314 /* See from which the next case to merge comes from. */
8317 /* P is empty so the next case must come from Q. */
8322 else if (qsize
== 0 || q
== NULL
)
8331 cmp
= compare_cases (p
, q
);
8334 /* The whole case range for P is less than the
8342 /* The whole case range for Q is greater than
8343 the case range for P. */
8350 /* The cases overlap, or they are the same
8351 element in the list. Either way, we must
8352 issue an error and get the next case from P. */
8353 /* FIXME: Sort P and Q by line number. */
8354 gfc_error ("CASE label at %L overlaps with CASE "
8355 "label at %L", &p
->where
, &q
->where
);
8363 /* Add the next element to the merged list. */
8372 /* P has now stepped INSIZE places along, and so has Q. So
8373 they're the same. */
8378 /* If we have done only one merge or none at all, we've
8379 finished sorting the cases. */
8388 /* Otherwise repeat, merging lists twice the size. */
8394 /* Check to see if an expression is suitable for use in a CASE statement.
8395 Makes sure that all case expressions are scalar constants of the same
8396 type. Return false if anything is wrong. */
8399 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8401 if (e
== NULL
) return true;
8403 if (e
->ts
.type
!= case_expr
->ts
.type
)
8405 gfc_error ("Expression in CASE statement at %L must be of type %s",
8406 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8410 /* C805 (R808) For a given case-construct, each case-value shall be of
8411 the same type as case-expr. For character type, length differences
8412 are allowed, but the kind type parameters shall be the same. */
8414 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8416 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8417 &e
->where
, case_expr
->ts
.kind
);
8421 /* Convert the case value kind to that of case expression kind,
8424 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8425 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8429 gfc_error ("Expression in CASE statement at %L must be scalar",
8438 /* Given a completely parsed select statement, we:
8440 - Validate all expressions and code within the SELECT.
8441 - Make sure that the selection expression is not of the wrong type.
8442 - Make sure that no case ranges overlap.
8443 - Eliminate unreachable cases and unreachable code resulting from
8444 removing case labels.
8446 The standard does allow unreachable cases, e.g. CASE (5:3). But
8447 they are a hassle for code generation, and to prevent that, we just
8448 cut them out here. This is not necessary for overlapping cases
8449 because they are illegal and we never even try to generate code.
8451 We have the additional caveat that a SELECT construct could have
8452 been a computed GOTO in the source code. Fortunately we can fairly
8453 easily work around that here: The case_expr for a "real" SELECT CASE
8454 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8455 we have to do is make sure that the case_expr is a scalar integer
8459 resolve_select (gfc_code
*code
, bool select_type
)
8462 gfc_expr
*case_expr
;
8463 gfc_case
*cp
, *default_case
, *tail
, *head
;
8464 int seen_unreachable
;
8470 if (code
->expr1
== NULL
)
8472 /* This was actually a computed GOTO statement. */
8473 case_expr
= code
->expr2
;
8474 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8475 gfc_error ("Selection expression in computed GOTO statement "
8476 "at %L must be a scalar integer expression",
8479 /* Further checking is not necessary because this SELECT was built
8480 by the compiler, so it should always be OK. Just move the
8481 case_expr from expr2 to expr so that we can handle computed
8482 GOTOs as normal SELECTs from here on. */
8483 code
->expr1
= code
->expr2
;
8488 case_expr
= code
->expr1
;
8489 type
= case_expr
->ts
.type
;
8492 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8494 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8495 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8497 /* Punt. Going on here just produce more garbage error messages. */
8502 if (!select_type
&& case_expr
->rank
!= 0)
8504 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8505 "expression", &case_expr
->where
);
8511 /* Raise a warning if an INTEGER case value exceeds the range of
8512 the case-expr. Later, all expressions will be promoted to the
8513 largest kind of all case-labels. */
8515 if (type
== BT_INTEGER
)
8516 for (body
= code
->block
; body
; body
= body
->block
)
8517 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8520 && gfc_check_integer_range (cp
->low
->value
.integer
,
8521 case_expr
->ts
.kind
) != ARITH_OK
)
8522 gfc_warning (0, "Expression in CASE statement at %L is "
8523 "not in the range of %s", &cp
->low
->where
,
8524 gfc_typename (&case_expr
->ts
));
8527 && cp
->low
!= cp
->high
8528 && gfc_check_integer_range (cp
->high
->value
.integer
,
8529 case_expr
->ts
.kind
) != ARITH_OK
)
8530 gfc_warning (0, "Expression in CASE statement at %L is "
8531 "not in the range of %s", &cp
->high
->where
,
8532 gfc_typename (&case_expr
->ts
));
8535 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8536 of the SELECT CASE expression and its CASE values. Walk the lists
8537 of case values, and if we find a mismatch, promote case_expr to
8538 the appropriate kind. */
8540 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8542 for (body
= code
->block
; body
; body
= body
->block
)
8544 /* Walk the case label list. */
8545 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8547 /* Intercept the DEFAULT case. It does not have a kind. */
8548 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8551 /* Unreachable case ranges are discarded, so ignore. */
8552 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8553 && cp
->low
!= cp
->high
8554 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8558 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8559 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8561 if (cp
->high
!= NULL
8562 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8563 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8568 /* Assume there is no DEFAULT case. */
8569 default_case
= NULL
;
8574 for (body
= code
->block
; body
; body
= body
->block
)
8576 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8578 seen_unreachable
= 0;
8580 /* Walk the case label list, making sure that all case labels
8582 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8584 /* Count the number of cases in the whole construct. */
8587 /* Intercept the DEFAULT case. */
8588 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8590 if (default_case
!= NULL
)
8592 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8593 "by a second DEFAULT CASE at %L",
8594 &default_case
->where
, &cp
->where
);
8605 /* Deal with single value cases and case ranges. Errors are
8606 issued from the validation function. */
8607 if (!validate_case_label_expr (cp
->low
, case_expr
)
8608 || !validate_case_label_expr (cp
->high
, case_expr
))
8614 if (type
== BT_LOGICAL
8615 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8616 || cp
->low
!= cp
->high
))
8618 gfc_error ("Logical range in CASE statement at %L is not "
8619 "allowed", &cp
->low
->where
);
8624 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8627 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8628 if (value
& seen_logical
)
8630 gfc_error ("Constant logical value in CASE statement "
8631 "is repeated at %L",
8636 seen_logical
|= value
;
8639 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8640 && cp
->low
!= cp
->high
8641 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8643 if (warn_surprising
)
8644 gfc_warning (OPT_Wsurprising
,
8645 "Range specification at %L can never be matched",
8648 cp
->unreachable
= 1;
8649 seen_unreachable
= 1;
8653 /* If the case range can be matched, it can also overlap with
8654 other cases. To make sure it does not, we put it in a
8655 double linked list here. We sort that with a merge sort
8656 later on to detect any overlapping cases. */
8660 head
->right
= head
->left
= NULL
;
8665 tail
->right
->left
= tail
;
8672 /* It there was a failure in the previous case label, give up
8673 for this case label list. Continue with the next block. */
8677 /* See if any case labels that are unreachable have been seen.
8678 If so, we eliminate them. This is a bit of a kludge because
8679 the case lists for a single case statement (label) is a
8680 single forward linked lists. */
8681 if (seen_unreachable
)
8683 /* Advance until the first case in the list is reachable. */
8684 while (body
->ext
.block
.case_list
!= NULL
8685 && body
->ext
.block
.case_list
->unreachable
)
8687 gfc_case
*n
= body
->ext
.block
.case_list
;
8688 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8690 gfc_free_case_list (n
);
8693 /* Strip all other unreachable cases. */
8694 if (body
->ext
.block
.case_list
)
8696 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8698 if (cp
->next
->unreachable
)
8700 gfc_case
*n
= cp
->next
;
8701 cp
->next
= cp
->next
->next
;
8703 gfc_free_case_list (n
);
8710 /* See if there were overlapping cases. If the check returns NULL,
8711 there was overlap. In that case we don't do anything. If head
8712 is non-NULL, we prepend the DEFAULT case. The sorted list can
8713 then used during code generation for SELECT CASE constructs with
8714 a case expression of a CHARACTER type. */
8717 head
= check_case_overlap (head
);
8719 /* Prepend the default_case if it is there. */
8720 if (head
!= NULL
&& default_case
)
8722 default_case
->left
= NULL
;
8723 default_case
->right
= head
;
8724 head
->left
= default_case
;
8728 /* Eliminate dead blocks that may be the result if we've seen
8729 unreachable case labels for a block. */
8730 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8732 if (body
->block
->ext
.block
.case_list
== NULL
)
8734 /* Cut the unreachable block from the code chain. */
8735 gfc_code
*c
= body
->block
;
8736 body
->block
= c
->block
;
8738 /* Kill the dead block, but not the blocks below it. */
8740 gfc_free_statements (c
);
8744 /* More than two cases is legal but insane for logical selects.
8745 Issue a warning for it. */
8746 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8747 gfc_warning (OPT_Wsurprising
,
8748 "Logical SELECT CASE block at %L has more that two cases",
8753 /* Check if a derived type is extensible. */
8756 gfc_type_is_extensible (gfc_symbol
*sym
)
8758 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8759 || (sym
->attr
.is_class
8760 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8765 resolve_types (gfc_namespace
*ns
);
8767 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8768 correct as well as possibly the array-spec. */
8771 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8775 gcc_assert (sym
->assoc
);
8776 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8778 /* If this is for SELECT TYPE, the target may not yet be set. In that
8779 case, return. Resolution will be called later manually again when
8781 target
= sym
->assoc
->target
;
8784 gcc_assert (!sym
->assoc
->dangling
);
8786 if (resolve_target
&& !gfc_resolve_expr (target
))
8789 /* For variable targets, we get some attributes from the target. */
8790 if (target
->expr_type
== EXPR_VARIABLE
)
8794 gcc_assert (target
->symtree
);
8795 tsym
= target
->symtree
->n
.sym
;
8797 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8798 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8800 sym
->attr
.target
= tsym
->attr
.target
8801 || gfc_expr_attr (target
).pointer
;
8802 if (is_subref_array (target
))
8803 sym
->attr
.subref_array_pointer
= 1;
8806 if (target
->expr_type
== EXPR_NULL
)
8808 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8811 else if (target
->ts
.type
== BT_UNKNOWN
)
8813 gfc_error ("Selector at %L has no type", &target
->where
);
8817 /* Get type if this was not already set. Note that it can be
8818 some other type than the target in case this is a SELECT TYPE
8819 selector! So we must not update when the type is already there. */
8820 if (sym
->ts
.type
== BT_UNKNOWN
)
8821 sym
->ts
= target
->ts
;
8823 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8825 /* See if this is a valid association-to-variable. */
8826 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8827 && !gfc_has_vector_subscript (target
));
8829 /* Finally resolve if this is an array or not. */
8830 if (sym
->attr
.dimension
&& target
->rank
== 0)
8832 /* primary.c makes the assumption that a reference to an associate
8833 name followed by a left parenthesis is an array reference. */
8834 if (sym
->ts
.type
!= BT_CHARACTER
)
8835 gfc_error ("Associate-name %qs at %L is used as array",
8836 sym
->name
, &sym
->declared_at
);
8837 sym
->attr
.dimension
= 0;
8842 /* We cannot deal with class selectors that need temporaries. */
8843 if (target
->ts
.type
== BT_CLASS
8844 && gfc_ref_needs_temporary_p (target
->ref
))
8846 gfc_error ("CLASS selector at %L needs a temporary which is not "
8847 "yet implemented", &target
->where
);
8851 if (target
->ts
.type
== BT_CLASS
)
8852 gfc_fix_class_refs (target
);
8854 if (target
->rank
!= 0)
8857 /* The rank may be incorrectly guessed at parsing, therefore make sure
8858 it is corrected now. */
8859 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8862 sym
->as
= gfc_get_array_spec ();
8864 as
->rank
= target
->rank
;
8865 as
->type
= AS_DEFERRED
;
8866 as
->corank
= gfc_get_corank (target
);
8867 sym
->attr
.dimension
= 1;
8868 if (as
->corank
!= 0)
8869 sym
->attr
.codimension
= 1;
8871 else if (sym
->ts
.type
== BT_CLASS
&& (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
8873 if (!CLASS_DATA (sym
)->as
)
8874 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
8875 as
= CLASS_DATA (sym
)->as
;
8876 as
->rank
= target
->rank
;
8877 as
->type
= AS_DEFERRED
;
8878 as
->corank
= gfc_get_corank (target
);
8879 CLASS_DATA (sym
)->attr
.dimension
= 1;
8880 if (as
->corank
!= 0)
8881 CLASS_DATA (sym
)->attr
.codimension
= 1;
8886 /* target's rank is 0, but the type of the sym is still array valued,
8887 which has to be corrected. */
8888 if (sym
->ts
.type
== BT_CLASS
8889 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
8892 symbol_attribute attr
;
8893 /* The associated variable's type is still the array type
8894 correct this now. */
8895 gfc_typespec
*ts
= &target
->ts
;
8898 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8903 ts
= &ref
->u
.c
.component
->ts
;
8906 if (ts
->type
== BT_CLASS
)
8907 ts
= &ts
->u
.derived
->components
->ts
;
8913 /* Create a scalar instance of the current class type. Because the
8914 rank of a class array goes into its name, the type has to be
8915 rebuild. The alternative of (re-)setting just the attributes
8916 and as in the current type, destroys the type also in other
8920 sym
->ts
.type
= BT_CLASS
;
8921 attr
= CLASS_DATA (sym
)->attr
;
8923 attr
.associate_var
= 1;
8924 attr
.dimension
= attr
.codimension
= 0;
8925 attr
.class_pointer
= 1;
8926 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8928 /* Make sure the _vptr is set. */
8929 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8930 if (c
->ts
.u
.derived
== NULL
)
8931 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8932 CLASS_DATA (sym
)->attr
.pointer
= 1;
8933 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8934 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8935 gfc_commit_symbol (sym
->ts
.u
.derived
);
8936 /* _vptr now has the _vtab in it, change it to the _vtype. */
8937 if (c
->ts
.u
.derived
->attr
.vtab
)
8938 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8939 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8940 resolve_types (c
->ts
.u
.derived
->ns
);
8944 /* Mark this as an associate variable. */
8945 sym
->attr
.associate_var
= 1;
8947 /* Fix up the type-spec for CHARACTER types. */
8948 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8951 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8953 if (sym
->ts
.deferred
&& target
->expr_type
== EXPR_VARIABLE
8954 && target
->symtree
->n
.sym
->attr
.dummy
8955 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
8957 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8958 sym
->ts
.deferred
= 1;
8961 if (!sym
->ts
.u
.cl
->length
8962 && !sym
->ts
.deferred
8963 && target
->expr_type
== EXPR_CONSTANT
)
8965 sym
->ts
.u
.cl
->length
=
8966 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8967 target
->value
.character
.length
);
8969 else if ((!sym
->ts
.u
.cl
->length
8970 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8971 && target
->expr_type
!= EXPR_VARIABLE
)
8973 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8974 sym
->ts
.deferred
= 1;
8976 /* This is reset in trans-stmt.c after the assignment
8977 of the target expression to the associate name. */
8978 sym
->attr
.allocatable
= 1;
8982 /* If the target is a good class object, so is the associate variable. */
8983 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8984 sym
->attr
.class_ok
= 1;
8988 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8989 array reference, where necessary. The symbols are artificial and so
8990 the dimension attribute and arrayspec can also be set. In addition,
8991 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8992 This is corrected here as well.*/
8995 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8996 int rank
, gfc_ref
*ref
)
8998 gfc_ref
*nref
= (*expr1
)->ref
;
8999 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
9000 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
9001 (*expr1
)->rank
= rank
;
9002 if (sym1
->ts
.type
== BT_CLASS
)
9004 if ((*expr1
)->ts
.type
!= BT_CLASS
)
9005 (*expr1
)->ts
= sym1
->ts
;
9007 CLASS_DATA (sym1
)->attr
.dimension
= 1;
9008 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
9009 CLASS_DATA (sym1
)->as
9010 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
9014 sym1
->attr
.dimension
= 1;
9015 if (sym1
->as
== NULL
&& sym2
)
9016 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
9019 for (; nref
; nref
= nref
->next
)
9020 if (nref
->next
== NULL
)
9023 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
9024 nref
->next
= gfc_copy_ref (ref
);
9025 else if (ref
&& !nref
)
9026 (*expr1
)->ref
= gfc_copy_ref (ref
);
9031 build_loc_call (gfc_expr
*sym_expr
)
9034 loc_call
= gfc_get_expr ();
9035 loc_call
->expr_type
= EXPR_FUNCTION
;
9036 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
9037 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
9038 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
9039 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
9040 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
9041 loc_call
->ts
.type
= BT_INTEGER
;
9042 loc_call
->ts
.kind
= gfc_index_integer_kind
;
9043 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
9044 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
9045 loc_call
->value
.function
.actual
->expr
= sym_expr
;
9046 loc_call
->where
= sym_expr
->where
;
9050 /* Resolve a SELECT TYPE statement. */
9053 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9055 gfc_symbol
*selector_type
;
9056 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9057 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9060 char name
[GFC_MAX_SYMBOL_LEN
];
9064 gfc_ref
* ref
= NULL
;
9065 gfc_expr
*selector_expr
= NULL
;
9067 ns
= code
->ext
.block
.ns
;
9070 /* Check for F03:C813. */
9071 if (code
->expr1
->ts
.type
!= BT_CLASS
9072 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9074 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9075 "at %L", &code
->loc
);
9079 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9084 gfc_ref
*ref2
= NULL
;
9085 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9086 if (ref
->type
== REF_COMPONENT
9087 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9092 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9093 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9094 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9098 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9099 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9100 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
9103 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
9104 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9106 /* F2008: C803 The selector expression must not be coindexed. */
9107 if (gfc_is_coindexed (code
->expr2
))
9109 gfc_error ("Selector at %L must not be coindexed",
9110 &code
->expr2
->where
);
9117 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9119 if (gfc_is_coindexed (code
->expr1
))
9121 gfc_error ("Selector at %L must not be coindexed",
9122 &code
->expr1
->where
);
9127 /* Loop over TYPE IS / CLASS IS cases. */
9128 for (body
= code
->block
; body
; body
= body
->block
)
9130 c
= body
->ext
.block
.case_list
;
9134 /* Check for repeated cases. */
9135 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9137 gfc_case
*d
= tail
->ext
.block
.case_list
;
9141 if (c
->ts
.type
== d
->ts
.type
9142 && ((c
->ts
.type
== BT_DERIVED
9143 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9144 && !strcmp (c
->ts
.u
.derived
->name
,
9145 d
->ts
.u
.derived
->name
))
9146 || c
->ts
.type
== BT_UNKNOWN
9147 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9148 && c
->ts
.kind
== d
->ts
.kind
)))
9150 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9151 &c
->where
, &d
->where
);
9157 /* Check F03:C815. */
9158 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9159 && !selector_type
->attr
.unlimited_polymorphic
9160 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9162 gfc_error ("Derived type %qs at %L must be extensible",
9163 c
->ts
.u
.derived
->name
, &c
->where
);
9168 /* Check F03:C816. */
9169 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
9170 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9171 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9173 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9174 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9175 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9177 gfc_error ("Unexpected intrinsic type %qs at %L",
9178 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9183 /* Check F03:C814. */
9184 if (c
->ts
.type
== BT_CHARACTER
9185 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9187 gfc_error ("The type-spec at %L shall specify that each length "
9188 "type parameter is assumed", &c
->where
);
9193 /* Intercept the DEFAULT case. */
9194 if (c
->ts
.type
== BT_UNKNOWN
)
9196 /* Check F03:C818. */
9199 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9200 "by a second DEFAULT CASE at %L",
9201 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9206 default_case
= body
;
9213 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9214 target if present. If there are any EXIT statements referring to the
9215 SELECT TYPE construct, this is no problem because the gfc_code
9216 reference stays the same and EXIT is equally possible from the BLOCK
9217 it is changed to. */
9218 code
->op
= EXEC_BLOCK
;
9221 gfc_association_list
* assoc
;
9223 assoc
= gfc_get_association_list ();
9224 assoc
->st
= code
->expr1
->symtree
;
9225 assoc
->target
= gfc_copy_expr (code
->expr2
);
9226 assoc
->target
->where
= code
->expr2
->where
;
9227 /* assoc->variable will be set by resolve_assoc_var. */
9229 code
->ext
.block
.assoc
= assoc
;
9230 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9232 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9235 code
->ext
.block
.assoc
= NULL
;
9237 /* Ensure that the selector rank and arrayspec are available to
9238 correct expressions in which they might be missing. */
9239 if (code
->expr2
&& code
->expr2
->rank
)
9241 rank
= code
->expr2
->rank
;
9242 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9243 if (ref
->next
== NULL
)
9245 if (ref
&& ref
->type
== REF_ARRAY
)
9246 ref
= gfc_copy_ref (ref
);
9248 /* Fixup expr1 if necessary. */
9250 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9252 else if (code
->expr1
->rank
)
9254 rank
= code
->expr1
->rank
;
9255 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9256 if (ref
->next
== NULL
)
9258 if (ref
&& ref
->type
== REF_ARRAY
)
9259 ref
= gfc_copy_ref (ref
);
9262 /* Add EXEC_SELECT to switch on type. */
9263 new_st
= gfc_get_code (code
->op
);
9264 new_st
->expr1
= code
->expr1
;
9265 new_st
->expr2
= code
->expr2
;
9266 new_st
->block
= code
->block
;
9267 code
->expr1
= code
->expr2
= NULL
;
9272 ns
->code
->next
= new_st
;
9274 code
->op
= EXEC_SELECT_TYPE
;
9276 /* Use the intrinsic LOC function to generate an integer expression
9277 for the vtable of the selector. Note that the rank of the selector
9278 expression has to be set to zero. */
9279 gfc_add_vptr_component (code
->expr1
);
9280 code
->expr1
->rank
= 0;
9281 code
->expr1
= build_loc_call (code
->expr1
);
9282 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9284 /* Loop over TYPE IS / CLASS IS cases. */
9285 for (body
= code
->block
; body
; body
= body
->block
)
9289 c
= body
->ext
.block
.case_list
;
9291 /* Generate an index integer expression for address of the
9292 TYPE/CLASS vtable and store it in c->low. The hash expression
9293 is stored in c->high and is used to resolve intrinsic cases. */
9294 if (c
->ts
.type
!= BT_UNKNOWN
)
9296 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9298 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9300 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9301 c
->ts
.u
.derived
->hash_value
);
9305 vtab
= gfc_find_vtab (&c
->ts
);
9306 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9307 e
= CLASS_DATA (vtab
)->initializer
;
9308 c
->high
= gfc_copy_expr (e
);
9309 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9312 ts
.kind
= gfc_integer_4_kind
;
9313 ts
.type
= BT_INTEGER
;
9314 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9318 e
= gfc_lval_expr_from_sym (vtab
);
9319 c
->low
= build_loc_call (e
);
9324 /* Associate temporary to selector. This should only be done
9325 when this case is actually true, so build a new ASSOCIATE
9326 that does precisely this here (instead of using the
9329 if (c
->ts
.type
== BT_CLASS
)
9330 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9331 else if (c
->ts
.type
== BT_DERIVED
)
9332 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9333 else if (c
->ts
.type
== BT_CHARACTER
)
9335 HOST_WIDE_INT charlen
= 0;
9336 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9337 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9338 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9339 snprintf (name
, sizeof (name
),
9340 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9341 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9344 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9347 st
= gfc_find_symtree (ns
->sym_root
, name
);
9348 gcc_assert (st
->n
.sym
->assoc
);
9349 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9350 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9351 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9353 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9354 /* Fixup the target expression if necessary. */
9356 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9359 new_st
= gfc_get_code (EXEC_BLOCK
);
9360 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9361 new_st
->ext
.block
.ns
->code
= body
->next
;
9362 body
->next
= new_st
;
9364 /* Chain in the new list only if it is marked as dangling. Otherwise
9365 there is a CASE label overlap and this is already used. Just ignore,
9366 the error is diagnosed elsewhere. */
9367 if (st
->n
.sym
->assoc
->dangling
)
9369 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9370 st
->n
.sym
->assoc
->dangling
= 0;
9373 resolve_assoc_var (st
->n
.sym
, false);
9376 /* Take out CLASS IS cases for separate treatment. */
9378 while (body
&& body
->block
)
9380 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9382 /* Add to class_is list. */
9383 if (class_is
== NULL
)
9385 class_is
= body
->block
;
9390 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9391 tail
->block
= body
->block
;
9394 /* Remove from EXEC_SELECT list. */
9395 body
->block
= body
->block
->block
;
9408 /* Add a default case to hold the CLASS IS cases. */
9409 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9410 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9412 tail
->ext
.block
.case_list
= gfc_get_case ();
9413 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9415 default_case
= tail
;
9418 /* More than one CLASS IS block? */
9419 if (class_is
->block
)
9423 /* Sort CLASS IS blocks by extension level. */
9427 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9430 /* F03:C817 (check for doubles). */
9431 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9432 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9434 gfc_error ("Double CLASS IS block in SELECT TYPE "
9436 &c2
->ext
.block
.case_list
->where
);
9439 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9440 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9443 (*c1
)->block
= c2
->block
;
9453 /* Generate IF chain. */
9454 if_st
= gfc_get_code (EXEC_IF
);
9456 for (body
= class_is
; body
; body
= body
->block
)
9458 new_st
->block
= gfc_get_code (EXEC_IF
);
9459 new_st
= new_st
->block
;
9460 /* Set up IF condition: Call _gfortran_is_extension_of. */
9461 new_st
->expr1
= gfc_get_expr ();
9462 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9463 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9464 new_st
->expr1
->ts
.kind
= 4;
9465 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9466 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9467 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9468 /* Set up arguments. */
9469 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9470 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9471 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9472 new_st
->expr1
->where
= code
->loc
;
9473 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9474 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9475 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9476 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9477 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9478 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9479 new_st
->next
= body
->next
;
9481 if (default_case
->next
)
9483 new_st
->block
= gfc_get_code (EXEC_IF
);
9484 new_st
= new_st
->block
;
9485 new_st
->next
= default_case
->next
;
9488 /* Replace CLASS DEFAULT code by the IF chain. */
9489 default_case
->next
= if_st
;
9492 /* Resolve the internal code. This cannot be done earlier because
9493 it requires that the sym->assoc of selectors is set already. */
9494 gfc_current_ns
= ns
;
9495 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9496 gfc_current_ns
= old_ns
;
9503 /* Resolve a transfer statement. This is making sure that:
9504 -- a derived type being transferred has only non-pointer components
9505 -- a derived type being transferred doesn't have private components, unless
9506 it's being transferred from the module where the type was defined
9507 -- we're not trying to transfer a whole assumed size array. */
9510 resolve_transfer (gfc_code
*code
)
9512 gfc_symbol
*sym
, *derived
;
9516 bool formatted
= false;
9517 gfc_dt
*dt
= code
->ext
.dt
;
9518 gfc_symbol
*dtio_sub
= NULL
;
9522 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9523 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9524 exp
= exp
->value
.op
.op1
;
9526 if (exp
&& exp
->expr_type
== EXPR_NULL
9529 gfc_error ("Invalid context for NULL () intrinsic at %L",
9534 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9535 && exp
->expr_type
!= EXPR_FUNCTION
9536 && exp
->expr_type
!= EXPR_STRUCTURE
))
9539 /* If we are reading, the variable will be changed. Note that
9540 code->ext.dt may be NULL if the TRANSFER is related to
9541 an INQUIRE statement -- but in this case, we are not reading, either. */
9542 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9543 && !gfc_check_vardef_context (exp
, false, false, false,
9547 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
9548 || exp
->expr_type
== EXPR_FUNCTION
9549 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9551 /* Go to actual component transferred. */
9552 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9553 if (ref
->type
== REF_COMPONENT
)
9554 ts
= &ref
->u
.c
.component
->ts
;
9556 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9557 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9559 derived
= ts
->u
.derived
;
9561 /* Determine when to use the formatted DTIO procedure. */
9562 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9565 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9566 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9567 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9569 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9572 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9573 /* Check to see if this is a nested DTIO call, with the
9574 dummy as the io-list object. */
9575 if (sym
&& sym
== dtio_sub
&& sym
->formal
9576 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9577 && exp
->ref
== NULL
)
9579 if (!sym
->attr
.recursive
)
9581 gfc_error ("DTIO %s procedure at %L must be recursive",
9582 sym
->name
, &sym
->declared_at
);
9589 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9591 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9592 "it is processed by a defined input/output procedure",
9597 if (ts
->type
== BT_DERIVED
)
9599 /* Check that transferred derived type doesn't contain POINTER
9600 components unless it is processed by a defined input/output
9602 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9604 gfc_error ("Data transfer element at %L cannot have POINTER "
9605 "components unless it is processed by a defined "
9606 "input/output procedure", &code
->loc
);
9611 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9613 gfc_error ("Data transfer element at %L cannot have "
9614 "procedure pointer components", &code
->loc
);
9618 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9620 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9621 "components unless it is processed by a defined "
9622 "input/output procedure", &code
->loc
);
9626 /* C_PTR and C_FUNPTR have private components which means they cannot
9627 be printed. However, if -std=gnu and not -pedantic, allow
9628 the component to be printed to help debugging. */
9629 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9631 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9632 "cannot have PRIVATE components", &code
->loc
))
9635 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9637 gfc_error ("Data transfer element at %L cannot have "
9638 "PRIVATE components unless it is processed by "
9639 "a defined input/output procedure", &code
->loc
);
9644 if (exp
->expr_type
== EXPR_STRUCTURE
)
9647 sym
= exp
->symtree
->n
.sym
;
9649 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9650 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9652 gfc_error ("Data transfer element at %L cannot be a full reference to "
9653 "an assumed-size array", &code
->loc
);
9657 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9658 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9662 /*********** Toplevel code resolution subroutines ***********/
9664 /* Find the set of labels that are reachable from this block. We also
9665 record the last statement in each block. */
9668 find_reachable_labels (gfc_code
*block
)
9675 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9677 /* Collect labels in this block. We don't keep those corresponding
9678 to END {IF|SELECT}, these are checked in resolve_branch by going
9679 up through the code_stack. */
9680 for (c
= block
; c
; c
= c
->next
)
9682 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9683 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9686 /* Merge with labels from parent block. */
9689 gcc_assert (cs_base
->prev
->reachable_labels
);
9690 bitmap_ior_into (cs_base
->reachable_labels
,
9691 cs_base
->prev
->reachable_labels
);
9697 resolve_lock_unlock_event (gfc_code
*code
)
9699 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9700 && code
->expr1
->value
.function
.isym
9701 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9702 remove_caf_get_intrinsic (code
->expr1
);
9704 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9705 && (code
->expr1
->ts
.type
!= BT_DERIVED
9706 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9707 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9708 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9709 || code
->expr1
->rank
!= 0
9710 || (!gfc_is_coarray (code
->expr1
) &&
9711 !gfc_is_coindexed (code
->expr1
))))
9712 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9713 &code
->expr1
->where
);
9714 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9715 && (code
->expr1
->ts
.type
!= BT_DERIVED
9716 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9717 || code
->expr1
->ts
.u
.derived
->from_intmod
9718 != INTMOD_ISO_FORTRAN_ENV
9719 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9720 != ISOFORTRAN_EVENT_TYPE
9721 || code
->expr1
->rank
!= 0))
9722 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9723 &code
->expr1
->where
);
9724 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9725 && !gfc_is_coindexed (code
->expr1
))
9726 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9727 &code
->expr1
->where
);
9728 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9729 gfc_error ("Event variable argument at %L must be a coarray but not "
9730 "coindexed", &code
->expr1
->where
);
9734 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9735 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9736 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9737 &code
->expr2
->where
);
9740 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9741 _("STAT variable")))
9746 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9747 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9748 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9749 &code
->expr3
->where
);
9752 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9753 _("ERRMSG variable")))
9756 /* Check for LOCK the ACQUIRED_LOCK. */
9757 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9758 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9759 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9760 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9761 "variable", &code
->expr4
->where
);
9763 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9764 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9765 _("ACQUIRED_LOCK variable")))
9768 /* Check for EVENT WAIT the UNTIL_COUNT. */
9769 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9771 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9772 || code
->expr4
->rank
!= 0)
9773 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9774 "expression", &code
->expr4
->where
);
9780 resolve_critical (gfc_code
*code
)
9782 gfc_symtree
*symtree
;
9783 gfc_symbol
*lock_type
;
9784 char name
[GFC_MAX_SYMBOL_LEN
];
9785 static int serial
= 0;
9787 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9790 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9791 GFC_PREFIX ("lock_type"));
9793 lock_type
= symtree
->n
.sym
;
9796 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9799 lock_type
= symtree
->n
.sym
;
9800 lock_type
->attr
.flavor
= FL_DERIVED
;
9801 lock_type
->attr
.zero_comp
= 1;
9802 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9803 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9806 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9807 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9810 code
->resolved_sym
= symtree
->n
.sym
;
9811 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9812 symtree
->n
.sym
->attr
.referenced
= 1;
9813 symtree
->n
.sym
->attr
.artificial
= 1;
9814 symtree
->n
.sym
->attr
.codimension
= 1;
9815 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9816 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9817 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9818 symtree
->n
.sym
->as
->corank
= 1;
9819 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9820 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9821 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9823 gfc_commit_symbols();
9828 resolve_sync (gfc_code
*code
)
9830 /* Check imageset. The * case matches expr1 == NULL. */
9833 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9834 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9835 "INTEGER expression", &code
->expr1
->where
);
9836 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9837 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9838 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9839 &code
->expr1
->where
);
9840 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9841 && gfc_simplify_expr (code
->expr1
, 0))
9843 gfc_constructor
*cons
;
9844 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9845 for (; cons
; cons
= gfc_constructor_next (cons
))
9846 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9847 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9848 gfc_error ("Imageset argument at %L must between 1 and "
9849 "num_images()", &cons
->expr
->where
);
9854 gfc_resolve_expr (code
->expr2
);
9856 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9857 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9858 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9859 &code
->expr2
->where
);
9862 gfc_resolve_expr (code
->expr3
);
9864 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9865 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9866 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9867 &code
->expr3
->where
);
9871 /* Given a branch to a label, see if the branch is conforming.
9872 The code node describes where the branch is located. */
9875 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9882 /* Step one: is this a valid branching target? */
9884 if (label
->defined
== ST_LABEL_UNKNOWN
)
9886 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9891 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9893 gfc_error ("Statement at %L is not a valid branch target statement "
9894 "for the branch statement at %L", &label
->where
, &code
->loc
);
9898 /* Step two: make sure this branch is not a branch to itself ;-) */
9900 if (code
->here
== label
)
9903 "Branch at %L may result in an infinite loop", &code
->loc
);
9907 /* Step three: See if the label is in the same block as the
9908 branching statement. The hard work has been done by setting up
9909 the bitmap reachable_labels. */
9911 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9913 /* Check now whether there is a CRITICAL construct; if so, check
9914 whether the label is still visible outside of the CRITICAL block,
9915 which is invalid. */
9916 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9918 if (stack
->current
->op
== EXEC_CRITICAL
9919 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9920 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9921 "label at %L", &code
->loc
, &label
->where
);
9922 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9923 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9924 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9925 "for label at %L", &code
->loc
, &label
->where
);
9931 /* Step four: If we haven't found the label in the bitmap, it may
9932 still be the label of the END of the enclosing block, in which
9933 case we find it by going up the code_stack. */
9935 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9937 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9939 if (stack
->current
->op
== EXEC_CRITICAL
)
9941 /* Note: A label at END CRITICAL does not leave the CRITICAL
9942 construct as END CRITICAL is still part of it. */
9943 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9944 " at %L", &code
->loc
, &label
->where
);
9947 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9949 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9950 "label at %L", &code
->loc
, &label
->where
);
9957 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9961 /* The label is not in an enclosing block, so illegal. This was
9962 allowed in Fortran 66, so we allow it as extension. No
9963 further checks are necessary in this case. */
9964 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9965 "as the GOTO statement at %L", &label
->where
,
9971 /* Check whether EXPR1 has the same shape as EXPR2. */
9974 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9976 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9977 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9978 bool result
= false;
9981 /* Compare the rank. */
9982 if (expr1
->rank
!= expr2
->rank
)
9985 /* Compare the size of each dimension. */
9986 for (i
=0; i
<expr1
->rank
; i
++)
9988 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9991 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9994 if (mpz_cmp (shape
[i
], shape2
[i
]))
9998 /* When either of the two expression is an assumed size array, we
9999 ignore the comparison of dimension sizes. */
10004 gfc_clear_shape (shape
, i
);
10005 gfc_clear_shape (shape2
, i
);
10010 /* Check whether a WHERE assignment target or a WHERE mask expression
10011 has the same shape as the outmost WHERE mask expression. */
10014 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
10018 gfc_expr
*e
= NULL
;
10020 cblock
= code
->block
;
10022 /* Store the first WHERE mask-expr of the WHERE statement or construct.
10023 In case of nested WHERE, only the outmost one is stored. */
10024 if (mask
== NULL
) /* outmost WHERE */
10026 else /* inner WHERE */
10033 /* Check if the mask-expr has a consistent shape with the
10034 outmost WHERE mask-expr. */
10035 if (!resolve_where_shape (cblock
->expr1
, e
))
10036 gfc_error ("WHERE mask at %L has inconsistent shape",
10037 &cblock
->expr1
->where
);
10040 /* the assignment statement of a WHERE statement, or the first
10041 statement in where-body-construct of a WHERE construct */
10042 cnext
= cblock
->next
;
10047 /* WHERE assignment statement */
10050 /* Check shape consistent for WHERE assignment target. */
10051 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10052 gfc_error ("WHERE assignment target at %L has "
10053 "inconsistent shape", &cnext
->expr1
->where
);
10057 case EXEC_ASSIGN_CALL
:
10058 resolve_call (cnext
);
10059 if (!cnext
->resolved_sym
->attr
.elemental
)
10060 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10061 &cnext
->ext
.actual
->expr
->where
);
10064 /* WHERE or WHERE construct is part of a where-body-construct */
10066 resolve_where (cnext
, e
);
10070 gfc_error ("Unsupported statement inside WHERE at %L",
10073 /* the next statement within the same where-body-construct */
10074 cnext
= cnext
->next
;
10076 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10077 cblock
= cblock
->block
;
10082 /* Resolve assignment in FORALL construct.
10083 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10084 FORALL index variables. */
10087 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10091 for (n
= 0; n
< nvar
; n
++)
10093 gfc_symbol
*forall_index
;
10095 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10097 /* Check whether the assignment target is one of the FORALL index
10099 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10100 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10101 gfc_error ("Assignment to a FORALL index variable at %L",
10102 &code
->expr1
->where
);
10105 /* If one of the FORALL index variables doesn't appear in the
10106 assignment variable, then there could be a many-to-one
10107 assignment. Emit a warning rather than an error because the
10108 mask could be resolving this problem. */
10109 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10110 gfc_warning (0, "The FORALL with index %qs is not used on the "
10111 "left side of the assignment at %L and so might "
10112 "cause multiple assignment to this object",
10113 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10119 /* Resolve WHERE statement in FORALL construct. */
10122 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10123 gfc_expr
**var_expr
)
10128 cblock
= code
->block
;
10131 /* the assignment statement of a WHERE statement, or the first
10132 statement in where-body-construct of a WHERE construct */
10133 cnext
= cblock
->next
;
10138 /* WHERE assignment statement */
10140 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10143 /* WHERE operator assignment statement */
10144 case EXEC_ASSIGN_CALL
:
10145 resolve_call (cnext
);
10146 if (!cnext
->resolved_sym
->attr
.elemental
)
10147 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10148 &cnext
->ext
.actual
->expr
->where
);
10151 /* WHERE or WHERE construct is part of a where-body-construct */
10153 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10157 gfc_error ("Unsupported statement inside WHERE at %L",
10160 /* the next statement within the same where-body-construct */
10161 cnext
= cnext
->next
;
10163 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10164 cblock
= cblock
->block
;
10169 /* Traverse the FORALL body to check whether the following errors exist:
10170 1. For assignment, check if a many-to-one assignment happens.
10171 2. For WHERE statement, check the WHERE body to see if there is any
10172 many-to-one assignment. */
10175 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10179 c
= code
->block
->next
;
10185 case EXEC_POINTER_ASSIGN
:
10186 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10189 case EXEC_ASSIGN_CALL
:
10193 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10194 there is no need to handle it here. */
10198 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10203 /* The next statement in the FORALL body. */
10209 /* Counts the number of iterators needed inside a forall construct, including
10210 nested forall constructs. This is used to allocate the needed memory
10211 in gfc_resolve_forall. */
10214 gfc_count_forall_iterators (gfc_code
*code
)
10216 int max_iters
, sub_iters
, current_iters
;
10217 gfc_forall_iterator
*fa
;
10219 gcc_assert(code
->op
== EXEC_FORALL
);
10223 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10226 code
= code
->block
->next
;
10230 if (code
->op
== EXEC_FORALL
)
10232 sub_iters
= gfc_count_forall_iterators (code
);
10233 if (sub_iters
> max_iters
)
10234 max_iters
= sub_iters
;
10239 return current_iters
+ max_iters
;
10243 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10244 gfc_resolve_forall_body to resolve the FORALL body. */
10247 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10249 static gfc_expr
**var_expr
;
10250 static int total_var
= 0;
10251 static int nvar
= 0;
10252 int i
, old_nvar
, tmp
;
10253 gfc_forall_iterator
*fa
;
10257 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10260 /* Start to resolve a FORALL construct */
10261 if (forall_save
== 0)
10263 /* Count the total number of FORALL indices in the nested FORALL
10264 construct in order to allocate the VAR_EXPR with proper size. */
10265 total_var
= gfc_count_forall_iterators (code
);
10267 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10268 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10271 /* The information about FORALL iterator, including FORALL indices start, end
10272 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10273 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10275 /* Fortran 20008: C738 (R753). */
10276 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10278 gfc_error ("FORALL index-name at %L must be a scalar variable "
10279 "of type integer", &fa
->var
->where
);
10283 /* Check if any outer FORALL index name is the same as the current
10285 for (i
= 0; i
< nvar
; i
++)
10287 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10288 gfc_error ("An outer FORALL construct already has an index "
10289 "with this name %L", &fa
->var
->where
);
10292 /* Record the current FORALL index. */
10293 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10297 /* No memory leak. */
10298 gcc_assert (nvar
<= total_var
);
10301 /* Resolve the FORALL body. */
10302 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10304 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10305 gfc_resolve_blocks (code
->block
, ns
);
10309 /* Free only the VAR_EXPRs allocated in this frame. */
10310 for (i
= nvar
; i
< tmp
; i
++)
10311 gfc_free_expr (var_expr
[i
]);
10315 /* We are in the outermost FORALL construct. */
10316 gcc_assert (forall_save
== 0);
10318 /* VAR_EXPR is not needed any more. */
10325 /* Resolve a BLOCK construct statement. */
10328 resolve_block_construct (gfc_code
* code
)
10330 /* Resolve the BLOCK's namespace. */
10331 gfc_resolve (code
->ext
.block
.ns
);
10333 /* For an ASSOCIATE block, the associations (and their targets) are already
10334 resolved during resolve_symbol. */
10338 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10342 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10346 for (; b
; b
= b
->block
)
10348 t
= gfc_resolve_expr (b
->expr1
);
10349 if (!gfc_resolve_expr (b
->expr2
))
10355 if (t
&& b
->expr1
!= NULL
10356 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10357 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10363 && b
->expr1
!= NULL
10364 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10365 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10370 resolve_branch (b
->label1
, b
);
10374 resolve_block_construct (b
);
10378 case EXEC_SELECT_TYPE
:
10381 case EXEC_DO_WHILE
:
10382 case EXEC_DO_CONCURRENT
:
10383 case EXEC_CRITICAL
:
10386 case EXEC_IOLENGTH
:
10390 case EXEC_OMP_ATOMIC
:
10391 case EXEC_OACC_ATOMIC
:
10393 gfc_omp_atomic_op aop
10394 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10396 /* Verify this before calling gfc_resolve_code, which might
10398 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10399 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10400 && b
->next
->next
== NULL
)
10401 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10402 && b
->next
->next
!= NULL
10403 && b
->next
->next
->op
== EXEC_ASSIGN
10404 && b
->next
->next
->next
== NULL
));
10408 case EXEC_OACC_PARALLEL_LOOP
:
10409 case EXEC_OACC_PARALLEL
:
10410 case EXEC_OACC_KERNELS_LOOP
:
10411 case EXEC_OACC_KERNELS
:
10412 case EXEC_OACC_DATA
:
10413 case EXEC_OACC_HOST_DATA
:
10414 case EXEC_OACC_LOOP
:
10415 case EXEC_OACC_UPDATE
:
10416 case EXEC_OACC_WAIT
:
10417 case EXEC_OACC_CACHE
:
10418 case EXEC_OACC_ENTER_DATA
:
10419 case EXEC_OACC_EXIT_DATA
:
10420 case EXEC_OACC_ROUTINE
:
10421 case EXEC_OMP_CRITICAL
:
10422 case EXEC_OMP_DISTRIBUTE
:
10423 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10424 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10425 case EXEC_OMP_DISTRIBUTE_SIMD
:
10427 case EXEC_OMP_DO_SIMD
:
10428 case EXEC_OMP_MASTER
:
10429 case EXEC_OMP_ORDERED
:
10430 case EXEC_OMP_PARALLEL
:
10431 case EXEC_OMP_PARALLEL_DO
:
10432 case EXEC_OMP_PARALLEL_DO_SIMD
:
10433 case EXEC_OMP_PARALLEL_SECTIONS
:
10434 case EXEC_OMP_PARALLEL_WORKSHARE
:
10435 case EXEC_OMP_SECTIONS
:
10436 case EXEC_OMP_SIMD
:
10437 case EXEC_OMP_SINGLE
:
10438 case EXEC_OMP_TARGET
:
10439 case EXEC_OMP_TARGET_DATA
:
10440 case EXEC_OMP_TARGET_ENTER_DATA
:
10441 case EXEC_OMP_TARGET_EXIT_DATA
:
10442 case EXEC_OMP_TARGET_PARALLEL
:
10443 case EXEC_OMP_TARGET_PARALLEL_DO
:
10444 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10445 case EXEC_OMP_TARGET_SIMD
:
10446 case EXEC_OMP_TARGET_TEAMS
:
10447 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10448 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10449 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10450 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10451 case EXEC_OMP_TARGET_UPDATE
:
10452 case EXEC_OMP_TASK
:
10453 case EXEC_OMP_TASKGROUP
:
10454 case EXEC_OMP_TASKLOOP
:
10455 case EXEC_OMP_TASKLOOP_SIMD
:
10456 case EXEC_OMP_TASKWAIT
:
10457 case EXEC_OMP_TASKYIELD
:
10458 case EXEC_OMP_TEAMS
:
10459 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10460 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10461 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10462 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10463 case EXEC_OMP_WORKSHARE
:
10467 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10470 gfc_resolve_code (b
->next
, ns
);
10475 /* Does everything to resolve an ordinary assignment. Returns true
10476 if this is an interface assignment. */
10478 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10485 symbol_attribute attr
;
10487 if (gfc_extend_assign (code
, ns
))
10491 if (code
->op
== EXEC_ASSIGN_CALL
)
10493 lhs
= code
->ext
.actual
->expr
;
10494 rhsptr
= &code
->ext
.actual
->next
->expr
;
10498 gfc_actual_arglist
* args
;
10499 gfc_typebound_proc
* tbp
;
10501 gcc_assert (code
->op
== EXEC_COMPCALL
);
10503 args
= code
->expr1
->value
.compcall
.actual
;
10505 rhsptr
= &args
->next
->expr
;
10507 tbp
= code
->expr1
->value
.compcall
.tbp
;
10508 gcc_assert (!tbp
->is_generic
);
10511 /* Make a temporary rhs when there is a default initializer
10512 and rhs is the same symbol as the lhs. */
10513 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10514 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10515 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10516 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10517 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10525 /* Handle the case of a BOZ literal on the RHS. */
10526 if (rhs
->ts
.type
== BT_BOZ
)
10528 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
10529 "statement value nor an actual argument of "
10530 "INT/REAL/DBLE/CMPLX intrinsic subprogram",
10534 switch (lhs
->ts
.type
)
10537 if (!gfc_boz2int (rhs
, lhs
->ts
.kind
))
10541 if (!gfc_boz2real (rhs
, lhs
->ts
.kind
))
10545 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs
->where
);
10550 if (lhs
->ts
.type
== BT_CHARACTER
&& warn_character_truncation
)
10552 HOST_WIDE_INT llen
= 0, rlen
= 0;
10553 if (lhs
->ts
.u
.cl
!= NULL
10554 && lhs
->ts
.u
.cl
->length
!= NULL
10555 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10556 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10558 if (rhs
->expr_type
== EXPR_CONSTANT
)
10559 rlen
= rhs
->value
.character
.length
;
10561 else if (rhs
->ts
.u
.cl
!= NULL
10562 && rhs
->ts
.u
.cl
->length
!= NULL
10563 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10564 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10566 if (rlen
&& llen
&& rlen
> llen
)
10567 gfc_warning_now (OPT_Wcharacter_truncation
,
10568 "CHARACTER expression will be truncated "
10569 "in assignment (%ld/%ld) at %L",
10570 (long) llen
, (long) rlen
, &code
->loc
);
10573 /* Ensure that a vector index expression for the lvalue is evaluated
10574 to a temporary if the lvalue symbol is referenced in it. */
10577 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10578 if (ref
->type
== REF_ARRAY
)
10580 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10581 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10582 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10583 ref
->u
.ar
.start
[n
]))
10585 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10589 if (gfc_pure (NULL
))
10591 if (lhs
->ts
.type
== BT_DERIVED
10592 && lhs
->expr_type
== EXPR_VARIABLE
10593 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10594 && rhs
->expr_type
== EXPR_VARIABLE
10595 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10596 || gfc_is_coindexed (rhs
)))
10598 /* F2008, C1283. */
10599 if (gfc_is_coindexed (rhs
))
10600 gfc_error ("Coindexed expression at %L is assigned to "
10601 "a derived type variable with a POINTER "
10602 "component in a PURE procedure",
10605 gfc_error ("The impure variable at %L is assigned to "
10606 "a derived type variable with a POINTER "
10607 "component in a PURE procedure (12.6)",
10612 /* Fortran 2008, C1283. */
10613 if (gfc_is_coindexed (lhs
))
10615 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10616 "procedure", &rhs
->where
);
10621 if (gfc_implicit_pure (NULL
))
10623 if (lhs
->expr_type
== EXPR_VARIABLE
10624 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10625 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10626 gfc_unset_implicit_pure (NULL
);
10628 if (lhs
->ts
.type
== BT_DERIVED
10629 && lhs
->expr_type
== EXPR_VARIABLE
10630 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10631 && rhs
->expr_type
== EXPR_VARIABLE
10632 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10633 || gfc_is_coindexed (rhs
)))
10634 gfc_unset_implicit_pure (NULL
);
10636 /* Fortran 2008, C1283. */
10637 if (gfc_is_coindexed (lhs
))
10638 gfc_unset_implicit_pure (NULL
);
10641 /* F2008, 7.2.1.2. */
10642 attr
= gfc_expr_attr (lhs
);
10643 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10645 if (attr
.codimension
)
10647 gfc_error ("Assignment to polymorphic coarray at %L is not "
10648 "permitted", &lhs
->where
);
10651 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10652 "polymorphic variable at %L", &lhs
->where
))
10654 if (!flag_realloc_lhs
)
10656 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10657 "requires %<-frealloc-lhs%>", &lhs
->where
);
10661 else if (lhs
->ts
.type
== BT_CLASS
)
10663 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10664 "assignment at %L - check that there is a matching specific "
10665 "subroutine for '=' operator", &lhs
->where
);
10669 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10671 /* F2008, Section 7.2.1.2. */
10672 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10674 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10675 "component in assignment at %L", &lhs
->where
);
10679 /* Assign the 'data' of a class object to a derived type. */
10680 if (lhs
->ts
.type
== BT_DERIVED
10681 && rhs
->ts
.type
== BT_CLASS
10682 && rhs
->expr_type
!= EXPR_ARRAY
)
10683 gfc_add_data_component (rhs
);
10685 /* Make sure there is a vtable and, in particular, a _copy for the
10687 if (UNLIMITED_POLY (lhs
) && lhs
->rank
&& rhs
->ts
.type
!= BT_CLASS
)
10688 gfc_find_vtab (&rhs
->ts
);
10690 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10692 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10693 && code
->expr2
->value
.function
.isym
10694 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10695 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10696 && !gfc_expr_attr (rhs
).allocatable
10697 && !gfc_has_vector_subscript (rhs
)));
10699 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10701 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10702 Additionally, insert this code when the RHS is a CAF as we then use the
10703 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10704 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10705 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10707 if (caf_convert_to_send
)
10709 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10710 && code
->expr2
->value
.function
.isym
10711 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10712 remove_caf_get_intrinsic (code
->expr2
);
10713 code
->op
= EXEC_CALL
;
10714 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10715 code
->resolved_sym
= code
->symtree
->n
.sym
;
10716 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10717 code
->resolved_sym
->attr
.intrinsic
= 1;
10718 code
->resolved_sym
->attr
.subroutine
= 1;
10719 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10720 gfc_commit_symbol (code
->resolved_sym
);
10721 code
->ext
.actual
= gfc_get_actual_arglist ();
10722 code
->ext
.actual
->expr
= lhs
;
10723 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10724 code
->ext
.actual
->next
->expr
= rhs
;
10725 code
->expr1
= NULL
;
10726 code
->expr2
= NULL
;
10733 /* Add a component reference onto an expression. */
10736 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10741 ref
= &((*ref
)->next
);
10742 *ref
= gfc_get_ref ();
10743 (*ref
)->type
= REF_COMPONENT
;
10744 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10745 (*ref
)->u
.c
.component
= c
;
10748 /* Add a full array ref, as necessary. */
10751 gfc_add_full_array_ref (e
, c
->as
);
10752 e
->rank
= c
->as
->rank
;
10757 /* Build an assignment. Keep the argument 'op' for future use, so that
10758 pointer assignments can be made. */
10761 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10762 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10764 gfc_code
*this_code
;
10766 this_code
= gfc_get_code (op
);
10767 this_code
->next
= NULL
;
10768 this_code
->expr1
= gfc_copy_expr (expr1
);
10769 this_code
->expr2
= gfc_copy_expr (expr2
);
10770 this_code
->loc
= loc
;
10771 if (comp1
&& comp2
)
10773 add_comp_ref (this_code
->expr1
, comp1
);
10774 add_comp_ref (this_code
->expr2
, comp2
);
10781 /* Makes a temporary variable expression based on the characteristics of
10782 a given variable expression. */
10785 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10787 static int serial
= 0;
10788 char name
[GFC_MAX_SYMBOL_LEN
];
10790 gfc_array_spec
*as
;
10791 gfc_array_ref
*aref
;
10794 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10795 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10796 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10798 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
10799 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
10801 e
->value
.character
.length
);
10807 /* Obtain the arrayspec for the temporary. */
10808 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10809 && e
->expr_type
!= EXPR_FUNCTION
10810 && e
->expr_type
!= EXPR_OP
)
10812 aref
= gfc_find_array_ref (e
);
10813 if (e
->expr_type
== EXPR_VARIABLE
10814 && e
->symtree
->n
.sym
->as
== aref
->as
)
10818 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10819 if (ref
->type
== REF_COMPONENT
10820 && ref
->u
.c
.component
->as
== aref
->as
)
10828 /* Add the attributes and the arrayspec to the temporary. */
10829 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10830 tmp
->n
.sym
->attr
.function
= 0;
10831 tmp
->n
.sym
->attr
.result
= 0;
10832 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10833 tmp
->n
.sym
->attr
.dummy
= 0;
10834 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
10838 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10841 if (as
->type
== AS_DEFERRED
)
10842 tmp
->n
.sym
->attr
.allocatable
= 1;
10844 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10845 || e
->expr_type
== EXPR_FUNCTION
10846 || e
->expr_type
== EXPR_OP
))
10848 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10849 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10850 tmp
->n
.sym
->as
->rank
= e
->rank
;
10851 tmp
->n
.sym
->attr
.allocatable
= 1;
10852 tmp
->n
.sym
->attr
.dimension
= 1;
10855 tmp
->n
.sym
->attr
.dimension
= 0;
10857 gfc_set_sym_referenced (tmp
->n
.sym
);
10858 gfc_commit_symbol (tmp
->n
.sym
);
10859 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10861 /* Should the lhs be a section, use its array ref for the
10862 temporary expression. */
10863 if (aref
&& aref
->type
!= AR_FULL
)
10865 gfc_free_ref_list (e
->ref
);
10866 e
->ref
= gfc_copy_ref (ref
);
10872 /* Add one line of code to the code chain, making sure that 'head' and
10873 'tail' are appropriately updated. */
10876 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10878 gcc_assert (this_code
);
10880 *head
= *tail
= *this_code
;
10882 *tail
= gfc_append_code (*tail
, *this_code
);
10887 /* Counts the potential number of part array references that would
10888 result from resolution of typebound defined assignments. */
10891 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10894 int c_depth
= 0, t_depth
;
10896 for (c
= derived
->components
; c
; c
= c
->next
)
10898 if ((!gfc_bt_struct (c
->ts
.type
)
10900 || c
->attr
.allocatable
10901 || c
->attr
.proc_pointer_comp
10902 || c
->attr
.class_pointer
10903 || c
->attr
.proc_pointer
)
10904 && !c
->attr
.defined_assign_comp
)
10907 if (c
->as
&& c_depth
== 0)
10910 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10911 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10916 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10918 return depth
+ c_depth
;
10922 /* Implement 7.2.1.3 of the F08 standard:
10923 "An intrinsic assignment where the variable is of derived type is
10924 performed as if each component of the variable were assigned from the
10925 corresponding component of expr using pointer assignment (7.2.2) for
10926 each pointer component, defined assignment for each nonpointer
10927 nonallocatable component of a type that has a type-bound defined
10928 assignment consistent with the component, intrinsic assignment for
10929 each other nonpointer nonallocatable component, ..."
10931 The pointer assignments are taken care of by the intrinsic
10932 assignment of the structure itself. This function recursively adds
10933 defined assignments where required. The recursion is accomplished
10934 by calling gfc_resolve_code.
10936 When the lhs in a defined assignment has intent INOUT, we need a
10937 temporary for the lhs. In pseudo-code:
10939 ! Only call function lhs once.
10940 if (lhs is not a constant or an variable)
10943 ! Do the intrinsic assignment
10945 ! Now do the defined assignments
10946 do over components with typebound defined assignment [%cmp]
10947 #if one component's assignment procedure is INOUT
10949 #if expr2 non-variable
10955 t1%cmp {defined=} expr2%cmp
10961 expr1%cmp {defined=} expr2%cmp
10965 /* The temporary assignments have to be put on top of the additional
10966 code to avoid the result being changed by the intrinsic assignment.
10968 static int component_assignment_level
= 0;
10969 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10972 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10974 gfc_component
*comp1
, *comp2
;
10975 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10977 int error_count
, depth
;
10979 gfc_get_errors (NULL
, &error_count
);
10981 /* Filter out continuing processing after an error. */
10983 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10984 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10987 /* TODO: Handle more than one part array reference in assignments. */
10988 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10989 (*code
)->expr1
->rank
? 1 : 0);
10992 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10993 "done because multiple part array references would "
10994 "occur in intermediate expressions.", &(*code
)->loc
);
10998 component_assignment_level
++;
11000 /* Create a temporary so that functions get called only once. */
11001 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
11002 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
11004 gfc_expr
*tmp_expr
;
11006 /* Assign the rhs to the temporary. */
11007 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11008 this_code
= build_assignment (EXEC_ASSIGN
,
11009 tmp_expr
, (*code
)->expr2
,
11010 NULL
, NULL
, (*code
)->loc
);
11011 /* Add the code and substitute the rhs expression. */
11012 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
11013 gfc_free_expr ((*code
)->expr2
);
11014 (*code
)->expr2
= tmp_expr
;
11017 /* Do the intrinsic assignment. This is not needed if the lhs is one
11018 of the temporaries generated here, since the intrinsic assignment
11019 to the final result already does this. */
11020 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
11022 this_code
= build_assignment (EXEC_ASSIGN
,
11023 (*code
)->expr1
, (*code
)->expr2
,
11024 NULL
, NULL
, (*code
)->loc
);
11025 add_code_to_chain (&this_code
, &head
, &tail
);
11028 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
11029 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
11032 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
11034 bool inout
= false;
11036 /* The intrinsic assignment does the right thing for pointers
11037 of all kinds and allocatable components. */
11038 if (!gfc_bt_struct (comp1
->ts
.type
)
11039 || comp1
->attr
.pointer
11040 || comp1
->attr
.allocatable
11041 || comp1
->attr
.proc_pointer_comp
11042 || comp1
->attr
.class_pointer
11043 || comp1
->attr
.proc_pointer
)
11046 /* Make an assigment for this component. */
11047 this_code
= build_assignment (EXEC_ASSIGN
,
11048 (*code
)->expr1
, (*code
)->expr2
,
11049 comp1
, comp2
, (*code
)->loc
);
11051 /* Convert the assignment if there is a defined assignment for
11052 this type. Otherwise, using the call from gfc_resolve_code,
11053 recurse into its components. */
11054 gfc_resolve_code (this_code
, ns
);
11056 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11058 gfc_formal_arglist
*dummy_args
;
11060 /* Check that there is a typebound defined assignment. If not,
11061 then this must be a module defined assignment. We cannot
11062 use the defined_assign_comp attribute here because it must
11063 be this derived type that has the defined assignment and not
11065 if (!(comp1
->ts
.u
.derived
->f2k_derived
11066 && comp1
->ts
.u
.derived
->f2k_derived
11067 ->tb_op
[INTRINSIC_ASSIGN
]))
11069 gfc_free_statements (this_code
);
11074 /* If the first argument of the subroutine has intent INOUT
11075 a temporary must be generated and used instead. */
11076 rsym
= this_code
->resolved_sym
;
11077 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11079 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
11081 gfc_code
*temp_code
;
11084 /* Build the temporary required for the assignment and put
11085 it at the head of the generated code. */
11088 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
11089 temp_code
= build_assignment (EXEC_ASSIGN
,
11090 t1
, (*code
)->expr1
,
11091 NULL
, NULL
, (*code
)->loc
);
11093 /* For allocatable LHS, check whether it is allocated. Note
11094 that allocatable components with defined assignment are
11095 not yet support. See PR 57696. */
11096 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11100 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11101 block
= gfc_get_code (EXEC_IF
);
11102 block
->block
= gfc_get_code (EXEC_IF
);
11103 block
->block
->expr1
11104 = gfc_build_intrinsic_call (ns
,
11105 GFC_ISYM_ALLOCATED
, "allocated",
11106 (*code
)->loc
, 1, e
);
11107 block
->block
->next
= temp_code
;
11110 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11113 /* Replace the first actual arg with the component of the
11115 gfc_free_expr (this_code
->ext
.actual
->expr
);
11116 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11117 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11119 /* If the LHS variable is allocatable and wasn't allocated and
11120 the temporary is allocatable, pointer assign the address of
11121 the freshly allocated LHS to the temporary. */
11122 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11123 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11128 cond
= gfc_get_expr ();
11129 cond
->ts
.type
= BT_LOGICAL
;
11130 cond
->ts
.kind
= gfc_default_logical_kind
;
11131 cond
->expr_type
= EXPR_OP
;
11132 cond
->where
= (*code
)->loc
;
11133 cond
->value
.op
.op
= INTRINSIC_NOT
;
11134 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11135 GFC_ISYM_ALLOCATED
, "allocated",
11136 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11137 block
= gfc_get_code (EXEC_IF
);
11138 block
->block
= gfc_get_code (EXEC_IF
);
11139 block
->block
->expr1
= cond
;
11140 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11141 t1
, (*code
)->expr1
,
11142 NULL
, NULL
, (*code
)->loc
);
11143 add_code_to_chain (&block
, &head
, &tail
);
11147 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11149 /* Don't add intrinsic assignments since they are already
11150 effected by the intrinsic assignment of the structure. */
11151 gfc_free_statements (this_code
);
11156 add_code_to_chain (&this_code
, &head
, &tail
);
11160 /* Transfer the value to the final result. */
11161 this_code
= build_assignment (EXEC_ASSIGN
,
11162 (*code
)->expr1
, t1
,
11163 comp1
, comp2
, (*code
)->loc
);
11164 add_code_to_chain (&this_code
, &head
, &tail
);
11168 /* Put the temporary assignments at the top of the generated code. */
11169 if (tmp_head
&& component_assignment_level
== 1)
11171 gfc_append_code (tmp_head
, head
);
11173 tmp_head
= tmp_tail
= NULL
;
11176 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11177 // not accidentally deallocated. Hence, nullify t1.
11178 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11179 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11185 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11186 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11187 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11188 block
= gfc_get_code (EXEC_IF
);
11189 block
->block
= gfc_get_code (EXEC_IF
);
11190 block
->block
->expr1
= cond
;
11191 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11192 t1
, gfc_get_null_expr (&(*code
)->loc
),
11193 NULL
, NULL
, (*code
)->loc
);
11194 gfc_append_code (tail
, block
);
11198 /* Now attach the remaining code chain to the input code. Step on
11199 to the end of the new code since resolution is complete. */
11200 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11201 tail
->next
= (*code
)->next
;
11202 /* Overwrite 'code' because this would place the intrinsic assignment
11203 before the temporary for the lhs is created. */
11204 gfc_free_expr ((*code
)->expr1
);
11205 gfc_free_expr ((*code
)->expr2
);
11211 component_assignment_level
--;
11215 /* F2008: Pointer function assignments are of the form:
11216 ptr_fcn (args) = expr
11217 This function breaks these assignments into two statements:
11218 temporary_pointer => ptr_fcn(args)
11219 temporary_pointer = expr */
11222 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11224 gfc_expr
*tmp_ptr_expr
;
11225 gfc_code
*this_code
;
11226 gfc_component
*comp
;
11229 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11232 /* Even if standard does not support this feature, continue to build
11233 the two statements to avoid upsetting frontend_passes.c. */
11234 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11235 "%L", &(*code
)->loc
);
11237 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11240 s
= comp
->ts
.interface
;
11242 s
= (*code
)->expr1
->symtree
->n
.sym
;
11244 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11246 gfc_error ("The function result on the lhs of the assignment at "
11247 "%L must have the pointer attribute.",
11248 &(*code
)->expr1
->where
);
11249 (*code
)->op
= EXEC_NOP
;
11253 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
11255 /* get_temp_from_expression is set up for ordinary assignments. To that
11256 end, where array bounds are not known, arrays are made allocatable.
11257 Change the temporary to a pointer here. */
11258 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11259 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11260 tmp_ptr_expr
->where
= (*code
)->loc
;
11262 this_code
= build_assignment (EXEC_ASSIGN
,
11263 tmp_ptr_expr
, (*code
)->expr2
,
11264 NULL
, NULL
, (*code
)->loc
);
11265 this_code
->next
= (*code
)->next
;
11266 (*code
)->next
= this_code
;
11267 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11268 (*code
)->expr2
= (*code
)->expr1
;
11269 (*code
)->expr1
= tmp_ptr_expr
;
11275 /* Deferred character length assignments from an operator expression
11276 require a temporary because the character length of the lhs can
11277 change in the course of the assignment. */
11280 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11282 gfc_expr
*tmp_expr
;
11283 gfc_code
*this_code
;
11285 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11286 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11287 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11290 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11293 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
11296 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11297 tmp_expr
->where
= (*code
)->loc
;
11299 /* A new charlen is required to ensure that the variable string
11300 length is different to that of the original lhs. */
11301 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11302 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11303 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11304 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11306 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11308 this_code
= build_assignment (EXEC_ASSIGN
,
11310 gfc_copy_expr (tmp_expr
),
11311 NULL
, NULL
, (*code
)->loc
);
11313 (*code
)->expr1
= tmp_expr
;
11315 this_code
->next
= (*code
)->next
;
11316 (*code
)->next
= this_code
;
11322 /* Given a block of code, recursively resolve everything pointed to by this
11326 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11328 int omp_workshare_save
;
11329 int forall_save
, do_concurrent_save
;
11333 frame
.prev
= cs_base
;
11337 find_reachable_labels (code
);
11339 for (; code
; code
= code
->next
)
11341 frame
.current
= code
;
11342 forall_save
= forall_flag
;
11343 do_concurrent_save
= gfc_do_concurrent_flag
;
11345 if (code
->op
== EXEC_FORALL
)
11348 gfc_resolve_forall (code
, ns
, forall_save
);
11351 else if (code
->block
)
11353 omp_workshare_save
= -1;
11356 case EXEC_OACC_PARALLEL_LOOP
:
11357 case EXEC_OACC_PARALLEL
:
11358 case EXEC_OACC_KERNELS_LOOP
:
11359 case EXEC_OACC_KERNELS
:
11360 case EXEC_OACC_DATA
:
11361 case EXEC_OACC_HOST_DATA
:
11362 case EXEC_OACC_LOOP
:
11363 gfc_resolve_oacc_blocks (code
, ns
);
11365 case EXEC_OMP_PARALLEL_WORKSHARE
:
11366 omp_workshare_save
= omp_workshare_flag
;
11367 omp_workshare_flag
= 1;
11368 gfc_resolve_omp_parallel_blocks (code
, ns
);
11370 case EXEC_OMP_PARALLEL
:
11371 case EXEC_OMP_PARALLEL_DO
:
11372 case EXEC_OMP_PARALLEL_DO_SIMD
:
11373 case EXEC_OMP_PARALLEL_SECTIONS
:
11374 case EXEC_OMP_TARGET_PARALLEL
:
11375 case EXEC_OMP_TARGET_PARALLEL_DO
:
11376 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11377 case EXEC_OMP_TARGET_TEAMS
:
11378 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11379 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11380 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11381 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11382 case EXEC_OMP_TASK
:
11383 case EXEC_OMP_TASKLOOP
:
11384 case EXEC_OMP_TASKLOOP_SIMD
:
11385 case EXEC_OMP_TEAMS
:
11386 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11387 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11388 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11389 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11390 omp_workshare_save
= omp_workshare_flag
;
11391 omp_workshare_flag
= 0;
11392 gfc_resolve_omp_parallel_blocks (code
, ns
);
11394 case EXEC_OMP_DISTRIBUTE
:
11395 case EXEC_OMP_DISTRIBUTE_SIMD
:
11397 case EXEC_OMP_DO_SIMD
:
11398 case EXEC_OMP_SIMD
:
11399 case EXEC_OMP_TARGET_SIMD
:
11400 gfc_resolve_omp_do_blocks (code
, ns
);
11402 case EXEC_SELECT_TYPE
:
11403 /* Blocks are handled in resolve_select_type because we have
11404 to transform the SELECT TYPE into ASSOCIATE first. */
11406 case EXEC_DO_CONCURRENT
:
11407 gfc_do_concurrent_flag
= 1;
11408 gfc_resolve_blocks (code
->block
, ns
);
11409 gfc_do_concurrent_flag
= 2;
11411 case EXEC_OMP_WORKSHARE
:
11412 omp_workshare_save
= omp_workshare_flag
;
11413 omp_workshare_flag
= 1;
11416 gfc_resolve_blocks (code
->block
, ns
);
11420 if (omp_workshare_save
!= -1)
11421 omp_workshare_flag
= omp_workshare_save
;
11425 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11426 t
= gfc_resolve_expr (code
->expr1
);
11427 forall_flag
= forall_save
;
11428 gfc_do_concurrent_flag
= do_concurrent_save
;
11430 if (!gfc_resolve_expr (code
->expr2
))
11433 if (code
->op
== EXEC_ALLOCATE
11434 && !gfc_resolve_expr (code
->expr3
))
11440 case EXEC_END_BLOCK
:
11441 case EXEC_END_NESTED_BLOCK
:
11445 case EXEC_ERROR_STOP
:
11447 case EXEC_CONTINUE
:
11449 case EXEC_ASSIGN_CALL
:
11452 case EXEC_CRITICAL
:
11453 resolve_critical (code
);
11456 case EXEC_SYNC_ALL
:
11457 case EXEC_SYNC_IMAGES
:
11458 case EXEC_SYNC_MEMORY
:
11459 resolve_sync (code
);
11464 case EXEC_EVENT_POST
:
11465 case EXEC_EVENT_WAIT
:
11466 resolve_lock_unlock_event (code
);
11469 case EXEC_FAIL_IMAGE
:
11470 case EXEC_FORM_TEAM
:
11471 case EXEC_CHANGE_TEAM
:
11472 case EXEC_END_TEAM
:
11473 case EXEC_SYNC_TEAM
:
11477 /* Keep track of which entry we are up to. */
11478 current_entry_id
= code
->ext
.entry
->id
;
11482 resolve_where (code
, NULL
);
11486 if (code
->expr1
!= NULL
)
11488 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11489 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11490 "INTEGER variable", &code
->expr1
->where
);
11491 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11492 gfc_error ("Variable %qs has not been assigned a target "
11493 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11494 &code
->expr1
->where
);
11497 resolve_branch (code
->label1
, code
);
11501 if (code
->expr1
!= NULL
11502 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11503 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11504 "INTEGER return specifier", &code
->expr1
->where
);
11507 case EXEC_INIT_ASSIGN
:
11508 case EXEC_END_PROCEDURE
:
11515 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11517 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11518 && code
->expr1
->value
.function
.isym
11519 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11520 remove_caf_get_intrinsic (code
->expr1
);
11522 /* If this is a pointer function in an lvalue variable context,
11523 the new code will have to be resolved afresh. This is also the
11524 case with an error, where the code is transformed into NOP to
11525 prevent ICEs downstream. */
11526 if (resolve_ptr_fcn_assign (&code
, ns
)
11527 || code
->op
== EXEC_NOP
)
11530 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11534 if (resolve_ordinary_assign (code
, ns
))
11536 if (code
->op
== EXEC_COMPCALL
)
11542 /* Check for dependencies in deferred character length array
11543 assignments and generate a temporary, if necessary. */
11544 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11547 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11548 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11549 && code
->expr1
->ts
.u
.derived
11550 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11551 generate_component_assignments (&code
, ns
);
11555 case EXEC_LABEL_ASSIGN
:
11556 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11557 gfc_error ("Label %d referenced at %L is never defined",
11558 code
->label1
->value
, &code
->label1
->where
);
11560 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11561 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11562 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11563 != gfc_default_integer_kind
11564 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11565 gfc_error ("ASSIGN statement at %L requires a scalar "
11566 "default INTEGER variable", &code
->expr1
->where
);
11569 case EXEC_POINTER_ASSIGN
:
11576 /* This is both a variable definition and pointer assignment
11577 context, so check both of them. For rank remapping, a final
11578 array ref may be present on the LHS and fool gfc_expr_attr
11579 used in gfc_check_vardef_context. Remove it. */
11580 e
= remove_last_array_ref (code
->expr1
);
11581 t
= gfc_check_vardef_context (e
, true, false, false,
11582 _("pointer assignment"));
11584 t
= gfc_check_vardef_context (e
, false, false, false,
11585 _("pointer assignment"));
11588 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
11593 /* Assigning a class object always is a regular assign. */
11594 if (code
->expr2
->ts
.type
== BT_CLASS
11595 && code
->expr1
->ts
.type
== BT_CLASS
11596 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11597 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11598 && code
->expr2
->expr_type
== EXPR_VARIABLE
11599 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11601 code
->op
= EXEC_ASSIGN
;
11605 case EXEC_ARITHMETIC_IF
:
11607 gfc_expr
*e
= code
->expr1
;
11609 gfc_resolve_expr (e
);
11610 if (e
->expr_type
== EXPR_NULL
)
11611 gfc_error ("Invalid NULL at %L", &e
->where
);
11613 if (t
&& (e
->rank
> 0
11614 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11615 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11616 "REAL or INTEGER expression", &e
->where
);
11618 resolve_branch (code
->label1
, code
);
11619 resolve_branch (code
->label2
, code
);
11620 resolve_branch (code
->label3
, code
);
11625 if (t
&& code
->expr1
!= NULL
11626 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11627 || code
->expr1
->rank
!= 0))
11628 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11629 &code
->expr1
->where
);
11634 resolve_call (code
);
11637 case EXEC_COMPCALL
:
11639 resolve_typebound_subroutine (code
);
11642 case EXEC_CALL_PPC
:
11643 resolve_ppc_call (code
);
11647 /* Select is complicated. Also, a SELECT construct could be
11648 a transformed computed GOTO. */
11649 resolve_select (code
, false);
11652 case EXEC_SELECT_TYPE
:
11653 resolve_select_type (code
, ns
);
11657 resolve_block_construct (code
);
11661 if (code
->ext
.iterator
!= NULL
)
11663 gfc_iterator
*iter
= code
->ext
.iterator
;
11664 if (gfc_resolve_iterator (iter
, true, false))
11665 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11670 case EXEC_DO_WHILE
:
11671 if (code
->expr1
== NULL
)
11672 gfc_internal_error ("gfc_resolve_code(): No expression on "
11675 && (code
->expr1
->rank
!= 0
11676 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11677 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11678 "a scalar LOGICAL expression", &code
->expr1
->where
);
11681 case EXEC_ALLOCATE
:
11683 resolve_allocate_deallocate (code
, "ALLOCATE");
11687 case EXEC_DEALLOCATE
:
11689 resolve_allocate_deallocate (code
, "DEALLOCATE");
11694 if (!gfc_resolve_open (code
->ext
.open
))
11697 resolve_branch (code
->ext
.open
->err
, code
);
11701 if (!gfc_resolve_close (code
->ext
.close
))
11704 resolve_branch (code
->ext
.close
->err
, code
);
11707 case EXEC_BACKSPACE
:
11711 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
11714 resolve_branch (code
->ext
.filepos
->err
, code
);
11718 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11721 resolve_branch (code
->ext
.inquire
->err
, code
);
11724 case EXEC_IOLENGTH
:
11725 gcc_assert (code
->ext
.inquire
!= NULL
);
11726 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11729 resolve_branch (code
->ext
.inquire
->err
, code
);
11733 if (!gfc_resolve_wait (code
->ext
.wait
))
11736 resolve_branch (code
->ext
.wait
->err
, code
);
11737 resolve_branch (code
->ext
.wait
->end
, code
);
11738 resolve_branch (code
->ext
.wait
->eor
, code
);
11743 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11746 resolve_branch (code
->ext
.dt
->err
, code
);
11747 resolve_branch (code
->ext
.dt
->end
, code
);
11748 resolve_branch (code
->ext
.dt
->eor
, code
);
11751 case EXEC_TRANSFER
:
11752 resolve_transfer (code
);
11755 case EXEC_DO_CONCURRENT
:
11757 resolve_forall_iterators (code
->ext
.forall_iterator
);
11759 if (code
->expr1
!= NULL
11760 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11761 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11762 "expression", &code
->expr1
->where
);
11765 case EXEC_OACC_PARALLEL_LOOP
:
11766 case EXEC_OACC_PARALLEL
:
11767 case EXEC_OACC_KERNELS_LOOP
:
11768 case EXEC_OACC_KERNELS
:
11769 case EXEC_OACC_DATA
:
11770 case EXEC_OACC_HOST_DATA
:
11771 case EXEC_OACC_LOOP
:
11772 case EXEC_OACC_UPDATE
:
11773 case EXEC_OACC_WAIT
:
11774 case EXEC_OACC_CACHE
:
11775 case EXEC_OACC_ENTER_DATA
:
11776 case EXEC_OACC_EXIT_DATA
:
11777 case EXEC_OACC_ATOMIC
:
11778 case EXEC_OACC_DECLARE
:
11779 gfc_resolve_oacc_directive (code
, ns
);
11782 case EXEC_OMP_ATOMIC
:
11783 case EXEC_OMP_BARRIER
:
11784 case EXEC_OMP_CANCEL
:
11785 case EXEC_OMP_CANCELLATION_POINT
:
11786 case EXEC_OMP_CRITICAL
:
11787 case EXEC_OMP_FLUSH
:
11788 case EXEC_OMP_DISTRIBUTE
:
11789 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11790 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11791 case EXEC_OMP_DISTRIBUTE_SIMD
:
11793 case EXEC_OMP_DO_SIMD
:
11794 case EXEC_OMP_MASTER
:
11795 case EXEC_OMP_ORDERED
:
11796 case EXEC_OMP_SECTIONS
:
11797 case EXEC_OMP_SIMD
:
11798 case EXEC_OMP_SINGLE
:
11799 case EXEC_OMP_TARGET
:
11800 case EXEC_OMP_TARGET_DATA
:
11801 case EXEC_OMP_TARGET_ENTER_DATA
:
11802 case EXEC_OMP_TARGET_EXIT_DATA
:
11803 case EXEC_OMP_TARGET_PARALLEL
:
11804 case EXEC_OMP_TARGET_PARALLEL_DO
:
11805 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11806 case EXEC_OMP_TARGET_SIMD
:
11807 case EXEC_OMP_TARGET_TEAMS
:
11808 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11809 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11810 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11811 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11812 case EXEC_OMP_TARGET_UPDATE
:
11813 case EXEC_OMP_TASK
:
11814 case EXEC_OMP_TASKGROUP
:
11815 case EXEC_OMP_TASKLOOP
:
11816 case EXEC_OMP_TASKLOOP_SIMD
:
11817 case EXEC_OMP_TASKWAIT
:
11818 case EXEC_OMP_TASKYIELD
:
11819 case EXEC_OMP_TEAMS
:
11820 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11821 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11822 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11823 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11824 case EXEC_OMP_WORKSHARE
:
11825 gfc_resolve_omp_directive (code
, ns
);
11828 case EXEC_OMP_PARALLEL
:
11829 case EXEC_OMP_PARALLEL_DO
:
11830 case EXEC_OMP_PARALLEL_DO_SIMD
:
11831 case EXEC_OMP_PARALLEL_SECTIONS
:
11832 case EXEC_OMP_PARALLEL_WORKSHARE
:
11833 omp_workshare_save
= omp_workshare_flag
;
11834 omp_workshare_flag
= 0;
11835 gfc_resolve_omp_directive (code
, ns
);
11836 omp_workshare_flag
= omp_workshare_save
;
11840 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11844 cs_base
= frame
.prev
;
11848 /* Resolve initial values and make sure they are compatible with
11852 resolve_values (gfc_symbol
*sym
)
11856 if (sym
->value
== NULL
)
11859 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11860 t
= resolve_structure_cons (sym
->value
, 1);
11862 t
= gfc_resolve_expr (sym
->value
);
11867 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11871 /* Verify any BIND(C) derived types in the namespace so we can report errors
11872 for them once, rather than for each variable declared of that type. */
11875 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11877 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11878 && derived_sym
->attr
.is_bind_c
== 1)
11879 verify_bind_c_derived_type (derived_sym
);
11885 /* Check the interfaces of DTIO procedures associated with derived
11886 type 'sym'. These procedures can either have typebound bindings or
11887 can appear in DTIO generic interfaces. */
11890 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11892 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11895 gfc_check_dtio_interfaces (sym
);
11900 /* Verify that any binding labels used in a given namespace do not collide
11901 with the names or binding labels of any global symbols. Multiple INTERFACE
11902 for the same procedure are permitted. */
11905 gfc_verify_binding_labels (gfc_symbol
*sym
)
11908 const char *module
;
11910 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11911 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11914 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11917 module
= sym
->module
;
11918 else if (sym
->ns
&& sym
->ns
->proc_name
11919 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11920 module
= sym
->ns
->proc_name
->name
;
11921 else if (sym
->ns
&& sym
->ns
->parent
11922 && sym
->ns
&& sym
->ns
->parent
->proc_name
11923 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11924 module
= sym
->ns
->parent
->proc_name
->name
;
11930 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11933 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
11934 gsym
->where
= sym
->declared_at
;
11935 gsym
->sym_name
= sym
->name
;
11936 gsym
->binding_label
= sym
->binding_label
;
11937 gsym
->ns
= sym
->ns
;
11938 gsym
->mod_name
= module
;
11939 if (sym
->attr
.function
)
11940 gsym
->type
= GSYM_FUNCTION
;
11941 else if (sym
->attr
.subroutine
)
11942 gsym
->type
= GSYM_SUBROUTINE
;
11943 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11944 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11948 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11950 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
11951 "identifier as entity at %L", sym
->name
,
11952 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11953 /* Clear the binding label to prevent checking multiple times. */
11954 sym
->binding_label
= NULL
;
11958 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11959 && (strcmp (module
, gsym
->mod_name
) != 0
11960 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11962 /* This can only happen if the variable is defined in a module - if it
11963 isn't the same module, reject it. */
11964 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
11965 "uses the same global identifier as entity at %L from module %qs",
11966 sym
->name
, module
, sym
->binding_label
,
11967 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11968 sym
->binding_label
= NULL
;
11972 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11973 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11974 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11975 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
11976 && (module
!= gsym
->mod_name
11977 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11978 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11980 /* Print an error if the procedure is defined multiple times; we have to
11981 exclude references to the same procedure via module association or
11982 multiple checks for the same procedure. */
11983 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
11984 "global identifier as entity at %L", sym
->name
,
11985 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11986 sym
->binding_label
= NULL
;
11991 /* Resolve an index expression. */
11994 resolve_index_expr (gfc_expr
*e
)
11996 if (!gfc_resolve_expr (e
))
11999 if (!gfc_simplify_expr (e
, 0))
12002 if (!gfc_specification_expr (e
))
12009 /* Resolve a charlen structure. */
12012 resolve_charlen (gfc_charlen
*cl
)
12015 bool saved_specification_expr
;
12021 saved_specification_expr
= specification_expr
;
12022 specification_expr
= true;
12024 if (cl
->length_from_typespec
)
12026 if (!gfc_resolve_expr (cl
->length
))
12028 specification_expr
= saved_specification_expr
;
12032 if (!gfc_simplify_expr (cl
->length
, 0))
12034 specification_expr
= saved_specification_expr
;
12038 /* cl->length has been resolved. It should have an integer type. */
12039 if (cl
->length
->ts
.type
!= BT_INTEGER
)
12041 gfc_error ("Scalar INTEGER expression expected at %L",
12042 &cl
->length
->where
);
12048 if (!resolve_index_expr (cl
->length
))
12050 specification_expr
= saved_specification_expr
;
12055 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12056 a negative value, the length of character entities declared is zero. */
12057 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12058 && mpz_sgn (cl
->length
->value
.integer
) < 0)
12059 gfc_replace_expr (cl
->length
,
12060 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
12062 /* Check that the character length is not too large. */
12063 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
12064 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12065 && cl
->length
->ts
.type
== BT_INTEGER
12066 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
12068 gfc_error ("String length at %L is too large", &cl
->length
->where
);
12069 specification_expr
= saved_specification_expr
;
12073 specification_expr
= saved_specification_expr
;
12078 /* Test for non-constant shape arrays. */
12081 is_non_constant_shape_array (gfc_symbol
*sym
)
12087 not_constant
= false;
12088 if (sym
->as
!= NULL
)
12090 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12091 has not been simplified; parameter array references. Do the
12092 simplification now. */
12093 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12095 e
= sym
->as
->lower
[i
];
12096 if (e
&& (!resolve_index_expr(e
)
12097 || !gfc_is_constant_expr (e
)))
12098 not_constant
= true;
12099 e
= sym
->as
->upper
[i
];
12100 if (e
&& (!resolve_index_expr(e
)
12101 || !gfc_is_constant_expr (e
)))
12102 not_constant
= true;
12105 return not_constant
;
12108 /* Given a symbol and an initialization expression, add code to initialize
12109 the symbol to the function entry. */
12111 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12115 gfc_namespace
*ns
= sym
->ns
;
12117 /* Search for the function namespace if this is a contained
12118 function without an explicit result. */
12119 if (sym
->attr
.function
&& sym
== sym
->result
12120 && sym
->name
!= sym
->ns
->proc_name
->name
)
12122 ns
= ns
->contained
;
12123 for (;ns
; ns
= ns
->sibling
)
12124 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12130 gfc_free_expr (init
);
12134 /* Build an l-value expression for the result. */
12135 lval
= gfc_lval_expr_from_sym (sym
);
12137 /* Add the code at scope entry. */
12138 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
12139 init_st
->next
= ns
->code
;
12140 ns
->code
= init_st
;
12142 /* Assign the default initializer to the l-value. */
12143 init_st
->loc
= sym
->declared_at
;
12144 init_st
->expr1
= lval
;
12145 init_st
->expr2
= init
;
12149 /* Whether or not we can generate a default initializer for a symbol. */
12152 can_generate_init (gfc_symbol
*sym
)
12154 symbol_attribute
*a
;
12159 /* These symbols should never have a default initialization. */
12164 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
12165 && (CLASS_DATA (sym
)->attr
.class_pointer
12166 || CLASS_DATA (sym
)->attr
.proc_pointer
))
12167 || a
->in_equivalence
12174 || (!a
->referenced
&& !a
->result
)
12175 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
12176 || (a
->function
&& sym
!= sym
->result
)
12181 /* Assign the default initializer to a derived type variable or result. */
12184 apply_default_init (gfc_symbol
*sym
)
12186 gfc_expr
*init
= NULL
;
12188 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12191 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12192 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12194 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12197 build_init_assign (sym
, init
);
12198 sym
->attr
.referenced
= 1;
12202 /* Build an initializer for a local. Returns null if the symbol should not have
12203 a default initialization. */
12206 build_default_init_expr (gfc_symbol
*sym
)
12208 /* These symbols should never have a default initialization. */
12209 if (sym
->attr
.allocatable
12210 || sym
->attr
.external
12212 || sym
->attr
.pointer
12213 || sym
->attr
.in_equivalence
12214 || sym
->attr
.in_common
12217 || sym
->attr
.cray_pointee
12218 || sym
->attr
.cray_pointer
12222 /* Get the appropriate init expression. */
12223 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12226 /* Add an initialization expression to a local variable. */
12228 apply_default_init_local (gfc_symbol
*sym
)
12230 gfc_expr
*init
= NULL
;
12232 /* The symbol should be a variable or a function return value. */
12233 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12234 || (sym
->attr
.function
&& sym
->result
!= sym
))
12237 /* Try to build the initializer expression. If we can't initialize
12238 this symbol, then init will be NULL. */
12239 init
= build_default_init_expr (sym
);
12243 /* For saved variables, we don't want to add an initializer at function
12244 entry, so we just add a static initializer. Note that automatic variables
12245 are stack allocated even with -fno-automatic; we have also to exclude
12246 result variable, which are also nonstatic. */
12247 if (!sym
->attr
.automatic
12248 && (sym
->attr
.save
|| sym
->ns
->save_all
12249 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12250 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12251 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12253 /* Don't clobber an existing initializer! */
12254 gcc_assert (sym
->value
== NULL
);
12259 build_init_assign (sym
, init
);
12263 /* Resolution of common features of flavors variable and procedure. */
12266 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12268 gfc_array_spec
*as
;
12270 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12271 as
= CLASS_DATA (sym
)->as
;
12275 /* Constraints on deferred shape variable. */
12276 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12278 bool pointer
, allocatable
, dimension
;
12280 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12282 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12283 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12284 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12288 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12289 allocatable
= sym
->attr
.allocatable
;
12290 dimension
= sym
->attr
.dimension
;
12295 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12297 gfc_error ("Allocatable array %qs at %L must have a deferred "
12298 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12301 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12302 "%qs at %L may not be ALLOCATABLE",
12303 sym
->name
, &sym
->declared_at
))
12307 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12309 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12310 "assumed rank", sym
->name
, &sym
->declared_at
);
12316 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12317 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12319 gfc_error ("Array %qs at %L cannot have a deferred shape",
12320 sym
->name
, &sym
->declared_at
);
12325 /* Constraints on polymorphic variables. */
12326 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12329 if (sym
->attr
.class_ok
12330 && !sym
->attr
.select_type_temporary
12331 && !UNLIMITED_POLY (sym
)
12332 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12334 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12335 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12336 &sym
->declared_at
);
12341 /* Assume that use associated symbols were checked in the module ns.
12342 Class-variables that are associate-names are also something special
12343 and excepted from the test. */
12344 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12346 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12347 "or pointer", sym
->name
, &sym
->declared_at
);
12356 /* Additional checks for symbols with flavor variable and derived
12357 type. To be called from resolve_fl_variable. */
12360 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12362 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12364 /* Check to see if a derived type is blocked from being host
12365 associated by the presence of another class I symbol in the same
12366 namespace. 14.6.1.3 of the standard and the discussion on
12367 comp.lang.fortran. */
12368 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12369 && !sym
->ts
.u
.derived
->attr
.use_assoc
12370 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12373 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12374 if (s
&& s
->attr
.generic
)
12375 s
= gfc_find_dt_in_generic (s
);
12376 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12378 gfc_error ("The type %qs cannot be host associated at %L "
12379 "because it is blocked by an incompatible object "
12380 "of the same name declared at %L",
12381 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12387 /* 4th constraint in section 11.3: "If an object of a type for which
12388 component-initialization is specified (R429) appears in the
12389 specification-part of a module and does not have the ALLOCATABLE
12390 or POINTER attribute, the object shall have the SAVE attribute."
12392 The check for initializers is performed with
12393 gfc_has_default_initializer because gfc_default_initializer generates
12394 a hidden default for allocatable components. */
12395 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12396 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12397 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12398 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12399 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12400 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12401 "%qs at %L, needed due to the default "
12402 "initialization", sym
->name
, &sym
->declared_at
))
12405 /* Assign default initializer. */
12406 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12407 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12408 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12414 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12415 except in the declaration of an entity or component that has the POINTER
12416 or ALLOCATABLE attribute. */
12419 deferred_requirements (gfc_symbol
*sym
)
12421 if (sym
->ts
.deferred
12422 && !(sym
->attr
.pointer
12423 || sym
->attr
.allocatable
12424 || sym
->attr
.associate_var
12425 || sym
->attr
.omp_udr_artificial_var
))
12427 /* If a function has a result variable, only check the variable. */
12428 if (sym
->result
&& sym
->name
!= sym
->result
->name
)
12431 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12432 "requires either the POINTER or ALLOCATABLE attribute",
12433 sym
->name
, &sym
->declared_at
);
12440 /* Resolve symbols with flavor variable. */
12443 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12445 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
12448 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12451 /* Set this flag to check that variables are parameters of all entries.
12452 This check is effected by the call to gfc_resolve_expr through
12453 is_non_constant_shape_array. */
12454 bool saved_specification_expr
= specification_expr
;
12455 specification_expr
= true;
12457 if (sym
->ns
->proc_name
12458 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12459 || sym
->ns
->proc_name
->attr
.is_main_program
)
12460 && !sym
->attr
.use_assoc
12461 && !sym
->attr
.allocatable
12462 && !sym
->attr
.pointer
12463 && is_non_constant_shape_array (sym
))
12465 /* F08:C541. The shape of an array defined in a main program or module
12466 * needs to be constant. */
12467 gfc_error ("The module or main program array %qs at %L must "
12468 "have constant shape", sym
->name
, &sym
->declared_at
);
12469 specification_expr
= saved_specification_expr
;
12473 /* Constraints on deferred type parameter. */
12474 if (!deferred_requirements (sym
))
12477 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12479 /* Make sure that character string variables with assumed length are
12480 dummy arguments. */
12481 gfc_expr
*e
= NULL
;
12484 e
= sym
->ts
.u
.cl
->length
;
12488 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12489 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12490 && !sym
->attr
.omp_udr_artificial_var
)
12492 gfc_error ("Entity with assumed character length at %L must be a "
12493 "dummy argument or a PARAMETER", &sym
->declared_at
);
12494 specification_expr
= saved_specification_expr
;
12498 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12500 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12501 specification_expr
= saved_specification_expr
;
12505 if (!gfc_is_constant_expr (e
)
12506 && !(e
->expr_type
== EXPR_VARIABLE
12507 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12509 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12510 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12511 || sym
->ns
->proc_name
->attr
.is_main_program
))
12513 gfc_error ("%qs at %L must have constant character length "
12514 "in this context", sym
->name
, &sym
->declared_at
);
12515 specification_expr
= saved_specification_expr
;
12518 if (sym
->attr
.in_common
)
12520 gfc_error ("COMMON variable %qs at %L must have constant "
12521 "character length", sym
->name
, &sym
->declared_at
);
12522 specification_expr
= saved_specification_expr
;
12528 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12529 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12531 /* Determine if the symbol may not have an initializer. */
12532 int no_init_flag
= 0, automatic_flag
= 0;
12533 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12534 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12536 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12537 && is_non_constant_shape_array (sym
))
12539 no_init_flag
= automatic_flag
= 1;
12541 /* Also, they must not have the SAVE attribute.
12542 SAVE_IMPLICIT is checked below. */
12543 if (sym
->as
&& sym
->attr
.codimension
)
12545 int corank
= sym
->as
->corank
;
12546 sym
->as
->corank
= 0;
12547 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12548 sym
->as
->corank
= corank
;
12550 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12552 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12553 specification_expr
= saved_specification_expr
;
12558 /* Ensure that any initializer is simplified. */
12560 gfc_simplify_expr (sym
->value
, 1);
12562 /* Reject illegal initializers. */
12563 if (!sym
->mark
&& sym
->value
)
12565 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12566 && CLASS_DATA (sym
)->attr
.allocatable
))
12567 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12568 sym
->name
, &sym
->declared_at
);
12569 else if (sym
->attr
.external
)
12570 gfc_error ("External %qs at %L cannot have an initializer",
12571 sym
->name
, &sym
->declared_at
);
12572 else if (sym
->attr
.dummy
12573 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12574 gfc_error ("Dummy %qs at %L cannot have an initializer",
12575 sym
->name
, &sym
->declared_at
);
12576 else if (sym
->attr
.intrinsic
)
12577 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12578 sym
->name
, &sym
->declared_at
);
12579 else if (sym
->attr
.result
)
12580 gfc_error ("Function result %qs at %L cannot have an initializer",
12581 sym
->name
, &sym
->declared_at
);
12582 else if (automatic_flag
)
12583 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12584 sym
->name
, &sym
->declared_at
);
12586 goto no_init_error
;
12587 specification_expr
= saved_specification_expr
;
12592 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12594 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12595 specification_expr
= saved_specification_expr
;
12599 specification_expr
= saved_specification_expr
;
12604 /* Compare the dummy characteristics of a module procedure interface
12605 declaration with the corresponding declaration in a submodule. */
12606 static gfc_formal_arglist
*new_formal
;
12607 static char errmsg
[200];
12610 compare_fsyms (gfc_symbol
*sym
)
12614 if (sym
== NULL
|| new_formal
== NULL
)
12617 fsym
= new_formal
->sym
;
12622 if (strcmp (sym
->name
, fsym
->name
) == 0)
12624 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12625 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12630 /* Resolve a procedure. */
12633 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12635 gfc_formal_arglist
*arg
;
12637 if (sym
->attr
.function
12638 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12641 /* Constraints on deferred type parameter. */
12642 if (!deferred_requirements (sym
))
12645 if (sym
->ts
.type
== BT_CHARACTER
)
12647 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12649 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12650 && !resolve_charlen (cl
))
12653 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12654 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12656 gfc_error ("Character-valued statement function %qs at %L must "
12657 "have constant length", sym
->name
, &sym
->declared_at
);
12662 /* Ensure that derived type for are not of a private type. Internal
12663 module procedures are excluded by 2.2.3.3 - i.e., they are not
12664 externally accessible and can access all the objects accessible in
12666 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
12667 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12668 && gfc_check_symbol_access (sym
))
12670 gfc_interface
*iface
;
12672 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12675 && arg
->sym
->ts
.type
== BT_DERIVED
12676 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12677 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12678 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12679 "and cannot be a dummy argument"
12680 " of %qs, which is PUBLIC at %L",
12681 arg
->sym
->name
, sym
->name
,
12682 &sym
->declared_at
))
12684 /* Stop this message from recurring. */
12685 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12690 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12691 PRIVATE to the containing module. */
12692 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12694 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12697 && arg
->sym
->ts
.type
== BT_DERIVED
12698 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12699 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12700 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12701 "PUBLIC interface %qs at %L "
12702 "takes dummy arguments of %qs which "
12703 "is PRIVATE", iface
->sym
->name
,
12704 sym
->name
, &iface
->sym
->declared_at
,
12705 gfc_typename(&arg
->sym
->ts
)))
12707 /* Stop this message from recurring. */
12708 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12715 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12716 && !sym
->attr
.proc_pointer
)
12718 gfc_error ("Function %qs at %L cannot have an initializer",
12719 sym
->name
, &sym
->declared_at
);
12721 /* Make sure no second error is issued for this. */
12722 sym
->value
->error
= 1;
12726 /* An external symbol may not have an initializer because it is taken to be
12727 a procedure. Exception: Procedure Pointers. */
12728 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12730 gfc_error ("External object %qs at %L may not have an initializer",
12731 sym
->name
, &sym
->declared_at
);
12735 /* An elemental function is required to return a scalar 12.7.1 */
12736 if (sym
->attr
.elemental
&& sym
->attr
.function
12737 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)))
12739 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12740 "result", sym
->name
, &sym
->declared_at
);
12741 /* Reset so that the error only occurs once. */
12742 sym
->attr
.elemental
= 0;
12746 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12747 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12749 gfc_error ("Statement function %qs at %L may not have pointer or "
12750 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12754 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12755 char-len-param shall not be array-valued, pointer-valued, recursive
12756 or pure. ....snip... A character value of * may only be used in the
12757 following ways: (i) Dummy arg of procedure - dummy associates with
12758 actual length; (ii) To declare a named constant; or (iii) External
12759 function - but length must be declared in calling scoping unit. */
12760 if (sym
->attr
.function
12761 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12762 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12764 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12765 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12767 if (sym
->as
&& sym
->as
->rank
)
12768 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12769 "array-valued", sym
->name
, &sym
->declared_at
);
12771 if (sym
->attr
.pointer
)
12772 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12773 "pointer-valued", sym
->name
, &sym
->declared_at
);
12775 if (sym
->attr
.pure
)
12776 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12777 "pure", sym
->name
, &sym
->declared_at
);
12779 if (sym
->attr
.recursive
)
12780 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12781 "recursive", sym
->name
, &sym
->declared_at
);
12786 /* Appendix B.2 of the standard. Contained functions give an
12787 error anyway. Deferred character length is an F2003 feature.
12788 Don't warn on intrinsic conversion functions, which start
12789 with two underscores. */
12790 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12791 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12792 gfc_notify_std (GFC_STD_F95_OBS
,
12793 "CHARACTER(*) function %qs at %L",
12794 sym
->name
, &sym
->declared_at
);
12797 /* F2008, C1218. */
12798 if (sym
->attr
.elemental
)
12800 if (sym
->attr
.proc_pointer
)
12802 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12803 sym
->name
, &sym
->declared_at
);
12806 if (sym
->attr
.dummy
)
12808 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12809 sym
->name
, &sym
->declared_at
);
12814 /* F2018, C15100: "The result of an elemental function shall be scalar,
12815 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
12816 pointer is tested and caught elsewhere. */
12817 if (sym
->attr
.elemental
&& sym
->result
12818 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
12820 gfc_error ("Function result variable %qs at %L of elemental "
12821 "function %qs shall not have an ALLOCATABLE or POINTER "
12822 "attribute", sym
->result
->name
,
12823 &sym
->result
->declared_at
, sym
->name
);
12827 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12829 gfc_formal_arglist
*curr_arg
;
12830 int has_non_interop_arg
= 0;
12832 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12833 sym
->common_block
))
12835 /* Clear these to prevent looking at them again if there was an
12837 sym
->attr
.is_bind_c
= 0;
12838 sym
->attr
.is_c_interop
= 0;
12839 sym
->ts
.is_c_interop
= 0;
12843 /* So far, no errors have been found. */
12844 sym
->attr
.is_c_interop
= 1;
12845 sym
->ts
.is_c_interop
= 1;
12848 curr_arg
= gfc_sym_get_dummy_args (sym
);
12849 while (curr_arg
!= NULL
)
12851 /* Skip implicitly typed dummy args here. */
12852 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
12853 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12854 /* If something is found to fail, record the fact so we
12855 can mark the symbol for the procedure as not being
12856 BIND(C) to try and prevent multiple errors being
12858 has_non_interop_arg
= 1;
12860 curr_arg
= curr_arg
->next
;
12863 /* See if any of the arguments were not interoperable and if so, clear
12864 the procedure symbol to prevent duplicate error messages. */
12865 if (has_non_interop_arg
!= 0)
12867 sym
->attr
.is_c_interop
= 0;
12868 sym
->ts
.is_c_interop
= 0;
12869 sym
->attr
.is_bind_c
= 0;
12873 if (!sym
->attr
.proc_pointer
)
12875 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12877 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12878 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12881 if (sym
->attr
.intent
)
12883 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12884 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12887 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12889 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12890 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12893 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12894 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12895 || sym
->attr
.contained
))
12897 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12898 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12901 if (strcmp ("ppr@", sym
->name
) == 0)
12903 gfc_error ("Procedure pointer result %qs at %L "
12904 "is missing the pointer attribute",
12905 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12910 /* Assume that a procedure whose body is not known has references
12911 to external arrays. */
12912 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12913 sym
->attr
.array_outer_dependency
= 1;
12915 /* Compare the characteristics of a module procedure with the
12916 interface declaration. Ideally this would be done with
12917 gfc_compare_interfaces but, at present, the formal interface
12918 cannot be copied to the ts.interface. */
12919 if (sym
->attr
.module_procedure
12920 && sym
->attr
.if_source
== IFSRC_DECL
)
12923 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12925 char *submodule_name
;
12926 strcpy (name
, sym
->ns
->proc_name
->name
);
12927 module_name
= strtok (name
, ".");
12928 submodule_name
= strtok (NULL
, ".");
12930 iface
= sym
->tlink
;
12933 /* Make sure that the result uses the correct charlen for deferred
12935 if (iface
&& sym
->result
12936 && iface
->ts
.type
== BT_CHARACTER
12937 && iface
->ts
.deferred
)
12938 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12943 /* Check the procedure characteristics. */
12944 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12946 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12947 "PROCEDURE at %L and its interface in %s",
12948 &sym
->declared_at
, module_name
);
12952 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12954 gfc_error ("Mismatch in PURE attribute between MODULE "
12955 "PROCEDURE at %L and its interface in %s",
12956 &sym
->declared_at
, module_name
);
12960 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12962 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12963 "PROCEDURE at %L and its interface in %s",
12964 &sym
->declared_at
, module_name
);
12968 /* Check the result characteristics. */
12969 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12971 gfc_error ("%s between the MODULE PROCEDURE declaration "
12972 "in MODULE %qs and the declaration at %L in "
12974 errmsg
, module_name
, &sym
->declared_at
,
12975 submodule_name
? submodule_name
: module_name
);
12980 /* Check the characteristics of the formal arguments. */
12981 if (sym
->formal
&& sym
->formal_ns
)
12983 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12986 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12994 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12995 been defined and we now know their defined arguments, check that they fulfill
12996 the requirements of the standard for procedures used as finalizers. */
12999 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
13001 gfc_finalizer
* list
;
13002 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
13003 bool result
= true;
13004 bool seen_scalar
= false;
13007 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
13010 gfc_resolve_finalizers (parent
, finalizable
);
13012 /* Ensure that derived-type components have a their finalizers resolved. */
13013 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
13014 for (c
= derived
->components
; c
; c
= c
->next
)
13015 if (c
->ts
.type
== BT_DERIVED
13016 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
13018 bool has_final2
= false;
13019 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
13020 return false; /* Error. */
13021 has_final
= has_final
|| has_final2
;
13023 /* Return early if not finalizable. */
13027 *finalizable
= false;
13031 /* Walk over the list of finalizer-procedures, check them, and if any one
13032 does not fit in with the standard's definition, print an error and remove
13033 it from the list. */
13034 prev_link
= &derived
->f2k_derived
->finalizers
;
13035 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
13037 gfc_formal_arglist
*dummy_args
;
13042 /* Skip this finalizer if we already resolved it. */
13043 if (list
->proc_tree
)
13045 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
13046 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
13047 seen_scalar
= true;
13048 prev_link
= &(list
->next
);
13052 /* Check this exists and is a SUBROUTINE. */
13053 if (!list
->proc_sym
->attr
.subroutine
)
13055 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
13056 list
->proc_sym
->name
, &list
->where
);
13060 /* We should have exactly one argument. */
13061 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
13062 if (!dummy_args
|| dummy_args
->next
)
13064 gfc_error ("FINAL procedure at %L must have exactly one argument",
13068 arg
= dummy_args
->sym
;
13070 /* This argument must be of our type. */
13071 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
13073 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
13074 &arg
->declared_at
, derived
->name
);
13078 /* It must neither be a pointer nor allocatable nor optional. */
13079 if (arg
->attr
.pointer
)
13081 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13082 &arg
->declared_at
);
13085 if (arg
->attr
.allocatable
)
13087 gfc_error ("Argument of FINAL procedure at %L must not be"
13088 " ALLOCATABLE", &arg
->declared_at
);
13091 if (arg
->attr
.optional
)
13093 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13094 &arg
->declared_at
);
13098 /* It must not be INTENT(OUT). */
13099 if (arg
->attr
.intent
== INTENT_OUT
)
13101 gfc_error ("Argument of FINAL procedure at %L must not be"
13102 " INTENT(OUT)", &arg
->declared_at
);
13106 /* Warn if the procedure is non-scalar and not assumed shape. */
13107 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
13108 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
13109 gfc_warning (OPT_Wsurprising
,
13110 "Non-scalar FINAL procedure at %L should have assumed"
13111 " shape argument", &arg
->declared_at
);
13113 /* Check that it does not match in kind and rank with a FINAL procedure
13114 defined earlier. To really loop over the *earlier* declarations,
13115 we need to walk the tail of the list as new ones were pushed at the
13117 /* TODO: Handle kind parameters once they are implemented. */
13118 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
13119 for (i
= list
->next
; i
; i
= i
->next
)
13121 gfc_formal_arglist
*dummy_args
;
13123 /* Argument list might be empty; that is an error signalled earlier,
13124 but we nevertheless continued resolving. */
13125 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
13128 gfc_symbol
* i_arg
= dummy_args
->sym
;
13129 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
13130 if (i_rank
== my_rank
)
13132 gfc_error ("FINAL procedure %qs declared at %L has the same"
13133 " rank (%d) as %qs",
13134 list
->proc_sym
->name
, &list
->where
, my_rank
,
13135 i
->proc_sym
->name
);
13141 /* Is this the/a scalar finalizer procedure? */
13143 seen_scalar
= true;
13145 /* Find the symtree for this procedure. */
13146 gcc_assert (!list
->proc_tree
);
13147 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
13149 prev_link
= &list
->next
;
13152 /* Remove wrong nodes immediately from the list so we don't risk any
13153 troubles in the future when they might fail later expectations. */
13156 *prev_link
= list
->next
;
13157 gfc_free_finalizer (i
);
13161 if (result
== false)
13164 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13165 were nodes in the list, must have been for arrays. It is surely a good
13166 idea to have a scalar version there if there's something to finalize. */
13167 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
13168 gfc_warning (OPT_Wsurprising
,
13169 "Only array FINAL procedures declared for derived type %qs"
13170 " defined at %L, suggest also scalar one",
13171 derived
->name
, &derived
->declared_at
);
13173 vtab
= gfc_find_derived_vtab (derived
);
13174 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
13175 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
13178 *finalizable
= true;
13184 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13187 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13188 const char* generic_name
, locus where
)
13190 gfc_symbol
*sym1
, *sym2
;
13191 const char *pass1
, *pass2
;
13192 gfc_formal_arglist
*dummy_args
;
13194 gcc_assert (t1
->specific
&& t2
->specific
);
13195 gcc_assert (!t1
->specific
->is_generic
);
13196 gcc_assert (!t2
->specific
->is_generic
);
13197 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13199 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13200 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13205 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13206 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13207 || sym1
->attr
.function
!= sym2
->attr
.function
)
13209 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
13210 " GENERIC %qs at %L",
13211 sym1
->name
, sym2
->name
, generic_name
, &where
);
13215 /* Determine PASS arguments. */
13216 if (t1
->specific
->nopass
)
13218 else if (t1
->specific
->pass_arg
)
13219 pass1
= t1
->specific
->pass_arg
;
13222 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13224 pass1
= dummy_args
->sym
->name
;
13228 if (t2
->specific
->nopass
)
13230 else if (t2
->specific
->pass_arg
)
13231 pass2
= t2
->specific
->pass_arg
;
13234 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13236 pass2
= dummy_args
->sym
->name
;
13241 /* Compare the interfaces. */
13242 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13243 NULL
, 0, pass1
, pass2
))
13245 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13246 sym1
->name
, sym2
->name
, generic_name
, &where
);
13254 /* Worker function for resolving a generic procedure binding; this is used to
13255 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13257 The difference between those cases is finding possible inherited bindings
13258 that are overridden, as one has to look for them in tb_sym_root,
13259 tb_uop_root or tb_op, respectively. Thus the caller must already find
13260 the super-type and set p->overridden correctly. */
13263 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13264 gfc_typebound_proc
* p
, const char* name
)
13266 gfc_tbp_generic
* target
;
13267 gfc_symtree
* first_target
;
13268 gfc_symtree
* inherited
;
13270 gcc_assert (p
&& p
->is_generic
);
13272 /* Try to find the specific bindings for the symtrees in our target-list. */
13273 gcc_assert (p
->u
.generic
);
13274 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13275 if (!target
->specific
)
13277 gfc_typebound_proc
* overridden_tbp
;
13278 gfc_tbp_generic
* g
;
13279 const char* target_name
;
13281 target_name
= target
->specific_st
->name
;
13283 /* Defined for this type directly. */
13284 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13286 target
->specific
= target
->specific_st
->n
.tb
;
13287 goto specific_found
;
13290 /* Look for an inherited specific binding. */
13293 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13298 gcc_assert (inherited
->n
.tb
);
13299 target
->specific
= inherited
->n
.tb
;
13300 goto specific_found
;
13304 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13305 " at %L", target_name
, name
, &p
->where
);
13308 /* Once we've found the specific binding, check it is not ambiguous with
13309 other specifics already found or inherited for the same GENERIC. */
13311 gcc_assert (target
->specific
);
13313 /* This must really be a specific binding! */
13314 if (target
->specific
->is_generic
)
13316 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13317 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13321 /* Check those already resolved on this type directly. */
13322 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13323 if (g
!= target
&& g
->specific
13324 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13327 /* Check for ambiguity with inherited specific targets. */
13328 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13329 overridden_tbp
= overridden_tbp
->overridden
)
13330 if (overridden_tbp
->is_generic
)
13332 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13334 gcc_assert (g
->specific
);
13335 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13341 /* If we attempt to "overwrite" a specific binding, this is an error. */
13342 if (p
->overridden
&& !p
->overridden
->is_generic
)
13344 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
13345 " the same name", name
, &p
->where
);
13349 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13350 all must have the same attributes here. */
13351 first_target
= p
->u
.generic
->specific
->u
.specific
;
13352 gcc_assert (first_target
);
13353 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13354 p
->function
= first_target
->n
.sym
->attr
.function
;
13360 /* Resolve a GENERIC procedure binding for a derived type. */
13363 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13365 gfc_symbol
* super_type
;
13367 /* Find the overridden binding if any. */
13368 st
->n
.tb
->overridden
= NULL
;
13369 super_type
= gfc_get_derived_super_type (derived
);
13372 gfc_symtree
* overridden
;
13373 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13376 if (overridden
&& overridden
->n
.tb
)
13377 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13380 /* Resolve using worker function. */
13381 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13385 /* Retrieve the target-procedure of an operator binding and do some checks in
13386 common for intrinsic and user-defined type-bound operators. */
13389 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13391 gfc_symbol
* target_proc
;
13393 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13394 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13395 gcc_assert (target_proc
);
13397 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13398 if (target
->specific
->nopass
)
13400 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
13404 return target_proc
;
13408 /* Resolve a type-bound intrinsic operator. */
13411 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13412 gfc_typebound_proc
* p
)
13414 gfc_symbol
* super_type
;
13415 gfc_tbp_generic
* target
;
13417 /* If there's already an error here, do nothing (but don't fail again). */
13421 /* Operators should always be GENERIC bindings. */
13422 gcc_assert (p
->is_generic
);
13424 /* Look for an overridden binding. */
13425 super_type
= gfc_get_derived_super_type (derived
);
13426 if (super_type
&& super_type
->f2k_derived
)
13427 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13430 p
->overridden
= NULL
;
13432 /* Resolve general GENERIC properties using worker function. */
13433 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13436 /* Check the targets to be procedures of correct interface. */
13437 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13439 gfc_symbol
* target_proc
;
13441 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13445 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13448 /* Add target to non-typebound operator list. */
13449 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13450 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13452 gfc_interface
*head
, *intr
;
13454 /* Preempt 'gfc_check_new_interface' for submodules, where the
13455 mechanism for handling module procedures winds up resolving
13456 operator interfaces twice and would otherwise cause an error. */
13457 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13458 if (intr
->sym
== target_proc
13459 && target_proc
->attr
.used_in_submodule
)
13462 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13463 target_proc
, p
->where
))
13465 head
= derived
->ns
->op
[op
];
13466 intr
= gfc_get_interface ();
13467 intr
->sym
= target_proc
;
13468 intr
->where
= p
->where
;
13470 derived
->ns
->op
[op
] = intr
;
13482 /* Resolve a type-bound user operator (tree-walker callback). */
13484 static gfc_symbol
* resolve_bindings_derived
;
13485 static bool resolve_bindings_result
;
13487 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13490 resolve_typebound_user_op (gfc_symtree
* stree
)
13492 gfc_symbol
* super_type
;
13493 gfc_tbp_generic
* target
;
13495 gcc_assert (stree
&& stree
->n
.tb
);
13497 if (stree
->n
.tb
->error
)
13500 /* Operators should always be GENERIC bindings. */
13501 gcc_assert (stree
->n
.tb
->is_generic
);
13503 /* Find overridden procedure, if any. */
13504 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13505 if (super_type
&& super_type
->f2k_derived
)
13507 gfc_symtree
* overridden
;
13508 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13509 stree
->name
, true, NULL
);
13511 if (overridden
&& overridden
->n
.tb
)
13512 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13515 stree
->n
.tb
->overridden
= NULL
;
13517 /* Resolve basically using worker function. */
13518 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13521 /* Check the targets to be functions of correct interface. */
13522 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13524 gfc_symbol
* target_proc
;
13526 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13530 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13537 resolve_bindings_result
= false;
13538 stree
->n
.tb
->error
= 1;
13542 /* Resolve the type-bound procedures for a derived type. */
13545 resolve_typebound_procedure (gfc_symtree
* stree
)
13549 gfc_symbol
* me_arg
;
13550 gfc_symbol
* super_type
;
13551 gfc_component
* comp
;
13553 gcc_assert (stree
);
13555 /* Undefined specific symbol from GENERIC target definition. */
13559 if (stree
->n
.tb
->error
)
13562 /* If this is a GENERIC binding, use that routine. */
13563 if (stree
->n
.tb
->is_generic
)
13565 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13570 /* Get the target-procedure to check it. */
13571 gcc_assert (!stree
->n
.tb
->is_generic
);
13572 gcc_assert (stree
->n
.tb
->u
.specific
);
13573 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13574 where
= stree
->n
.tb
->where
;
13576 /* Default access should already be resolved from the parser. */
13577 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13579 if (stree
->n
.tb
->deferred
)
13581 if (!check_proc_interface (proc
, &where
))
13586 /* If proc has not been resolved at this point, proc->name may
13587 actually be a USE associated entity. See PR fortran/89647. */
13588 if (!proc
->resolved
13589 && proc
->attr
.function
== 0 && proc
->attr
.subroutine
== 0)
13592 gfc_find_symbol (proc
->name
, gfc_current_ns
->parent
, 1, &tmp
);
13593 if (tmp
&& tmp
->attr
.use_assoc
)
13595 proc
->module
= tmp
->module
;
13596 proc
->attr
.proc
= tmp
->attr
.proc
;
13597 proc
->attr
.function
= tmp
->attr
.function
;
13598 proc
->attr
.subroutine
= tmp
->attr
.subroutine
;
13599 proc
->attr
.use_assoc
= tmp
->attr
.use_assoc
;
13600 proc
->ts
= tmp
->ts
;
13601 proc
->result
= tmp
->result
;
13605 /* Check for F08:C465. */
13606 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13607 || (proc
->attr
.proc
!= PROC_MODULE
13608 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13609 || proc
->attr
.abstract
)
13611 gfc_error ("%qs must be a module procedure or an external "
13612 "procedure with an explicit interface at %L",
13613 proc
->name
, &where
);
13618 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13619 stree
->n
.tb
->function
= proc
->attr
.function
;
13621 /* Find the super-type of the current derived type. We could do this once and
13622 store in a global if speed is needed, but as long as not I believe this is
13623 more readable and clearer. */
13624 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13626 /* If PASS, resolve and check arguments if not already resolved / loaded
13627 from a .mod file. */
13628 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13630 gfc_formal_arglist
*dummy_args
;
13632 dummy_args
= gfc_sym_get_dummy_args (proc
);
13633 if (stree
->n
.tb
->pass_arg
)
13635 gfc_formal_arglist
*i
;
13637 /* If an explicit passing argument name is given, walk the arg-list
13638 and look for it. */
13641 stree
->n
.tb
->pass_arg_num
= 1;
13642 for (i
= dummy_args
; i
; i
= i
->next
)
13644 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13649 ++stree
->n
.tb
->pass_arg_num
;
13654 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13656 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13657 stree
->n
.tb
->pass_arg
);
13663 /* Otherwise, take the first one; there should in fact be at least
13665 stree
->n
.tb
->pass_arg_num
= 1;
13668 gfc_error ("Procedure %qs with PASS at %L must have at"
13669 " least one argument", proc
->name
, &where
);
13672 me_arg
= dummy_args
->sym
;
13675 /* Now check that the argument-type matches and the passed-object
13676 dummy argument is generally fine. */
13678 gcc_assert (me_arg
);
13680 if (me_arg
->ts
.type
!= BT_CLASS
)
13682 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13683 " at %L", proc
->name
, &where
);
13687 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13688 != resolve_bindings_derived
)
13690 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13691 " the derived-type %qs", me_arg
->name
, proc
->name
,
13692 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13696 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13697 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13699 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13700 " scalar", proc
->name
, &where
);
13703 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13705 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13706 " be ALLOCATABLE", proc
->name
, &where
);
13709 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13711 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13712 " be POINTER", proc
->name
, &where
);
13717 /* If we are extending some type, check that we don't override a procedure
13718 flagged NON_OVERRIDABLE. */
13719 stree
->n
.tb
->overridden
= NULL
;
13722 gfc_symtree
* overridden
;
13723 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13724 stree
->name
, true, NULL
);
13728 if (overridden
->n
.tb
)
13729 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13731 if (!gfc_check_typebound_override (stree
, overridden
))
13736 /* See if there's a name collision with a component directly in this type. */
13737 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13738 if (!strcmp (comp
->name
, stree
->name
))
13740 gfc_error ("Procedure %qs at %L has the same name as a component of"
13742 stree
->name
, &where
, resolve_bindings_derived
->name
);
13746 /* Try to find a name collision with an inherited component. */
13747 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13750 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13751 " component of %qs",
13752 stree
->name
, &where
, resolve_bindings_derived
->name
);
13756 stree
->n
.tb
->error
= 0;
13760 resolve_bindings_result
= false;
13761 stree
->n
.tb
->error
= 1;
13766 resolve_typebound_procedures (gfc_symbol
* derived
)
13769 gfc_symbol
* super_type
;
13771 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13774 super_type
= gfc_get_derived_super_type (derived
);
13776 resolve_symbol (super_type
);
13778 resolve_bindings_derived
= derived
;
13779 resolve_bindings_result
= true;
13781 if (derived
->f2k_derived
->tb_sym_root
)
13782 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13783 &resolve_typebound_procedure
);
13785 if (derived
->f2k_derived
->tb_uop_root
)
13786 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13787 &resolve_typebound_user_op
);
13789 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13791 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13792 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13793 (gfc_intrinsic_op
)op
, p
))
13794 resolve_bindings_result
= false;
13797 return resolve_bindings_result
;
13801 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13802 to give all identical derived types the same backend_decl. */
13804 add_dt_to_dt_list (gfc_symbol
*derived
)
13806 if (!derived
->dt_next
)
13808 if (gfc_derived_types
)
13810 derived
->dt_next
= gfc_derived_types
->dt_next
;
13811 gfc_derived_types
->dt_next
= derived
;
13815 derived
->dt_next
= derived
;
13817 gfc_derived_types
= derived
;
13822 /* Ensure that a derived-type is really not abstract, meaning that every
13823 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13826 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13831 if (!ensure_not_abstract_walker (sub
, st
->left
))
13833 if (!ensure_not_abstract_walker (sub
, st
->right
))
13836 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13838 gfc_symtree
* overriding
;
13839 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13842 gcc_assert (overriding
->n
.tb
);
13843 if (overriding
->n
.tb
->deferred
)
13845 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13846 " %qs is DEFERRED and not overridden",
13847 sub
->name
, &sub
->declared_at
, st
->name
);
13856 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13858 /* The algorithm used here is to recursively travel up the ancestry of sub
13859 and for each ancestor-type, check all bindings. If any of them is
13860 DEFERRED, look it up starting from sub and see if the found (overriding)
13861 binding is not DEFERRED.
13862 This is not the most efficient way to do this, but it should be ok and is
13863 clearer than something sophisticated. */
13865 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13867 if (!ancestor
->attr
.abstract
)
13870 /* Walk bindings of this ancestor. */
13871 if (ancestor
->f2k_derived
)
13874 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13879 /* Find next ancestor type and recurse on it. */
13880 ancestor
= gfc_get_derived_super_type (ancestor
);
13882 return ensure_not_abstract (sub
, ancestor
);
13888 /* This check for typebound defined assignments is done recursively
13889 since the order in which derived types are resolved is not always in
13890 order of the declarations. */
13893 check_defined_assignments (gfc_symbol
*derived
)
13897 for (c
= derived
->components
; c
; c
= c
->next
)
13899 if (!gfc_bt_struct (c
->ts
.type
)
13901 || c
->attr
.allocatable
13902 || c
->attr
.proc_pointer_comp
13903 || c
->attr
.class_pointer
13904 || c
->attr
.proc_pointer
)
13907 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13908 || (c
->ts
.u
.derived
->f2k_derived
13909 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13911 derived
->attr
.defined_assign_comp
= 1;
13915 check_defined_assignments (c
->ts
.u
.derived
);
13916 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13918 derived
->attr
.defined_assign_comp
= 1;
13925 /* Resolve a single component of a derived type or structure. */
13928 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13930 gfc_symbol
*super_type
;
13931 symbol_attribute
*attr
;
13933 if (c
->attr
.artificial
)
13936 /* Do not allow vtype components to be resolved in nameless namespaces
13937 such as block data because the procedure pointers will cause ICEs
13938 and vtables are not needed in these contexts. */
13939 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
13940 && sym
->ns
->proc_name
== NULL
)
13944 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13945 && c
->attr
.codimension
13946 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13948 gfc_error ("Coarray component %qs at %L must be allocatable with "
13949 "deferred shape", c
->name
, &c
->loc
);
13954 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13955 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13957 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13958 "shall not be a coarray", c
->name
, &c
->loc
);
13963 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13964 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13965 || c
->attr
.allocatable
))
13967 gfc_error ("Component %qs at %L with coarray component "
13968 "shall be a nonpointer, nonallocatable scalar",
13974 if (c
->ts
.type
== BT_CLASS
)
13976 if (CLASS_DATA (c
))
13978 attr
= &(CLASS_DATA (c
)->attr
);
13980 /* Fix up contiguous attribute. */
13981 if (c
->attr
.contiguous
)
13982 attr
->contiguous
= 1;
13990 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
13992 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13993 "is not an array pointer", c
->name
, &c
->loc
);
13997 /* F2003, 15.2.1 - length has to be one. */
13998 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
13999 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
14000 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
14001 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
14003 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
14008 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
14010 gfc_symbol
*ifc
= c
->ts
.interface
;
14012 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
14018 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
14020 /* Resolve interface and copy attributes. */
14021 if (ifc
->formal
&& !ifc
->formal_ns
)
14022 resolve_symbol (ifc
);
14023 if (ifc
->attr
.intrinsic
)
14024 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
14028 c
->ts
= ifc
->result
->ts
;
14029 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
14030 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
14031 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
14032 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
14033 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
14038 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
14039 c
->attr
.pointer
= ifc
->attr
.pointer
;
14040 c
->attr
.dimension
= ifc
->attr
.dimension
;
14041 c
->as
= gfc_copy_array_spec (ifc
->as
);
14042 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
14044 c
->ts
.interface
= ifc
;
14045 c
->attr
.function
= ifc
->attr
.function
;
14046 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
14048 c
->attr
.pure
= ifc
->attr
.pure
;
14049 c
->attr
.elemental
= ifc
->attr
.elemental
;
14050 c
->attr
.recursive
= ifc
->attr
.recursive
;
14051 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
14052 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
14053 /* Copy char length. */
14054 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
14056 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
14057 if (cl
->length
&& !cl
->resolved
14058 && !gfc_resolve_expr (cl
->length
))
14067 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
14069 /* Since PPCs are not implicitly typed, a PPC without an explicit
14070 interface must be a subroutine. */
14071 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
14074 /* Procedure pointer components: Check PASS arg. */
14075 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
14076 && !sym
->attr
.vtype
)
14078 gfc_symbol
* me_arg
;
14080 if (c
->tb
->pass_arg
)
14082 gfc_formal_arglist
* i
;
14084 /* If an explicit passing argument name is given, walk the arg-list
14085 and look for it. */
14088 c
->tb
->pass_arg_num
= 1;
14089 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
14091 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
14096 c
->tb
->pass_arg_num
++;
14101 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14102 "at %L has no argument %qs", c
->name
,
14103 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
14110 /* Otherwise, take the first one; there should in fact be at least
14112 c
->tb
->pass_arg_num
= 1;
14113 if (!c
->ts
.interface
->formal
)
14115 gfc_error ("Procedure pointer component %qs with PASS at %L "
14116 "must have at least one argument",
14121 me_arg
= c
->ts
.interface
->formal
->sym
;
14124 /* Now check that the argument-type matches. */
14125 gcc_assert (me_arg
);
14126 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
14127 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
14128 || (me_arg
->ts
.type
== BT_CLASS
14129 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
14131 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14132 " the derived type %qs", me_arg
->name
, c
->name
,
14133 me_arg
->name
, &c
->loc
, sym
->name
);
14138 /* Check for F03:C453. */
14139 if (CLASS_DATA (me_arg
)->attr
.dimension
)
14141 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14142 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
14148 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14150 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14151 "may not have the POINTER attribute", me_arg
->name
,
14152 c
->name
, me_arg
->name
, &c
->loc
);
14157 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14159 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14160 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
14161 me_arg
->name
, &c
->loc
);
14166 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
14168 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14169 " at %L", c
->name
, &c
->loc
);
14175 /* Check type-spec if this is not the parent-type component. */
14176 if (((sym
->attr
.is_class
14177 && (!sym
->components
->ts
.u
.derived
->attr
.extension
14178 || c
!= sym
->components
->ts
.u
.derived
->components
))
14179 || (!sym
->attr
.is_class
14180 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
14181 && !sym
->attr
.vtype
14182 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
14185 super_type
= gfc_get_derived_super_type (sym
);
14187 /* If this type is an extension, set the accessibility of the parent
14190 && ((sym
->attr
.is_class
14191 && c
== sym
->components
->ts
.u
.derived
->components
)
14192 || (!sym
->attr
.is_class
&& c
== sym
->components
))
14193 && strcmp (super_type
->name
, c
->name
) == 0)
14194 c
->attr
.access
= super_type
->attr
.access
;
14196 /* If this type is an extension, see if this component has the same name
14197 as an inherited type-bound procedure. */
14198 if (super_type
&& !sym
->attr
.is_class
14199 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
14201 gfc_error ("Component %qs of %qs at %L has the same name as an"
14202 " inherited type-bound procedure",
14203 c
->name
, sym
->name
, &c
->loc
);
14207 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
14208 && !c
->ts
.deferred
)
14210 if (c
->ts
.u
.cl
->length
== NULL
14211 || (!resolve_charlen(c
->ts
.u
.cl
))
14212 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
14214 gfc_error ("Character length of component %qs needs to "
14215 "be a constant specification expression at %L",
14217 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14222 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14223 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14225 gfc_error ("Character component %qs of %qs at %L with deferred "
14226 "length must be a POINTER or ALLOCATABLE",
14227 c
->name
, sym
->name
, &c
->loc
);
14231 /* Add the hidden deferred length field. */
14232 if (c
->ts
.type
== BT_CHARACTER
14233 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14234 && !c
->attr
.function
14235 && !sym
->attr
.is_class
)
14237 char name
[GFC_MAX_SYMBOL_LEN
+9];
14238 gfc_component
*strlen
;
14239 sprintf (name
, "_%s_length", c
->name
);
14240 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14241 if (strlen
== NULL
)
14243 if (!gfc_add_component (sym
, name
, &strlen
))
14245 strlen
->ts
.type
= BT_INTEGER
;
14246 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14247 strlen
->attr
.access
= ACCESS_PRIVATE
;
14248 strlen
->attr
.artificial
= 1;
14252 if (c
->ts
.type
== BT_DERIVED
14253 && sym
->component_access
!= ACCESS_PRIVATE
14254 && gfc_check_symbol_access (sym
)
14255 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14256 && !c
->ts
.u
.derived
->attr
.use_assoc
14257 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14258 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14259 "PRIVATE type and cannot be a component of "
14260 "%qs, which is PUBLIC at %L", c
->name
,
14261 sym
->name
, &sym
->declared_at
))
14264 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14266 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14267 "type %s", c
->name
, &c
->loc
, sym
->name
);
14271 if (sym
->attr
.sequence
)
14273 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14275 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14276 "not have the SEQUENCE attribute",
14277 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14282 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14283 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14284 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14285 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14286 CLASS_DATA (c
)->ts
.u
.derived
14287 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14289 /* If an allocatable component derived type is of the same type as
14290 the enclosing derived type, we need a vtable generating so that
14291 the __deallocate procedure is created. */
14292 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14293 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14294 gfc_find_vtab (&c
->ts
);
14296 /* Ensure that all the derived type components are put on the
14297 derived type list; even in formal namespaces, where derived type
14298 pointer components might not have been declared. */
14299 if (c
->ts
.type
== BT_DERIVED
14301 && c
->ts
.u
.derived
->components
14303 && sym
!= c
->ts
.u
.derived
)
14304 add_dt_to_dt_list (c
->ts
.u
.derived
);
14306 if (!gfc_resolve_array_spec (c
->as
,
14307 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
14308 || c
->attr
.allocatable
)))
14311 if (c
->initializer
&& !sym
->attr
.vtype
14312 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
14313 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
14320 /* Be nice about the locus for a structure expression - show the locus of the
14321 first non-null sub-expression if we can. */
14324 cons_where (gfc_expr
*struct_expr
)
14326 gfc_constructor
*cons
;
14328 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
14330 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
14331 for (; cons
; cons
= gfc_constructor_next (cons
))
14333 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
14334 return &cons
->expr
->where
;
14337 return &struct_expr
->where
;
14340 /* Resolve the components of a structure type. Much less work than derived
14344 resolve_fl_struct (gfc_symbol
*sym
)
14347 gfc_expr
*init
= NULL
;
14350 /* Make sure UNIONs do not have overlapping initializers. */
14351 if (sym
->attr
.flavor
== FL_UNION
)
14353 for (c
= sym
->components
; c
; c
= c
->next
)
14355 if (init
&& c
->initializer
)
14357 gfc_error ("Conflicting initializers in union at %L and %L",
14358 cons_where (init
), cons_where (c
->initializer
));
14359 gfc_free_expr (c
->initializer
);
14360 c
->initializer
= NULL
;
14363 init
= c
->initializer
;
14368 for (c
= sym
->components
; c
; c
= c
->next
)
14369 if (!resolve_component (c
, sym
))
14375 if (sym
->components
)
14376 add_dt_to_dt_list (sym
);
14382 /* Resolve the components of a derived type. This does not have to wait until
14383 resolution stage, but can be done as soon as the dt declaration has been
14387 resolve_fl_derived0 (gfc_symbol
*sym
)
14389 gfc_symbol
* super_type
;
14391 gfc_formal_arglist
*f
;
14394 if (sym
->attr
.unlimited_polymorphic
)
14397 super_type
= gfc_get_derived_super_type (sym
);
14400 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14402 gfc_error ("As extending type %qs at %L has a coarray component, "
14403 "parent type %qs shall also have one", sym
->name
,
14404 &sym
->declared_at
, super_type
->name
);
14408 /* Ensure the extended type gets resolved before we do. */
14409 if (super_type
&& !resolve_fl_derived0 (super_type
))
14412 /* An ABSTRACT type must be extensible. */
14413 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14415 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14416 sym
->name
, &sym
->declared_at
);
14420 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14424 for ( ; c
!= NULL
; c
= c
->next
)
14425 if (!resolve_component (c
, sym
))
14431 /* Now add the caf token field, where needed. */
14432 if (flag_coarray
!= GFC_FCOARRAY_NONE
14433 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14435 for (c
= sym
->components
; c
; c
= c
->next
)
14436 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14437 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14439 char name
[GFC_MAX_SYMBOL_LEN
+9];
14440 gfc_component
*token
;
14441 sprintf (name
, "_caf_%s", c
->name
);
14442 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14445 if (!gfc_add_component (sym
, name
, &token
))
14447 token
->ts
.type
= BT_VOID
;
14448 token
->ts
.kind
= gfc_default_integer_kind
;
14449 token
->attr
.access
= ACCESS_PRIVATE
;
14450 token
->attr
.artificial
= 1;
14451 token
->attr
.caf_token
= 1;
14456 check_defined_assignments (sym
);
14458 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14459 sym
->attr
.defined_assign_comp
14460 = super_type
->attr
.defined_assign_comp
;
14462 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14463 all DEFERRED bindings are overridden. */
14464 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14465 && !sym
->attr
.is_class
14466 && !ensure_not_abstract (sym
, super_type
))
14469 /* Check that there is a component for every PDT parameter. */
14470 if (sym
->attr
.pdt_template
)
14472 for (f
= sym
->formal
; f
; f
= f
->next
)
14476 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14479 gfc_error ("Parameterized type %qs does not have a component "
14480 "corresponding to parameter %qs at %L", sym
->name
,
14481 f
->sym
->name
, &sym
->declared_at
);
14487 /* Add derived type to the derived type list. */
14488 add_dt_to_dt_list (sym
);
14494 /* The following procedure does the full resolution of a derived type,
14495 including resolution of all type-bound procedures (if present). In contrast
14496 to 'resolve_fl_derived0' this can only be done after the module has been
14497 parsed completely. */
14500 resolve_fl_derived (gfc_symbol
*sym
)
14502 gfc_symbol
*gen_dt
= NULL
;
14504 if (sym
->attr
.unlimited_polymorphic
)
14507 if (!sym
->attr
.is_class
)
14508 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14509 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14510 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14511 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14512 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14513 "%qs at %L being the same name as derived "
14514 "type at %L", sym
->name
,
14515 gen_dt
->generic
->sym
== sym
14516 ? gen_dt
->generic
->next
->sym
->name
14517 : gen_dt
->generic
->sym
->name
,
14518 gen_dt
->generic
->sym
== sym
14519 ? &gen_dt
->generic
->next
->sym
->declared_at
14520 : &gen_dt
->generic
->sym
->declared_at
,
14521 &sym
->declared_at
))
14524 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
14526 gfc_error ("Derived type %qs at %L has not been declared",
14527 sym
->name
, &sym
->declared_at
);
14531 /* Resolve the finalizer procedures. */
14532 if (!gfc_resolve_finalizers (sym
, NULL
))
14535 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14537 /* Fix up incomplete CLASS symbols. */
14538 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14539 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14541 /* Nothing more to do for unlimited polymorphic entities. */
14542 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14544 else if (vptr
->ts
.u
.derived
== NULL
)
14546 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14548 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14549 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14554 if (!resolve_fl_derived0 (sym
))
14557 /* Resolve the type-bound procedures. */
14558 if (!resolve_typebound_procedures (sym
))
14561 /* Generate module vtables subject to their accessibility and their not
14562 being vtables or pdt templates. If this is not done class declarations
14563 in external procedures wind up with their own version and so SELECT TYPE
14564 fails because the vptrs do not have the same address. */
14565 if (gfc_option
.allow_std
& GFC_STD_F2003
14566 && sym
->ns
->proc_name
14567 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14568 && sym
->attr
.access
!= ACCESS_PRIVATE
14569 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14571 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14572 gfc_set_sym_referenced (vtab
);
14580 resolve_fl_namelist (gfc_symbol
*sym
)
14585 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14587 /* Check again, the check in match only works if NAMELIST comes
14589 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14591 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14592 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14596 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14597 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14598 "with assumed shape in namelist %qs at %L",
14599 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14602 if (is_non_constant_shape_array (nl
->sym
)
14603 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14604 "with nonconstant shape in namelist %qs at %L",
14605 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14608 if (nl
->sym
->ts
.type
== BT_CHARACTER
14609 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14610 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14611 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14612 "nonconstant character length in "
14613 "namelist %qs at %L", nl
->sym
->name
,
14614 sym
->name
, &sym
->declared_at
))
14619 /* Reject PRIVATE objects in a PUBLIC namelist. */
14620 if (gfc_check_symbol_access (sym
))
14622 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14624 if (!nl
->sym
->attr
.use_assoc
14625 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14626 && !gfc_check_symbol_access (nl
->sym
))
14628 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14629 "cannot be member of PUBLIC namelist %qs at %L",
14630 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14634 if (nl
->sym
->ts
.type
== BT_DERIVED
14635 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14636 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14638 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14639 "namelist %qs at %L with ALLOCATABLE "
14640 "or POINTER components", nl
->sym
->name
,
14641 sym
->name
, &sym
->declared_at
))
14646 /* Types with private components that came here by USE-association. */
14647 if (nl
->sym
->ts
.type
== BT_DERIVED
14648 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14650 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14651 "components and cannot be member of namelist %qs at %L",
14652 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14656 /* Types with private components that are defined in the same module. */
14657 if (nl
->sym
->ts
.type
== BT_DERIVED
14658 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14659 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14661 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14662 "cannot be a member of PUBLIC namelist %qs at %L",
14663 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14670 /* 14.1.2 A module or internal procedure represent local entities
14671 of the same type as a namelist member and so are not allowed. */
14672 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14674 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14677 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14678 if ((nl
->sym
== sym
->ns
->proc_name
)
14680 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14685 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14686 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14688 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14689 "attribute in %qs at %L", nlsym
->name
,
14690 &sym
->declared_at
);
14697 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14698 nl
->sym
->attr
.asynchronous
= 1;
14705 resolve_fl_parameter (gfc_symbol
*sym
)
14707 /* A parameter array's shape needs to be constant. */
14708 if (sym
->as
!= NULL
14709 && (sym
->as
->type
== AS_DEFERRED
14710 || is_non_constant_shape_array (sym
)))
14712 gfc_error ("Parameter array %qs at %L cannot be automatic "
14713 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14717 /* Constraints on deferred type parameter. */
14718 if (!deferred_requirements (sym
))
14721 /* Make sure a parameter that has been implicitly typed still
14722 matches the implicit type, since PARAMETER statements can precede
14723 IMPLICIT statements. */
14724 if (sym
->attr
.implicit_type
14725 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14728 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14729 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14733 /* Make sure the types of derived parameters are consistent. This
14734 type checking is deferred until resolution because the type may
14735 refer to a derived type from the host. */
14736 if (sym
->ts
.type
== BT_DERIVED
14737 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14739 gfc_error ("Incompatible derived type in PARAMETER at %L",
14740 &sym
->value
->where
);
14744 /* F03:C509,C514. */
14745 if (sym
->ts
.type
== BT_CLASS
)
14747 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14748 sym
->name
, &sym
->declared_at
);
14756 /* Called by resolve_symbol to check PDTs. */
14759 resolve_pdt (gfc_symbol
* sym
)
14761 gfc_symbol
*derived
= NULL
;
14762 gfc_actual_arglist
*param
;
14764 bool const_len_exprs
= true;
14765 bool assumed_len_exprs
= false;
14766 symbol_attribute
*attr
;
14768 if (sym
->ts
.type
== BT_DERIVED
)
14770 derived
= sym
->ts
.u
.derived
;
14771 attr
= &(sym
->attr
);
14773 else if (sym
->ts
.type
== BT_CLASS
)
14775 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14776 attr
= &(CLASS_DATA (sym
)->attr
);
14779 gcc_unreachable ();
14781 gcc_assert (derived
->attr
.pdt_type
);
14783 for (param
= sym
->param_list
; param
; param
= param
->next
)
14785 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14787 if (c
->attr
.pdt_kind
)
14790 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14791 && c
->attr
.pdt_len
)
14792 const_len_exprs
= false;
14793 else if (param
->spec_type
== SPEC_ASSUMED
)
14794 assumed_len_exprs
= true;
14796 if (param
->spec_type
== SPEC_DEFERRED
14797 && !attr
->allocatable
&& !attr
->pointer
)
14798 gfc_error ("The object %qs at %L has a deferred LEN "
14799 "parameter %qs and is neither allocatable "
14800 "nor a pointer", sym
->name
, &sym
->declared_at
,
14805 if (!const_len_exprs
14806 && (sym
->ns
->proc_name
->attr
.is_main_program
14807 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14808 || sym
->attr
.save
!= SAVE_NONE
))
14809 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14810 "SAVE attribute or be a variable declared in the "
14811 "main program, a module or a submodule(F08/C513)",
14812 sym
->name
, &sym
->declared_at
);
14814 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14815 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14816 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14817 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14818 sym
->name
, &sym
->declared_at
);
14822 /* Do anything necessary to resolve a symbol. Right now, we just
14823 assume that an otherwise unknown symbol is a variable. This sort
14824 of thing commonly happens for symbols in module. */
14827 resolve_symbol (gfc_symbol
*sym
)
14829 int check_constant
, mp_flag
;
14830 gfc_symtree
*symtree
;
14831 gfc_symtree
*this_symtree
;
14834 symbol_attribute class_attr
;
14835 gfc_array_spec
*as
;
14836 bool saved_specification_expr
;
14842 /* No symbol will ever have union type; only components can be unions.
14843 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14844 (just like derived type declaration symbols have flavor FL_DERIVED). */
14845 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14847 /* Coarrayed polymorphic objects with allocatable or pointer components are
14848 yet unsupported for -fcoarray=lib. */
14849 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14850 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14851 && CLASS_DATA (sym
)->attr
.codimension
14852 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14853 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14855 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14856 "type coarrays at %L are unsupported", &sym
->declared_at
);
14860 if (sym
->attr
.artificial
)
14863 if (sym
->attr
.unlimited_polymorphic
)
14866 if (sym
->attr
.flavor
== FL_UNKNOWN
14867 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14868 && !sym
->attr
.generic
&& !sym
->attr
.external
14869 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14870 && sym
->ts
.type
== BT_UNKNOWN
))
14873 /* If we find that a flavorless symbol is an interface in one of the
14874 parent namespaces, find its symtree in this namespace, free the
14875 symbol and set the symtree to point to the interface symbol. */
14876 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14878 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14879 if (symtree
&& (symtree
->n
.sym
->generic
||
14880 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14881 && sym
->ns
->construct_entities
)))
14883 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14885 if (this_symtree
->n
.sym
== sym
)
14887 symtree
->n
.sym
->refs
++;
14888 gfc_release_symbol (sym
);
14889 this_symtree
->n
.sym
= symtree
->n
.sym
;
14895 /* Otherwise give it a flavor according to such attributes as
14897 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14898 && sym
->attr
.intrinsic
== 0)
14899 sym
->attr
.flavor
= FL_VARIABLE
;
14900 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14902 sym
->attr
.flavor
= FL_PROCEDURE
;
14903 if (sym
->attr
.dimension
)
14904 sym
->attr
.function
= 1;
14908 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14909 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14911 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14912 && !resolve_procedure_interface (sym
))
14915 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14916 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14918 if (sym
->attr
.external
)
14919 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14920 "at %L", &sym
->declared_at
);
14922 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14923 "at %L", &sym
->declared_at
);
14928 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14931 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14932 && !resolve_fl_struct (sym
))
14935 /* Symbols that are module procedures with results (functions) have
14936 the types and array specification copied for type checking in
14937 procedures that call them, as well as for saving to a module
14938 file. These symbols can't stand the scrutiny that their results
14940 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14942 /* Make sure that the intrinsic is consistent with its internal
14943 representation. This needs to be done before assigning a default
14944 type to avoid spurious warnings. */
14945 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14946 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14949 /* Resolve associate names. */
14951 resolve_assoc_var (sym
, true);
14953 /* Assign default type to symbols that need one and don't have one. */
14954 if (sym
->ts
.type
== BT_UNKNOWN
)
14956 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14958 gfc_set_default_type (sym
, 1, NULL
);
14961 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14962 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14963 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14964 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14966 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14968 /* The specific case of an external procedure should emit an error
14969 in the case that there is no implicit type. */
14972 if (!sym
->attr
.mixed_entry_master
)
14973 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14977 /* Result may be in another namespace. */
14978 resolve_symbol (sym
->result
);
14980 if (!sym
->result
->attr
.proc_pointer
)
14982 sym
->ts
= sym
->result
->ts
;
14983 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14984 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14985 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14986 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14987 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14992 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14994 bool saved_specification_expr
= specification_expr
;
14995 specification_expr
= true;
14996 gfc_resolve_array_spec (sym
->result
->as
, false);
14997 specification_expr
= saved_specification_expr
;
15000 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
15002 as
= CLASS_DATA (sym
)->as
;
15003 class_attr
= CLASS_DATA (sym
)->attr
;
15004 class_attr
.pointer
= class_attr
.class_pointer
;
15008 class_attr
= sym
->attr
;
15013 if (sym
->attr
.contiguous
15014 && (!class_attr
.dimension
15015 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
15016 && !class_attr
.pointer
)))
15018 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
15019 "array pointer or an assumed-shape or assumed-rank array",
15020 sym
->name
, &sym
->declared_at
);
15024 /* Assumed size arrays and assumed shape arrays must be dummy
15025 arguments. Array-spec's of implied-shape should have been resolved to
15026 AS_EXPLICIT already. */
15030 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
15031 specification expression. */
15032 if (as
->type
== AS_IMPLIED_SHAPE
)
15035 for (i
=0; i
<as
->rank
; i
++)
15037 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
15039 gfc_error ("Bad specification for assumed size array at %L",
15040 &as
->lower
[i
]->where
);
15047 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
15048 || as
->type
== AS_ASSUMED_SHAPE
)
15049 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
15051 if (as
->type
== AS_ASSUMED_SIZE
)
15052 gfc_error ("Assumed size array at %L must be a dummy argument",
15053 &sym
->declared_at
);
15055 gfc_error ("Assumed shape array at %L must be a dummy argument",
15056 &sym
->declared_at
);
15059 /* TS 29113, C535a. */
15060 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
15061 && !sym
->attr
.select_type_temporary
)
15063 gfc_error ("Assumed-rank array at %L must be a dummy argument",
15064 &sym
->declared_at
);
15067 if (as
->type
== AS_ASSUMED_RANK
15068 && (sym
->attr
.codimension
|| sym
->attr
.value
))
15070 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15071 "CODIMENSION attribute", &sym
->declared_at
);
15076 /* Make sure symbols with known intent or optional are really dummy
15077 variable. Because of ENTRY statement, this has to be deferred
15078 until resolution time. */
15080 if (!sym
->attr
.dummy
15081 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
15083 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
15087 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
15089 gfc_error ("%qs at %L cannot have the VALUE attribute because "
15090 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
15094 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
15096 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
15097 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
15099 gfc_error ("Character dummy variable %qs at %L with VALUE "
15100 "attribute must have constant length",
15101 sym
->name
, &sym
->declared_at
);
15105 if (sym
->ts
.is_c_interop
15106 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
15108 gfc_error ("C interoperable character dummy variable %qs at %L "
15109 "with VALUE attribute must have length one",
15110 sym
->name
, &sym
->declared_at
);
15115 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15116 && sym
->ts
.u
.derived
->attr
.generic
)
15118 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
15119 if (!sym
->ts
.u
.derived
)
15121 gfc_error ("The derived type %qs at %L is of type %qs, "
15122 "which has not been defined", sym
->name
,
15123 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15124 sym
->ts
.type
= BT_UNKNOWN
;
15129 /* Use the same constraints as TYPE(*), except for the type check
15130 and that only scalars and assumed-size arrays are permitted. */
15131 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
15133 if (!sym
->attr
.dummy
)
15135 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15136 "a dummy argument", sym
->name
, &sym
->declared_at
);
15140 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
15141 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
15142 && sym
->ts
.type
!= BT_COMPLEX
)
15144 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15145 "of type TYPE(*) or of an numeric intrinsic type",
15146 sym
->name
, &sym
->declared_at
);
15150 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15151 || sym
->attr
.pointer
|| sym
->attr
.value
)
15153 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15154 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15155 "attribute", sym
->name
, &sym
->declared_at
);
15159 if (sym
->attr
.intent
== INTENT_OUT
)
15161 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15162 "have the INTENT(OUT) attribute",
15163 sym
->name
, &sym
->declared_at
);
15166 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
15168 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15169 "either be a scalar or an assumed-size array",
15170 sym
->name
, &sym
->declared_at
);
15174 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15175 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15177 sym
->ts
.type
= BT_ASSUMED
;
15178 sym
->as
= gfc_get_array_spec ();
15179 sym
->as
->type
= AS_ASSUMED_SIZE
;
15181 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
15183 else if (sym
->ts
.type
== BT_ASSUMED
)
15185 /* TS 29113, C407a. */
15186 if (!sym
->attr
.dummy
)
15188 gfc_error ("Assumed type of variable %s at %L is only permitted "
15189 "for dummy variables", sym
->name
, &sym
->declared_at
);
15192 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15193 || sym
->attr
.pointer
|| sym
->attr
.value
)
15195 gfc_error ("Assumed-type variable %s at %L may not have the "
15196 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15197 sym
->name
, &sym
->declared_at
);
15200 if (sym
->attr
.intent
== INTENT_OUT
)
15202 gfc_error ("Assumed-type variable %s at %L may not have the "
15203 "INTENT(OUT) attribute",
15204 sym
->name
, &sym
->declared_at
);
15207 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
15209 gfc_error ("Assumed-type variable %s at %L shall not be an "
15210 "explicit-shape array", sym
->name
, &sym
->declared_at
);
15215 /* If the symbol is marked as bind(c), that it is declared at module level
15216 scope and verify its type and kind. Do not do the latter for symbols
15217 that are implicitly typed because that is handled in
15218 gfc_set_default_type. Handle dummy arguments and procedure definitions
15219 separately. Also, anything that is use associated is not handled here
15220 but instead is handled in the module it is declared in. Finally, derived
15221 type definitions are allowed to be BIND(C) since that only implies that
15222 they're interoperable, and they are checked fully for interoperability
15223 when a variable is declared of that type. */
15224 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15225 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15226 && sym
->attr
.flavor
!= FL_DERIVED
)
15230 /* First, make sure the variable is declared at the
15231 module-level scope (J3/04-007, Section 15.3). */
15232 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
15233 sym
->attr
.in_common
== 0)
15235 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15236 "is neither a COMMON block nor declared at the "
15237 "module level scope", sym
->name
, &(sym
->declared_at
));
15240 else if (sym
->ts
.type
== BT_CHARACTER
15241 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15242 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15243 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15245 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15246 sym
->name
, &sym
->declared_at
);
15249 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15251 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15253 else if (sym
->attr
.implicit_type
== 0)
15255 /* If type() declaration, we need to verify that the components
15256 of the given type are all C interoperable, etc. */
15257 if (sym
->ts
.type
== BT_DERIVED
&&
15258 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15260 /* Make sure the user marked the derived type as BIND(C). If
15261 not, call the verify routine. This could print an error
15262 for the derived type more than once if multiple variables
15263 of that type are declared. */
15264 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15265 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15269 /* Verify the variable itself as C interoperable if it
15270 is BIND(C). It is not possible for this to succeed if
15271 the verify_bind_c_derived_type failed, so don't have to handle
15272 any error returned by verify_bind_c_derived_type. */
15273 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15274 sym
->common_block
);
15279 /* clear the is_bind_c flag to prevent reporting errors more than
15280 once if something failed. */
15281 sym
->attr
.is_bind_c
= 0;
15286 /* If a derived type symbol has reached this point, without its
15287 type being declared, we have an error. Notice that most
15288 conditions that produce undefined derived types have already
15289 been dealt with. However, the likes of:
15290 implicit type(t) (t) ..... call foo (t) will get us here if
15291 the type is not declared in the scope of the implicit
15292 statement. Change the type to BT_UNKNOWN, both because it is so
15293 and to prevent an ICE. */
15294 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15295 && sym
->ts
.u
.derived
->components
== NULL
15296 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
15298 gfc_error ("The derived type %qs at %L is of type %qs, "
15299 "which has not been defined", sym
->name
,
15300 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15301 sym
->ts
.type
= BT_UNKNOWN
;
15305 /* Make sure that the derived type has been resolved and that the
15306 derived type is visible in the symbol's namespace, if it is a
15307 module function and is not PRIVATE. */
15308 if (sym
->ts
.type
== BT_DERIVED
15309 && sym
->ts
.u
.derived
->attr
.use_assoc
15310 && sym
->ns
->proc_name
15311 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15312 && !resolve_fl_derived (sym
->ts
.u
.derived
))
15315 /* Unless the derived-type declaration is use associated, Fortran 95
15316 does not allow public entries of private derived types.
15317 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15318 161 in 95-006r3. */
15319 if (sym
->ts
.type
== BT_DERIVED
15320 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15321 && !sym
->ts
.u
.derived
->attr
.use_assoc
15322 && gfc_check_symbol_access (sym
)
15323 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15324 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
15325 "derived type %qs",
15326 (sym
->attr
.flavor
== FL_PARAMETER
)
15327 ? "parameter" : "variable",
15328 sym
->name
, &sym
->declared_at
,
15329 sym
->ts
.u
.derived
->name
))
15332 /* F2008, C1302. */
15333 if (sym
->ts
.type
== BT_DERIVED
15334 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15335 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
15336 || sym
->ts
.u
.derived
->attr
.lock_comp
)
15337 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15339 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15340 "type LOCK_TYPE must be a coarray", sym
->name
,
15341 &sym
->declared_at
);
15345 /* TS18508, C702/C703. */
15346 if (sym
->ts
.type
== BT_DERIVED
15347 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15348 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
15349 || sym
->ts
.u
.derived
->attr
.event_comp
)
15350 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15352 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15353 "type EVENT_TYPE must be a coarray", sym
->name
,
15354 &sym
->declared_at
);
15358 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15359 default initialization is defined (5.1.2.4.4). */
15360 if (sym
->ts
.type
== BT_DERIVED
15362 && sym
->attr
.intent
== INTENT_OUT
15364 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15366 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15368 if (c
->initializer
)
15370 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15371 "ASSUMED SIZE and so cannot have a default initializer",
15372 sym
->name
, &sym
->declared_at
);
15379 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15380 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15382 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15383 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15388 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15389 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15391 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15392 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15397 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15398 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15399 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15400 || class_attr
.codimension
)
15401 && (sym
->attr
.result
|| sym
->result
== sym
))
15403 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15404 "a coarray component", sym
->name
, &sym
->declared_at
);
15409 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15410 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15412 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15413 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15418 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15419 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15420 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15421 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15422 || class_attr
.allocatable
))
15424 gfc_error ("Variable %qs at %L with coarray component shall be a "
15425 "nonpointer, nonallocatable scalar, which is not a coarray",
15426 sym
->name
, &sym
->declared_at
);
15430 /* F2008, C526. The function-result case was handled above. */
15431 if (class_attr
.codimension
15432 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15433 || sym
->attr
.select_type_temporary
15434 || sym
->attr
.associate_var
15435 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15436 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15437 || sym
->ns
->proc_name
->attr
.is_main_program
15438 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15440 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15441 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15445 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15446 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15448 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15449 "deferred shape", sym
->name
, &sym
->declared_at
);
15452 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15453 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15455 gfc_error ("Allocatable coarray variable %qs at %L must have "
15456 "deferred shape", sym
->name
, &sym
->declared_at
);
15461 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15462 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15463 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15464 || (class_attr
.codimension
&& class_attr
.allocatable
))
15465 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15467 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15468 "allocatable coarray or have coarray components",
15469 sym
->name
, &sym
->declared_at
);
15473 if (class_attr
.codimension
&& sym
->attr
.dummy
15474 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15476 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15477 "procedure %qs", sym
->name
, &sym
->declared_at
,
15478 sym
->ns
->proc_name
->name
);
15482 if (sym
->ts
.type
== BT_LOGICAL
15483 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15484 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15485 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15488 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15489 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15491 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15492 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15493 "%L with non-C_Bool kind in BIND(C) procedure "
15494 "%qs", sym
->name
, &sym
->declared_at
,
15495 sym
->ns
->proc_name
->name
))
15497 else if (!gfc_logical_kinds
[i
].c_bool
15498 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15499 "%qs at %L with non-C_Bool kind in "
15500 "BIND(C) procedure %qs", sym
->name
,
15502 sym
->attr
.function
? sym
->name
15503 : sym
->ns
->proc_name
->name
))
15507 switch (sym
->attr
.flavor
)
15510 if (!resolve_fl_variable (sym
, mp_flag
))
15515 if (sym
->formal
&& !sym
->formal_ns
)
15517 /* Check that none of the arguments are a namelist. */
15518 gfc_formal_arglist
*formal
= sym
->formal
;
15520 for (; formal
; formal
= formal
->next
)
15521 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15523 gfc_error ("Namelist %qs cannot be an argument to "
15524 "subroutine or function at %L",
15525 formal
->sym
->name
, &sym
->declared_at
);
15530 if (!resolve_fl_procedure (sym
, mp_flag
))
15535 if (!resolve_fl_namelist (sym
))
15540 if (!resolve_fl_parameter (sym
))
15548 /* Resolve array specifier. Check as well some constraints
15549 on COMMON blocks. */
15551 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15553 /* Set the formal_arg_flag so that check_conflict will not throw
15554 an error for host associated variables in the specification
15555 expression for an array_valued function. */
15556 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
15557 formal_arg_flag
= true;
15559 saved_specification_expr
= specification_expr
;
15560 specification_expr
= true;
15561 gfc_resolve_array_spec (sym
->as
, check_constant
);
15562 specification_expr
= saved_specification_expr
;
15564 formal_arg_flag
= false;
15566 /* Resolve formal namespaces. */
15567 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15568 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15569 gfc_resolve (sym
->formal_ns
);
15571 /* Make sure the formal namespace is present. */
15572 if (sym
->formal
&& !sym
->formal_ns
)
15574 gfc_formal_arglist
*formal
= sym
->formal
;
15575 while (formal
&& !formal
->sym
)
15576 formal
= formal
->next
;
15580 sym
->formal_ns
= formal
->sym
->ns
;
15581 if (sym
->ns
!= formal
->sym
->ns
)
15582 sym
->formal_ns
->refs
++;
15586 /* Check threadprivate restrictions. */
15587 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15588 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15589 && (!sym
->attr
.in_common
15590 && sym
->module
== NULL
15591 && (sym
->ns
->proc_name
== NULL
15592 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15593 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15595 /* Check omp declare target restrictions. */
15596 if (sym
->attr
.omp_declare_target
15597 && sym
->attr
.flavor
== FL_VARIABLE
15599 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15600 && (!sym
->attr
.in_common
15601 && sym
->module
== NULL
15602 && (sym
->ns
->proc_name
== NULL
15603 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15604 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15605 sym
->name
, &sym
->declared_at
);
15607 /* If we have come this far we can apply default-initializers, as
15608 described in 14.7.5, to those variables that have not already
15609 been assigned one. */
15610 if (sym
->ts
.type
== BT_DERIVED
15612 && !sym
->attr
.allocatable
15613 && !sym
->attr
.alloc_comp
)
15615 symbol_attribute
*a
= &sym
->attr
;
15617 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15618 && !a
->in_common
&& !a
->use_assoc
15620 && !((a
->function
|| a
->result
)
15622 || sym
->ts
.u
.derived
->attr
.alloc_comp
15623 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15624 && !(a
->function
&& sym
!= sym
->result
))
15625 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15626 apply_default_init (sym
);
15627 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15628 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15629 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15630 /* Mark the result symbol to be referenced, when it has allocatable
15632 sym
->result
->attr
.referenced
= 1;
15635 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15636 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15637 && !CLASS_DATA (sym
)->attr
.class_pointer
15638 && !CLASS_DATA (sym
)->attr
.allocatable
)
15639 apply_default_init (sym
);
15641 /* If this symbol has a type-spec, check it. */
15642 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15643 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15644 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15647 if (sym
->param_list
)
15652 /************* Resolve DATA statements *************/
15656 gfc_data_value
*vnode
;
15662 /* Advance the values structure to point to the next value in the data list. */
15665 next_data_value (void)
15667 while (mpz_cmp_ui (values
.left
, 0) == 0)
15670 if (values
.vnode
->next
== NULL
)
15673 values
.vnode
= values
.vnode
->next
;
15674 mpz_set (values
.left
, values
.vnode
->repeat
);
15682 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15688 ar_type mark
= AR_UNKNOWN
;
15690 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15696 if (!gfc_resolve_expr (var
->expr
))
15700 mpz_init_set_si (offset
, 0);
15703 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15704 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15705 e
= e
->value
.function
.actual
->expr
;
15707 if (e
->expr_type
!= EXPR_VARIABLE
)
15709 gfc_error ("Expecting definable entity near %L", where
);
15713 sym
= e
->symtree
->n
.sym
;
15715 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15717 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15718 sym
->name
, &sym
->declared_at
);
15722 if (e
->ref
== NULL
&& sym
->as
)
15724 gfc_error ("DATA array %qs at %L must be specified in a previous"
15725 " declaration", sym
->name
, where
);
15729 if (gfc_is_coindexed (e
))
15731 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15736 has_pointer
= sym
->attr
.pointer
;
15738 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15740 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15745 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_FULL
)
15747 gfc_error ("DATA element %qs at %L is a pointer and so must "
15748 "be a full array", sym
->name
, where
);
15752 if (values
.vnode
->expr
->expr_type
== EXPR_CONSTANT
)
15754 gfc_error ("DATA object near %L has the pointer attribute "
15755 "and the corresponding DATA value is not a valid "
15756 "initial-data-target", where
);
15762 if (e
->rank
== 0 || has_pointer
)
15764 mpz_init_set_ui (size
, 1);
15771 /* Find the array section reference. */
15772 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15774 if (ref
->type
!= REF_ARRAY
)
15776 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15782 /* Set marks according to the reference pattern. */
15783 switch (ref
->u
.ar
.type
)
15791 /* Get the start position of array section. */
15792 gfc_get_section_index (ar
, section_index
, &offset
);
15797 gcc_unreachable ();
15800 if (!gfc_array_size (e
, &size
))
15802 gfc_error ("Nonconstant array section at %L in DATA statement",
15804 mpz_clear (offset
);
15811 while (mpz_cmp_ui (size
, 0) > 0)
15813 if (!next_data_value ())
15815 gfc_error ("DATA statement at %L has more variables than values",
15821 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
15825 /* If we have more than one element left in the repeat count,
15826 and we have more than one element left in the target variable,
15827 then create a range assignment. */
15828 /* FIXME: Only done for full arrays for now, since array sections
15830 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
15831 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
15835 if (mpz_cmp (size
, values
.left
) >= 0)
15837 mpz_init_set (range
, values
.left
);
15838 mpz_sub (size
, size
, values
.left
);
15839 mpz_set_ui (values
.left
, 0);
15843 mpz_init_set (range
, size
);
15844 mpz_sub (values
.left
, values
.left
, size
);
15845 mpz_set_ui (size
, 0);
15848 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15851 mpz_add (offset
, offset
, range
);
15858 /* Assign initial value to symbol. */
15861 mpz_sub_ui (values
.left
, values
.left
, 1);
15862 mpz_sub_ui (size
, size
, 1);
15864 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15869 if (mark
== AR_FULL
)
15870 mpz_add_ui (offset
, offset
, 1);
15872 /* Modify the array section indexes and recalculate the offset
15873 for next element. */
15874 else if (mark
== AR_SECTION
)
15875 gfc_advance_section (section_index
, ar
, &offset
);
15879 if (mark
== AR_SECTION
)
15881 for (i
= 0; i
< ar
->dimen
; i
++)
15882 mpz_clear (section_index
[i
]);
15886 mpz_clear (offset
);
15892 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15894 /* Iterate over a list of elements in a DATA statement. */
15897 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15900 iterator_stack frame
;
15901 gfc_expr
*e
, *start
, *end
, *step
;
15902 bool retval
= true;
15904 mpz_init (frame
.value
);
15907 start
= gfc_copy_expr (var
->iter
.start
);
15908 end
= gfc_copy_expr (var
->iter
.end
);
15909 step
= gfc_copy_expr (var
->iter
.step
);
15911 if (!gfc_simplify_expr (start
, 1)
15912 || start
->expr_type
!= EXPR_CONSTANT
)
15914 gfc_error ("start of implied-do loop at %L could not be "
15915 "simplified to a constant value", &start
->where
);
15919 if (!gfc_simplify_expr (end
, 1)
15920 || end
->expr_type
!= EXPR_CONSTANT
)
15922 gfc_error ("end of implied-do loop at %L could not be "
15923 "simplified to a constant value", &start
->where
);
15927 if (!gfc_simplify_expr (step
, 1)
15928 || step
->expr_type
!= EXPR_CONSTANT
)
15930 gfc_error ("step of implied-do loop at %L could not be "
15931 "simplified to a constant value", &start
->where
);
15936 mpz_set (trip
, end
->value
.integer
);
15937 mpz_sub (trip
, trip
, start
->value
.integer
);
15938 mpz_add (trip
, trip
, step
->value
.integer
);
15940 mpz_div (trip
, trip
, step
->value
.integer
);
15942 mpz_set (frame
.value
, start
->value
.integer
);
15944 frame
.prev
= iter_stack
;
15945 frame
.variable
= var
->iter
.var
->symtree
;
15946 iter_stack
= &frame
;
15948 while (mpz_cmp_ui (trip
, 0) > 0)
15950 if (!traverse_data_var (var
->list
, where
))
15956 e
= gfc_copy_expr (var
->expr
);
15957 if (!gfc_simplify_expr (e
, 1))
15964 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15966 mpz_sub_ui (trip
, trip
, 1);
15970 mpz_clear (frame
.value
);
15973 gfc_free_expr (start
);
15974 gfc_free_expr (end
);
15975 gfc_free_expr (step
);
15977 iter_stack
= frame
.prev
;
15982 /* Type resolve variables in the variable list of a DATA statement. */
15985 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15989 for (; var
; var
= var
->next
)
15991 if (var
->expr
== NULL
)
15992 t
= traverse_data_list (var
, where
);
15994 t
= check_data_variable (var
, where
);
16004 /* Resolve the expressions and iterators associated with a data statement.
16005 This is separate from the assignment checking because data lists should
16006 only be resolved once. */
16009 resolve_data_variables (gfc_data_variable
*d
)
16011 for (; d
; d
= d
->next
)
16013 if (d
->list
== NULL
)
16015 if (!gfc_resolve_expr (d
->expr
))
16020 if (!gfc_resolve_iterator (&d
->iter
, false, true))
16023 if (!resolve_data_variables (d
->list
))
16032 /* Resolve a single DATA statement. We implement this by storing a pointer to
16033 the value list into static variables, and then recursively traversing the
16034 variables list, expanding iterators and such. */
16037 resolve_data (gfc_data
*d
)
16040 if (!resolve_data_variables (d
->var
))
16043 values
.vnode
= d
->value
;
16044 if (d
->value
== NULL
)
16045 mpz_set_ui (values
.left
, 0);
16047 mpz_set (values
.left
, d
->value
->repeat
);
16049 if (!traverse_data_var (d
->var
, &d
->where
))
16052 /* At this point, we better not have any values left. */
16054 if (next_data_value ())
16055 gfc_error ("DATA statement at %L has more values than variables",
16060 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
16061 accessed by host or use association, is a dummy argument to a pure function,
16062 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
16063 is storage associated with any such variable, shall not be used in the
16064 following contexts: (clients of this function). */
16066 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
16067 procedure. Returns zero if assignment is OK, nonzero if there is a
16070 gfc_impure_variable (gfc_symbol
*sym
)
16075 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
16078 /* Check if the symbol's ns is inside the pure procedure. */
16079 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16083 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
16087 proc
= sym
->ns
->proc_name
;
16088 if (sym
->attr
.dummy
16089 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
16090 || proc
->attr
.function
))
16093 /* TODO: Sort out what can be storage associated, if anything, and include
16094 it here. In principle equivalences should be scanned but it does not
16095 seem to be possible to storage associate an impure variable this way. */
16100 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
16101 current namespace is inside a pure procedure. */
16104 gfc_pure (gfc_symbol
*sym
)
16106 symbol_attribute attr
;
16111 /* Check if the current namespace or one of its parents
16112 belongs to a pure procedure. */
16113 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16115 sym
= ns
->proc_name
;
16119 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
16127 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
16131 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16132 checks if the current namespace is implicitly pure. Note that this
16133 function returns false for a PURE procedure. */
16136 gfc_implicit_pure (gfc_symbol
*sym
)
16142 /* Check if the current procedure is implicit_pure. Walk up
16143 the procedure list until we find a procedure. */
16144 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16146 sym
= ns
->proc_name
;
16150 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16155 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
16156 && !sym
->attr
.pure
;
16161 gfc_unset_implicit_pure (gfc_symbol
*sym
)
16167 /* Check if the current procedure is implicit_pure. Walk up
16168 the procedure list until we find a procedure. */
16169 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16171 sym
= ns
->proc_name
;
16175 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16180 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16181 sym
->attr
.implicit_pure
= 0;
16183 sym
->attr
.pure
= 0;
16187 /* Test whether the current procedure is elemental or not. */
16190 gfc_elemental (gfc_symbol
*sym
)
16192 symbol_attribute attr
;
16195 sym
= gfc_current_ns
->proc_name
;
16200 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
16204 /* Warn about unused labels. */
16207 warn_unused_fortran_label (gfc_st_label
*label
)
16212 warn_unused_fortran_label (label
->left
);
16214 if (label
->defined
== ST_LABEL_UNKNOWN
)
16217 switch (label
->referenced
)
16219 case ST_LABEL_UNKNOWN
:
16220 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
16221 label
->value
, &label
->where
);
16224 case ST_LABEL_BAD_TARGET
:
16225 gfc_warning (OPT_Wunused_label
,
16226 "Label %d at %L defined but cannot be used",
16227 label
->value
, &label
->where
);
16234 warn_unused_fortran_label (label
->right
);
16238 /* Returns the sequence type of a symbol or sequence. */
16241 sequence_type (gfc_typespec ts
)
16250 if (ts
.u
.derived
->components
== NULL
)
16251 return SEQ_NONDEFAULT
;
16253 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16254 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16255 if (sequence_type (c
->ts
) != result
)
16261 if (ts
.kind
!= gfc_default_character_kind
)
16262 return SEQ_NONDEFAULT
;
16264 return SEQ_CHARACTER
;
16267 if (ts
.kind
!= gfc_default_integer_kind
)
16268 return SEQ_NONDEFAULT
;
16270 return SEQ_NUMERIC
;
16273 if (!(ts
.kind
== gfc_default_real_kind
16274 || ts
.kind
== gfc_default_double_kind
))
16275 return SEQ_NONDEFAULT
;
16277 return SEQ_NUMERIC
;
16280 if (ts
.kind
!= gfc_default_complex_kind
)
16281 return SEQ_NONDEFAULT
;
16283 return SEQ_NUMERIC
;
16286 if (ts
.kind
!= gfc_default_logical_kind
)
16287 return SEQ_NONDEFAULT
;
16289 return SEQ_NUMERIC
;
16292 return SEQ_NONDEFAULT
;
16297 /* Resolve derived type EQUIVALENCE object. */
16300 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
16302 gfc_component
*c
= derived
->components
;
16307 /* Shall not be an object of nonsequence derived type. */
16308 if (!derived
->attr
.sequence
)
16310 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16311 "attribute to be an EQUIVALENCE object", sym
->name
,
16316 /* Shall not have allocatable components. */
16317 if (derived
->attr
.alloc_comp
)
16319 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16320 "components to be an EQUIVALENCE object",sym
->name
,
16325 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
16327 gfc_error ("Derived type variable %qs at %L with default "
16328 "initialization cannot be in EQUIVALENCE with a variable "
16329 "in COMMON", sym
->name
, &e
->where
);
16333 for (; c
; c
= c
->next
)
16335 if (gfc_bt_struct (c
->ts
.type
)
16336 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
16339 /* Shall not be an object of sequence derived type containing a pointer
16340 in the structure. */
16341 if (c
->attr
.pointer
)
16343 gfc_error ("Derived type variable %qs at %L with pointer "
16344 "component(s) cannot be an EQUIVALENCE object",
16345 sym
->name
, &e
->where
);
16353 /* Resolve equivalence object.
16354 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16355 an allocatable array, an object of nonsequence derived type, an object of
16356 sequence derived type containing a pointer at any level of component
16357 selection, an automatic object, a function name, an entry name, a result
16358 name, a named constant, a structure component, or a subobject of any of
16359 the preceding objects. A substring shall not have length zero. A
16360 derived type shall not have components with default initialization nor
16361 shall two objects of an equivalence group be initialized.
16362 Either all or none of the objects shall have an protected attribute.
16363 The simple constraints are done in symbol.c(check_conflict) and the rest
16364 are implemented here. */
16367 resolve_equivalence (gfc_equiv
*eq
)
16370 gfc_symbol
*first_sym
;
16373 locus
*last_where
= NULL
;
16374 seq_type eq_type
, last_eq_type
;
16375 gfc_typespec
*last_ts
;
16376 int object
, cnt_protected
;
16379 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16381 first_sym
= eq
->expr
->symtree
->n
.sym
;
16385 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16389 e
->ts
= e
->symtree
->n
.sym
->ts
;
16390 /* match_varspec might not know yet if it is seeing
16391 array reference or substring reference, as it doesn't
16393 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16395 gfc_ref
*ref
= e
->ref
;
16396 sym
= e
->symtree
->n
.sym
;
16398 if (sym
->attr
.dimension
)
16400 ref
->u
.ar
.as
= sym
->as
;
16404 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16405 if (e
->ts
.type
== BT_CHARACTER
16407 && ref
->type
== REF_ARRAY
16408 && ref
->u
.ar
.dimen
== 1
16409 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16410 && ref
->u
.ar
.stride
[0] == NULL
)
16412 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16413 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16416 /* Optimize away the (:) reference. */
16417 if (start
== NULL
&& end
== NULL
)
16420 e
->ref
= ref
->next
;
16422 e
->ref
->next
= ref
->next
;
16427 ref
->type
= REF_SUBSTRING
;
16429 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16431 ref
->u
.ss
.start
= start
;
16432 if (end
== NULL
&& e
->ts
.u
.cl
)
16433 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16434 ref
->u
.ss
.end
= end
;
16435 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16442 /* Any further ref is an error. */
16445 gcc_assert (ref
->type
== REF_ARRAY
);
16446 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16452 if (!gfc_resolve_expr (e
))
16455 sym
= e
->symtree
->n
.sym
;
16457 if (sym
->attr
.is_protected
)
16459 if (cnt_protected
> 0 && cnt_protected
!= object
)
16461 gfc_error ("Either all or none of the objects in the "
16462 "EQUIVALENCE set at %L shall have the "
16463 "PROTECTED attribute",
16468 /* Shall not equivalence common block variables in a PURE procedure. */
16469 if (sym
->ns
->proc_name
16470 && sym
->ns
->proc_name
->attr
.pure
16471 && sym
->attr
.in_common
)
16473 /* Need to check for symbols that may have entered the pure
16474 procedure via a USE statement. */
16475 bool saw_sym
= false;
16476 if (sym
->ns
->use_stmts
)
16479 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16480 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16486 gfc_error ("COMMON block member %qs at %L cannot be an "
16487 "EQUIVALENCE object in the pure procedure %qs",
16488 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16492 /* Shall not be a named constant. */
16493 if (e
->expr_type
== EXPR_CONSTANT
)
16495 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16496 "object", sym
->name
, &e
->where
);
16500 if (e
->ts
.type
== BT_DERIVED
16501 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16504 /* Check that the types correspond correctly:
16506 A numeric sequence structure may be equivalenced to another sequence
16507 structure, an object of default integer type, default real type, double
16508 precision real type, default logical type such that components of the
16509 structure ultimately only become associated to objects of the same
16510 kind. A character sequence structure may be equivalenced to an object
16511 of default character kind or another character sequence structure.
16512 Other objects may be equivalenced only to objects of the same type and
16513 kind parameters. */
16515 /* Identical types are unconditionally OK. */
16516 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16517 goto identical_types
;
16519 last_eq_type
= sequence_type (*last_ts
);
16520 eq_type
= sequence_type (sym
->ts
);
16522 /* Since the pair of objects is not of the same type, mixed or
16523 non-default sequences can be rejected. */
16525 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16526 "statement at %L with different type objects";
16528 && last_eq_type
== SEQ_MIXED
16529 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16530 || (eq_type
== SEQ_MIXED
16531 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16534 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16535 "statement at %L with objects of different type";
16537 && last_eq_type
== SEQ_NONDEFAULT
16538 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16539 || (eq_type
== SEQ_NONDEFAULT
16540 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16543 msg
="Non-CHARACTER object %qs in default CHARACTER "
16544 "EQUIVALENCE statement at %L";
16545 if (last_eq_type
== SEQ_CHARACTER
16546 && eq_type
!= SEQ_CHARACTER
16547 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16550 msg
="Non-NUMERIC object %qs in default NUMERIC "
16551 "EQUIVALENCE statement at %L";
16552 if (last_eq_type
== SEQ_NUMERIC
16553 && eq_type
!= SEQ_NUMERIC
16554 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16559 last_where
= &e
->where
;
16564 /* Shall not be an automatic array. */
16565 if (e
->ref
->type
== REF_ARRAY
16566 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16568 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16569 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16576 /* Shall not be a structure component. */
16577 if (r
->type
== REF_COMPONENT
)
16579 gfc_error ("Structure component %qs at %L cannot be an "
16580 "EQUIVALENCE object",
16581 r
->u
.c
.component
->name
, &e
->where
);
16585 /* A substring shall not have length zero. */
16586 if (r
->type
== REF_SUBSTRING
)
16588 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16590 gfc_error ("Substring at %L has length zero",
16591 &r
->u
.ss
.start
->where
);
16601 /* Function called by resolve_fntype to flag other symbol used in the
16602 length type parameter specification of function resuls. */
16605 flag_fn_result_spec (gfc_expr
*expr
,
16607 int *f ATTRIBUTE_UNUSED
)
16612 if (expr
->expr_type
== EXPR_VARIABLE
)
16614 s
= expr
->symtree
->n
.sym
;
16615 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16621 gfc_error ("Self reference in character length expression "
16622 "for %qs at %L", sym
->name
, &expr
->where
);
16626 if (!s
->fn_result_spec
16627 && s
->attr
.flavor
== FL_PARAMETER
)
16629 /* Function contained in a module.... */
16630 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16633 s
->fn_result_spec
= 1;
16634 /* Make sure that this symbol is translated as a module
16636 st
= gfc_get_unique_symtree (ns
);
16640 /* ... which is use associated and called. */
16641 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16643 /* External function matched with an interface. */
16646 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16647 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16648 && s
->ns
->proc_name
->attr
.function
))
16649 s
->fn_result_spec
= 1;
16656 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16659 resolve_fntype (gfc_namespace
*ns
)
16661 gfc_entry_list
*el
;
16664 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16667 /* If there are any entries, ns->proc_name is the entry master
16668 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16670 sym
= ns
->entries
->sym
;
16672 sym
= ns
->proc_name
;
16673 if (sym
->result
== sym
16674 && sym
->ts
.type
== BT_UNKNOWN
16675 && !gfc_set_default_type (sym
, 0, NULL
)
16676 && !sym
->attr
.untyped
)
16678 gfc_error ("Function %qs at %L has no IMPLICIT type",
16679 sym
->name
, &sym
->declared_at
);
16680 sym
->attr
.untyped
= 1;
16683 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16684 && !sym
->attr
.contained
16685 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16686 && gfc_check_symbol_access (sym
))
16688 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16689 "%L of PRIVATE type %qs", sym
->name
,
16690 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16694 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16696 if (el
->sym
->result
== el
->sym
16697 && el
->sym
->ts
.type
== BT_UNKNOWN
16698 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16699 && !el
->sym
->attr
.untyped
)
16701 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16702 el
->sym
->name
, &el
->sym
->declared_at
);
16703 el
->sym
->attr
.untyped
= 1;
16707 if (sym
->ts
.type
== BT_CHARACTER
)
16708 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16712 /* 12.3.2.1.1 Defined operators. */
16715 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16717 gfc_formal_arglist
*formal
;
16719 if (!sym
->attr
.function
)
16721 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16722 sym
->name
, &where
);
16726 if (sym
->ts
.type
== BT_CHARACTER
16727 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16728 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16729 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16731 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16732 "character length", sym
->name
, &where
);
16736 formal
= gfc_sym_get_dummy_args (sym
);
16737 if (!formal
|| !formal
->sym
)
16739 gfc_error ("User operator procedure %qs at %L must have at least "
16740 "one argument", sym
->name
, &where
);
16744 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16746 gfc_error ("First argument of operator interface at %L must be "
16747 "INTENT(IN)", &where
);
16751 if (formal
->sym
->attr
.optional
)
16753 gfc_error ("First argument of operator interface at %L cannot be "
16754 "optional", &where
);
16758 formal
= formal
->next
;
16759 if (!formal
|| !formal
->sym
)
16762 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16764 gfc_error ("Second argument of operator interface at %L must be "
16765 "INTENT(IN)", &where
);
16769 if (formal
->sym
->attr
.optional
)
16771 gfc_error ("Second argument of operator interface at %L cannot be "
16772 "optional", &where
);
16778 gfc_error ("Operator interface at %L must have, at most, two "
16779 "arguments", &where
);
16787 gfc_resolve_uops (gfc_symtree
*symtree
)
16789 gfc_interface
*itr
;
16791 if (symtree
== NULL
)
16794 gfc_resolve_uops (symtree
->left
);
16795 gfc_resolve_uops (symtree
->right
);
16797 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16798 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16802 /* Examine all of the expressions associated with a program unit,
16803 assign types to all intermediate expressions, make sure that all
16804 assignments are to compatible types and figure out which names
16805 refer to which functions or subroutines. It doesn't check code
16806 block, which is handled by gfc_resolve_code. */
16809 resolve_types (gfc_namespace
*ns
)
16815 gfc_namespace
* old_ns
= gfc_current_ns
;
16817 if (ns
->types_resolved
)
16820 /* Check that all IMPLICIT types are ok. */
16821 if (!ns
->seen_implicit_none
)
16824 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
16825 if (ns
->set_flag
[letter
]
16826 && !resolve_typespec_used (&ns
->default_type
[letter
],
16827 &ns
->implicit_loc
[letter
], NULL
))
16831 gfc_current_ns
= ns
;
16833 resolve_entries (ns
);
16835 resolve_common_vars (&ns
->blank_common
, false);
16836 resolve_common_blocks (ns
->common_root
);
16838 resolve_contained_functions (ns
);
16840 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
16841 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16842 resolve_formal_arglist (ns
->proc_name
);
16844 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
16846 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
16847 resolve_charlen (cl
);
16849 gfc_traverse_ns (ns
, resolve_symbol
);
16851 resolve_fntype (ns
);
16853 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16855 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
16856 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16857 "also be PURE", n
->proc_name
->name
,
16858 &n
->proc_name
->declared_at
);
16864 gfc_do_concurrent_flag
= 0;
16865 gfc_check_interfaces (ns
);
16867 gfc_traverse_ns (ns
, resolve_values
);
16869 if (ns
->save_all
|| !flag_automatic
)
16873 for (d
= ns
->data
; d
; d
= d
->next
)
16877 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16879 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16881 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16882 resolve_equivalence (eq
);
16884 /* Warn about unused labels. */
16885 if (warn_unused_label
)
16886 warn_unused_fortran_label (ns
->st_labels
);
16888 gfc_resolve_uops (ns
->uop_root
);
16890 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16892 gfc_resolve_omp_declare_simd (ns
);
16894 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16896 ns
->types_resolved
= 1;
16898 gfc_current_ns
= old_ns
;
16902 /* Call gfc_resolve_code recursively. */
16905 resolve_codes (gfc_namespace
*ns
)
16908 bitmap_obstack old_obstack
;
16910 if (ns
->resolved
== 1)
16913 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16916 gfc_current_ns
= ns
;
16918 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16919 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16922 /* Set to an out of range value. */
16923 current_entry_id
= -1;
16925 old_obstack
= labels_obstack
;
16926 bitmap_obstack_initialize (&labels_obstack
);
16928 gfc_resolve_oacc_declare (ns
);
16929 gfc_resolve_oacc_routines (ns
);
16930 gfc_resolve_omp_local_vars (ns
);
16931 gfc_resolve_code (ns
->code
, ns
);
16933 bitmap_obstack_release (&labels_obstack
);
16934 labels_obstack
= old_obstack
;
16938 /* This function is called after a complete program unit has been compiled.
16939 Its purpose is to examine all of the expressions associated with a program
16940 unit, assign types to all intermediate expressions, make sure that all
16941 assignments are to compatible types and figure out which names refer to
16942 which functions or subroutines. */
16945 gfc_resolve (gfc_namespace
*ns
)
16947 gfc_namespace
*old_ns
;
16948 code_stack
*old_cs_base
;
16949 struct gfc_omp_saved_state old_omp_state
;
16955 old_ns
= gfc_current_ns
;
16956 old_cs_base
= cs_base
;
16958 /* As gfc_resolve can be called during resolution of an OpenMP construct
16959 body, we should clear any state associated to it, so that say NS's
16960 DO loops are not interpreted as OpenMP loops. */
16961 if (!ns
->construct_entities
)
16962 gfc_omp_save_and_clear_state (&old_omp_state
);
16964 resolve_types (ns
);
16965 component_assignment_level
= 0;
16966 resolve_codes (ns
);
16968 gfc_current_ns
= old_ns
;
16969 cs_base
= old_cs_base
;
16972 gfc_run_passes (ns
);
16974 if (!ns
->construct_entities
)
16975 gfc_omp_restore_state (&old_omp_state
);