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
, int sub
)
2513 enum gfc_symbol_type type
;
2516 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2518 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2519 sym
->binding_label
!= NULL
);
2521 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2522 gfc_global_used (gsym
, where
);
2524 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2525 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2526 && gsym
->type
!= GSYM_UNKNOWN
2527 && !gsym
->binding_label
2529 && gsym
->ns
->proc_name
2530 && not_in_recursive (sym
, gsym
->ns
)
2531 && not_entry_self_reference (sym
, gsym
->ns
))
2533 gfc_symbol
*def_sym
;
2534 def_sym
= gsym
->ns
->proc_name
;
2536 if (gsym
->ns
->resolved
!= -1)
2539 /* Resolve the gsymbol namespace if needed. */
2540 if (!gsym
->ns
->resolved
)
2542 gfc_symbol
*old_dt_list
;
2544 /* Stash away derived types so that the backend_decls
2545 do not get mixed up. */
2546 old_dt_list
= gfc_derived_types
;
2547 gfc_derived_types
= NULL
;
2549 gfc_resolve (gsym
->ns
);
2551 /* Store the new derived types with the global namespace. */
2552 if (gfc_derived_types
)
2553 gsym
->ns
->derived_types
= gfc_derived_types
;
2555 /* Restore the derived types of this namespace. */
2556 gfc_derived_types
= old_dt_list
;
2559 /* Make sure that translation for the gsymbol occurs before
2560 the procedure currently being resolved. */
2561 ns
= gfc_global_ns_list
;
2562 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2564 if (ns
->sibling
== gsym
->ns
)
2566 ns
->sibling
= gsym
->ns
->sibling
;
2567 gsym
->ns
->sibling
= gfc_global_ns_list
;
2568 gfc_global_ns_list
= gsym
->ns
;
2573 /* This can happen if a binding name has been specified. */
2574 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2575 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2577 if (def_sym
->attr
.entry_master
|| def_sym
->attr
.entry
)
2579 gfc_entry_list
*entry
;
2580 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2581 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2583 def_sym
= entry
->sym
;
2589 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2591 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2592 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2593 gfc_typename (&def_sym
->ts
));
2597 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2598 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2600 gfc_error ("Explicit interface required for %qs at %L: %s",
2601 sym
->name
, &sym
->declared_at
, reason
);
2605 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2606 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2607 gfc_errors_to_warnings (true);
2609 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2610 reason
, sizeof(reason
), NULL
, NULL
))
2612 gfc_error_opt (OPT_Wargument_mismatch
,
2613 "Interface mismatch in global procedure %qs at %L:"
2614 " %s", sym
->name
, &sym
->declared_at
, reason
);
2620 gfc_errors_to_warnings (false);
2622 if (gsym
->type
== GSYM_UNKNOWN
)
2625 gsym
->where
= *where
;
2632 /************* Function resolution *************/
2634 /* Resolve a function call known to be generic.
2635 Section 14.1.2.4.1. */
2638 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2642 if (sym
->attr
.generic
)
2644 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2647 expr
->value
.function
.name
= s
->name
;
2648 expr
->value
.function
.esym
= s
;
2650 if (s
->ts
.type
!= BT_UNKNOWN
)
2652 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2653 expr
->ts
= s
->result
->ts
;
2656 expr
->rank
= s
->as
->rank
;
2657 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2658 expr
->rank
= s
->result
->as
->rank
;
2660 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2665 /* TODO: Need to search for elemental references in generic
2669 if (sym
->attr
.intrinsic
)
2670 return gfc_intrinsic_func_interface (expr
, 0);
2677 resolve_generic_f (gfc_expr
*expr
)
2681 gfc_interface
*intr
= NULL
;
2683 sym
= expr
->symtree
->n
.sym
;
2687 m
= resolve_generic_f0 (expr
, sym
);
2690 else if (m
== MATCH_ERROR
)
2695 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2696 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2699 if (sym
->ns
->parent
== NULL
)
2701 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2705 if (!generic_sym (sym
))
2709 /* Last ditch attempt. See if the reference is to an intrinsic
2710 that possesses a matching interface. 14.1.2.4 */
2711 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2713 if (gfc_init_expr_flag
)
2714 gfc_error ("Function %qs in initialization expression at %L "
2715 "must be an intrinsic function",
2716 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2718 gfc_error ("There is no specific function for the generic %qs "
2719 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2725 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2728 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2730 return resolve_structure_cons (expr
, 0);
2733 m
= gfc_intrinsic_func_interface (expr
, 0);
2738 gfc_error ("Generic function %qs at %L is not consistent with a "
2739 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2746 /* Resolve a function call known to be specific. */
2749 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2753 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2755 if (sym
->attr
.dummy
)
2757 sym
->attr
.proc
= PROC_DUMMY
;
2761 sym
->attr
.proc
= PROC_EXTERNAL
;
2765 if (sym
->attr
.proc
== PROC_MODULE
2766 || sym
->attr
.proc
== PROC_ST_FUNCTION
2767 || sym
->attr
.proc
== PROC_INTERNAL
)
2770 if (sym
->attr
.intrinsic
)
2772 m
= gfc_intrinsic_func_interface (expr
, 1);
2776 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2777 "with an intrinsic", sym
->name
, &expr
->where
);
2785 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2788 expr
->ts
= sym
->result
->ts
;
2791 expr
->value
.function
.name
= sym
->name
;
2792 expr
->value
.function
.esym
= sym
;
2793 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2795 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2797 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2798 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2799 else if (sym
->as
!= NULL
)
2800 expr
->rank
= sym
->as
->rank
;
2807 resolve_specific_f (gfc_expr
*expr
)
2812 sym
= expr
->symtree
->n
.sym
;
2816 m
= resolve_specific_f0 (sym
, expr
);
2819 if (m
== MATCH_ERROR
)
2822 if (sym
->ns
->parent
== NULL
)
2825 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2831 gfc_error ("Unable to resolve the specific function %qs at %L",
2832 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2837 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2838 candidates in CANDIDATES_LEN. */
2841 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2843 size_t &candidates_len
)
2849 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2850 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2851 vec_push (candidates
, candidates_len
, sym
->name
);
2855 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2859 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2863 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2866 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2868 char **candidates
= NULL
;
2869 size_t candidates_len
= 0;
2870 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2871 return gfc_closest_fuzzy_match (fn
, candidates
);
2875 /* Resolve a procedure call not known to be generic nor specific. */
2878 resolve_unknown_f (gfc_expr
*expr
)
2883 sym
= expr
->symtree
->n
.sym
;
2885 if (sym
->attr
.dummy
)
2887 sym
->attr
.proc
= PROC_DUMMY
;
2888 expr
->value
.function
.name
= sym
->name
;
2892 /* See if we have an intrinsic function reference. */
2894 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2896 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2901 /* The reference is to an external name. */
2903 sym
->attr
.proc
= PROC_EXTERNAL
;
2904 expr
->value
.function
.name
= sym
->name
;
2905 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2907 if (sym
->as
!= NULL
)
2908 expr
->rank
= sym
->as
->rank
;
2910 /* Type of the expression is either the type of the symbol or the
2911 default type of the symbol. */
2914 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2916 if (sym
->ts
.type
!= BT_UNKNOWN
)
2920 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2922 if (ts
->type
== BT_UNKNOWN
)
2925 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2927 gfc_error ("Function %qs at %L has no IMPLICIT type"
2928 "; did you mean %qs?",
2929 sym
->name
, &expr
->where
, guessed
);
2931 gfc_error ("Function %qs at %L has no IMPLICIT type",
2932 sym
->name
, &expr
->where
);
2943 /* Return true, if the symbol is an external procedure. */
2945 is_external_proc (gfc_symbol
*sym
)
2947 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2948 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2949 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2950 && !sym
->attr
.proc_pointer
2951 && !sym
->attr
.use_assoc
2959 /* Figure out if a function reference is pure or not. Also set the name
2960 of the function for a potential error message. Return nonzero if the
2961 function is PURE, zero if not. */
2963 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2966 gfc_pure_function (gfc_expr
*e
, const char **name
)
2969 gfc_component
*comp
;
2973 if (e
->symtree
!= NULL
2974 && e
->symtree
->n
.sym
!= NULL
2975 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2976 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2978 comp
= gfc_get_proc_ptr_comp (e
);
2981 pure
= gfc_pure (comp
->ts
.interface
);
2984 else if (e
->value
.function
.esym
)
2986 pure
= gfc_pure (e
->value
.function
.esym
);
2987 *name
= e
->value
.function
.esym
->name
;
2989 else if (e
->value
.function
.isym
)
2991 pure
= e
->value
.function
.isym
->pure
2992 || e
->value
.function
.isym
->elemental
;
2993 *name
= e
->value
.function
.isym
->name
;
2997 /* Implicit functions are not pure. */
2999 *name
= e
->value
.function
.name
;
3006 /* Check if the expression is a reference to an implicitly pure function. */
3009 gfc_implicit_pure_function (gfc_expr
*e
)
3011 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
3013 return gfc_implicit_pure (comp
->ts
.interface
);
3014 else if (e
->value
.function
.esym
)
3015 return gfc_implicit_pure (e
->value
.function
.esym
);
3022 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3023 int *f ATTRIBUTE_UNUSED
)
3027 /* Don't bother recursing into other statement functions
3028 since they will be checked individually for purity. */
3029 if (e
->expr_type
!= EXPR_FUNCTION
3031 || e
->symtree
->n
.sym
== sym
3032 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3035 return gfc_pure_function (e
, &name
) ? false : true;
3040 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3042 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3046 /* Check if an impure function is allowed in the current context. */
3048 static bool check_pure_function (gfc_expr
*e
)
3050 const char *name
= NULL
;
3051 if (!gfc_pure_function (e
, &name
) && name
)
3055 gfc_error ("Reference to impure function %qs at %L inside a "
3056 "FORALL %s", name
, &e
->where
,
3057 forall_flag
== 2 ? "mask" : "block");
3060 else if (gfc_do_concurrent_flag
)
3062 gfc_error ("Reference to impure function %qs at %L inside a "
3063 "DO CONCURRENT %s", name
, &e
->where
,
3064 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3067 else if (gfc_pure (NULL
))
3069 gfc_error ("Reference to impure function %qs at %L "
3070 "within a PURE procedure", name
, &e
->where
);
3073 if (!gfc_implicit_pure_function (e
))
3074 gfc_unset_implicit_pure (NULL
);
3080 /* Update current procedure's array_outer_dependency flag, considering
3081 a call to procedure SYM. */
3084 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3086 /* Check to see if this is a sibling function that has not yet
3088 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3089 for (; sibling
; sibling
= sibling
->sibling
)
3091 if (sibling
->proc_name
== sym
)
3093 gfc_resolve (sibling
);
3098 /* If SYM has references to outer arrays, so has the procedure calling
3099 SYM. If SYM is a procedure pointer, we can assume the worst. */
3100 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3101 && gfc_current_ns
->proc_name
)
3102 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3106 /* Resolve a function call, which means resolving the arguments, then figuring
3107 out which entity the name refers to. */
3110 resolve_function (gfc_expr
*expr
)
3112 gfc_actual_arglist
*arg
;
3116 procedure_type p
= PROC_INTRINSIC
;
3117 bool no_formal_args
;
3121 sym
= expr
->symtree
->n
.sym
;
3123 /* If this is a procedure pointer component, it has already been resolved. */
3124 if (gfc_is_proc_ptr_comp (expr
))
3127 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3129 if (sym
&& sym
->attr
.intrinsic
3130 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3131 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3134 if (sym
&& sym
->attr
.intrinsic
3135 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3138 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3140 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3144 /* If this is a deferred TBP with an abstract interface (which may
3145 of course be referenced), expr->value.function.esym will be set. */
3146 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3148 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3149 sym
->name
, &expr
->where
);
3153 /* If this is a deferred TBP with an abstract interface, its result
3154 cannot be an assumed length character (F2003: C418). */
3155 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3156 && sym
->result
->ts
.u
.cl
3157 && sym
->result
->ts
.u
.cl
->length
== NULL
3158 && !sym
->result
->ts
.deferred
)
3160 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3161 "character length result (F2008: C418)", sym
->name
,
3166 /* Switch off assumed size checking and do this again for certain kinds
3167 of procedure, once the procedure itself is resolved. */
3168 need_full_assumed_size
++;
3170 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3171 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3173 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3174 inquiry_argument
= true;
3175 no_formal_args
= sym
&& is_external_proc (sym
)
3176 && gfc_sym_get_dummy_args (sym
) == NULL
;
3178 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3181 inquiry_argument
= false;
3185 inquiry_argument
= false;
3187 /* Resume assumed_size checking. */
3188 need_full_assumed_size
--;
3190 /* If the procedure is external, check for usage. */
3191 if (sym
&& is_external_proc (sym
))
3192 resolve_global_procedure (sym
, &expr
->where
, 0);
3194 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3196 && sym
->ts
.u
.cl
->length
== NULL
3198 && !sym
->ts
.deferred
3199 && expr
->value
.function
.esym
== NULL
3200 && !sym
->attr
.contained
)
3202 /* Internal procedures are taken care of in resolve_contained_fntype. */
3203 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3204 "be used at %L since it is not a dummy argument",
3205 sym
->name
, &expr
->where
);
3209 /* See if function is already resolved. */
3211 if (expr
->value
.function
.name
!= NULL
3212 || expr
->value
.function
.isym
!= NULL
)
3214 if (expr
->ts
.type
== BT_UNKNOWN
)
3220 /* Apply the rules of section 14.1.2. */
3222 switch (procedure_kind (sym
))
3225 t
= resolve_generic_f (expr
);
3228 case PTYPE_SPECIFIC
:
3229 t
= resolve_specific_f (expr
);
3233 t
= resolve_unknown_f (expr
);
3237 gfc_internal_error ("resolve_function(): bad function type");
3241 /* If the expression is still a function (it might have simplified),
3242 then we check to see if we are calling an elemental function. */
3244 if (expr
->expr_type
!= EXPR_FUNCTION
)
3247 temp
= need_full_assumed_size
;
3248 need_full_assumed_size
= 0;
3250 if (!resolve_elemental_actual (expr
, NULL
))
3253 if (omp_workshare_flag
3254 && expr
->value
.function
.esym
3255 && ! gfc_elemental (expr
->value
.function
.esym
))
3257 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3258 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3263 #define GENERIC_ID expr->value.function.isym->id
3264 else if (expr
->value
.function
.actual
!= NULL
3265 && expr
->value
.function
.isym
!= NULL
3266 && GENERIC_ID
!= GFC_ISYM_LBOUND
3267 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3268 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3269 && GENERIC_ID
!= GFC_ISYM_LEN
3270 && GENERIC_ID
!= GFC_ISYM_LOC
3271 && GENERIC_ID
!= GFC_ISYM_C_LOC
3272 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3274 /* Array intrinsics must also have the last upper bound of an
3275 assumed size array argument. UBOUND and SIZE have to be
3276 excluded from the check if the second argument is anything
3279 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3281 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3282 && arg
== expr
->value
.function
.actual
3283 && arg
->next
!= NULL
&& arg
->next
->expr
)
3285 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3288 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3291 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3296 if (arg
->expr
!= NULL
3297 && arg
->expr
->rank
> 0
3298 && resolve_assumed_size_actual (arg
->expr
))
3304 need_full_assumed_size
= temp
;
3306 if (!check_pure_function(expr
))
3309 /* Functions without the RECURSIVE attribution are not allowed to
3310 * call themselves. */
3311 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3314 esym
= expr
->value
.function
.esym
;
3316 if (is_illegal_recursion (esym
, gfc_current_ns
))
3318 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3319 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3320 " function %qs is not RECURSIVE",
3321 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3323 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3324 " is not RECURSIVE", esym
->name
, &expr
->where
);
3330 /* Character lengths of use associated functions may contains references to
3331 symbols not referenced from the current program unit otherwise. Make sure
3332 those symbols are marked as referenced. */
3334 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3335 && expr
->value
.function
.esym
->attr
.use_assoc
)
3337 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3340 /* Make sure that the expression has a typespec that works. */
3341 if (expr
->ts
.type
== BT_UNKNOWN
)
3343 if (expr
->symtree
->n
.sym
->result
3344 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3345 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3346 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3349 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3351 if (expr
->value
.function
.esym
)
3352 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3354 update_current_proc_array_outer_dependency (sym
);
3357 /* typebound procedure: Assume the worst. */
3358 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3364 /************* Subroutine resolution *************/
3367 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3374 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3378 else if (gfc_do_concurrent_flag
)
3380 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3384 else if (gfc_pure (NULL
))
3386 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3390 gfc_unset_implicit_pure (NULL
);
3396 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3400 if (sym
->attr
.generic
)
3402 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3405 c
->resolved_sym
= s
;
3406 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3411 /* TODO: Need to search for elemental references in generic interface. */
3414 if (sym
->attr
.intrinsic
)
3415 return gfc_intrinsic_sub_interface (c
, 0);
3422 resolve_generic_s (gfc_code
*c
)
3427 sym
= c
->symtree
->n
.sym
;
3431 m
= resolve_generic_s0 (c
, sym
);
3434 else if (m
== MATCH_ERROR
)
3438 if (sym
->ns
->parent
== NULL
)
3440 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3444 if (!generic_sym (sym
))
3448 /* Last ditch attempt. See if the reference is to an intrinsic
3449 that possesses a matching interface. 14.1.2.4 */
3450 sym
= c
->symtree
->n
.sym
;
3452 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3454 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3455 sym
->name
, &c
->loc
);
3459 m
= gfc_intrinsic_sub_interface (c
, 0);
3463 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3464 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3470 /* Resolve a subroutine call known to be specific. */
3473 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3477 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3479 if (sym
->attr
.dummy
)
3481 sym
->attr
.proc
= PROC_DUMMY
;
3485 sym
->attr
.proc
= PROC_EXTERNAL
;
3489 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3492 if (sym
->attr
.intrinsic
)
3494 m
= gfc_intrinsic_sub_interface (c
, 1);
3498 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3499 "with an intrinsic", sym
->name
, &c
->loc
);
3507 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3509 c
->resolved_sym
= sym
;
3510 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3518 resolve_specific_s (gfc_code
*c
)
3523 sym
= c
->symtree
->n
.sym
;
3527 m
= resolve_specific_s0 (c
, sym
);
3530 if (m
== MATCH_ERROR
)
3533 if (sym
->ns
->parent
== NULL
)
3536 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3542 sym
= c
->symtree
->n
.sym
;
3543 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3544 sym
->name
, &c
->loc
);
3550 /* Resolve a subroutine call not known to be generic nor specific. */
3553 resolve_unknown_s (gfc_code
*c
)
3557 sym
= c
->symtree
->n
.sym
;
3559 if (sym
->attr
.dummy
)
3561 sym
->attr
.proc
= PROC_DUMMY
;
3565 /* See if we have an intrinsic function reference. */
3567 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3569 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3574 /* The reference is to an external name. */
3577 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3579 c
->resolved_sym
= sym
;
3581 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3585 /* Resolve a subroutine call. Although it was tempting to use the same code
3586 for functions, subroutines and functions are stored differently and this
3587 makes things awkward. */
3590 resolve_call (gfc_code
*c
)
3593 procedure_type ptype
= PROC_INTRINSIC
;
3594 gfc_symbol
*csym
, *sym
;
3595 bool no_formal_args
;
3597 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3599 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3601 gfc_error ("%qs at %L has a type, which is not consistent with "
3602 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3606 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3609 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3610 sym
= st
? st
->n
.sym
: NULL
;
3611 if (sym
&& csym
!= sym
3612 && sym
->ns
== gfc_current_ns
3613 && sym
->attr
.flavor
== FL_PROCEDURE
3614 && sym
->attr
.contained
)
3617 if (csym
->attr
.generic
)
3618 c
->symtree
->n
.sym
= sym
;
3621 csym
= c
->symtree
->n
.sym
;
3625 /* If this ia a deferred TBP, c->expr1 will be set. */
3626 if (!c
->expr1
&& csym
)
3628 if (csym
->attr
.abstract
)
3630 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3631 csym
->name
, &c
->loc
);
3635 /* Subroutines without the RECURSIVE attribution are not allowed to
3637 if (is_illegal_recursion (csym
, gfc_current_ns
))
3639 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3640 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3641 "as subroutine %qs is not RECURSIVE",
3642 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3644 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3645 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3651 /* Switch off assumed size checking and do this again for certain kinds
3652 of procedure, once the procedure itself is resolved. */
3653 need_full_assumed_size
++;
3656 ptype
= csym
->attr
.proc
;
3658 no_formal_args
= csym
&& is_external_proc (csym
)
3659 && gfc_sym_get_dummy_args (csym
) == NULL
;
3660 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3663 /* Resume assumed_size checking. */
3664 need_full_assumed_size
--;
3666 /* If external, check for usage. */
3667 if (csym
&& is_external_proc (csym
))
3668 resolve_global_procedure (csym
, &c
->loc
, 1);
3671 if (c
->resolved_sym
== NULL
)
3673 c
->resolved_isym
= NULL
;
3674 switch (procedure_kind (csym
))
3677 t
= resolve_generic_s (c
);
3680 case PTYPE_SPECIFIC
:
3681 t
= resolve_specific_s (c
);
3685 t
= resolve_unknown_s (c
);
3689 gfc_internal_error ("resolve_subroutine(): bad function type");
3693 /* Some checks of elemental subroutine actual arguments. */
3694 if (!resolve_elemental_actual (NULL
, c
))
3698 update_current_proc_array_outer_dependency (csym
);
3700 /* Typebound procedure: Assume the worst. */
3701 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3707 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3708 op1->shape and op2->shape are non-NULL return true if their shapes
3709 match. If both op1->shape and op2->shape are non-NULL return false
3710 if their shapes do not match. If either op1->shape or op2->shape is
3711 NULL, return true. */
3714 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3721 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3723 for (i
= 0; i
< op1
->rank
; i
++)
3725 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3727 gfc_error ("Shapes for operands at %L and %L are not conformable",
3728 &op1
->where
, &op2
->where
);
3738 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3739 For example A .AND. B becomes IAND(A, B). */
3741 logical_to_bitwise (gfc_expr
*e
)
3743 gfc_expr
*tmp
, *op1
, *op2
;
3745 gfc_actual_arglist
*args
= NULL
;
3747 gcc_assert (e
->expr_type
== EXPR_OP
);
3749 isym
= GFC_ISYM_NONE
;
3750 op1
= e
->value
.op
.op1
;
3751 op2
= e
->value
.op
.op2
;
3753 switch (e
->value
.op
.op
)
3756 isym
= GFC_ISYM_NOT
;
3759 isym
= GFC_ISYM_IAND
;
3762 isym
= GFC_ISYM_IOR
;
3764 case INTRINSIC_NEQV
:
3765 isym
= GFC_ISYM_IEOR
;
3768 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3769 Change the old expression to NEQV, which will get replaced by IEOR,
3770 and wrap it in NOT. */
3771 tmp
= gfc_copy_expr (e
);
3772 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3773 tmp
= logical_to_bitwise (tmp
);
3774 isym
= GFC_ISYM_NOT
;
3779 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3782 /* Inherit the original operation's operands as arguments. */
3783 args
= gfc_get_actual_arglist ();
3787 args
->next
= gfc_get_actual_arglist ();
3788 args
->next
->expr
= op2
;
3791 /* Convert the expression to a function call. */
3792 e
->expr_type
= EXPR_FUNCTION
;
3793 e
->value
.function
.actual
= args
;
3794 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3795 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3796 e
->value
.function
.esym
= NULL
;
3798 /* Make up a pre-resolved function call symtree if we need to. */
3799 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3802 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3803 sym
= e
->symtree
->n
.sym
;
3805 sym
->attr
.flavor
= FL_PROCEDURE
;
3806 sym
->attr
.function
= 1;
3807 sym
->attr
.elemental
= 1;
3809 sym
->attr
.referenced
= 1;
3810 gfc_intrinsic_symbol (sym
);
3811 gfc_commit_symbol (sym
);
3814 args
->name
= e
->value
.function
.isym
->formal
->name
;
3815 if (e
->value
.function
.isym
->formal
->next
)
3816 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3821 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3822 candidates in CANDIDATES_LEN. */
3824 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3826 size_t &candidates_len
)
3833 /* Not sure how to properly filter here. Use all for a start.
3834 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3835 these as i suppose they don't make terribly sense. */
3837 if (uop
->n
.uop
->op
!= NULL
)
3838 vec_push (candidates
, candidates_len
, uop
->name
);
3842 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3846 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3849 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3852 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3854 char **candidates
= NULL
;
3855 size_t candidates_len
= 0;
3856 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3857 return gfc_closest_fuzzy_match (op
, candidates
);
3861 /* Callback finding an impure function as an operand to an .and. or
3862 .or. expression. Remember the last function warned about to
3863 avoid double warnings when recursing. */
3866 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3871 static gfc_expr
*last
= NULL
;
3872 bool *found
= (bool *) data
;
3874 if (f
->expr_type
== EXPR_FUNCTION
)
3877 if (f
!= last
&& !gfc_pure_function (f
, &name
)
3878 && !gfc_implicit_pure_function (f
))
3881 gfc_warning (OPT_Wfunction_elimination
,
3882 "Impure function %qs at %L might not be evaluated",
3885 gfc_warning (OPT_Wfunction_elimination
,
3886 "Impure function at %L might not be evaluated",
3896 /* Resolve an operator expression node. This can involve replacing the
3897 operation with a user defined function call. */
3900 resolve_operator (gfc_expr
*e
)
3902 gfc_expr
*op1
, *op2
;
3904 bool dual_locus_error
;
3907 /* Resolve all subnodes-- give them types. */
3909 switch (e
->value
.op
.op
)
3912 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3918 case INTRINSIC_UPLUS
:
3919 case INTRINSIC_UMINUS
:
3920 case INTRINSIC_PARENTHESES
:
3921 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3924 && e
->value
.op
.op1
->ts
.type
== BT_BOZ
&& !e
->value
.op
.op2
)
3926 gfc_error ("BOZ literal constant at %L cannot be an operand of "
3927 "unary operator %qs", &e
->value
.op
.op1
->where
,
3928 gfc_op2string (e
->value
.op
.op
));
3934 /* Typecheck the new node. */
3936 op1
= e
->value
.op
.op1
;
3937 op2
= e
->value
.op
.op2
;
3938 dual_locus_error
= false;
3940 /* op1 and op2 cannot both be BOZ. */
3941 if (op1
&& op1
->ts
.type
== BT_BOZ
3942 && op2
&& op2
->ts
.type
== BT_BOZ
)
3944 gfc_error ("Operands at %L and %L cannot appear as operands of "
3945 "binary operator %qs", &op1
->where
, &op2
->where
,
3946 gfc_op2string (e
->value
.op
.op
));
3950 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3951 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3953 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3957 switch (e
->value
.op
.op
)
3959 case INTRINSIC_UPLUS
:
3960 case INTRINSIC_UMINUS
:
3961 if (op1
->ts
.type
== BT_INTEGER
3962 || op1
->ts
.type
== BT_REAL
3963 || op1
->ts
.type
== BT_COMPLEX
)
3969 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3970 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3973 case INTRINSIC_PLUS
:
3974 case INTRINSIC_MINUS
:
3975 case INTRINSIC_TIMES
:
3976 case INTRINSIC_DIVIDE
:
3977 case INTRINSIC_POWER
:
3978 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3980 gfc_type_convert_binary (e
, 1);
3984 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
3986 _("Unexpected derived-type entities in binary intrinsic "
3987 "numeric operator %%<%s%%> at %%L"),
3988 gfc_op2string (e
->value
.op
.op
));
3991 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3992 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3993 gfc_typename (&op2
->ts
));
3996 case INTRINSIC_CONCAT
:
3997 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3998 && op1
->ts
.kind
== op2
->ts
.kind
)
4000 e
->ts
.type
= BT_CHARACTER
;
4001 e
->ts
.kind
= op1
->ts
.kind
;
4006 _("Operands of string concatenation operator at %%L are %s/%s"),
4007 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
4013 case INTRINSIC_NEQV
:
4014 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4016 e
->ts
.type
= BT_LOGICAL
;
4017 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4018 if (op1
->ts
.kind
< e
->ts
.kind
)
4019 gfc_convert_type (op1
, &e
->ts
, 2);
4020 else if (op2
->ts
.kind
< e
->ts
.kind
)
4021 gfc_convert_type (op2
, &e
->ts
, 2);
4023 if (flag_frontend_optimize
&&
4024 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4026 /* Warn about short-circuiting
4027 with impure function as second operand. */
4029 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4034 /* Logical ops on integers become bitwise ops with -fdec. */
4036 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4038 e
->ts
.type
= BT_INTEGER
;
4039 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4040 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4041 gfc_convert_type (op1
, &e
->ts
, 1);
4042 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4043 gfc_convert_type (op2
, &e
->ts
, 1);
4044 e
= logical_to_bitwise (e
);
4048 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4049 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4050 gfc_typename (&op2
->ts
));
4055 /* Logical ops on integers become bitwise ops with -fdec. */
4056 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4058 e
->ts
.type
= BT_INTEGER
;
4059 e
->ts
.kind
= op1
->ts
.kind
;
4060 e
= logical_to_bitwise (e
);
4064 if (op1
->ts
.type
== BT_LOGICAL
)
4066 e
->ts
.type
= BT_LOGICAL
;
4067 e
->ts
.kind
= op1
->ts
.kind
;
4071 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4072 gfc_typename (&op1
->ts
));
4076 case INTRINSIC_GT_OS
:
4078 case INTRINSIC_GE_OS
:
4080 case INTRINSIC_LT_OS
:
4082 case INTRINSIC_LE_OS
:
4083 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4085 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4092 case INTRINSIC_EQ_OS
:
4094 case INTRINSIC_NE_OS
:
4095 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4096 && op1
->ts
.kind
== op2
->ts
.kind
)
4098 e
->ts
.type
= BT_LOGICAL
;
4099 e
->ts
.kind
= gfc_default_logical_kind
;
4103 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4104 if (op1
->ts
.type
== BT_BOZ
)
4106 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4107 "an operand of a relational operator",
4111 if (op2
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op1
, op2
->ts
.kind
))
4114 if (op2
->ts
.type
== BT_REAL
&& !gfc_boz2real (op1
, op2
->ts
.kind
))
4118 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4119 if (op2
->ts
.type
== BT_BOZ
)
4121 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4122 "an operand of a relational operator",
4126 if (op1
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op2
, op1
->ts
.kind
))
4129 if (op1
->ts
.type
== BT_REAL
&& !gfc_boz2real (op2
, op1
->ts
.kind
))
4133 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4135 gfc_type_convert_binary (e
, 1);
4137 e
->ts
.type
= BT_LOGICAL
;
4138 e
->ts
.kind
= gfc_default_logical_kind
;
4140 if (warn_compare_reals
)
4142 gfc_intrinsic_op op
= e
->value
.op
.op
;
4144 /* Type conversion has made sure that the types of op1 and op2
4145 agree, so it is only necessary to check the first one. */
4146 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4147 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4148 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4152 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4153 msg
= "Equality comparison for %s at %L";
4155 msg
= "Inequality comparison for %s at %L";
4157 gfc_warning (OPT_Wcompare_reals
, msg
,
4158 gfc_typename (&op1
->ts
), &op1
->where
);
4165 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4167 _("Logicals at %%L must be compared with %s instead of %s"),
4168 (e
->value
.op
.op
== INTRINSIC_EQ
4169 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4170 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4173 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4174 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4175 gfc_typename (&op2
->ts
));
4179 case INTRINSIC_USER
:
4180 if (e
->value
.op
.uop
->op
== NULL
)
4182 const char *name
= e
->value
.op
.uop
->name
;
4183 const char *guessed
;
4184 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4186 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4189 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4191 else if (op2
== NULL
)
4192 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4193 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4196 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4197 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4198 gfc_typename (&op2
->ts
));
4199 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4204 case INTRINSIC_PARENTHESES
:
4206 if (e
->ts
.type
== BT_CHARACTER
)
4207 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4211 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4214 /* Deal with arrayness of an operand through an operator. */
4216 switch (e
->value
.op
.op
)
4218 case INTRINSIC_PLUS
:
4219 case INTRINSIC_MINUS
:
4220 case INTRINSIC_TIMES
:
4221 case INTRINSIC_DIVIDE
:
4222 case INTRINSIC_POWER
:
4223 case INTRINSIC_CONCAT
:
4227 case INTRINSIC_NEQV
:
4229 case INTRINSIC_EQ_OS
:
4231 case INTRINSIC_NE_OS
:
4233 case INTRINSIC_GT_OS
:
4235 case INTRINSIC_GE_OS
:
4237 case INTRINSIC_LT_OS
:
4239 case INTRINSIC_LE_OS
:
4241 if (op1
->rank
== 0 && op2
->rank
== 0)
4244 if (op1
->rank
== 0 && op2
->rank
!= 0)
4246 e
->rank
= op2
->rank
;
4248 if (e
->shape
== NULL
)
4249 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4252 if (op1
->rank
!= 0 && op2
->rank
== 0)
4254 e
->rank
= op1
->rank
;
4256 if (e
->shape
== NULL
)
4257 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4260 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4262 if (op1
->rank
== op2
->rank
)
4264 e
->rank
= op1
->rank
;
4265 if (e
->shape
== NULL
)
4267 t
= compare_shapes (op1
, op2
);
4271 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4276 /* Allow higher level expressions to work. */
4279 /* Try user-defined operators, and otherwise throw an error. */
4280 dual_locus_error
= true;
4282 _("Inconsistent ranks for operator at %%L and %%L"));
4289 case INTRINSIC_PARENTHESES
:
4291 case INTRINSIC_UPLUS
:
4292 case INTRINSIC_UMINUS
:
4293 /* Simply copy arrayness attribute */
4294 e
->rank
= op1
->rank
;
4296 if (e
->shape
== NULL
)
4297 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4307 /* Attempt to simplify the expression. */
4310 t
= gfc_simplify_expr (e
, 0);
4311 /* Some calls do not succeed in simplification and return false
4312 even though there is no error; e.g. variable references to
4313 PARAMETER arrays. */
4314 if (!gfc_is_constant_expr (e
))
4322 match m
= gfc_extend_expr (e
);
4325 if (m
== MATCH_ERROR
)
4329 if (dual_locus_error
)
4330 gfc_error (msg
, &op1
->where
, &op2
->where
);
4332 gfc_error (msg
, &e
->where
);
4338 /************** Array resolution subroutines **************/
4341 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4343 /* Compare two integer expressions. */
4345 static compare_result
4346 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4350 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4351 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4354 /* If either of the types isn't INTEGER, we must have
4355 raised an error earlier. */
4357 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4360 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4370 /* Compare an integer expression with an integer. */
4372 static compare_result
4373 compare_bound_int (gfc_expr
*a
, int b
)
4377 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4380 if (a
->ts
.type
!= BT_INTEGER
)
4381 gfc_internal_error ("compare_bound_int(): Bad expression");
4383 i
= mpz_cmp_si (a
->value
.integer
, b
);
4393 /* Compare an integer expression with a mpz_t. */
4395 static compare_result
4396 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4400 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4403 if (a
->ts
.type
!= BT_INTEGER
)
4404 gfc_internal_error ("compare_bound_int(): Bad expression");
4406 i
= mpz_cmp (a
->value
.integer
, b
);
4416 /* Compute the last value of a sequence given by a triplet.
4417 Return 0 if it wasn't able to compute the last value, or if the
4418 sequence if empty, and 1 otherwise. */
4421 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4422 gfc_expr
*stride
, mpz_t last
)
4426 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4427 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4428 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4431 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4432 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4435 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4437 if (compare_bound (start
, end
) == CMP_GT
)
4439 mpz_set (last
, end
->value
.integer
);
4443 if (compare_bound_int (stride
, 0) == CMP_GT
)
4445 /* Stride is positive */
4446 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4451 /* Stride is negative */
4452 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4457 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4458 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4459 mpz_sub (last
, end
->value
.integer
, rem
);
4466 /* Compare a single dimension of an array reference to the array
4470 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4474 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4476 gcc_assert (ar
->stride
[i
] == NULL
);
4477 /* This implies [*] as [*:] and [*:3] are not possible. */
4478 if (ar
->start
[i
] == NULL
)
4480 gcc_assert (ar
->end
[i
] == NULL
);
4485 /* Given start, end and stride values, calculate the minimum and
4486 maximum referenced indexes. */
4488 switch (ar
->dimen_type
[i
])
4491 case DIMEN_THIS_IMAGE
:
4496 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4499 gfc_warning (0, "Array reference at %L is out of bounds "
4500 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4501 mpz_get_si (ar
->start
[i
]->value
.integer
),
4502 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4504 gfc_warning (0, "Array reference at %L is out of bounds "
4505 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4506 mpz_get_si (ar
->start
[i
]->value
.integer
),
4507 mpz_get_si (as
->lower
[i
]->value
.integer
),
4511 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4514 gfc_warning (0, "Array reference at %L is out of bounds "
4515 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4516 mpz_get_si (ar
->start
[i
]->value
.integer
),
4517 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4519 gfc_warning (0, "Array reference at %L is out of bounds "
4520 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4521 mpz_get_si (ar
->start
[i
]->value
.integer
),
4522 mpz_get_si (as
->upper
[i
]->value
.integer
),
4531 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4532 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4534 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4536 /* Check for zero stride, which is not allowed. */
4537 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4539 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4543 /* if start == len || (stride > 0 && start < len)
4544 || (stride < 0 && start > len),
4545 then the array section contains at least one element. In this
4546 case, there is an out-of-bounds access if
4547 (start < lower || start > upper). */
4548 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4549 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4550 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4551 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4552 && comp_start_end
== CMP_GT
))
4554 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4556 gfc_warning (0, "Lower array reference at %L is out of bounds "
4557 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4558 mpz_get_si (AR_START
->value
.integer
),
4559 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4562 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4564 gfc_warning (0, "Lower array reference at %L is out of bounds "
4565 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4566 mpz_get_si (AR_START
->value
.integer
),
4567 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4572 /* If we can compute the highest index of the array section,
4573 then it also has to be between lower and upper. */
4574 mpz_init (last_value
);
4575 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4578 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4580 gfc_warning (0, "Upper array reference at %L is out of bounds "
4581 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4582 mpz_get_si (last_value
),
4583 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4584 mpz_clear (last_value
);
4587 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4589 gfc_warning (0, "Upper array reference at %L is out of bounds "
4590 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4591 mpz_get_si (last_value
),
4592 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4593 mpz_clear (last_value
);
4597 mpz_clear (last_value
);
4605 gfc_internal_error ("check_dimension(): Bad array reference");
4612 /* Compare an array reference with an array specification. */
4615 compare_spec_to_ref (gfc_array_ref
*ar
)
4622 /* TODO: Full array sections are only allowed as actual parameters. */
4623 if (as
->type
== AS_ASSUMED_SIZE
4624 && (/*ar->type == AR_FULL
4625 ||*/ (ar
->type
== AR_SECTION
4626 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4628 gfc_error ("Rightmost upper bound of assumed size array section "
4629 "not specified at %L", &ar
->where
);
4633 if (ar
->type
== AR_FULL
)
4636 if (as
->rank
!= ar
->dimen
)
4638 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4639 &ar
->where
, ar
->dimen
, as
->rank
);
4643 /* ar->codimen == 0 is a local array. */
4644 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4646 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4647 &ar
->where
, ar
->codimen
, as
->corank
);
4651 for (i
= 0; i
< as
->rank
; i
++)
4652 if (!check_dimension (i
, ar
, as
))
4655 /* Local access has no coarray spec. */
4656 if (ar
->codimen
!= 0)
4657 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4659 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4660 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4662 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4663 i
+ 1 - as
->rank
, &ar
->where
);
4666 if (!check_dimension (i
, ar
, as
))
4674 /* Resolve one part of an array index. */
4677 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4678 int force_index_integer_kind
)
4685 if (!gfc_resolve_expr (index
))
4688 if (check_scalar
&& index
->rank
!= 0)
4690 gfc_error ("Array index at %L must be scalar", &index
->where
);
4694 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4696 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4697 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4701 if (index
->ts
.type
== BT_REAL
)
4702 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4706 if ((index
->ts
.kind
!= gfc_index_integer_kind
4707 && force_index_integer_kind
)
4708 || index
->ts
.type
!= BT_INTEGER
)
4711 ts
.type
= BT_INTEGER
;
4712 ts
.kind
= gfc_index_integer_kind
;
4714 gfc_convert_type_warn (index
, &ts
, 2, 0);
4720 /* Resolve one part of an array index. */
4723 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4725 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4728 /* Resolve a dim argument to an intrinsic function. */
4731 gfc_resolve_dim_arg (gfc_expr
*dim
)
4736 if (!gfc_resolve_expr (dim
))
4741 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4746 if (dim
->ts
.type
!= BT_INTEGER
)
4748 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4752 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4757 ts
.type
= BT_INTEGER
;
4758 ts
.kind
= gfc_index_integer_kind
;
4760 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4766 /* Given an expression that contains array references, update those array
4767 references to point to the right array specifications. While this is
4768 filled in during matching, this information is difficult to save and load
4769 in a module, so we take care of it here.
4771 The idea here is that the original array reference comes from the
4772 base symbol. We traverse the list of reference structures, setting
4773 the stored reference to references. Component references can
4774 provide an additional array specification. */
4777 find_array_spec (gfc_expr
*e
)
4782 bool class_as
= false;
4784 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4786 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4790 as
= e
->symtree
->n
.sym
->as
;
4792 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4797 gfc_internal_error ("find_array_spec(): Missing spec");
4804 c
= ref
->u
.c
.component
;
4805 if (c
->attr
.dimension
)
4807 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
4808 gfc_internal_error ("find_array_spec(): unused as(1)");
4820 gfc_internal_error ("find_array_spec(): unused as(2)");
4824 /* Resolve an array reference. */
4827 resolve_array_ref (gfc_array_ref
*ar
)
4829 int i
, check_scalar
;
4832 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4834 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4836 /* Do not force gfc_index_integer_kind for the start. We can
4837 do fine with any integer kind. This avoids temporary arrays
4838 created for indexing with a vector. */
4839 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4841 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4843 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4848 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4852 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4856 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4857 if (e
->expr_type
== EXPR_VARIABLE
4858 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4859 ar
->start
[i
] = gfc_get_parentheses (e
);
4863 gfc_error ("Array index at %L is an array of rank %d",
4864 &ar
->c_where
[i
], e
->rank
);
4868 /* Fill in the upper bound, which may be lower than the
4869 specified one for something like a(2:10:5), which is
4870 identical to a(2:7:5). Only relevant for strides not equal
4871 to one. Don't try a division by zero. */
4872 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4873 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4874 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4875 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4879 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4881 if (ar
->end
[i
] == NULL
)
4884 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4886 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4888 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4889 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4891 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4902 if (ar
->type
== AR_FULL
)
4904 if (ar
->as
->rank
== 0)
4905 ar
->type
= AR_ELEMENT
;
4907 /* Make sure array is the same as array(:,:), this way
4908 we don't need to special case all the time. */
4909 ar
->dimen
= ar
->as
->rank
;
4910 for (i
= 0; i
< ar
->dimen
; i
++)
4912 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4914 gcc_assert (ar
->start
[i
] == NULL
);
4915 gcc_assert (ar
->end
[i
] == NULL
);
4916 gcc_assert (ar
->stride
[i
] == NULL
);
4920 /* If the reference type is unknown, figure out what kind it is. */
4922 if (ar
->type
== AR_UNKNOWN
)
4924 ar
->type
= AR_ELEMENT
;
4925 for (i
= 0; i
< ar
->dimen
; i
++)
4926 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4927 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4929 ar
->type
= AR_SECTION
;
4934 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4937 if (ar
->as
->corank
&& ar
->codimen
== 0)
4940 ar
->codimen
= ar
->as
->corank
;
4941 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4942 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4950 resolve_substring (gfc_ref
*ref
, bool *equal_length
)
4952 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4954 if (ref
->u
.ss
.start
!= NULL
)
4956 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4959 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4961 gfc_error ("Substring start index at %L must be of type INTEGER",
4962 &ref
->u
.ss
.start
->where
);
4966 if (ref
->u
.ss
.start
->rank
!= 0)
4968 gfc_error ("Substring start index at %L must be scalar",
4969 &ref
->u
.ss
.start
->where
);
4973 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4974 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4975 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4977 gfc_error ("Substring start index at %L is less than one",
4978 &ref
->u
.ss
.start
->where
);
4983 if (ref
->u
.ss
.end
!= NULL
)
4985 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4988 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4990 gfc_error ("Substring end index at %L must be of type INTEGER",
4991 &ref
->u
.ss
.end
->where
);
4995 if (ref
->u
.ss
.end
->rank
!= 0)
4997 gfc_error ("Substring end index at %L must be scalar",
4998 &ref
->u
.ss
.end
->where
);
5002 if (ref
->u
.ss
.length
!= NULL
5003 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
5004 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5005 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5007 gfc_error ("Substring end index at %L exceeds the string length",
5008 &ref
->u
.ss
.start
->where
);
5012 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
5013 gfc_integer_kinds
[k
].huge
) == 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 is too large",
5018 &ref
->u
.ss
.end
->where
);
5021 /* If the substring has the same length as the original
5022 variable, the reference itself can be deleted. */
5024 if (ref
->u
.ss
.length
!= NULL
5025 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
5026 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
5027 *equal_length
= true;
5034 /* This function supplies missing substring charlens. */
5037 gfc_resolve_substring_charlen (gfc_expr
*e
)
5040 gfc_expr
*start
, *end
;
5041 gfc_typespec
*ts
= NULL
;
5044 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5046 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5048 if (char_ref
->type
== REF_COMPONENT
)
5049 ts
= &char_ref
->u
.c
.component
->ts
;
5052 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5055 gcc_assert (char_ref
->next
== NULL
);
5059 if (e
->ts
.u
.cl
->length
)
5060 gfc_free_expr (e
->ts
.u
.cl
->length
);
5061 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5065 e
->ts
.type
= BT_CHARACTER
;
5066 e
->ts
.kind
= gfc_default_character_kind
;
5069 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5071 if (char_ref
->u
.ss
.start
)
5072 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5074 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5076 if (char_ref
->u
.ss
.end
)
5077 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5078 else if (e
->expr_type
== EXPR_VARIABLE
)
5081 ts
= &e
->symtree
->n
.sym
->ts
;
5082 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5089 gfc_free_expr (start
);
5090 gfc_free_expr (end
);
5094 /* Length = (end - start + 1).
5095 Check first whether it has a constant length. */
5096 if (gfc_dep_difference (end
, start
, &diff
))
5098 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5101 mpz_add_ui (len
->value
.integer
, diff
, 1);
5103 e
->ts
.u
.cl
->length
= len
;
5104 /* The check for length < 0 is handled below */
5108 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5109 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5110 gfc_get_int_expr (gfc_charlen_int_kind
,
5114 /* F2008, 6.4.1: Both the starting point and the ending point shall
5115 be within the range 1, 2, ..., n unless the starting point exceeds
5116 the ending point, in which case the substring has length zero. */
5118 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5119 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5121 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5122 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5124 /* Make sure that the length is simplified. */
5125 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5126 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5130 /* Resolve subtype references. */
5133 resolve_ref (gfc_expr
*expr
)
5135 int current_part_dimension
, n_components
, seen_part_dimension
;
5136 gfc_ref
*ref
, **prev
;
5139 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5140 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5142 find_array_spec (expr
);
5146 for (prev
= &expr
->ref
; *prev
!= NULL
;
5147 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5148 switch ((*prev
)->type
)
5151 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5160 equal_length
= false;
5161 if (!resolve_substring (*prev
, &equal_length
))
5164 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5166 /* Remove the reference and move the charlen, if any. */
5170 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5171 ref
->u
.ss
.length
= NULL
;
5172 gfc_free_ref_list (ref
);
5177 /* Check constraints on part references. */
5179 current_part_dimension
= 0;
5180 seen_part_dimension
= 0;
5183 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5188 switch (ref
->u
.ar
.type
)
5191 /* Coarray scalar. */
5192 if (ref
->u
.ar
.as
->rank
== 0)
5194 current_part_dimension
= 0;
5199 current_part_dimension
= 1;
5203 current_part_dimension
= 0;
5207 gfc_internal_error ("resolve_ref(): Bad array reference");
5213 if (current_part_dimension
|| seen_part_dimension
)
5216 if (ref
->u
.c
.component
->attr
.pointer
5217 || ref
->u
.c
.component
->attr
.proc_pointer
5218 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5219 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5221 gfc_error ("Component to the right of a part reference "
5222 "with nonzero rank must not have the POINTER "
5223 "attribute at %L", &expr
->where
);
5226 else if (ref
->u
.c
.component
->attr
.allocatable
5227 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5228 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5231 gfc_error ("Component to the right of a part reference "
5232 "with nonzero rank must not have the ALLOCATABLE "
5233 "attribute at %L", &expr
->where
);
5246 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5247 || ref
->next
== NULL
)
5248 && current_part_dimension
5249 && seen_part_dimension
)
5251 gfc_error ("Two or more part references with nonzero rank must "
5252 "not be specified at %L", &expr
->where
);
5256 if (ref
->type
== REF_COMPONENT
)
5258 if (current_part_dimension
)
5259 seen_part_dimension
= 1;
5261 /* reset to make sure */
5262 current_part_dimension
= 0;
5270 /* Given an expression, determine its shape. This is easier than it sounds.
5271 Leaves the shape array NULL if it is not possible to determine the shape. */
5274 expression_shape (gfc_expr
*e
)
5276 mpz_t array
[GFC_MAX_DIMENSIONS
];
5279 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5282 for (i
= 0; i
< e
->rank
; i
++)
5283 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5286 e
->shape
= gfc_get_shape (e
->rank
);
5288 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5293 for (i
--; i
>= 0; i
--)
5294 mpz_clear (array
[i
]);
5298 /* Given a variable expression node, compute the rank of the expression by
5299 examining the base symbol and any reference structures it may have. */
5302 expression_rank (gfc_expr
*e
)
5307 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5308 could lead to serious confusion... */
5309 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5313 if (e
->expr_type
== EXPR_ARRAY
)
5315 /* Constructors can have a rank different from one via RESHAPE(). */
5317 if (e
->symtree
== NULL
)
5323 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5324 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5330 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5332 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5333 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5334 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5336 if (ref
->type
!= REF_ARRAY
)
5339 if (ref
->u
.ar
.type
== AR_FULL
)
5341 rank
= ref
->u
.ar
.as
->rank
;
5345 if (ref
->u
.ar
.type
== AR_SECTION
)
5347 /* Figure out the rank of the section. */
5349 gfc_internal_error ("expression_rank(): Two array specs");
5351 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5352 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5353 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5363 expression_shape (e
);
5368 add_caf_get_intrinsic (gfc_expr
*e
)
5370 gfc_expr
*wrapper
, *tmp_expr
;
5374 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5375 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5380 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5381 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5384 tmp_expr
= XCNEW (gfc_expr
);
5386 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5387 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5388 wrapper
->ts
= e
->ts
;
5389 wrapper
->rank
= e
->rank
;
5391 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5398 remove_caf_get_intrinsic (gfc_expr
*e
)
5400 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5401 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5402 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5403 e
->value
.function
.actual
->expr
= NULL
;
5404 gfc_free_actual_arglist (e
->value
.function
.actual
);
5405 gfc_free_shape (&e
->shape
, e
->rank
);
5411 /* Resolve a variable expression. */
5414 resolve_variable (gfc_expr
*e
)
5421 if (e
->symtree
== NULL
)
5423 sym
= e
->symtree
->n
.sym
;
5425 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5426 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5427 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5429 if (!actual_arg
|| inquiry_argument
)
5431 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5432 "be used as actual argument", sym
->name
, &e
->where
);
5436 /* TS 29113, 407b. */
5437 else if (e
->ts
.type
== BT_ASSUMED
)
5441 gfc_error ("Assumed-type variable %s at %L may only be used "
5442 "as actual argument", sym
->name
, &e
->where
);
5445 else if (inquiry_argument
&& !first_actual_arg
)
5447 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5448 for all inquiry functions in resolve_function; the reason is
5449 that the function-name resolution happens too late in that
5451 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5452 "an inquiry function shall be the first argument",
5453 sym
->name
, &e
->where
);
5457 /* TS 29113, C535b. */
5458 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5459 && CLASS_DATA (sym
)->as
5460 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5461 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5462 && sym
->as
->type
== AS_ASSUMED_RANK
))
5466 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5467 "actual argument", sym
->name
, &e
->where
);
5470 else if (inquiry_argument
&& !first_actual_arg
)
5472 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5473 for all inquiry functions in resolve_function; the reason is
5474 that the function-name resolution happens too late in that
5476 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5477 "to an inquiry function shall be the first argument",
5478 sym
->name
, &e
->where
);
5483 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5484 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5485 && e
->ref
->next
== NULL
))
5487 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5488 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5491 /* TS 29113, 407b. */
5492 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5493 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5494 && e
->ref
->next
== NULL
))
5496 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5497 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5501 /* TS 29113, C535b. */
5502 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5503 && CLASS_DATA (sym
)->as
5504 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5505 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5506 && sym
->as
->type
== AS_ASSUMED_RANK
))
5508 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5509 && e
->ref
->next
== NULL
))
5511 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5512 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5516 /* For variables that are used in an associate (target => object) where
5517 the object's basetype is array valued while the target is scalar,
5518 the ts' type of the component refs is still array valued, which
5519 can't be translated that way. */
5520 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5521 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5522 && CLASS_DATA (sym
->assoc
->target
)->as
)
5524 gfc_ref
*ref
= e
->ref
;
5530 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5531 /* Stop the loop. */
5541 /* If this is an associate-name, it may be parsed with an array reference
5542 in error even though the target is scalar. Fail directly in this case.
5543 TODO Understand why class scalar expressions must be excluded. */
5544 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5546 if (sym
->ts
.type
== BT_CLASS
)
5547 gfc_fix_class_refs (e
);
5548 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5550 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5552 /* This can happen because the parser did not detect that the
5553 associate name is an array and the expression had no array
5555 gfc_ref
*ref
= gfc_get_ref ();
5556 ref
->type
= REF_ARRAY
;
5557 ref
->u
.ar
= *gfc_get_array_ref();
5558 ref
->u
.ar
.type
= AR_FULL
;
5561 ref
->u
.ar
.as
= sym
->as
;
5562 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5570 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5571 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5573 /* On the other hand, the parser may not have known this is an array;
5574 in this case, we have to add a FULL reference. */
5575 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5577 e
->ref
= gfc_get_ref ();
5578 e
->ref
->type
= REF_ARRAY
;
5579 e
->ref
->u
.ar
.type
= AR_FULL
;
5580 e
->ref
->u
.ar
.dimen
= 0;
5583 /* Like above, but for class types, where the checking whether an array
5584 ref is present is more complicated. Furthermore make sure not to add
5585 the full array ref to _vptr or _len refs. */
5586 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5587 && CLASS_DATA (sym
)->attr
.dimension
5588 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5590 gfc_ref
*ref
, *newref
;
5592 newref
= gfc_get_ref ();
5593 newref
->type
= REF_ARRAY
;
5594 newref
->u
.ar
.type
= AR_FULL
;
5595 newref
->u
.ar
.dimen
= 0;
5596 /* Because this is an associate var and the first ref either is a ref to
5597 the _data component or not, no traversal of the ref chain is
5598 needed. The array ref needs to be inserted after the _data ref,
5599 or when that is not present, which may happend for polymorphic
5600 types, then at the first position. */
5604 else if (ref
->type
== REF_COMPONENT
5605 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5607 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5609 newref
->next
= ref
->next
;
5613 /* Array ref present already. */
5614 gfc_free_ref_list (newref
);
5616 else if (ref
->type
== REF_ARRAY
)
5617 /* Array ref present already. */
5618 gfc_free_ref_list (newref
);
5626 if (e
->ref
&& !resolve_ref (e
))
5629 if (sym
->attr
.flavor
== FL_PROCEDURE
5630 && (!sym
->attr
.function
5631 || (sym
->attr
.function
&& sym
->result
5632 && sym
->result
->attr
.proc_pointer
5633 && !sym
->result
->attr
.function
)))
5635 e
->ts
.type
= BT_PROCEDURE
;
5636 goto resolve_procedure
;
5639 if (sym
->ts
.type
!= BT_UNKNOWN
)
5640 gfc_variable_attr (e
, &e
->ts
);
5641 else if (sym
->attr
.flavor
== FL_PROCEDURE
5642 && sym
->attr
.function
&& sym
->result
5643 && sym
->result
->ts
.type
!= BT_UNKNOWN
5644 && sym
->result
->attr
.proc_pointer
)
5645 e
->ts
= sym
->result
->ts
;
5648 /* Must be a simple variable reference. */
5649 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5654 if (check_assumed_size_reference (sym
, e
))
5657 /* Deal with forward references to entries during gfc_resolve_code, to
5658 satisfy, at least partially, 12.5.2.5. */
5659 if (gfc_current_ns
->entries
5660 && current_entry_id
== sym
->entry_id
5663 && cs_base
->current
->op
!= EXEC_ENTRY
)
5665 gfc_entry_list
*entry
;
5666 gfc_formal_arglist
*formal
;
5668 bool seen
, saved_specification_expr
;
5670 /* If the symbol is a dummy... */
5671 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5673 entry
= gfc_current_ns
->entries
;
5676 /* ...test if the symbol is a parameter of previous entries. */
5677 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5678 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5680 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5687 /* If it has not been seen as a dummy, this is an error. */
5690 if (specification_expr
)
5691 gfc_error ("Variable %qs, used in a specification expression"
5692 ", is referenced at %L before the ENTRY statement "
5693 "in which it is a parameter",
5694 sym
->name
, &cs_base
->current
->loc
);
5696 gfc_error ("Variable %qs is used at %L before the ENTRY "
5697 "statement in which it is a parameter",
5698 sym
->name
, &cs_base
->current
->loc
);
5703 /* Now do the same check on the specification expressions. */
5704 saved_specification_expr
= specification_expr
;
5705 specification_expr
= true;
5706 if (sym
->ts
.type
== BT_CHARACTER
5707 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5711 for (n
= 0; n
< sym
->as
->rank
; n
++)
5713 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5715 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5718 specification_expr
= saved_specification_expr
;
5721 /* Update the symbol's entry level. */
5722 sym
->entry_id
= current_entry_id
+ 1;
5725 /* If a symbol has been host_associated mark it. This is used latter,
5726 to identify if aliasing is possible via host association. */
5727 if (sym
->attr
.flavor
== FL_VARIABLE
5728 && gfc_current_ns
->parent
5729 && (gfc_current_ns
->parent
== sym
->ns
5730 || (gfc_current_ns
->parent
->parent
5731 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5732 sym
->attr
.host_assoc
= 1;
5734 if (gfc_current_ns
->proc_name
5735 && sym
->attr
.dimension
5736 && (sym
->ns
!= gfc_current_ns
5737 || sym
->attr
.use_assoc
5738 || sym
->attr
.in_common
))
5739 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5742 if (t
&& !resolve_procedure_expression (e
))
5745 /* F2008, C617 and C1229. */
5746 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5747 && gfc_is_coindexed (e
))
5749 gfc_ref
*ref
, *ref2
= NULL
;
5751 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5753 if (ref
->type
== REF_COMPONENT
)
5755 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5759 for ( ; ref
; ref
= ref
->next
)
5760 if (ref
->type
== REF_COMPONENT
)
5763 /* Expression itself is not coindexed object. */
5764 if (ref
&& e
->ts
.type
== BT_CLASS
)
5766 gfc_error ("Polymorphic subobject of coindexed object at %L",
5771 /* Expression itself is coindexed object. */
5775 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5776 for ( ; c
; c
= c
->next
)
5777 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5779 gfc_error ("Coindexed object with polymorphic allocatable "
5780 "subcomponent at %L", &e
->where
);
5788 expression_rank (e
);
5790 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5791 add_caf_get_intrinsic (e
);
5793 /* Simplify cases where access to a parameter array results in a
5794 single constant. Suppress errors since those will have been
5795 issued before, as warnings. */
5796 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5798 gfc_push_suppress_errors ();
5799 gfc_simplify_expr (e
, 1);
5800 gfc_pop_suppress_errors ();
5807 /* Checks to see that the correct symbol has been host associated.
5808 The only situation where this arises is that in which a twice
5809 contained function is parsed after the host association is made.
5810 Therefore, on detecting this, change the symbol in the expression
5811 and convert the array reference into an actual arglist if the old
5812 symbol is a variable. */
5814 check_host_association (gfc_expr
*e
)
5816 gfc_symbol
*sym
, *old_sym
;
5820 gfc_actual_arglist
*arg
, *tail
= NULL
;
5821 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5823 /* If the expression is the result of substitution in
5824 interface.c(gfc_extend_expr) because there is no way in
5825 which the host association can be wrong. */
5826 if (e
->symtree
== NULL
5827 || e
->symtree
->n
.sym
== NULL
5828 || e
->user_operator
)
5831 old_sym
= e
->symtree
->n
.sym
;
5833 if (gfc_current_ns
->parent
5834 && old_sym
->ns
!= gfc_current_ns
)
5836 /* Use the 'USE' name so that renamed module symbols are
5837 correctly handled. */
5838 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5840 if (sym
&& old_sym
!= sym
5841 && sym
->ts
.type
== old_sym
->ts
.type
5842 && sym
->attr
.flavor
== FL_PROCEDURE
5843 && sym
->attr
.contained
)
5845 /* Clear the shape, since it might not be valid. */
5846 gfc_free_shape (&e
->shape
, e
->rank
);
5848 /* Give the expression the right symtree! */
5849 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5850 gcc_assert (st
!= NULL
);
5852 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5853 || e
->expr_type
== EXPR_FUNCTION
)
5855 /* Original was function so point to the new symbol, since
5856 the actual argument list is already attached to the
5858 e
->value
.function
.esym
= NULL
;
5863 /* Original was variable so convert array references into
5864 an actual arglist. This does not need any checking now
5865 since resolve_function will take care of it. */
5866 e
->value
.function
.actual
= NULL
;
5867 e
->expr_type
= EXPR_FUNCTION
;
5870 /* Ambiguity will not arise if the array reference is not
5871 the last reference. */
5872 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5873 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5876 gcc_assert (ref
->type
== REF_ARRAY
);
5878 /* Grab the start expressions from the array ref and
5879 copy them into actual arguments. */
5880 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5882 arg
= gfc_get_actual_arglist ();
5883 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5884 if (e
->value
.function
.actual
== NULL
)
5885 tail
= e
->value
.function
.actual
= arg
;
5893 /* Dump the reference list and set the rank. */
5894 gfc_free_ref_list (e
->ref
);
5896 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5899 gfc_resolve_expr (e
);
5903 /* This might have changed! */
5904 return e
->expr_type
== EXPR_FUNCTION
;
5909 gfc_resolve_character_operator (gfc_expr
*e
)
5911 gfc_expr
*op1
= e
->value
.op
.op1
;
5912 gfc_expr
*op2
= e
->value
.op
.op2
;
5913 gfc_expr
*e1
= NULL
;
5914 gfc_expr
*e2
= NULL
;
5916 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5918 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5919 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5920 else if (op1
->expr_type
== EXPR_CONSTANT
)
5921 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5922 op1
->value
.character
.length
);
5924 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5925 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5926 else if (op2
->expr_type
== EXPR_CONSTANT
)
5927 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5928 op2
->value
.character
.length
);
5930 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5940 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5941 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5942 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5943 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5944 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5950 /* Ensure that an character expression has a charlen and, if possible, a
5951 length expression. */
5954 fixup_charlen (gfc_expr
*e
)
5956 /* The cases fall through so that changes in expression type and the need
5957 for multiple fixes are picked up. In all circumstances, a charlen should
5958 be available for the middle end to hang a backend_decl on. */
5959 switch (e
->expr_type
)
5962 gfc_resolve_character_operator (e
);
5966 if (e
->expr_type
== EXPR_ARRAY
)
5967 gfc_resolve_character_array_constructor (e
);
5970 case EXPR_SUBSTRING
:
5971 if (!e
->ts
.u
.cl
&& e
->ref
)
5972 gfc_resolve_substring_charlen (e
);
5977 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5984 /* Update an actual argument to include the passed-object for type-bound
5985 procedures at the right position. */
5987 static gfc_actual_arglist
*
5988 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5991 gcc_assert (argpos
> 0);
5995 gfc_actual_arglist
* result
;
5997 result
= gfc_get_actual_arglist ();
6001 result
->name
= name
;
6007 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
6009 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
6014 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6017 extract_compcall_passed_object (gfc_expr
* e
)
6021 if (e
->expr_type
== EXPR_UNKNOWN
)
6023 gfc_error ("Error in typebound call at %L",
6028 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6030 if (e
->value
.compcall
.base_object
)
6031 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
6034 po
= gfc_get_expr ();
6035 po
->expr_type
= EXPR_VARIABLE
;
6036 po
->symtree
= e
->symtree
;
6037 po
->ref
= gfc_copy_ref (e
->ref
);
6038 po
->where
= e
->where
;
6041 if (!gfc_resolve_expr (po
))
6048 /* Update the arglist of an EXPR_COMPCALL expression to include the
6052 update_compcall_arglist (gfc_expr
* e
)
6055 gfc_typebound_proc
* tbp
;
6057 tbp
= e
->value
.compcall
.tbp
;
6062 po
= extract_compcall_passed_object (e
);
6066 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6072 if (tbp
->pass_arg_num
<= 0)
6075 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6083 /* Extract the passed object from a PPC call (a copy of it). */
6086 extract_ppc_passed_object (gfc_expr
*e
)
6091 po
= gfc_get_expr ();
6092 po
->expr_type
= EXPR_VARIABLE
;
6093 po
->symtree
= e
->symtree
;
6094 po
->ref
= gfc_copy_ref (e
->ref
);
6095 po
->where
= e
->where
;
6097 /* Remove PPC reference. */
6099 while ((*ref
)->next
)
6100 ref
= &(*ref
)->next
;
6101 gfc_free_ref_list (*ref
);
6104 if (!gfc_resolve_expr (po
))
6111 /* Update the actual arglist of a procedure pointer component to include the
6115 update_ppc_arglist (gfc_expr
* e
)
6119 gfc_typebound_proc
* tb
;
6121 ppc
= gfc_get_proc_ptr_comp (e
);
6129 else if (tb
->nopass
)
6132 po
= extract_ppc_passed_object (e
);
6139 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6144 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6146 gfc_error ("Base object for procedure-pointer component call at %L is of"
6147 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6151 gcc_assert (tb
->pass_arg_num
> 0);
6152 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6160 /* Check that the object a TBP is called on is valid, i.e. it must not be
6161 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6164 check_typebound_baseobject (gfc_expr
* e
)
6167 bool return_value
= false;
6169 base
= extract_compcall_passed_object (e
);
6173 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6175 gfc_error ("Error in typebound call at %L", &e
->where
);
6179 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6183 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6185 gfc_error ("Base object for type-bound procedure call at %L is of"
6186 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6190 /* F08:C1230. If the procedure called is NOPASS,
6191 the base object must be scalar. */
6192 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6194 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6195 " be scalar", &e
->where
);
6199 return_value
= true;
6202 gfc_free_expr (base
);
6203 return return_value
;
6207 /* Resolve a call to a type-bound procedure, either function or subroutine,
6208 statically from the data in an EXPR_COMPCALL expression. The adapted
6209 arglist and the target-procedure symtree are returned. */
6212 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6213 gfc_actual_arglist
** actual
)
6215 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6216 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6218 /* Update the actual arglist for PASS. */
6219 if (!update_compcall_arglist (e
))
6222 *actual
= e
->value
.compcall
.actual
;
6223 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6225 gfc_free_ref_list (e
->ref
);
6227 e
->value
.compcall
.actual
= NULL
;
6229 /* If we find a deferred typebound procedure, check for derived types
6230 that an overriding typebound procedure has not been missed. */
6231 if (e
->value
.compcall
.name
6232 && !e
->value
.compcall
.tbp
->non_overridable
6233 && e
->value
.compcall
.base_object
6234 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6237 gfc_symbol
*derived
;
6239 /* Use the derived type of the base_object. */
6240 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6243 /* If necessary, go through the inheritance chain. */
6244 while (!st
&& derived
)
6246 /* Look for the typebound procedure 'name'. */
6247 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6248 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6249 e
->value
.compcall
.name
);
6251 derived
= gfc_get_derived_super_type (derived
);
6254 /* Now find the specific name in the derived type namespace. */
6255 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6256 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6257 derived
->ns
, 1, &st
);
6265 /* Get the ultimate declared type from an expression. In addition,
6266 return the last class/derived type reference and the copy of the
6267 reference list. If check_types is set true, derived types are
6268 identified as well as class references. */
6270 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6271 gfc_expr
*e
, bool check_types
)
6273 gfc_symbol
*declared
;
6280 *new_ref
= gfc_copy_ref (e
->ref
);
6282 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6284 if (ref
->type
!= REF_COMPONENT
)
6287 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6288 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6289 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6291 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6297 if (declared
== NULL
)
6298 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6304 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6305 which of the specific bindings (if any) matches the arglist and transform
6306 the expression into a call of that binding. */
6309 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6311 gfc_typebound_proc
* genproc
;
6312 const char* genname
;
6314 gfc_symbol
*derived
;
6316 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6317 genname
= e
->value
.compcall
.name
;
6318 genproc
= e
->value
.compcall
.tbp
;
6320 if (!genproc
->is_generic
)
6323 /* Try the bindings on this type and in the inheritance hierarchy. */
6324 for (; genproc
; genproc
= genproc
->overridden
)
6328 gcc_assert (genproc
->is_generic
);
6329 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6332 gfc_actual_arglist
* args
;
6335 gcc_assert (g
->specific
);
6337 if (g
->specific
->error
)
6340 target
= g
->specific
->u
.specific
->n
.sym
;
6342 /* Get the right arglist by handling PASS/NOPASS. */
6343 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6344 if (!g
->specific
->nopass
)
6347 po
= extract_compcall_passed_object (e
);
6350 gfc_free_actual_arglist (args
);
6354 gcc_assert (g
->specific
->pass_arg_num
> 0);
6355 gcc_assert (!g
->specific
->error
);
6356 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6357 g
->specific
->pass_arg
);
6359 resolve_actual_arglist (args
, target
->attr
.proc
,
6360 is_external_proc (target
)
6361 && gfc_sym_get_dummy_args (target
) == NULL
);
6363 /* Check if this arglist matches the formal. */
6364 matches
= gfc_arglist_matches_symbol (&args
, target
);
6366 /* Clean up and break out of the loop if we've found it. */
6367 gfc_free_actual_arglist (args
);
6370 e
->value
.compcall
.tbp
= g
->specific
;
6371 genname
= g
->specific_st
->name
;
6372 /* Pass along the name for CLASS methods, where the vtab
6373 procedure pointer component has to be referenced. */
6381 /* Nothing matching found! */
6382 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6383 " %qs at %L", genname
, &e
->where
);
6387 /* Make sure that we have the right specific instance for the name. */
6388 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6390 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6392 e
->value
.compcall
.tbp
= st
->n
.tb
;
6398 /* Resolve a call to a type-bound subroutine. */
6401 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6403 gfc_actual_arglist
* newactual
;
6404 gfc_symtree
* target
;
6406 /* Check that's really a SUBROUTINE. */
6407 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6409 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6410 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6411 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6412 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6413 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6416 gfc_error ("%qs at %L should be a SUBROUTINE",
6417 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6422 if (!check_typebound_baseobject (c
->expr1
))
6425 /* Pass along the name for CLASS methods, where the vtab
6426 procedure pointer component has to be referenced. */
6428 *name
= c
->expr1
->value
.compcall
.name
;
6430 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6433 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6435 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6437 /* Transform into an ordinary EXEC_CALL for now. */
6439 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6442 c
->ext
.actual
= newactual
;
6443 c
->symtree
= target
;
6444 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6446 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6448 gfc_free_expr (c
->expr1
);
6449 c
->expr1
= gfc_get_expr ();
6450 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6451 c
->expr1
->symtree
= target
;
6452 c
->expr1
->where
= c
->loc
;
6454 return resolve_call (c
);
6458 /* Resolve a component-call expression. */
6460 resolve_compcall (gfc_expr
* e
, const char **name
)
6462 gfc_actual_arglist
* newactual
;
6463 gfc_symtree
* target
;
6465 /* Check that's really a FUNCTION. */
6466 if (!e
->value
.compcall
.tbp
->function
)
6468 gfc_error ("%qs at %L should be a FUNCTION",
6469 e
->value
.compcall
.name
, &e
->where
);
6474 /* These must not be assign-calls! */
6475 gcc_assert (!e
->value
.compcall
.assign
);
6477 if (!check_typebound_baseobject (e
))
6480 /* Pass along the name for CLASS methods, where the vtab
6481 procedure pointer component has to be referenced. */
6483 *name
= e
->value
.compcall
.name
;
6485 if (!resolve_typebound_generic_call (e
, name
))
6487 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6489 /* Take the rank from the function's symbol. */
6490 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6491 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6493 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6494 arglist to the TBP's binding target. */
6496 if (!resolve_typebound_static (e
, &target
, &newactual
))
6499 e
->value
.function
.actual
= newactual
;
6500 e
->value
.function
.name
= NULL
;
6501 e
->value
.function
.esym
= target
->n
.sym
;
6502 e
->value
.function
.isym
= NULL
;
6503 e
->symtree
= target
;
6504 e
->ts
= target
->n
.sym
->ts
;
6505 e
->expr_type
= EXPR_FUNCTION
;
6507 /* Resolution is not necessary if this is a class subroutine; this
6508 function only has to identify the specific proc. Resolution of
6509 the call will be done next in resolve_typebound_call. */
6510 return gfc_resolve_expr (e
);
6514 static bool resolve_fl_derived (gfc_symbol
*sym
);
6517 /* Resolve a typebound function, or 'method'. First separate all
6518 the non-CLASS references by calling resolve_compcall directly. */
6521 resolve_typebound_function (gfc_expr
* e
)
6523 gfc_symbol
*declared
;
6535 /* Deal with typebound operators for CLASS objects. */
6536 expr
= e
->value
.compcall
.base_object
;
6537 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6538 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6540 /* If the base_object is not a variable, the corresponding actual
6541 argument expression must be stored in e->base_expression so
6542 that the corresponding tree temporary can be used as the base
6543 object in gfc_conv_procedure_call. */
6544 if (expr
->expr_type
!= EXPR_VARIABLE
)
6546 gfc_actual_arglist
*args
;
6548 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6550 if (expr
== args
->expr
)
6555 /* Since the typebound operators are generic, we have to ensure
6556 that any delays in resolution are corrected and that the vtab
6559 declared
= ts
.u
.derived
;
6560 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6561 if (c
->ts
.u
.derived
== NULL
)
6562 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6564 if (!resolve_compcall (e
, &name
))
6567 /* Use the generic name if it is there. */
6568 name
= name
? name
: e
->value
.function
.esym
->name
;
6569 e
->symtree
= expr
->symtree
;
6570 e
->ref
= gfc_copy_ref (expr
->ref
);
6571 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6573 /* Trim away the extraneous references that emerge from nested
6574 use of interface.c (extend_expr). */
6575 if (class_ref
&& class_ref
->next
)
6577 gfc_free_ref_list (class_ref
->next
);
6578 class_ref
->next
= NULL
;
6580 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6582 gfc_free_ref_list (e
->ref
);
6586 gfc_add_vptr_component (e
);
6587 gfc_add_component_ref (e
, name
);
6588 e
->value
.function
.esym
= NULL
;
6589 if (expr
->expr_type
!= EXPR_VARIABLE
)
6590 e
->base_expr
= expr
;
6595 return resolve_compcall (e
, NULL
);
6597 if (!resolve_ref (e
))
6600 /* Get the CLASS declared type. */
6601 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6603 if (!resolve_fl_derived (declared
))
6606 /* Weed out cases of the ultimate component being a derived type. */
6607 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6608 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6610 gfc_free_ref_list (new_ref
);
6611 return resolve_compcall (e
, NULL
);
6614 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6616 /* Treat the call as if it is a typebound procedure, in order to roll
6617 out the correct name for the specific function. */
6618 if (!resolve_compcall (e
, &name
))
6620 gfc_free_ref_list (new_ref
);
6627 /* Convert the expression to a procedure pointer component call. */
6628 e
->value
.function
.esym
= NULL
;
6634 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6635 gfc_add_vptr_component (e
);
6636 gfc_add_component_ref (e
, name
);
6638 /* Recover the typespec for the expression. This is really only
6639 necessary for generic procedures, where the additional call
6640 to gfc_add_component_ref seems to throw the collection of the
6641 correct typespec. */
6645 gfc_free_ref_list (new_ref
);
6650 /* Resolve a typebound subroutine, or 'method'. First separate all
6651 the non-CLASS references by calling resolve_typebound_call
6655 resolve_typebound_subroutine (gfc_code
*code
)
6657 gfc_symbol
*declared
;
6667 st
= code
->expr1
->symtree
;
6669 /* Deal with typebound operators for CLASS objects. */
6670 expr
= code
->expr1
->value
.compcall
.base_object
;
6671 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6672 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6674 /* If the base_object is not a variable, the corresponding actual
6675 argument expression must be stored in e->base_expression so
6676 that the corresponding tree temporary can be used as the base
6677 object in gfc_conv_procedure_call. */
6678 if (expr
->expr_type
!= EXPR_VARIABLE
)
6680 gfc_actual_arglist
*args
;
6682 args
= code
->expr1
->value
.function
.actual
;
6683 for (; args
; args
= args
->next
)
6684 if (expr
== args
->expr
)
6688 /* Since the typebound operators are generic, we have to ensure
6689 that any delays in resolution are corrected and that the vtab
6691 declared
= expr
->ts
.u
.derived
;
6692 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6693 if (c
->ts
.u
.derived
== NULL
)
6694 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6696 if (!resolve_typebound_call (code
, &name
, NULL
))
6699 /* Use the generic name if it is there. */
6700 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6701 code
->expr1
->symtree
= expr
->symtree
;
6702 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6704 /* Trim away the extraneous references that emerge from nested
6705 use of interface.c (extend_expr). */
6706 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6707 if (class_ref
&& class_ref
->next
)
6709 gfc_free_ref_list (class_ref
->next
);
6710 class_ref
->next
= NULL
;
6712 else if (code
->expr1
->ref
&& !class_ref
)
6714 gfc_free_ref_list (code
->expr1
->ref
);
6715 code
->expr1
->ref
= NULL
;
6718 /* Now use the procedure in the vtable. */
6719 gfc_add_vptr_component (code
->expr1
);
6720 gfc_add_component_ref (code
->expr1
, name
);
6721 code
->expr1
->value
.function
.esym
= NULL
;
6722 if (expr
->expr_type
!= EXPR_VARIABLE
)
6723 code
->expr1
->base_expr
= expr
;
6728 return resolve_typebound_call (code
, NULL
, NULL
);
6730 if (!resolve_ref (code
->expr1
))
6733 /* Get the CLASS declared type. */
6734 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6736 /* Weed out cases of the ultimate component being a derived type. */
6737 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6738 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6740 gfc_free_ref_list (new_ref
);
6741 return resolve_typebound_call (code
, NULL
, NULL
);
6744 if (!resolve_typebound_call (code
, &name
, &overridable
))
6746 gfc_free_ref_list (new_ref
);
6749 ts
= code
->expr1
->ts
;
6753 /* Convert the expression to a procedure pointer component call. */
6754 code
->expr1
->value
.function
.esym
= NULL
;
6755 code
->expr1
->symtree
= st
;
6758 code
->expr1
->ref
= new_ref
;
6760 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6761 gfc_add_vptr_component (code
->expr1
);
6762 gfc_add_component_ref (code
->expr1
, name
);
6764 /* Recover the typespec for the expression. This is really only
6765 necessary for generic procedures, where the additional call
6766 to gfc_add_component_ref seems to throw the collection of the
6767 correct typespec. */
6768 code
->expr1
->ts
= ts
;
6771 gfc_free_ref_list (new_ref
);
6777 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6780 resolve_ppc_call (gfc_code
* c
)
6782 gfc_component
*comp
;
6784 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6785 gcc_assert (comp
!= NULL
);
6787 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6788 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6790 if (!comp
->attr
.subroutine
)
6791 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6793 if (!resolve_ref (c
->expr1
))
6796 if (!update_ppc_arglist (c
->expr1
))
6799 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6801 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6802 !(comp
->ts
.interface
6803 && comp
->ts
.interface
->formal
)))
6806 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6809 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6815 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6818 resolve_expr_ppc (gfc_expr
* e
)
6820 gfc_component
*comp
;
6822 comp
= gfc_get_proc_ptr_comp (e
);
6823 gcc_assert (comp
!= NULL
);
6825 /* Convert to EXPR_FUNCTION. */
6826 e
->expr_type
= EXPR_FUNCTION
;
6827 e
->value
.function
.isym
= NULL
;
6828 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6830 if (comp
->as
!= NULL
)
6831 e
->rank
= comp
->as
->rank
;
6833 if (!comp
->attr
.function
)
6834 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6836 if (!resolve_ref (e
))
6839 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6840 !(comp
->ts
.interface
6841 && comp
->ts
.interface
->formal
)))
6844 if (!update_ppc_arglist (e
))
6847 if (!check_pure_function(e
))
6850 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6857 gfc_is_expandable_expr (gfc_expr
*e
)
6859 gfc_constructor
*con
;
6861 if (e
->expr_type
== EXPR_ARRAY
)
6863 /* Traverse the constructor looking for variables that are flavor
6864 parameter. Parameters must be expanded since they are fully used at
6866 con
= gfc_constructor_first (e
->value
.constructor
);
6867 for (; con
; con
= gfc_constructor_next (con
))
6869 if (con
->expr
->expr_type
== EXPR_VARIABLE
6870 && con
->expr
->symtree
6871 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6872 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6874 if (con
->expr
->expr_type
== EXPR_ARRAY
6875 && gfc_is_expandable_expr (con
->expr
))
6884 /* Sometimes variables in specification expressions of the result
6885 of module procedures in submodules wind up not being the 'real'
6886 dummy. Find this, if possible, in the namespace of the first
6890 fixup_unique_dummy (gfc_expr
*e
)
6892 gfc_symtree
*st
= NULL
;
6893 gfc_symbol
*s
= NULL
;
6895 if (e
->symtree
->n
.sym
->ns
->proc_name
6896 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6897 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6900 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6903 && st
->n
.sym
!= NULL
6904 && st
->n
.sym
->attr
.dummy
)
6908 /* Resolve an expression. That is, make sure that types of operands agree
6909 with their operators, intrinsic operators are converted to function calls
6910 for overloaded types and unresolved function references are resolved. */
6913 gfc_resolve_expr (gfc_expr
*e
)
6916 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6921 /* inquiry_argument only applies to variables. */
6922 inquiry_save
= inquiry_argument
;
6923 actual_arg_save
= actual_arg
;
6924 first_actual_arg_save
= first_actual_arg
;
6926 if (e
->expr_type
!= EXPR_VARIABLE
)
6928 inquiry_argument
= false;
6930 first_actual_arg
= false;
6932 else if (e
->symtree
!= NULL
6933 && *e
->symtree
->name
== '@'
6934 && e
->symtree
->n
.sym
->attr
.dummy
)
6936 /* Deal with submodule specification expressions that are not
6937 found to be referenced in module.c(read_cleanup). */
6938 fixup_unique_dummy (e
);
6941 switch (e
->expr_type
)
6944 t
= resolve_operator (e
);
6950 if (check_host_association (e
))
6951 t
= resolve_function (e
);
6953 t
= resolve_variable (e
);
6955 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6956 && e
->ref
->type
!= REF_SUBSTRING
)
6957 gfc_resolve_substring_charlen (e
);
6962 t
= resolve_typebound_function (e
);
6965 case EXPR_SUBSTRING
:
6966 t
= resolve_ref (e
);
6975 t
= resolve_expr_ppc (e
);
6980 if (!resolve_ref (e
))
6983 t
= gfc_resolve_array_constructor (e
);
6984 /* Also try to expand a constructor. */
6987 expression_rank (e
);
6988 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6989 gfc_expand_constructor (e
, false);
6992 /* This provides the opportunity for the length of constructors with
6993 character valued function elements to propagate the string length
6994 to the expression. */
6995 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6997 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6998 here rather then add a duplicate test for it above. */
6999 gfc_expand_constructor (e
, false);
7000 t
= gfc_resolve_character_array_constructor (e
);
7005 case EXPR_STRUCTURE
:
7006 t
= resolve_ref (e
);
7010 t
= resolve_structure_cons (e
, 0);
7014 t
= gfc_simplify_expr (e
, 0);
7018 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7021 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
7024 inquiry_argument
= inquiry_save
;
7025 actual_arg
= actual_arg_save
;
7026 first_actual_arg
= first_actual_arg_save
;
7032 /* Resolve an expression from an iterator. They must be scalar and have
7033 INTEGER or (optionally) REAL type. */
7036 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
7037 const char *name_msgid
)
7039 if (!gfc_resolve_expr (expr
))
7042 if (expr
->rank
!= 0)
7044 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7048 if (expr
->ts
.type
!= BT_INTEGER
)
7050 if (expr
->ts
.type
== BT_REAL
)
7053 return gfc_notify_std (GFC_STD_F95_DEL
,
7054 "%s at %L must be integer",
7055 _(name_msgid
), &expr
->where
);
7058 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7065 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7073 /* Resolve the expressions in an iterator structure. If REAL_OK is
7074 false allow only INTEGER type iterators, otherwise allow REAL types.
7075 Set own_scope to true for ac-implied-do and data-implied-do as those
7076 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7079 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7081 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7084 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7085 _("iterator variable")))
7088 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7089 "Start expression in DO loop"))
7092 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7093 "End expression in DO loop"))
7096 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7097 "Step expression in DO loop"))
7100 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7102 if ((iter
->step
->ts
.type
== BT_INTEGER
7103 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7104 || (iter
->step
->ts
.type
== BT_REAL
7105 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7107 gfc_error ("Step expression in DO loop at %L cannot be zero",
7108 &iter
->step
->where
);
7113 /* Convert start, end, and step to the same type as var. */
7114 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7115 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7116 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7118 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7119 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7120 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7122 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7123 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7124 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7126 if (iter
->start
->expr_type
== EXPR_CONSTANT
7127 && iter
->end
->expr_type
== EXPR_CONSTANT
7128 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7131 if (iter
->start
->ts
.type
== BT_INTEGER
)
7133 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7134 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7138 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7139 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7141 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7142 gfc_warning (OPT_Wzerotrip
,
7143 "DO loop at %L will be executed zero times",
7144 &iter
->step
->where
);
7147 if (iter
->end
->expr_type
== EXPR_CONSTANT
7148 && iter
->end
->ts
.type
== BT_INTEGER
7149 && iter
->step
->expr_type
== EXPR_CONSTANT
7150 && iter
->step
->ts
.type
== BT_INTEGER
7151 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7152 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7154 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7155 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7157 if (is_step_positive
7158 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7159 gfc_warning (OPT_Wundefined_do_loop
,
7160 "DO loop at %L is undefined as it overflows",
7161 &iter
->step
->where
);
7162 else if (!is_step_positive
7163 && mpz_cmp (iter
->end
->value
.integer
,
7164 gfc_integer_kinds
[k
].min_int
) == 0)
7165 gfc_warning (OPT_Wundefined_do_loop
,
7166 "DO loop at %L is undefined as it underflows",
7167 &iter
->step
->where
);
7174 /* Traversal function for find_forall_index. f == 2 signals that
7175 that variable itself is not to be checked - only the references. */
7178 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7180 if (expr
->expr_type
!= EXPR_VARIABLE
)
7183 /* A scalar assignment */
7184 if (!expr
->ref
|| *f
== 1)
7186 if (expr
->symtree
->n
.sym
== sym
)
7198 /* Check whether the FORALL index appears in the expression or not.
7199 Returns true if SYM is found in EXPR. */
7202 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7204 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7211 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7212 to be a scalar INTEGER variable. The subscripts and stride are scalar
7213 INTEGERs, and if stride is a constant it must be nonzero.
7214 Furthermore "A subscript or stride in a forall-triplet-spec shall
7215 not contain a reference to any index-name in the
7216 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7219 resolve_forall_iterators (gfc_forall_iterator
*it
)
7221 gfc_forall_iterator
*iter
, *iter2
;
7223 for (iter
= it
; iter
; iter
= iter
->next
)
7225 if (gfc_resolve_expr (iter
->var
)
7226 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7227 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7230 if (gfc_resolve_expr (iter
->start
)
7231 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7232 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7233 &iter
->start
->where
);
7234 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7235 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7237 if (gfc_resolve_expr (iter
->end
)
7238 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7239 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7241 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7242 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7244 if (gfc_resolve_expr (iter
->stride
))
7246 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7247 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7248 &iter
->stride
->where
, "INTEGER");
7250 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7251 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7252 gfc_error ("FORALL stride expression at %L cannot be zero",
7253 &iter
->stride
->where
);
7255 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7256 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7259 for (iter
= it
; iter
; iter
= iter
->next
)
7260 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7262 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7263 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7264 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7265 gfc_error ("FORALL index %qs may not appear in triplet "
7266 "specification at %L", iter
->var
->symtree
->name
,
7267 &iter2
->start
->where
);
7272 /* Given a pointer to a symbol that is a derived type, see if it's
7273 inaccessible, i.e. if it's defined in another module and the components are
7274 PRIVATE. The search is recursive if necessary. Returns zero if no
7275 inaccessible components are found, nonzero otherwise. */
7278 derived_inaccessible (gfc_symbol
*sym
)
7282 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7285 for (c
= sym
->components
; c
; c
= c
->next
)
7287 /* Prevent an infinite loop through this function. */
7288 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7289 && sym
== c
->ts
.u
.derived
)
7292 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7300 /* Resolve the argument of a deallocate expression. The expression must be
7301 a pointer or a full array. */
7304 resolve_deallocate_expr (gfc_expr
*e
)
7306 symbol_attribute attr
;
7307 int allocatable
, pointer
;
7313 if (!gfc_resolve_expr (e
))
7316 if (e
->expr_type
!= EXPR_VARIABLE
)
7319 sym
= e
->symtree
->n
.sym
;
7320 unlimited
= UNLIMITED_POLY(sym
);
7322 if (sym
->ts
.type
== BT_CLASS
)
7324 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7325 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7329 allocatable
= sym
->attr
.allocatable
;
7330 pointer
= sym
->attr
.pointer
;
7332 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7337 if (ref
->u
.ar
.type
!= AR_FULL
7338 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7339 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7344 c
= ref
->u
.c
.component
;
7345 if (c
->ts
.type
== BT_CLASS
)
7347 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7348 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7352 allocatable
= c
->attr
.allocatable
;
7353 pointer
= c
->attr
.pointer
;
7364 attr
= gfc_expr_attr (e
);
7366 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7369 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7375 if (gfc_is_coindexed (e
))
7377 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7382 && !gfc_check_vardef_context (e
, true, true, false,
7383 _("DEALLOCATE object")))
7385 if (!gfc_check_vardef_context (e
, false, true, false,
7386 _("DEALLOCATE object")))
7393 /* Returns true if the expression e contains a reference to the symbol sym. */
7395 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7397 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7404 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7406 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7410 /* Given the expression node e for an allocatable/pointer of derived type to be
7411 allocated, get the expression node to be initialized afterwards (needed for
7412 derived types with default initializers, and derived types with allocatable
7413 components that need nullification.) */
7416 gfc_expr_to_initialize (gfc_expr
*e
)
7422 result
= gfc_copy_expr (e
);
7424 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7425 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7426 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7428 ref
->u
.ar
.type
= AR_FULL
;
7430 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7431 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7436 gfc_free_shape (&result
->shape
, result
->rank
);
7438 /* Recalculate rank, shape, etc. */
7439 gfc_resolve_expr (result
);
7444 /* If the last ref of an expression is an array ref, return a copy of the
7445 expression with that one removed. Otherwise, a copy of the original
7446 expression. This is used for allocate-expressions and pointer assignment
7447 LHS, where there may be an array specification that needs to be stripped
7448 off when using gfc_check_vardef_context. */
7451 remove_last_array_ref (gfc_expr
* e
)
7456 e2
= gfc_copy_expr (e
);
7457 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7458 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7460 gfc_free_ref_list (*r
);
7469 /* Used in resolve_allocate_expr to check that a allocation-object and
7470 a source-expr are conformable. This does not catch all possible
7471 cases; in particular a runtime checking is needed. */
7474 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7477 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7479 /* First compare rank. */
7480 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7481 || (!tail
&& e1
->rank
!= e2
->rank
))
7483 gfc_error ("Source-expr at %L must be scalar or have the "
7484 "same rank as the allocate-object at %L",
7485 &e1
->where
, &e2
->where
);
7496 for (i
= 0; i
< e1
->rank
; i
++)
7498 if (tail
->u
.ar
.start
[i
] == NULL
)
7501 if (tail
->u
.ar
.end
[i
])
7503 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7504 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7505 mpz_add_ui (s
, s
, 1);
7509 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7512 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7514 gfc_error ("Source-expr at %L and allocate-object at %L must "
7515 "have the same shape", &e1
->where
, &e2
->where
);
7528 /* Resolve the expression in an ALLOCATE statement, doing the additional
7529 checks to see whether the expression is OK or not. The expression must
7530 have a trailing array reference that gives the size of the array. */
7533 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7535 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7539 symbol_attribute attr
;
7540 gfc_ref
*ref
, *ref2
;
7543 gfc_symbol
*sym
= NULL
;
7548 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7549 checking of coarrays. */
7550 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7551 if (ref
->next
== NULL
)
7554 if (ref
&& ref
->type
== REF_ARRAY
)
7555 ref
->u
.ar
.in_allocate
= true;
7557 if (!gfc_resolve_expr (e
))
7560 /* Make sure the expression is allocatable or a pointer. If it is
7561 pointer, the next-to-last reference must be a pointer. */
7565 sym
= e
->symtree
->n
.sym
;
7567 /* Check whether ultimate component is abstract and CLASS. */
7570 /* Is the allocate-object unlimited polymorphic? */
7571 unlimited
= UNLIMITED_POLY(e
);
7573 if (e
->expr_type
!= EXPR_VARIABLE
)
7576 attr
= gfc_expr_attr (e
);
7577 pointer
= attr
.pointer
;
7578 dimension
= attr
.dimension
;
7579 codimension
= attr
.codimension
;
7583 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7585 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7586 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7587 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7588 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7589 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7593 allocatable
= sym
->attr
.allocatable
;
7594 pointer
= sym
->attr
.pointer
;
7595 dimension
= sym
->attr
.dimension
;
7596 codimension
= sym
->attr
.codimension
;
7601 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7606 if (ref
->u
.ar
.codimen
> 0)
7609 for (n
= ref
->u
.ar
.dimen
;
7610 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7611 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7618 if (ref
->next
!= NULL
)
7626 gfc_error ("Coindexed allocatable object at %L",
7631 c
= ref
->u
.c
.component
;
7632 if (c
->ts
.type
== BT_CLASS
)
7634 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7635 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7636 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7637 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7638 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7642 allocatable
= c
->attr
.allocatable
;
7643 pointer
= c
->attr
.pointer
;
7644 dimension
= c
->attr
.dimension
;
7645 codimension
= c
->attr
.codimension
;
7646 is_abstract
= c
->attr
.abstract
;
7659 /* Check for F08:C628. */
7660 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7662 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7667 /* Some checks for the SOURCE tag. */
7670 /* Check F03:C631. */
7671 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7673 gfc_error ("Type of entity at %L is type incompatible with "
7674 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7678 /* Check F03:C632 and restriction following Note 6.18. */
7679 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7682 /* Check F03:C633. */
7683 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7685 gfc_error ("The allocate-object at %L and the source-expr at %L "
7686 "shall have the same kind type parameter",
7687 &e
->where
, &code
->expr3
->where
);
7691 /* Check F2008, C642. */
7692 if (code
->expr3
->ts
.type
== BT_DERIVED
7693 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7694 || (code
->expr3
->ts
.u
.derived
->from_intmod
7695 == INTMOD_ISO_FORTRAN_ENV
7696 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7697 == ISOFORTRAN_LOCK_TYPE
)))
7699 gfc_error ("The source-expr at %L shall neither be of type "
7700 "LOCK_TYPE nor have a LOCK_TYPE component if "
7701 "allocate-object at %L is a coarray",
7702 &code
->expr3
->where
, &e
->where
);
7706 /* Check TS18508, C702/C703. */
7707 if (code
->expr3
->ts
.type
== BT_DERIVED
7708 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7709 || (code
->expr3
->ts
.u
.derived
->from_intmod
7710 == INTMOD_ISO_FORTRAN_ENV
7711 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7712 == ISOFORTRAN_EVENT_TYPE
)))
7714 gfc_error ("The source-expr at %L shall neither be of type "
7715 "EVENT_TYPE nor have a EVENT_TYPE component if "
7716 "allocate-object at %L is a coarray",
7717 &code
->expr3
->where
, &e
->where
);
7722 /* Check F08:C629. */
7723 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7726 gcc_assert (e
->ts
.type
== BT_CLASS
);
7727 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7728 "type-spec or source-expr", sym
->name
, &e
->where
);
7732 /* Check F08:C632. */
7733 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7734 && !UNLIMITED_POLY (e
))
7738 if (!e
->ts
.u
.cl
->length
)
7741 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7742 code
->ext
.alloc
.ts
.u
.cl
->length
);
7743 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7745 gfc_error ("Allocating %s at %L with type-spec requires the same "
7746 "character-length parameter as in the declaration",
7747 sym
->name
, &e
->where
);
7752 /* In the variable definition context checks, gfc_expr_attr is used
7753 on the expression. This is fooled by the array specification
7754 present in e, thus we have to eliminate that one temporarily. */
7755 e2
= remove_last_array_ref (e
);
7758 t
= gfc_check_vardef_context (e2
, true, true, false,
7759 _("ALLOCATE object"));
7761 t
= gfc_check_vardef_context (e2
, false, true, false,
7762 _("ALLOCATE object"));
7767 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7768 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7770 /* For class arrays, the initialization with SOURCE is done
7771 using _copy and trans_call. It is convenient to exploit that
7772 when the allocated type is different from the declared type but
7773 no SOURCE exists by setting expr3. */
7774 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7776 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7777 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7778 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7780 /* We have to zero initialize the integer variable. */
7781 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7784 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7786 /* Make sure the vtab symbol is present when
7787 the module variables are generated. */
7788 gfc_typespec ts
= e
->ts
;
7790 ts
= code
->expr3
->ts
;
7791 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7792 ts
= code
->ext
.alloc
.ts
;
7794 /* Finding the vtab also publishes the type's symbol. Therefore this
7795 statement is necessary. */
7796 gfc_find_derived_vtab (ts
.u
.derived
);
7798 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7800 /* Again, make sure the vtab symbol is present when
7801 the module variables are generated. */
7802 gfc_typespec
*ts
= NULL
;
7804 ts
= &code
->expr3
->ts
;
7806 ts
= &code
->ext
.alloc
.ts
;
7810 /* Finding the vtab also publishes the type's symbol. Therefore this
7811 statement is necessary. */
7815 if (dimension
== 0 && codimension
== 0)
7818 /* Make sure the last reference node is an array specification. */
7820 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7821 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7826 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7827 "in ALLOCATE statement at %L", &e
->where
))
7829 if (code
->expr3
->rank
!= 0)
7830 *array_alloc_wo_spec
= true;
7833 gfc_error ("Array specification or array-valued SOURCE= "
7834 "expression required in ALLOCATE statement at %L",
7841 gfc_error ("Array specification required in ALLOCATE statement "
7842 "at %L", &e
->where
);
7847 /* Make sure that the array section reference makes sense in the
7848 context of an ALLOCATE specification. */
7853 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7855 switch (ar
->dimen_type
[i
])
7857 case DIMEN_THIS_IMAGE
:
7858 gfc_error ("Coarray specification required in ALLOCATE statement "
7859 "at %L", &e
->where
);
7863 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0)
7865 /* If ar->stride[i] is NULL, we issued a previous error. */
7866 if (ar
->stride
[i
] == NULL
)
7867 gfc_error ("Bad array specification in ALLOCATE statement "
7868 "at %L", &e
->where
);
7871 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
7873 gfc_error ("Upper cobound is less than lower cobound at %L",
7874 &ar
->start
[i
]->where
);
7880 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
7882 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
7883 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
7885 gfc_error ("Upper cobound is less than lower cobound "
7886 "of 1 at %L", &ar
->start
[i
]->where
);
7896 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7902 for (i
= 0; i
< ar
->dimen
; i
++)
7904 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7907 switch (ar
->dimen_type
[i
])
7913 if (ar
->start
[i
] != NULL
7914 && ar
->end
[i
] != NULL
7915 && ar
->stride
[i
] == NULL
)
7923 case DIMEN_THIS_IMAGE
:
7924 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7930 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7932 sym
= a
->expr
->symtree
->n
.sym
;
7934 /* TODO - check derived type components. */
7935 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7938 if ((ar
->start
[i
] != NULL
7939 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7940 || (ar
->end
[i
] != NULL
7941 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7943 gfc_error ("%qs must not appear in the array specification at "
7944 "%L in the same ALLOCATE statement where it is "
7945 "itself allocated", sym
->name
, &ar
->where
);
7951 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7953 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7954 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7956 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7958 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7959 "statement at %L", &e
->where
);
7965 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7966 && ar
->stride
[i
] == NULL
)
7969 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7983 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7985 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7986 gfc_alloc
*a
, *p
, *q
;
7989 errmsg
= code
->expr2
;
7991 /* Check the stat variable. */
7994 gfc_check_vardef_context (stat
, false, false, false,
7995 _("STAT variable"));
7997 if ((stat
->ts
.type
!= BT_INTEGER
7998 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7999 || stat
->ref
->type
== REF_COMPONENT
)))
8001 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8002 "variable", &stat
->where
);
8004 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8005 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
8007 gfc_ref
*ref1
, *ref2
;
8010 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
8011 ref1
= ref1
->next
, ref2
= ref2
->next
)
8013 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8015 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8024 gfc_error ("Stat-variable at %L shall not be %sd within "
8025 "the same %s statement", &stat
->where
, fcn
, fcn
);
8031 /* Check the errmsg variable. */
8035 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8038 gfc_check_vardef_context (errmsg
, false, false, false,
8039 _("ERRMSG variable"));
8041 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8042 F18:R930 errmsg-variable is scalar-default-char-variable
8043 F18:R906 default-char-variable is variable
8044 F18:C906 default-char-variable shall be default character. */
8045 if ((errmsg
->ts
.type
!= BT_CHARACTER
8047 && (errmsg
->ref
->type
== REF_ARRAY
8048 || errmsg
->ref
->type
== REF_COMPONENT
)))
8050 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8051 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8052 "variable", &errmsg
->where
);
8054 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8055 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8057 gfc_ref
*ref1
, *ref2
;
8060 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
8061 ref1
= ref1
->next
, ref2
= ref2
->next
)
8063 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8065 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8074 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8075 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8081 /* Check that an allocate-object appears only once in the statement. */
8083 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8086 for (q
= p
->next
; q
; q
= q
->next
)
8089 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8091 /* This is a potential collision. */
8092 gfc_ref
*pr
= pe
->ref
;
8093 gfc_ref
*qr
= qe
->ref
;
8095 /* Follow the references until
8096 a) They start to differ, in which case there is no error;
8097 you can deallocate a%b and a%c in a single statement
8098 b) Both of them stop, which is an error
8099 c) One of them stops, which is also an error. */
8102 if (pr
== NULL
&& qr
== NULL
)
8104 gfc_error ("Allocate-object at %L also appears at %L",
8105 &pe
->where
, &qe
->where
);
8108 else if (pr
!= NULL
&& qr
== NULL
)
8110 gfc_error ("Allocate-object at %L is subobject of"
8111 " object at %L", &pe
->where
, &qe
->where
);
8114 else if (pr
== NULL
&& qr
!= NULL
)
8116 gfc_error ("Allocate-object at %L is subobject of"
8117 " object at %L", &qe
->where
, &pe
->where
);
8120 /* Here, pr != NULL && qr != NULL */
8121 gcc_assert(pr
->type
== qr
->type
);
8122 if (pr
->type
== REF_ARRAY
)
8124 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8126 gcc_assert (qr
->type
== REF_ARRAY
);
8128 if (pr
->next
&& qr
->next
)
8131 gfc_array_ref
*par
= &(pr
->u
.ar
);
8132 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8134 for (i
=0; i
<par
->dimen
; i
++)
8136 if ((par
->start
[i
] != NULL
8137 || qar
->start
[i
] != NULL
)
8138 && gfc_dep_compare_expr (par
->start
[i
],
8139 qar
->start
[i
]) != 0)
8146 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8159 if (strcmp (fcn
, "ALLOCATE") == 0)
8161 bool arr_alloc_wo_spec
= false;
8163 /* Resolving the expr3 in the loop over all objects to allocate would
8164 execute loop invariant code for each loop item. Therefore do it just
8166 if (code
->expr3
&& code
->expr3
->mold
8167 && code
->expr3
->ts
.type
== BT_DERIVED
)
8169 /* Default initialization via MOLD (non-polymorphic). */
8170 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8173 gfc_resolve_expr (rhs
);
8174 gfc_free_expr (code
->expr3
);
8178 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8179 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8181 if (arr_alloc_wo_spec
&& code
->expr3
)
8183 /* Mark the allocate to have to take the array specification
8185 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8190 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8191 resolve_deallocate_expr (a
->expr
);
8196 /************ SELECT CASE resolution subroutines ************/
8198 /* Callback function for our mergesort variant. Determines interval
8199 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8200 op1 > op2. Assumes we're not dealing with the default case.
8201 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8202 There are nine situations to check. */
8205 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8209 if (op1
->low
== NULL
) /* op1 = (:L) */
8211 /* op2 = (:N), so overlap. */
8213 /* op2 = (M:) or (M:N), L < M */
8214 if (op2
->low
!= NULL
8215 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8218 else if (op1
->high
== NULL
) /* op1 = (K:) */
8220 /* op2 = (M:), so overlap. */
8222 /* op2 = (:N) or (M:N), K > N */
8223 if (op2
->high
!= NULL
8224 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8227 else /* op1 = (K:L) */
8229 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8230 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8232 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8233 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8235 else /* op2 = (M:N) */
8239 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8242 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8251 /* Merge-sort a double linked case list, detecting overlap in the
8252 process. LIST is the head of the double linked case list before it
8253 is sorted. Returns the head of the sorted list if we don't see any
8254 overlap, or NULL otherwise. */
8257 check_case_overlap (gfc_case
*list
)
8259 gfc_case
*p
, *q
, *e
, *tail
;
8260 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8262 /* If the passed list was empty, return immediately. */
8269 /* Loop unconditionally. The only exit from this loop is a return
8270 statement, when we've finished sorting the case list. */
8277 /* Count the number of merges we do in this pass. */
8280 /* Loop while there exists a merge to be done. */
8285 /* Count this merge. */
8288 /* Cut the list in two pieces by stepping INSIZE places
8289 forward in the list, starting from P. */
8292 for (i
= 0; i
< insize
; i
++)
8301 /* Now we have two lists. Merge them! */
8302 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8304 /* See from which the next case to merge comes from. */
8307 /* P is empty so the next case must come from Q. */
8312 else if (qsize
== 0 || q
== NULL
)
8321 cmp
= compare_cases (p
, q
);
8324 /* The whole case range for P is less than the
8332 /* The whole case range for Q is greater than
8333 the case range for P. */
8340 /* The cases overlap, or they are the same
8341 element in the list. Either way, we must
8342 issue an error and get the next case from P. */
8343 /* FIXME: Sort P and Q by line number. */
8344 gfc_error ("CASE label at %L overlaps with CASE "
8345 "label at %L", &p
->where
, &q
->where
);
8353 /* Add the next element to the merged list. */
8362 /* P has now stepped INSIZE places along, and so has Q. So
8363 they're the same. */
8368 /* If we have done only one merge or none at all, we've
8369 finished sorting the cases. */
8378 /* Otherwise repeat, merging lists twice the size. */
8384 /* Check to see if an expression is suitable for use in a CASE statement.
8385 Makes sure that all case expressions are scalar constants of the same
8386 type. Return false if anything is wrong. */
8389 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8391 if (e
== NULL
) return true;
8393 if (e
->ts
.type
!= case_expr
->ts
.type
)
8395 gfc_error ("Expression in CASE statement at %L must be of type %s",
8396 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8400 /* C805 (R808) For a given case-construct, each case-value shall be of
8401 the same type as case-expr. For character type, length differences
8402 are allowed, but the kind type parameters shall be the same. */
8404 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8406 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8407 &e
->where
, case_expr
->ts
.kind
);
8411 /* Convert the case value kind to that of case expression kind,
8414 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8415 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8419 gfc_error ("Expression in CASE statement at %L must be scalar",
8428 /* Given a completely parsed select statement, we:
8430 - Validate all expressions and code within the SELECT.
8431 - Make sure that the selection expression is not of the wrong type.
8432 - Make sure that no case ranges overlap.
8433 - Eliminate unreachable cases and unreachable code resulting from
8434 removing case labels.
8436 The standard does allow unreachable cases, e.g. CASE (5:3). But
8437 they are a hassle for code generation, and to prevent that, we just
8438 cut them out here. This is not necessary for overlapping cases
8439 because they are illegal and we never even try to generate code.
8441 We have the additional caveat that a SELECT construct could have
8442 been a computed GOTO in the source code. Fortunately we can fairly
8443 easily work around that here: The case_expr for a "real" SELECT CASE
8444 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8445 we have to do is make sure that the case_expr is a scalar integer
8449 resolve_select (gfc_code
*code
, bool select_type
)
8452 gfc_expr
*case_expr
;
8453 gfc_case
*cp
, *default_case
, *tail
, *head
;
8454 int seen_unreachable
;
8460 if (code
->expr1
== NULL
)
8462 /* This was actually a computed GOTO statement. */
8463 case_expr
= code
->expr2
;
8464 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8465 gfc_error ("Selection expression in computed GOTO statement "
8466 "at %L must be a scalar integer expression",
8469 /* Further checking is not necessary because this SELECT was built
8470 by the compiler, so it should always be OK. Just move the
8471 case_expr from expr2 to expr so that we can handle computed
8472 GOTOs as normal SELECTs from here on. */
8473 code
->expr1
= code
->expr2
;
8478 case_expr
= code
->expr1
;
8479 type
= case_expr
->ts
.type
;
8482 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8484 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8485 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8487 /* Punt. Going on here just produce more garbage error messages. */
8492 if (!select_type
&& case_expr
->rank
!= 0)
8494 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8495 "expression", &case_expr
->where
);
8501 /* Raise a warning if an INTEGER case value exceeds the range of
8502 the case-expr. Later, all expressions will be promoted to the
8503 largest kind of all case-labels. */
8505 if (type
== BT_INTEGER
)
8506 for (body
= code
->block
; body
; body
= body
->block
)
8507 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8510 && gfc_check_integer_range (cp
->low
->value
.integer
,
8511 case_expr
->ts
.kind
) != ARITH_OK
)
8512 gfc_warning (0, "Expression in CASE statement at %L is "
8513 "not in the range of %s", &cp
->low
->where
,
8514 gfc_typename (&case_expr
->ts
));
8517 && cp
->low
!= cp
->high
8518 && gfc_check_integer_range (cp
->high
->value
.integer
,
8519 case_expr
->ts
.kind
) != ARITH_OK
)
8520 gfc_warning (0, "Expression in CASE statement at %L is "
8521 "not in the range of %s", &cp
->high
->where
,
8522 gfc_typename (&case_expr
->ts
));
8525 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8526 of the SELECT CASE expression and its CASE values. Walk the lists
8527 of case values, and if we find a mismatch, promote case_expr to
8528 the appropriate kind. */
8530 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8532 for (body
= code
->block
; body
; body
= body
->block
)
8534 /* Walk the case label list. */
8535 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8537 /* Intercept the DEFAULT case. It does not have a kind. */
8538 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8541 /* Unreachable case ranges are discarded, so ignore. */
8542 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8543 && cp
->low
!= cp
->high
8544 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8548 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8549 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8551 if (cp
->high
!= NULL
8552 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8553 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8558 /* Assume there is no DEFAULT case. */
8559 default_case
= NULL
;
8564 for (body
= code
->block
; body
; body
= body
->block
)
8566 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8568 seen_unreachable
= 0;
8570 /* Walk the case label list, making sure that all case labels
8572 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8574 /* Count the number of cases in the whole construct. */
8577 /* Intercept the DEFAULT case. */
8578 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8580 if (default_case
!= NULL
)
8582 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8583 "by a second DEFAULT CASE at %L",
8584 &default_case
->where
, &cp
->where
);
8595 /* Deal with single value cases and case ranges. Errors are
8596 issued from the validation function. */
8597 if (!validate_case_label_expr (cp
->low
, case_expr
)
8598 || !validate_case_label_expr (cp
->high
, case_expr
))
8604 if (type
== BT_LOGICAL
8605 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8606 || cp
->low
!= cp
->high
))
8608 gfc_error ("Logical range in CASE statement at %L is not "
8609 "allowed", &cp
->low
->where
);
8614 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8617 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8618 if (value
& seen_logical
)
8620 gfc_error ("Constant logical value in CASE statement "
8621 "is repeated at %L",
8626 seen_logical
|= value
;
8629 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8630 && cp
->low
!= cp
->high
8631 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8633 if (warn_surprising
)
8634 gfc_warning (OPT_Wsurprising
,
8635 "Range specification at %L can never be matched",
8638 cp
->unreachable
= 1;
8639 seen_unreachable
= 1;
8643 /* If the case range can be matched, it can also overlap with
8644 other cases. To make sure it does not, we put it in a
8645 double linked list here. We sort that with a merge sort
8646 later on to detect any overlapping cases. */
8650 head
->right
= head
->left
= NULL
;
8655 tail
->right
->left
= tail
;
8662 /* It there was a failure in the previous case label, give up
8663 for this case label list. Continue with the next block. */
8667 /* See if any case labels that are unreachable have been seen.
8668 If so, we eliminate them. This is a bit of a kludge because
8669 the case lists for a single case statement (label) is a
8670 single forward linked lists. */
8671 if (seen_unreachable
)
8673 /* Advance until the first case in the list is reachable. */
8674 while (body
->ext
.block
.case_list
!= NULL
8675 && body
->ext
.block
.case_list
->unreachable
)
8677 gfc_case
*n
= body
->ext
.block
.case_list
;
8678 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8680 gfc_free_case_list (n
);
8683 /* Strip all other unreachable cases. */
8684 if (body
->ext
.block
.case_list
)
8686 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8688 if (cp
->next
->unreachable
)
8690 gfc_case
*n
= cp
->next
;
8691 cp
->next
= cp
->next
->next
;
8693 gfc_free_case_list (n
);
8700 /* See if there were overlapping cases. If the check returns NULL,
8701 there was overlap. In that case we don't do anything. If head
8702 is non-NULL, we prepend the DEFAULT case. The sorted list can
8703 then used during code generation for SELECT CASE constructs with
8704 a case expression of a CHARACTER type. */
8707 head
= check_case_overlap (head
);
8709 /* Prepend the default_case if it is there. */
8710 if (head
!= NULL
&& default_case
)
8712 default_case
->left
= NULL
;
8713 default_case
->right
= head
;
8714 head
->left
= default_case
;
8718 /* Eliminate dead blocks that may be the result if we've seen
8719 unreachable case labels for a block. */
8720 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8722 if (body
->block
->ext
.block
.case_list
== NULL
)
8724 /* Cut the unreachable block from the code chain. */
8725 gfc_code
*c
= body
->block
;
8726 body
->block
= c
->block
;
8728 /* Kill the dead block, but not the blocks below it. */
8730 gfc_free_statements (c
);
8734 /* More than two cases is legal but insane for logical selects.
8735 Issue a warning for it. */
8736 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8737 gfc_warning (OPT_Wsurprising
,
8738 "Logical SELECT CASE block at %L has more that two cases",
8743 /* Check if a derived type is extensible. */
8746 gfc_type_is_extensible (gfc_symbol
*sym
)
8748 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8749 || (sym
->attr
.is_class
8750 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8755 resolve_types (gfc_namespace
*ns
);
8757 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8758 correct as well as possibly the array-spec. */
8761 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8765 gcc_assert (sym
->assoc
);
8766 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8768 /* If this is for SELECT TYPE, the target may not yet be set. In that
8769 case, return. Resolution will be called later manually again when
8771 target
= sym
->assoc
->target
;
8774 gcc_assert (!sym
->assoc
->dangling
);
8776 if (resolve_target
&& !gfc_resolve_expr (target
))
8779 /* For variable targets, we get some attributes from the target. */
8780 if (target
->expr_type
== EXPR_VARIABLE
)
8784 gcc_assert (target
->symtree
);
8785 tsym
= target
->symtree
->n
.sym
;
8787 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8788 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8790 sym
->attr
.target
= tsym
->attr
.target
8791 || gfc_expr_attr (target
).pointer
;
8792 if (is_subref_array (target
))
8793 sym
->attr
.subref_array_pointer
= 1;
8796 if (target
->expr_type
== EXPR_NULL
)
8798 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8801 else if (target
->ts
.type
== BT_UNKNOWN
)
8803 gfc_error ("Selector at %L has no type", &target
->where
);
8807 /* Get type if this was not already set. Note that it can be
8808 some other type than the target in case this is a SELECT TYPE
8809 selector! So we must not update when the type is already there. */
8810 if (sym
->ts
.type
== BT_UNKNOWN
)
8811 sym
->ts
= target
->ts
;
8813 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8815 /* See if this is a valid association-to-variable. */
8816 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8817 && !gfc_has_vector_subscript (target
));
8819 /* Finally resolve if this is an array or not. */
8820 if (sym
->attr
.dimension
&& target
->rank
== 0)
8822 /* primary.c makes the assumption that a reference to an associate
8823 name followed by a left parenthesis is an array reference. */
8824 if (sym
->ts
.type
!= BT_CHARACTER
)
8825 gfc_error ("Associate-name %qs at %L is used as array",
8826 sym
->name
, &sym
->declared_at
);
8827 sym
->attr
.dimension
= 0;
8832 /* We cannot deal with class selectors that need temporaries. */
8833 if (target
->ts
.type
== BT_CLASS
8834 && gfc_ref_needs_temporary_p (target
->ref
))
8836 gfc_error ("CLASS selector at %L needs a temporary which is not "
8837 "yet implemented", &target
->where
);
8841 if (target
->ts
.type
== BT_CLASS
)
8842 gfc_fix_class_refs (target
);
8844 if (target
->rank
!= 0)
8847 /* The rank may be incorrectly guessed at parsing, therefore make sure
8848 it is corrected now. */
8849 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8852 sym
->as
= gfc_get_array_spec ();
8854 as
->rank
= target
->rank
;
8855 as
->type
= AS_DEFERRED
;
8856 as
->corank
= gfc_get_corank (target
);
8857 sym
->attr
.dimension
= 1;
8858 if (as
->corank
!= 0)
8859 sym
->attr
.codimension
= 1;
8861 else if (sym
->ts
.type
== BT_CLASS
&& (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
8863 if (!CLASS_DATA (sym
)->as
)
8864 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
8865 as
= CLASS_DATA (sym
)->as
;
8866 as
->rank
= target
->rank
;
8867 as
->type
= AS_DEFERRED
;
8868 as
->corank
= gfc_get_corank (target
);
8869 CLASS_DATA (sym
)->attr
.dimension
= 1;
8870 if (as
->corank
!= 0)
8871 CLASS_DATA (sym
)->attr
.codimension
= 1;
8876 /* target's rank is 0, but the type of the sym is still array valued,
8877 which has to be corrected. */
8878 if (sym
->ts
.type
== BT_CLASS
8879 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
8882 symbol_attribute attr
;
8883 /* The associated variable's type is still the array type
8884 correct this now. */
8885 gfc_typespec
*ts
= &target
->ts
;
8888 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8893 ts
= &ref
->u
.c
.component
->ts
;
8896 if (ts
->type
== BT_CLASS
)
8897 ts
= &ts
->u
.derived
->components
->ts
;
8903 /* Create a scalar instance of the current class type. Because the
8904 rank of a class array goes into its name, the type has to be
8905 rebuild. The alternative of (re-)setting just the attributes
8906 and as in the current type, destroys the type also in other
8910 sym
->ts
.type
= BT_CLASS
;
8911 attr
= CLASS_DATA (sym
)->attr
;
8913 attr
.associate_var
= 1;
8914 attr
.dimension
= attr
.codimension
= 0;
8915 attr
.class_pointer
= 1;
8916 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8918 /* Make sure the _vptr is set. */
8919 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8920 if (c
->ts
.u
.derived
== NULL
)
8921 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8922 CLASS_DATA (sym
)->attr
.pointer
= 1;
8923 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8924 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8925 gfc_commit_symbol (sym
->ts
.u
.derived
);
8926 /* _vptr now has the _vtab in it, change it to the _vtype. */
8927 if (c
->ts
.u
.derived
->attr
.vtab
)
8928 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8929 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8930 resolve_types (c
->ts
.u
.derived
->ns
);
8934 /* Mark this as an associate variable. */
8935 sym
->attr
.associate_var
= 1;
8937 /* Fix up the type-spec for CHARACTER types. */
8938 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8941 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8943 if (sym
->ts
.deferred
&& target
->expr_type
== EXPR_VARIABLE
8944 && target
->symtree
->n
.sym
->attr
.dummy
8945 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
8947 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8948 sym
->ts
.deferred
= 1;
8951 if (!sym
->ts
.u
.cl
->length
8952 && !sym
->ts
.deferred
8953 && target
->expr_type
== EXPR_CONSTANT
)
8955 sym
->ts
.u
.cl
->length
=
8956 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8957 target
->value
.character
.length
);
8959 else if ((!sym
->ts
.u
.cl
->length
8960 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8961 && target
->expr_type
!= EXPR_VARIABLE
)
8963 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8964 sym
->ts
.deferred
= 1;
8966 /* This is reset in trans-stmt.c after the assignment
8967 of the target expression to the associate name. */
8968 sym
->attr
.allocatable
= 1;
8972 /* If the target is a good class object, so is the associate variable. */
8973 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8974 sym
->attr
.class_ok
= 1;
8978 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8979 array reference, where necessary. The symbols are artificial and so
8980 the dimension attribute and arrayspec can also be set. In addition,
8981 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8982 This is corrected here as well.*/
8985 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8986 int rank
, gfc_ref
*ref
)
8988 gfc_ref
*nref
= (*expr1
)->ref
;
8989 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8990 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8991 (*expr1
)->rank
= rank
;
8992 if (sym1
->ts
.type
== BT_CLASS
)
8994 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8995 (*expr1
)->ts
= sym1
->ts
;
8997 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8998 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8999 CLASS_DATA (sym1
)->as
9000 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
9004 sym1
->attr
.dimension
= 1;
9005 if (sym1
->as
== NULL
&& sym2
)
9006 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
9009 for (; nref
; nref
= nref
->next
)
9010 if (nref
->next
== NULL
)
9013 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
9014 nref
->next
= gfc_copy_ref (ref
);
9015 else if (ref
&& !nref
)
9016 (*expr1
)->ref
= gfc_copy_ref (ref
);
9021 build_loc_call (gfc_expr
*sym_expr
)
9024 loc_call
= gfc_get_expr ();
9025 loc_call
->expr_type
= EXPR_FUNCTION
;
9026 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
9027 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
9028 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
9029 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
9030 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
9031 loc_call
->ts
.type
= BT_INTEGER
;
9032 loc_call
->ts
.kind
= gfc_index_integer_kind
;
9033 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
9034 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
9035 loc_call
->value
.function
.actual
->expr
= sym_expr
;
9036 loc_call
->where
= sym_expr
->where
;
9040 /* Resolve a SELECT TYPE statement. */
9043 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9045 gfc_symbol
*selector_type
;
9046 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9047 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9050 char name
[GFC_MAX_SYMBOL_LEN
];
9054 gfc_ref
* ref
= NULL
;
9055 gfc_expr
*selector_expr
= NULL
;
9057 ns
= code
->ext
.block
.ns
;
9060 /* Check for F03:C813. */
9061 if (code
->expr1
->ts
.type
!= BT_CLASS
9062 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9064 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9065 "at %L", &code
->loc
);
9069 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9074 gfc_ref
*ref2
= NULL
;
9075 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9076 if (ref
->type
== REF_COMPONENT
9077 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9082 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9083 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9084 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9088 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9089 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9090 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
9093 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
9094 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9096 /* F2008: C803 The selector expression must not be coindexed. */
9097 if (gfc_is_coindexed (code
->expr2
))
9099 gfc_error ("Selector at %L must not be coindexed",
9100 &code
->expr2
->where
);
9107 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9109 if (gfc_is_coindexed (code
->expr1
))
9111 gfc_error ("Selector at %L must not be coindexed",
9112 &code
->expr1
->where
);
9117 /* Loop over TYPE IS / CLASS IS cases. */
9118 for (body
= code
->block
; body
; body
= body
->block
)
9120 c
= body
->ext
.block
.case_list
;
9124 /* Check for repeated cases. */
9125 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9127 gfc_case
*d
= tail
->ext
.block
.case_list
;
9131 if (c
->ts
.type
== d
->ts
.type
9132 && ((c
->ts
.type
== BT_DERIVED
9133 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9134 && !strcmp (c
->ts
.u
.derived
->name
,
9135 d
->ts
.u
.derived
->name
))
9136 || c
->ts
.type
== BT_UNKNOWN
9137 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9138 && c
->ts
.kind
== d
->ts
.kind
)))
9140 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9141 &c
->where
, &d
->where
);
9147 /* Check F03:C815. */
9148 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9149 && !selector_type
->attr
.unlimited_polymorphic
9150 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9152 gfc_error ("Derived type %qs at %L must be extensible",
9153 c
->ts
.u
.derived
->name
, &c
->where
);
9158 /* Check F03:C816. */
9159 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
9160 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9161 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9163 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9164 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9165 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9167 gfc_error ("Unexpected intrinsic type %qs at %L",
9168 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9173 /* Check F03:C814. */
9174 if (c
->ts
.type
== BT_CHARACTER
9175 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9177 gfc_error ("The type-spec at %L shall specify that each length "
9178 "type parameter is assumed", &c
->where
);
9183 /* Intercept the DEFAULT case. */
9184 if (c
->ts
.type
== BT_UNKNOWN
)
9186 /* Check F03:C818. */
9189 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9190 "by a second DEFAULT CASE at %L",
9191 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9196 default_case
= body
;
9203 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9204 target if present. If there are any EXIT statements referring to the
9205 SELECT TYPE construct, this is no problem because the gfc_code
9206 reference stays the same and EXIT is equally possible from the BLOCK
9207 it is changed to. */
9208 code
->op
= EXEC_BLOCK
;
9211 gfc_association_list
* assoc
;
9213 assoc
= gfc_get_association_list ();
9214 assoc
->st
= code
->expr1
->symtree
;
9215 assoc
->target
= gfc_copy_expr (code
->expr2
);
9216 assoc
->target
->where
= code
->expr2
->where
;
9217 /* assoc->variable will be set by resolve_assoc_var. */
9219 code
->ext
.block
.assoc
= assoc
;
9220 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9222 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9225 code
->ext
.block
.assoc
= NULL
;
9227 /* Ensure that the selector rank and arrayspec are available to
9228 correct expressions in which they might be missing. */
9229 if (code
->expr2
&& code
->expr2
->rank
)
9231 rank
= code
->expr2
->rank
;
9232 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9233 if (ref
->next
== NULL
)
9235 if (ref
&& ref
->type
== REF_ARRAY
)
9236 ref
= gfc_copy_ref (ref
);
9238 /* Fixup expr1 if necessary. */
9240 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9242 else if (code
->expr1
->rank
)
9244 rank
= code
->expr1
->rank
;
9245 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9246 if (ref
->next
== NULL
)
9248 if (ref
&& ref
->type
== REF_ARRAY
)
9249 ref
= gfc_copy_ref (ref
);
9252 /* Add EXEC_SELECT to switch on type. */
9253 new_st
= gfc_get_code (code
->op
);
9254 new_st
->expr1
= code
->expr1
;
9255 new_st
->expr2
= code
->expr2
;
9256 new_st
->block
= code
->block
;
9257 code
->expr1
= code
->expr2
= NULL
;
9262 ns
->code
->next
= new_st
;
9264 code
->op
= EXEC_SELECT_TYPE
;
9266 /* Use the intrinsic LOC function to generate an integer expression
9267 for the vtable of the selector. Note that the rank of the selector
9268 expression has to be set to zero. */
9269 gfc_add_vptr_component (code
->expr1
);
9270 code
->expr1
->rank
= 0;
9271 code
->expr1
= build_loc_call (code
->expr1
);
9272 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9274 /* Loop over TYPE IS / CLASS IS cases. */
9275 for (body
= code
->block
; body
; body
= body
->block
)
9279 c
= body
->ext
.block
.case_list
;
9281 /* Generate an index integer expression for address of the
9282 TYPE/CLASS vtable and store it in c->low. The hash expression
9283 is stored in c->high and is used to resolve intrinsic cases. */
9284 if (c
->ts
.type
!= BT_UNKNOWN
)
9286 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9288 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9290 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9291 c
->ts
.u
.derived
->hash_value
);
9295 vtab
= gfc_find_vtab (&c
->ts
);
9296 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9297 e
= CLASS_DATA (vtab
)->initializer
;
9298 c
->high
= gfc_copy_expr (e
);
9299 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9302 ts
.kind
= gfc_integer_4_kind
;
9303 ts
.type
= BT_INTEGER
;
9304 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9308 e
= gfc_lval_expr_from_sym (vtab
);
9309 c
->low
= build_loc_call (e
);
9314 /* Associate temporary to selector. This should only be done
9315 when this case is actually true, so build a new ASSOCIATE
9316 that does precisely this here (instead of using the
9319 if (c
->ts
.type
== BT_CLASS
)
9320 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9321 else if (c
->ts
.type
== BT_DERIVED
)
9322 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9323 else if (c
->ts
.type
== BT_CHARACTER
)
9325 HOST_WIDE_INT charlen
= 0;
9326 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9327 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9328 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9329 snprintf (name
, sizeof (name
),
9330 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9331 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9334 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9337 st
= gfc_find_symtree (ns
->sym_root
, name
);
9338 gcc_assert (st
->n
.sym
->assoc
);
9339 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9340 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9341 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9343 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9344 /* Fixup the target expression if necessary. */
9346 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9349 new_st
= gfc_get_code (EXEC_BLOCK
);
9350 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9351 new_st
->ext
.block
.ns
->code
= body
->next
;
9352 body
->next
= new_st
;
9354 /* Chain in the new list only if it is marked as dangling. Otherwise
9355 there is a CASE label overlap and this is already used. Just ignore,
9356 the error is diagnosed elsewhere. */
9357 if (st
->n
.sym
->assoc
->dangling
)
9359 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9360 st
->n
.sym
->assoc
->dangling
= 0;
9363 resolve_assoc_var (st
->n
.sym
, false);
9366 /* Take out CLASS IS cases for separate treatment. */
9368 while (body
&& body
->block
)
9370 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9372 /* Add to class_is list. */
9373 if (class_is
== NULL
)
9375 class_is
= body
->block
;
9380 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9381 tail
->block
= body
->block
;
9384 /* Remove from EXEC_SELECT list. */
9385 body
->block
= body
->block
->block
;
9398 /* Add a default case to hold the CLASS IS cases. */
9399 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9400 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9402 tail
->ext
.block
.case_list
= gfc_get_case ();
9403 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9405 default_case
= tail
;
9408 /* More than one CLASS IS block? */
9409 if (class_is
->block
)
9413 /* Sort CLASS IS blocks by extension level. */
9417 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9420 /* F03:C817 (check for doubles). */
9421 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9422 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9424 gfc_error ("Double CLASS IS block in SELECT TYPE "
9426 &c2
->ext
.block
.case_list
->where
);
9429 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9430 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9433 (*c1
)->block
= c2
->block
;
9443 /* Generate IF chain. */
9444 if_st
= gfc_get_code (EXEC_IF
);
9446 for (body
= class_is
; body
; body
= body
->block
)
9448 new_st
->block
= gfc_get_code (EXEC_IF
);
9449 new_st
= new_st
->block
;
9450 /* Set up IF condition: Call _gfortran_is_extension_of. */
9451 new_st
->expr1
= gfc_get_expr ();
9452 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9453 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9454 new_st
->expr1
->ts
.kind
= 4;
9455 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9456 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9457 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9458 /* Set up arguments. */
9459 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9460 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9461 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9462 new_st
->expr1
->where
= code
->loc
;
9463 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9464 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9465 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9466 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9467 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9468 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9469 new_st
->next
= body
->next
;
9471 if (default_case
->next
)
9473 new_st
->block
= gfc_get_code (EXEC_IF
);
9474 new_st
= new_st
->block
;
9475 new_st
->next
= default_case
->next
;
9478 /* Replace CLASS DEFAULT code by the IF chain. */
9479 default_case
->next
= if_st
;
9482 /* Resolve the internal code. This cannot be done earlier because
9483 it requires that the sym->assoc of selectors is set already. */
9484 gfc_current_ns
= ns
;
9485 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9486 gfc_current_ns
= old_ns
;
9493 /* Resolve a transfer statement. This is making sure that:
9494 -- a derived type being transferred has only non-pointer components
9495 -- a derived type being transferred doesn't have private components, unless
9496 it's being transferred from the module where the type was defined
9497 -- we're not trying to transfer a whole assumed size array. */
9500 resolve_transfer (gfc_code
*code
)
9502 gfc_symbol
*sym
, *derived
;
9506 bool formatted
= false;
9507 gfc_dt
*dt
= code
->ext
.dt
;
9508 gfc_symbol
*dtio_sub
= NULL
;
9512 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9513 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9514 exp
= exp
->value
.op
.op1
;
9516 if (exp
&& exp
->expr_type
== EXPR_NULL
9519 gfc_error ("Invalid context for NULL () intrinsic at %L",
9524 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9525 && exp
->expr_type
!= EXPR_FUNCTION
9526 && exp
->expr_type
!= EXPR_STRUCTURE
))
9529 /* If we are reading, the variable will be changed. Note that
9530 code->ext.dt may be NULL if the TRANSFER is related to
9531 an INQUIRE statement -- but in this case, we are not reading, either. */
9532 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9533 && !gfc_check_vardef_context (exp
, false, false, false,
9537 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
9538 || exp
->expr_type
== EXPR_FUNCTION
9539 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9541 /* Go to actual component transferred. */
9542 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9543 if (ref
->type
== REF_COMPONENT
)
9544 ts
= &ref
->u
.c
.component
->ts
;
9546 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9547 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9549 derived
= ts
->u
.derived
;
9551 /* Determine when to use the formatted DTIO procedure. */
9552 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9555 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9556 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9557 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9559 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9562 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9563 /* Check to see if this is a nested DTIO call, with the
9564 dummy as the io-list object. */
9565 if (sym
&& sym
== dtio_sub
&& sym
->formal
9566 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9567 && exp
->ref
== NULL
)
9569 if (!sym
->attr
.recursive
)
9571 gfc_error ("DTIO %s procedure at %L must be recursive",
9572 sym
->name
, &sym
->declared_at
);
9579 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9581 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9582 "it is processed by a defined input/output procedure",
9587 if (ts
->type
== BT_DERIVED
)
9589 /* Check that transferred derived type doesn't contain POINTER
9590 components unless it is processed by a defined input/output
9592 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9594 gfc_error ("Data transfer element at %L cannot have POINTER "
9595 "components unless it is processed by a defined "
9596 "input/output procedure", &code
->loc
);
9601 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9603 gfc_error ("Data transfer element at %L cannot have "
9604 "procedure pointer components", &code
->loc
);
9608 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9610 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9611 "components unless it is processed by a defined "
9612 "input/output procedure", &code
->loc
);
9616 /* C_PTR and C_FUNPTR have private components which means they cannot
9617 be printed. However, if -std=gnu and not -pedantic, allow
9618 the component to be printed to help debugging. */
9619 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9621 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9622 "cannot have PRIVATE components", &code
->loc
))
9625 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9627 gfc_error ("Data transfer element at %L cannot have "
9628 "PRIVATE components unless it is processed by "
9629 "a defined input/output procedure", &code
->loc
);
9634 if (exp
->expr_type
== EXPR_STRUCTURE
)
9637 sym
= exp
->symtree
->n
.sym
;
9639 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9640 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9642 gfc_error ("Data transfer element at %L cannot be a full reference to "
9643 "an assumed-size array", &code
->loc
);
9647 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9648 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9652 /*********** Toplevel code resolution subroutines ***********/
9654 /* Find the set of labels that are reachable from this block. We also
9655 record the last statement in each block. */
9658 find_reachable_labels (gfc_code
*block
)
9665 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9667 /* Collect labels in this block. We don't keep those corresponding
9668 to END {IF|SELECT}, these are checked in resolve_branch by going
9669 up through the code_stack. */
9670 for (c
= block
; c
; c
= c
->next
)
9672 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9673 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9676 /* Merge with labels from parent block. */
9679 gcc_assert (cs_base
->prev
->reachable_labels
);
9680 bitmap_ior_into (cs_base
->reachable_labels
,
9681 cs_base
->prev
->reachable_labels
);
9687 resolve_lock_unlock_event (gfc_code
*code
)
9689 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9690 && code
->expr1
->value
.function
.isym
9691 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9692 remove_caf_get_intrinsic (code
->expr1
);
9694 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9695 && (code
->expr1
->ts
.type
!= BT_DERIVED
9696 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9697 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9698 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9699 || code
->expr1
->rank
!= 0
9700 || (!gfc_is_coarray (code
->expr1
) &&
9701 !gfc_is_coindexed (code
->expr1
))))
9702 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9703 &code
->expr1
->where
);
9704 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9705 && (code
->expr1
->ts
.type
!= BT_DERIVED
9706 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9707 || code
->expr1
->ts
.u
.derived
->from_intmod
9708 != INTMOD_ISO_FORTRAN_ENV
9709 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9710 != ISOFORTRAN_EVENT_TYPE
9711 || code
->expr1
->rank
!= 0))
9712 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9713 &code
->expr1
->where
);
9714 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9715 && !gfc_is_coindexed (code
->expr1
))
9716 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9717 &code
->expr1
->where
);
9718 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9719 gfc_error ("Event variable argument at %L must be a coarray but not "
9720 "coindexed", &code
->expr1
->where
);
9724 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9725 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9726 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9727 &code
->expr2
->where
);
9730 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9731 _("STAT variable")))
9736 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9737 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9738 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9739 &code
->expr3
->where
);
9742 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9743 _("ERRMSG variable")))
9746 /* Check for LOCK the ACQUIRED_LOCK. */
9747 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9748 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9749 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9750 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9751 "variable", &code
->expr4
->where
);
9753 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9754 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9755 _("ACQUIRED_LOCK variable")))
9758 /* Check for EVENT WAIT the UNTIL_COUNT. */
9759 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9761 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9762 || code
->expr4
->rank
!= 0)
9763 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9764 "expression", &code
->expr4
->where
);
9770 resolve_critical (gfc_code
*code
)
9772 gfc_symtree
*symtree
;
9773 gfc_symbol
*lock_type
;
9774 char name
[GFC_MAX_SYMBOL_LEN
];
9775 static int serial
= 0;
9777 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9780 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9781 GFC_PREFIX ("lock_type"));
9783 lock_type
= symtree
->n
.sym
;
9786 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9789 lock_type
= symtree
->n
.sym
;
9790 lock_type
->attr
.flavor
= FL_DERIVED
;
9791 lock_type
->attr
.zero_comp
= 1;
9792 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9793 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9796 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9797 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9800 code
->resolved_sym
= symtree
->n
.sym
;
9801 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9802 symtree
->n
.sym
->attr
.referenced
= 1;
9803 symtree
->n
.sym
->attr
.artificial
= 1;
9804 symtree
->n
.sym
->attr
.codimension
= 1;
9805 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9806 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9807 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9808 symtree
->n
.sym
->as
->corank
= 1;
9809 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9810 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9811 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9813 gfc_commit_symbols();
9818 resolve_sync (gfc_code
*code
)
9820 /* Check imageset. The * case matches expr1 == NULL. */
9823 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9824 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9825 "INTEGER expression", &code
->expr1
->where
);
9826 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9827 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9828 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9829 &code
->expr1
->where
);
9830 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9831 && gfc_simplify_expr (code
->expr1
, 0))
9833 gfc_constructor
*cons
;
9834 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9835 for (; cons
; cons
= gfc_constructor_next (cons
))
9836 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9837 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9838 gfc_error ("Imageset argument at %L must between 1 and "
9839 "num_images()", &cons
->expr
->where
);
9844 gfc_resolve_expr (code
->expr2
);
9846 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9847 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9848 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9849 &code
->expr2
->where
);
9852 gfc_resolve_expr (code
->expr3
);
9854 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9855 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9856 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9857 &code
->expr3
->where
);
9861 /* Given a branch to a label, see if the branch is conforming.
9862 The code node describes where the branch is located. */
9865 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9872 /* Step one: is this a valid branching target? */
9874 if (label
->defined
== ST_LABEL_UNKNOWN
)
9876 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9881 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9883 gfc_error ("Statement at %L is not a valid branch target statement "
9884 "for the branch statement at %L", &label
->where
, &code
->loc
);
9888 /* Step two: make sure this branch is not a branch to itself ;-) */
9890 if (code
->here
== label
)
9893 "Branch at %L may result in an infinite loop", &code
->loc
);
9897 /* Step three: See if the label is in the same block as the
9898 branching statement. The hard work has been done by setting up
9899 the bitmap reachable_labels. */
9901 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9903 /* Check now whether there is a CRITICAL construct; if so, check
9904 whether the label is still visible outside of the CRITICAL block,
9905 which is invalid. */
9906 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9908 if (stack
->current
->op
== EXEC_CRITICAL
9909 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9910 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9911 "label at %L", &code
->loc
, &label
->where
);
9912 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9913 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9914 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9915 "for label at %L", &code
->loc
, &label
->where
);
9921 /* Step four: If we haven't found the label in the bitmap, it may
9922 still be the label of the END of the enclosing block, in which
9923 case we find it by going up the code_stack. */
9925 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9927 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9929 if (stack
->current
->op
== EXEC_CRITICAL
)
9931 /* Note: A label at END CRITICAL does not leave the CRITICAL
9932 construct as END CRITICAL is still part of it. */
9933 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9934 " at %L", &code
->loc
, &label
->where
);
9937 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9939 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9940 "label at %L", &code
->loc
, &label
->where
);
9947 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9951 /* The label is not in an enclosing block, so illegal. This was
9952 allowed in Fortran 66, so we allow it as extension. No
9953 further checks are necessary in this case. */
9954 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9955 "as the GOTO statement at %L", &label
->where
,
9961 /* Check whether EXPR1 has the same shape as EXPR2. */
9964 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9966 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9967 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9968 bool result
= false;
9971 /* Compare the rank. */
9972 if (expr1
->rank
!= expr2
->rank
)
9975 /* Compare the size of each dimension. */
9976 for (i
=0; i
<expr1
->rank
; i
++)
9978 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9981 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9984 if (mpz_cmp (shape
[i
], shape2
[i
]))
9988 /* When either of the two expression is an assumed size array, we
9989 ignore the comparison of dimension sizes. */
9994 gfc_clear_shape (shape
, i
);
9995 gfc_clear_shape (shape2
, i
);
10000 /* Check whether a WHERE assignment target or a WHERE mask expression
10001 has the same shape as the outmost WHERE mask expression. */
10004 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
10008 gfc_expr
*e
= NULL
;
10010 cblock
= code
->block
;
10012 /* Store the first WHERE mask-expr of the WHERE statement or construct.
10013 In case of nested WHERE, only the outmost one is stored. */
10014 if (mask
== NULL
) /* outmost WHERE */
10016 else /* inner WHERE */
10023 /* Check if the mask-expr has a consistent shape with the
10024 outmost WHERE mask-expr. */
10025 if (!resolve_where_shape (cblock
->expr1
, e
))
10026 gfc_error ("WHERE mask at %L has inconsistent shape",
10027 &cblock
->expr1
->where
);
10030 /* the assignment statement of a WHERE statement, or the first
10031 statement in where-body-construct of a WHERE construct */
10032 cnext
= cblock
->next
;
10037 /* WHERE assignment statement */
10040 /* Check shape consistent for WHERE assignment target. */
10041 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10042 gfc_error ("WHERE assignment target at %L has "
10043 "inconsistent shape", &cnext
->expr1
->where
);
10047 case EXEC_ASSIGN_CALL
:
10048 resolve_call (cnext
);
10049 if (!cnext
->resolved_sym
->attr
.elemental
)
10050 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10051 &cnext
->ext
.actual
->expr
->where
);
10054 /* WHERE or WHERE construct is part of a where-body-construct */
10056 resolve_where (cnext
, e
);
10060 gfc_error ("Unsupported statement inside WHERE at %L",
10063 /* the next statement within the same where-body-construct */
10064 cnext
= cnext
->next
;
10066 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10067 cblock
= cblock
->block
;
10072 /* Resolve assignment in FORALL construct.
10073 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10074 FORALL index variables. */
10077 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10081 for (n
= 0; n
< nvar
; n
++)
10083 gfc_symbol
*forall_index
;
10085 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10087 /* Check whether the assignment target is one of the FORALL index
10089 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10090 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10091 gfc_error ("Assignment to a FORALL index variable at %L",
10092 &code
->expr1
->where
);
10095 /* If one of the FORALL index variables doesn't appear in the
10096 assignment variable, then there could be a many-to-one
10097 assignment. Emit a warning rather than an error because the
10098 mask could be resolving this problem. */
10099 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10100 gfc_warning (0, "The FORALL with index %qs is not used on the "
10101 "left side of the assignment at %L and so might "
10102 "cause multiple assignment to this object",
10103 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10109 /* Resolve WHERE statement in FORALL construct. */
10112 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10113 gfc_expr
**var_expr
)
10118 cblock
= code
->block
;
10121 /* the assignment statement of a WHERE statement, or the first
10122 statement in where-body-construct of a WHERE construct */
10123 cnext
= cblock
->next
;
10128 /* WHERE assignment statement */
10130 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10133 /* WHERE operator assignment statement */
10134 case EXEC_ASSIGN_CALL
:
10135 resolve_call (cnext
);
10136 if (!cnext
->resolved_sym
->attr
.elemental
)
10137 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10138 &cnext
->ext
.actual
->expr
->where
);
10141 /* WHERE or WHERE construct is part of a where-body-construct */
10143 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10147 gfc_error ("Unsupported statement inside WHERE at %L",
10150 /* the next statement within the same where-body-construct */
10151 cnext
= cnext
->next
;
10153 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10154 cblock
= cblock
->block
;
10159 /* Traverse the FORALL body to check whether the following errors exist:
10160 1. For assignment, check if a many-to-one assignment happens.
10161 2. For WHERE statement, check the WHERE body to see if there is any
10162 many-to-one assignment. */
10165 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10169 c
= code
->block
->next
;
10175 case EXEC_POINTER_ASSIGN
:
10176 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10179 case EXEC_ASSIGN_CALL
:
10183 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10184 there is no need to handle it here. */
10188 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10193 /* The next statement in the FORALL body. */
10199 /* Counts the number of iterators needed inside a forall construct, including
10200 nested forall constructs. This is used to allocate the needed memory
10201 in gfc_resolve_forall. */
10204 gfc_count_forall_iterators (gfc_code
*code
)
10206 int max_iters
, sub_iters
, current_iters
;
10207 gfc_forall_iterator
*fa
;
10209 gcc_assert(code
->op
== EXEC_FORALL
);
10213 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10216 code
= code
->block
->next
;
10220 if (code
->op
== EXEC_FORALL
)
10222 sub_iters
= gfc_count_forall_iterators (code
);
10223 if (sub_iters
> max_iters
)
10224 max_iters
= sub_iters
;
10229 return current_iters
+ max_iters
;
10233 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10234 gfc_resolve_forall_body to resolve the FORALL body. */
10237 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10239 static gfc_expr
**var_expr
;
10240 static int total_var
= 0;
10241 static int nvar
= 0;
10242 int i
, old_nvar
, tmp
;
10243 gfc_forall_iterator
*fa
;
10247 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10250 /* Start to resolve a FORALL construct */
10251 if (forall_save
== 0)
10253 /* Count the total number of FORALL indices in the nested FORALL
10254 construct in order to allocate the VAR_EXPR with proper size. */
10255 total_var
= gfc_count_forall_iterators (code
);
10257 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10258 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10261 /* The information about FORALL iterator, including FORALL indices start, end
10262 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10263 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10265 /* Fortran 20008: C738 (R753). */
10266 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10268 gfc_error ("FORALL index-name at %L must be a scalar variable "
10269 "of type integer", &fa
->var
->where
);
10273 /* Check if any outer FORALL index name is the same as the current
10275 for (i
= 0; i
< nvar
; i
++)
10277 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10278 gfc_error ("An outer FORALL construct already has an index "
10279 "with this name %L", &fa
->var
->where
);
10282 /* Record the current FORALL index. */
10283 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10287 /* No memory leak. */
10288 gcc_assert (nvar
<= total_var
);
10291 /* Resolve the FORALL body. */
10292 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10294 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10295 gfc_resolve_blocks (code
->block
, ns
);
10299 /* Free only the VAR_EXPRs allocated in this frame. */
10300 for (i
= nvar
; i
< tmp
; i
++)
10301 gfc_free_expr (var_expr
[i
]);
10305 /* We are in the outermost FORALL construct. */
10306 gcc_assert (forall_save
== 0);
10308 /* VAR_EXPR is not needed any more. */
10315 /* Resolve a BLOCK construct statement. */
10318 resolve_block_construct (gfc_code
* code
)
10320 /* Resolve the BLOCK's namespace. */
10321 gfc_resolve (code
->ext
.block
.ns
);
10323 /* For an ASSOCIATE block, the associations (and their targets) are already
10324 resolved during resolve_symbol. */
10328 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10332 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10336 for (; b
; b
= b
->block
)
10338 t
= gfc_resolve_expr (b
->expr1
);
10339 if (!gfc_resolve_expr (b
->expr2
))
10345 if (t
&& b
->expr1
!= NULL
10346 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10347 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10353 && b
->expr1
!= NULL
10354 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10355 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10360 resolve_branch (b
->label1
, b
);
10364 resolve_block_construct (b
);
10368 case EXEC_SELECT_TYPE
:
10371 case EXEC_DO_WHILE
:
10372 case EXEC_DO_CONCURRENT
:
10373 case EXEC_CRITICAL
:
10376 case EXEC_IOLENGTH
:
10380 case EXEC_OMP_ATOMIC
:
10381 case EXEC_OACC_ATOMIC
:
10383 gfc_omp_atomic_op aop
10384 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10386 /* Verify this before calling gfc_resolve_code, which might
10388 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10389 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10390 && b
->next
->next
== NULL
)
10391 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10392 && b
->next
->next
!= NULL
10393 && b
->next
->next
->op
== EXEC_ASSIGN
10394 && b
->next
->next
->next
== NULL
));
10398 case EXEC_OACC_PARALLEL_LOOP
:
10399 case EXEC_OACC_PARALLEL
:
10400 case EXEC_OACC_KERNELS_LOOP
:
10401 case EXEC_OACC_KERNELS
:
10402 case EXEC_OACC_DATA
:
10403 case EXEC_OACC_HOST_DATA
:
10404 case EXEC_OACC_LOOP
:
10405 case EXEC_OACC_UPDATE
:
10406 case EXEC_OACC_WAIT
:
10407 case EXEC_OACC_CACHE
:
10408 case EXEC_OACC_ENTER_DATA
:
10409 case EXEC_OACC_EXIT_DATA
:
10410 case EXEC_OACC_ROUTINE
:
10411 case EXEC_OMP_CRITICAL
:
10412 case EXEC_OMP_DISTRIBUTE
:
10413 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10414 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10415 case EXEC_OMP_DISTRIBUTE_SIMD
:
10417 case EXEC_OMP_DO_SIMD
:
10418 case EXEC_OMP_MASTER
:
10419 case EXEC_OMP_ORDERED
:
10420 case EXEC_OMP_PARALLEL
:
10421 case EXEC_OMP_PARALLEL_DO
:
10422 case EXEC_OMP_PARALLEL_DO_SIMD
:
10423 case EXEC_OMP_PARALLEL_SECTIONS
:
10424 case EXEC_OMP_PARALLEL_WORKSHARE
:
10425 case EXEC_OMP_SECTIONS
:
10426 case EXEC_OMP_SIMD
:
10427 case EXEC_OMP_SINGLE
:
10428 case EXEC_OMP_TARGET
:
10429 case EXEC_OMP_TARGET_DATA
:
10430 case EXEC_OMP_TARGET_ENTER_DATA
:
10431 case EXEC_OMP_TARGET_EXIT_DATA
:
10432 case EXEC_OMP_TARGET_PARALLEL
:
10433 case EXEC_OMP_TARGET_PARALLEL_DO
:
10434 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10435 case EXEC_OMP_TARGET_SIMD
:
10436 case EXEC_OMP_TARGET_TEAMS
:
10437 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10438 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10439 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10440 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10441 case EXEC_OMP_TARGET_UPDATE
:
10442 case EXEC_OMP_TASK
:
10443 case EXEC_OMP_TASKGROUP
:
10444 case EXEC_OMP_TASKLOOP
:
10445 case EXEC_OMP_TASKLOOP_SIMD
:
10446 case EXEC_OMP_TASKWAIT
:
10447 case EXEC_OMP_TASKYIELD
:
10448 case EXEC_OMP_TEAMS
:
10449 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10450 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10451 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10452 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10453 case EXEC_OMP_WORKSHARE
:
10457 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10460 gfc_resolve_code (b
->next
, ns
);
10465 /* Does everything to resolve an ordinary assignment. Returns true
10466 if this is an interface assignment. */
10468 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10475 symbol_attribute attr
;
10477 if (gfc_extend_assign (code
, ns
))
10481 if (code
->op
== EXEC_ASSIGN_CALL
)
10483 lhs
= code
->ext
.actual
->expr
;
10484 rhsptr
= &code
->ext
.actual
->next
->expr
;
10488 gfc_actual_arglist
* args
;
10489 gfc_typebound_proc
* tbp
;
10491 gcc_assert (code
->op
== EXEC_COMPCALL
);
10493 args
= code
->expr1
->value
.compcall
.actual
;
10495 rhsptr
= &args
->next
->expr
;
10497 tbp
= code
->expr1
->value
.compcall
.tbp
;
10498 gcc_assert (!tbp
->is_generic
);
10501 /* Make a temporary rhs when there is a default initializer
10502 and rhs is the same symbol as the lhs. */
10503 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10504 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10505 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10506 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10507 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10515 /* Handle the case of a BOZ literal on the RHS. */
10516 if (rhs
->ts
.type
== BT_BOZ
)
10518 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
10519 "statement value nor an actual argument of "
10520 "INT/REAL/DBLE/CMPLX intrinsic subprogram",
10524 switch (lhs
->ts
.type
)
10527 if (!gfc_boz2int (rhs
, lhs
->ts
.kind
))
10531 if (!gfc_boz2real (rhs
, lhs
->ts
.kind
))
10535 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs
->where
);
10540 if (lhs
->ts
.type
== BT_CHARACTER
&& warn_character_truncation
)
10542 HOST_WIDE_INT llen
= 0, rlen
= 0;
10543 if (lhs
->ts
.u
.cl
!= NULL
10544 && lhs
->ts
.u
.cl
->length
!= NULL
10545 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10546 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10548 if (rhs
->expr_type
== EXPR_CONSTANT
)
10549 rlen
= rhs
->value
.character
.length
;
10551 else if (rhs
->ts
.u
.cl
!= NULL
10552 && rhs
->ts
.u
.cl
->length
!= NULL
10553 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10554 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10556 if (rlen
&& llen
&& rlen
> llen
)
10557 gfc_warning_now (OPT_Wcharacter_truncation
,
10558 "CHARACTER expression will be truncated "
10559 "in assignment (%ld/%ld) at %L",
10560 (long) llen
, (long) rlen
, &code
->loc
);
10563 /* Ensure that a vector index expression for the lvalue is evaluated
10564 to a temporary if the lvalue symbol is referenced in it. */
10567 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10568 if (ref
->type
== REF_ARRAY
)
10570 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10571 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10572 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10573 ref
->u
.ar
.start
[n
]))
10575 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10579 if (gfc_pure (NULL
))
10581 if (lhs
->ts
.type
== BT_DERIVED
10582 && lhs
->expr_type
== EXPR_VARIABLE
10583 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10584 && rhs
->expr_type
== EXPR_VARIABLE
10585 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10586 || gfc_is_coindexed (rhs
)))
10588 /* F2008, C1283. */
10589 if (gfc_is_coindexed (rhs
))
10590 gfc_error ("Coindexed expression at %L is assigned to "
10591 "a derived type variable with a POINTER "
10592 "component in a PURE procedure",
10595 gfc_error ("The impure variable at %L is assigned to "
10596 "a derived type variable with a POINTER "
10597 "component in a PURE procedure (12.6)",
10602 /* Fortran 2008, C1283. */
10603 if (gfc_is_coindexed (lhs
))
10605 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10606 "procedure", &rhs
->where
);
10611 if (gfc_implicit_pure (NULL
))
10613 if (lhs
->expr_type
== EXPR_VARIABLE
10614 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10615 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10616 gfc_unset_implicit_pure (NULL
);
10618 if (lhs
->ts
.type
== BT_DERIVED
10619 && lhs
->expr_type
== EXPR_VARIABLE
10620 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10621 && rhs
->expr_type
== EXPR_VARIABLE
10622 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10623 || gfc_is_coindexed (rhs
)))
10624 gfc_unset_implicit_pure (NULL
);
10626 /* Fortran 2008, C1283. */
10627 if (gfc_is_coindexed (lhs
))
10628 gfc_unset_implicit_pure (NULL
);
10631 /* F2008, 7.2.1.2. */
10632 attr
= gfc_expr_attr (lhs
);
10633 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10635 if (attr
.codimension
)
10637 gfc_error ("Assignment to polymorphic coarray at %L is not "
10638 "permitted", &lhs
->where
);
10641 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10642 "polymorphic variable at %L", &lhs
->where
))
10644 if (!flag_realloc_lhs
)
10646 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10647 "requires %<-frealloc-lhs%>", &lhs
->where
);
10651 else if (lhs
->ts
.type
== BT_CLASS
)
10653 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10654 "assignment at %L - check that there is a matching specific "
10655 "subroutine for '=' operator", &lhs
->where
);
10659 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10661 /* F2008, Section 7.2.1.2. */
10662 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10664 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10665 "component in assignment at %L", &lhs
->where
);
10669 /* Assign the 'data' of a class object to a derived type. */
10670 if (lhs
->ts
.type
== BT_DERIVED
10671 && rhs
->ts
.type
== BT_CLASS
10672 && rhs
->expr_type
!= EXPR_ARRAY
)
10673 gfc_add_data_component (rhs
);
10675 /* Make sure there is a vtable and, in particular, a _copy for the
10677 if (UNLIMITED_POLY (lhs
) && lhs
->rank
&& rhs
->ts
.type
!= BT_CLASS
)
10678 gfc_find_vtab (&rhs
->ts
);
10680 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10682 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10683 && code
->expr2
->value
.function
.isym
10684 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10685 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10686 && !gfc_expr_attr (rhs
).allocatable
10687 && !gfc_has_vector_subscript (rhs
)));
10689 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10691 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10692 Additionally, insert this code when the RHS is a CAF as we then use the
10693 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10694 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10695 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10697 if (caf_convert_to_send
)
10699 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10700 && code
->expr2
->value
.function
.isym
10701 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10702 remove_caf_get_intrinsic (code
->expr2
);
10703 code
->op
= EXEC_CALL
;
10704 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10705 code
->resolved_sym
= code
->symtree
->n
.sym
;
10706 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10707 code
->resolved_sym
->attr
.intrinsic
= 1;
10708 code
->resolved_sym
->attr
.subroutine
= 1;
10709 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10710 gfc_commit_symbol (code
->resolved_sym
);
10711 code
->ext
.actual
= gfc_get_actual_arglist ();
10712 code
->ext
.actual
->expr
= lhs
;
10713 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10714 code
->ext
.actual
->next
->expr
= rhs
;
10715 code
->expr1
= NULL
;
10716 code
->expr2
= NULL
;
10723 /* Add a component reference onto an expression. */
10726 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10731 ref
= &((*ref
)->next
);
10732 *ref
= gfc_get_ref ();
10733 (*ref
)->type
= REF_COMPONENT
;
10734 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10735 (*ref
)->u
.c
.component
= c
;
10738 /* Add a full array ref, as necessary. */
10741 gfc_add_full_array_ref (e
, c
->as
);
10742 e
->rank
= c
->as
->rank
;
10747 /* Build an assignment. Keep the argument 'op' for future use, so that
10748 pointer assignments can be made. */
10751 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10752 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10754 gfc_code
*this_code
;
10756 this_code
= gfc_get_code (op
);
10757 this_code
->next
= NULL
;
10758 this_code
->expr1
= gfc_copy_expr (expr1
);
10759 this_code
->expr2
= gfc_copy_expr (expr2
);
10760 this_code
->loc
= loc
;
10761 if (comp1
&& comp2
)
10763 add_comp_ref (this_code
->expr1
, comp1
);
10764 add_comp_ref (this_code
->expr2
, comp2
);
10771 /* Makes a temporary variable expression based on the characteristics of
10772 a given variable expression. */
10775 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10777 static int serial
= 0;
10778 char name
[GFC_MAX_SYMBOL_LEN
];
10780 gfc_array_spec
*as
;
10781 gfc_array_ref
*aref
;
10784 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10785 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10786 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10788 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
10789 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
10791 e
->value
.character
.length
);
10797 /* Obtain the arrayspec for the temporary. */
10798 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10799 && e
->expr_type
!= EXPR_FUNCTION
10800 && e
->expr_type
!= EXPR_OP
)
10802 aref
= gfc_find_array_ref (e
);
10803 if (e
->expr_type
== EXPR_VARIABLE
10804 && e
->symtree
->n
.sym
->as
== aref
->as
)
10808 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10809 if (ref
->type
== REF_COMPONENT
10810 && ref
->u
.c
.component
->as
== aref
->as
)
10818 /* Add the attributes and the arrayspec to the temporary. */
10819 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10820 tmp
->n
.sym
->attr
.function
= 0;
10821 tmp
->n
.sym
->attr
.result
= 0;
10822 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10823 tmp
->n
.sym
->attr
.dummy
= 0;
10824 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
10828 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10831 if (as
->type
== AS_DEFERRED
)
10832 tmp
->n
.sym
->attr
.allocatable
= 1;
10834 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10835 || e
->expr_type
== EXPR_FUNCTION
10836 || e
->expr_type
== EXPR_OP
))
10838 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10839 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10840 tmp
->n
.sym
->as
->rank
= e
->rank
;
10841 tmp
->n
.sym
->attr
.allocatable
= 1;
10842 tmp
->n
.sym
->attr
.dimension
= 1;
10845 tmp
->n
.sym
->attr
.dimension
= 0;
10847 gfc_set_sym_referenced (tmp
->n
.sym
);
10848 gfc_commit_symbol (tmp
->n
.sym
);
10849 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10851 /* Should the lhs be a section, use its array ref for the
10852 temporary expression. */
10853 if (aref
&& aref
->type
!= AR_FULL
)
10855 gfc_free_ref_list (e
->ref
);
10856 e
->ref
= gfc_copy_ref (ref
);
10862 /* Add one line of code to the code chain, making sure that 'head' and
10863 'tail' are appropriately updated. */
10866 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10868 gcc_assert (this_code
);
10870 *head
= *tail
= *this_code
;
10872 *tail
= gfc_append_code (*tail
, *this_code
);
10877 /* Counts the potential number of part array references that would
10878 result from resolution of typebound defined assignments. */
10881 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10884 int c_depth
= 0, t_depth
;
10886 for (c
= derived
->components
; c
; c
= c
->next
)
10888 if ((!gfc_bt_struct (c
->ts
.type
)
10890 || c
->attr
.allocatable
10891 || c
->attr
.proc_pointer_comp
10892 || c
->attr
.class_pointer
10893 || c
->attr
.proc_pointer
)
10894 && !c
->attr
.defined_assign_comp
)
10897 if (c
->as
&& c_depth
== 0)
10900 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10901 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10906 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10908 return depth
+ c_depth
;
10912 /* Implement 7.2.1.3 of the F08 standard:
10913 "An intrinsic assignment where the variable is of derived type is
10914 performed as if each component of the variable were assigned from the
10915 corresponding component of expr using pointer assignment (7.2.2) for
10916 each pointer component, defined assignment for each nonpointer
10917 nonallocatable component of a type that has a type-bound defined
10918 assignment consistent with the component, intrinsic assignment for
10919 each other nonpointer nonallocatable component, ..."
10921 The pointer assignments are taken care of by the intrinsic
10922 assignment of the structure itself. This function recursively adds
10923 defined assignments where required. The recursion is accomplished
10924 by calling gfc_resolve_code.
10926 When the lhs in a defined assignment has intent INOUT, we need a
10927 temporary for the lhs. In pseudo-code:
10929 ! Only call function lhs once.
10930 if (lhs is not a constant or an variable)
10933 ! Do the intrinsic assignment
10935 ! Now do the defined assignments
10936 do over components with typebound defined assignment [%cmp]
10937 #if one component's assignment procedure is INOUT
10939 #if expr2 non-variable
10945 t1%cmp {defined=} expr2%cmp
10951 expr1%cmp {defined=} expr2%cmp
10955 /* The temporary assignments have to be put on top of the additional
10956 code to avoid the result being changed by the intrinsic assignment.
10958 static int component_assignment_level
= 0;
10959 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10962 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10964 gfc_component
*comp1
, *comp2
;
10965 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10967 int error_count
, depth
;
10969 gfc_get_errors (NULL
, &error_count
);
10971 /* Filter out continuing processing after an error. */
10973 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10974 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10977 /* TODO: Handle more than one part array reference in assignments. */
10978 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10979 (*code
)->expr1
->rank
? 1 : 0);
10982 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10983 "done because multiple part array references would "
10984 "occur in intermediate expressions.", &(*code
)->loc
);
10988 component_assignment_level
++;
10990 /* Create a temporary so that functions get called only once. */
10991 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10992 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10994 gfc_expr
*tmp_expr
;
10996 /* Assign the rhs to the temporary. */
10997 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10998 this_code
= build_assignment (EXEC_ASSIGN
,
10999 tmp_expr
, (*code
)->expr2
,
11000 NULL
, NULL
, (*code
)->loc
);
11001 /* Add the code and substitute the rhs expression. */
11002 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
11003 gfc_free_expr ((*code
)->expr2
);
11004 (*code
)->expr2
= tmp_expr
;
11007 /* Do the intrinsic assignment. This is not needed if the lhs is one
11008 of the temporaries generated here, since the intrinsic assignment
11009 to the final result already does this. */
11010 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
11012 this_code
= build_assignment (EXEC_ASSIGN
,
11013 (*code
)->expr1
, (*code
)->expr2
,
11014 NULL
, NULL
, (*code
)->loc
);
11015 add_code_to_chain (&this_code
, &head
, &tail
);
11018 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
11019 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
11022 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
11024 bool inout
= false;
11026 /* The intrinsic assignment does the right thing for pointers
11027 of all kinds and allocatable components. */
11028 if (!gfc_bt_struct (comp1
->ts
.type
)
11029 || comp1
->attr
.pointer
11030 || comp1
->attr
.allocatable
11031 || comp1
->attr
.proc_pointer_comp
11032 || comp1
->attr
.class_pointer
11033 || comp1
->attr
.proc_pointer
)
11036 /* Make an assigment for this component. */
11037 this_code
= build_assignment (EXEC_ASSIGN
,
11038 (*code
)->expr1
, (*code
)->expr2
,
11039 comp1
, comp2
, (*code
)->loc
);
11041 /* Convert the assignment if there is a defined assignment for
11042 this type. Otherwise, using the call from gfc_resolve_code,
11043 recurse into its components. */
11044 gfc_resolve_code (this_code
, ns
);
11046 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11048 gfc_formal_arglist
*dummy_args
;
11050 /* Check that there is a typebound defined assignment. If not,
11051 then this must be a module defined assignment. We cannot
11052 use the defined_assign_comp attribute here because it must
11053 be this derived type that has the defined assignment and not
11055 if (!(comp1
->ts
.u
.derived
->f2k_derived
11056 && comp1
->ts
.u
.derived
->f2k_derived
11057 ->tb_op
[INTRINSIC_ASSIGN
]))
11059 gfc_free_statements (this_code
);
11064 /* If the first argument of the subroutine has intent INOUT
11065 a temporary must be generated and used instead. */
11066 rsym
= this_code
->resolved_sym
;
11067 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11069 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
11071 gfc_code
*temp_code
;
11074 /* Build the temporary required for the assignment and put
11075 it at the head of the generated code. */
11078 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
11079 temp_code
= build_assignment (EXEC_ASSIGN
,
11080 t1
, (*code
)->expr1
,
11081 NULL
, NULL
, (*code
)->loc
);
11083 /* For allocatable LHS, check whether it is allocated. Note
11084 that allocatable components with defined assignment are
11085 not yet support. See PR 57696. */
11086 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11090 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11091 block
= gfc_get_code (EXEC_IF
);
11092 block
->block
= gfc_get_code (EXEC_IF
);
11093 block
->block
->expr1
11094 = gfc_build_intrinsic_call (ns
,
11095 GFC_ISYM_ALLOCATED
, "allocated",
11096 (*code
)->loc
, 1, e
);
11097 block
->block
->next
= temp_code
;
11100 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11103 /* Replace the first actual arg with the component of the
11105 gfc_free_expr (this_code
->ext
.actual
->expr
);
11106 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11107 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11109 /* If the LHS variable is allocatable and wasn't allocated and
11110 the temporary is allocatable, pointer assign the address of
11111 the freshly allocated LHS to the temporary. */
11112 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11113 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11118 cond
= gfc_get_expr ();
11119 cond
->ts
.type
= BT_LOGICAL
;
11120 cond
->ts
.kind
= gfc_default_logical_kind
;
11121 cond
->expr_type
= EXPR_OP
;
11122 cond
->where
= (*code
)->loc
;
11123 cond
->value
.op
.op
= INTRINSIC_NOT
;
11124 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11125 GFC_ISYM_ALLOCATED
, "allocated",
11126 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11127 block
= gfc_get_code (EXEC_IF
);
11128 block
->block
= gfc_get_code (EXEC_IF
);
11129 block
->block
->expr1
= cond
;
11130 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11131 t1
, (*code
)->expr1
,
11132 NULL
, NULL
, (*code
)->loc
);
11133 add_code_to_chain (&block
, &head
, &tail
);
11137 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11139 /* Don't add intrinsic assignments since they are already
11140 effected by the intrinsic assignment of the structure. */
11141 gfc_free_statements (this_code
);
11146 add_code_to_chain (&this_code
, &head
, &tail
);
11150 /* Transfer the value to the final result. */
11151 this_code
= build_assignment (EXEC_ASSIGN
,
11152 (*code
)->expr1
, t1
,
11153 comp1
, comp2
, (*code
)->loc
);
11154 add_code_to_chain (&this_code
, &head
, &tail
);
11158 /* Put the temporary assignments at the top of the generated code. */
11159 if (tmp_head
&& component_assignment_level
== 1)
11161 gfc_append_code (tmp_head
, head
);
11163 tmp_head
= tmp_tail
= NULL
;
11166 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11167 // not accidentally deallocated. Hence, nullify t1.
11168 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11169 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11175 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11176 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11177 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11178 block
= gfc_get_code (EXEC_IF
);
11179 block
->block
= gfc_get_code (EXEC_IF
);
11180 block
->block
->expr1
= cond
;
11181 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11182 t1
, gfc_get_null_expr (&(*code
)->loc
),
11183 NULL
, NULL
, (*code
)->loc
);
11184 gfc_append_code (tail
, block
);
11188 /* Now attach the remaining code chain to the input code. Step on
11189 to the end of the new code since resolution is complete. */
11190 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11191 tail
->next
= (*code
)->next
;
11192 /* Overwrite 'code' because this would place the intrinsic assignment
11193 before the temporary for the lhs is created. */
11194 gfc_free_expr ((*code
)->expr1
);
11195 gfc_free_expr ((*code
)->expr2
);
11201 component_assignment_level
--;
11205 /* F2008: Pointer function assignments are of the form:
11206 ptr_fcn (args) = expr
11207 This function breaks these assignments into two statements:
11208 temporary_pointer => ptr_fcn(args)
11209 temporary_pointer = expr */
11212 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11214 gfc_expr
*tmp_ptr_expr
;
11215 gfc_code
*this_code
;
11216 gfc_component
*comp
;
11219 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11222 /* Even if standard does not support this feature, continue to build
11223 the two statements to avoid upsetting frontend_passes.c. */
11224 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11225 "%L", &(*code
)->loc
);
11227 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11230 s
= comp
->ts
.interface
;
11232 s
= (*code
)->expr1
->symtree
->n
.sym
;
11234 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11236 gfc_error ("The function result on the lhs of the assignment at "
11237 "%L must have the pointer attribute.",
11238 &(*code
)->expr1
->where
);
11239 (*code
)->op
= EXEC_NOP
;
11243 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
11245 /* get_temp_from_expression is set up for ordinary assignments. To that
11246 end, where array bounds are not known, arrays are made allocatable.
11247 Change the temporary to a pointer here. */
11248 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11249 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11250 tmp_ptr_expr
->where
= (*code
)->loc
;
11252 this_code
= build_assignment (EXEC_ASSIGN
,
11253 tmp_ptr_expr
, (*code
)->expr2
,
11254 NULL
, NULL
, (*code
)->loc
);
11255 this_code
->next
= (*code
)->next
;
11256 (*code
)->next
= this_code
;
11257 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11258 (*code
)->expr2
= (*code
)->expr1
;
11259 (*code
)->expr1
= tmp_ptr_expr
;
11265 /* Deferred character length assignments from an operator expression
11266 require a temporary because the character length of the lhs can
11267 change in the course of the assignment. */
11270 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11272 gfc_expr
*tmp_expr
;
11273 gfc_code
*this_code
;
11275 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11276 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11277 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11280 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11283 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
11286 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11287 tmp_expr
->where
= (*code
)->loc
;
11289 /* A new charlen is required to ensure that the variable string
11290 length is different to that of the original lhs. */
11291 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11292 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11293 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11294 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11296 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11298 this_code
= build_assignment (EXEC_ASSIGN
,
11300 gfc_copy_expr (tmp_expr
),
11301 NULL
, NULL
, (*code
)->loc
);
11303 (*code
)->expr1
= tmp_expr
;
11305 this_code
->next
= (*code
)->next
;
11306 (*code
)->next
= this_code
;
11312 /* Given a block of code, recursively resolve everything pointed to by this
11316 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11318 int omp_workshare_save
;
11319 int forall_save
, do_concurrent_save
;
11323 frame
.prev
= cs_base
;
11327 find_reachable_labels (code
);
11329 for (; code
; code
= code
->next
)
11331 frame
.current
= code
;
11332 forall_save
= forall_flag
;
11333 do_concurrent_save
= gfc_do_concurrent_flag
;
11335 if (code
->op
== EXEC_FORALL
)
11338 gfc_resolve_forall (code
, ns
, forall_save
);
11341 else if (code
->block
)
11343 omp_workshare_save
= -1;
11346 case EXEC_OACC_PARALLEL_LOOP
:
11347 case EXEC_OACC_PARALLEL
:
11348 case EXEC_OACC_KERNELS_LOOP
:
11349 case EXEC_OACC_KERNELS
:
11350 case EXEC_OACC_DATA
:
11351 case EXEC_OACC_HOST_DATA
:
11352 case EXEC_OACC_LOOP
:
11353 gfc_resolve_oacc_blocks (code
, ns
);
11355 case EXEC_OMP_PARALLEL_WORKSHARE
:
11356 omp_workshare_save
= omp_workshare_flag
;
11357 omp_workshare_flag
= 1;
11358 gfc_resolve_omp_parallel_blocks (code
, ns
);
11360 case EXEC_OMP_PARALLEL
:
11361 case EXEC_OMP_PARALLEL_DO
:
11362 case EXEC_OMP_PARALLEL_DO_SIMD
:
11363 case EXEC_OMP_PARALLEL_SECTIONS
:
11364 case EXEC_OMP_TARGET_PARALLEL
:
11365 case EXEC_OMP_TARGET_PARALLEL_DO
:
11366 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11367 case EXEC_OMP_TARGET_TEAMS
:
11368 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11369 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11370 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11371 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11372 case EXEC_OMP_TASK
:
11373 case EXEC_OMP_TASKLOOP
:
11374 case EXEC_OMP_TASKLOOP_SIMD
:
11375 case EXEC_OMP_TEAMS
:
11376 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11377 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11378 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11379 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11380 omp_workshare_save
= omp_workshare_flag
;
11381 omp_workshare_flag
= 0;
11382 gfc_resolve_omp_parallel_blocks (code
, ns
);
11384 case EXEC_OMP_DISTRIBUTE
:
11385 case EXEC_OMP_DISTRIBUTE_SIMD
:
11387 case EXEC_OMP_DO_SIMD
:
11388 case EXEC_OMP_SIMD
:
11389 case EXEC_OMP_TARGET_SIMD
:
11390 gfc_resolve_omp_do_blocks (code
, ns
);
11392 case EXEC_SELECT_TYPE
:
11393 /* Blocks are handled in resolve_select_type because we have
11394 to transform the SELECT TYPE into ASSOCIATE first. */
11396 case EXEC_DO_CONCURRENT
:
11397 gfc_do_concurrent_flag
= 1;
11398 gfc_resolve_blocks (code
->block
, ns
);
11399 gfc_do_concurrent_flag
= 2;
11401 case EXEC_OMP_WORKSHARE
:
11402 omp_workshare_save
= omp_workshare_flag
;
11403 omp_workshare_flag
= 1;
11406 gfc_resolve_blocks (code
->block
, ns
);
11410 if (omp_workshare_save
!= -1)
11411 omp_workshare_flag
= omp_workshare_save
;
11415 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11416 t
= gfc_resolve_expr (code
->expr1
);
11417 forall_flag
= forall_save
;
11418 gfc_do_concurrent_flag
= do_concurrent_save
;
11420 if (!gfc_resolve_expr (code
->expr2
))
11423 if (code
->op
== EXEC_ALLOCATE
11424 && !gfc_resolve_expr (code
->expr3
))
11430 case EXEC_END_BLOCK
:
11431 case EXEC_END_NESTED_BLOCK
:
11435 case EXEC_ERROR_STOP
:
11437 case EXEC_CONTINUE
:
11439 case EXEC_ASSIGN_CALL
:
11442 case EXEC_CRITICAL
:
11443 resolve_critical (code
);
11446 case EXEC_SYNC_ALL
:
11447 case EXEC_SYNC_IMAGES
:
11448 case EXEC_SYNC_MEMORY
:
11449 resolve_sync (code
);
11454 case EXEC_EVENT_POST
:
11455 case EXEC_EVENT_WAIT
:
11456 resolve_lock_unlock_event (code
);
11459 case EXEC_FAIL_IMAGE
:
11460 case EXEC_FORM_TEAM
:
11461 case EXEC_CHANGE_TEAM
:
11462 case EXEC_END_TEAM
:
11463 case EXEC_SYNC_TEAM
:
11467 /* Keep track of which entry we are up to. */
11468 current_entry_id
= code
->ext
.entry
->id
;
11472 resolve_where (code
, NULL
);
11476 if (code
->expr1
!= NULL
)
11478 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11479 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11480 "INTEGER variable", &code
->expr1
->where
);
11481 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11482 gfc_error ("Variable %qs has not been assigned a target "
11483 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11484 &code
->expr1
->where
);
11487 resolve_branch (code
->label1
, code
);
11491 if (code
->expr1
!= NULL
11492 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11493 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11494 "INTEGER return specifier", &code
->expr1
->where
);
11497 case EXEC_INIT_ASSIGN
:
11498 case EXEC_END_PROCEDURE
:
11505 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11507 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11508 && code
->expr1
->value
.function
.isym
11509 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11510 remove_caf_get_intrinsic (code
->expr1
);
11512 /* If this is a pointer function in an lvalue variable context,
11513 the new code will have to be resolved afresh. This is also the
11514 case with an error, where the code is transformed into NOP to
11515 prevent ICEs downstream. */
11516 if (resolve_ptr_fcn_assign (&code
, ns
)
11517 || code
->op
== EXEC_NOP
)
11520 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11524 if (resolve_ordinary_assign (code
, ns
))
11526 if (code
->op
== EXEC_COMPCALL
)
11532 /* Check for dependencies in deferred character length array
11533 assignments and generate a temporary, if necessary. */
11534 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11537 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11538 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11539 && code
->expr1
->ts
.u
.derived
11540 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11541 generate_component_assignments (&code
, ns
);
11545 case EXEC_LABEL_ASSIGN
:
11546 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11547 gfc_error ("Label %d referenced at %L is never defined",
11548 code
->label1
->value
, &code
->label1
->where
);
11550 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11551 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11552 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11553 != gfc_default_integer_kind
11554 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11555 gfc_error ("ASSIGN statement at %L requires a scalar "
11556 "default INTEGER variable", &code
->expr1
->where
);
11559 case EXEC_POINTER_ASSIGN
:
11566 /* This is both a variable definition and pointer assignment
11567 context, so check both of them. For rank remapping, a final
11568 array ref may be present on the LHS and fool gfc_expr_attr
11569 used in gfc_check_vardef_context. Remove it. */
11570 e
= remove_last_array_ref (code
->expr1
);
11571 t
= gfc_check_vardef_context (e
, true, false, false,
11572 _("pointer assignment"));
11574 t
= gfc_check_vardef_context (e
, false, false, false,
11575 _("pointer assignment"));
11578 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
11583 /* Assigning a class object always is a regular assign. */
11584 if (code
->expr2
->ts
.type
== BT_CLASS
11585 && code
->expr1
->ts
.type
== BT_CLASS
11586 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11587 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11588 && code
->expr2
->expr_type
== EXPR_VARIABLE
11589 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11591 code
->op
= EXEC_ASSIGN
;
11595 case EXEC_ARITHMETIC_IF
:
11597 gfc_expr
*e
= code
->expr1
;
11599 gfc_resolve_expr (e
);
11600 if (e
->expr_type
== EXPR_NULL
)
11601 gfc_error ("Invalid NULL at %L", &e
->where
);
11603 if (t
&& (e
->rank
> 0
11604 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11605 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11606 "REAL or INTEGER expression", &e
->where
);
11608 resolve_branch (code
->label1
, code
);
11609 resolve_branch (code
->label2
, code
);
11610 resolve_branch (code
->label3
, code
);
11615 if (t
&& code
->expr1
!= NULL
11616 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11617 || code
->expr1
->rank
!= 0))
11618 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11619 &code
->expr1
->where
);
11624 resolve_call (code
);
11627 case EXEC_COMPCALL
:
11629 resolve_typebound_subroutine (code
);
11632 case EXEC_CALL_PPC
:
11633 resolve_ppc_call (code
);
11637 /* Select is complicated. Also, a SELECT construct could be
11638 a transformed computed GOTO. */
11639 resolve_select (code
, false);
11642 case EXEC_SELECT_TYPE
:
11643 resolve_select_type (code
, ns
);
11647 resolve_block_construct (code
);
11651 if (code
->ext
.iterator
!= NULL
)
11653 gfc_iterator
*iter
= code
->ext
.iterator
;
11654 if (gfc_resolve_iterator (iter
, true, false))
11655 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11660 case EXEC_DO_WHILE
:
11661 if (code
->expr1
== NULL
)
11662 gfc_internal_error ("gfc_resolve_code(): No expression on "
11665 && (code
->expr1
->rank
!= 0
11666 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11667 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11668 "a scalar LOGICAL expression", &code
->expr1
->where
);
11671 case EXEC_ALLOCATE
:
11673 resolve_allocate_deallocate (code
, "ALLOCATE");
11677 case EXEC_DEALLOCATE
:
11679 resolve_allocate_deallocate (code
, "DEALLOCATE");
11684 if (!gfc_resolve_open (code
->ext
.open
))
11687 resolve_branch (code
->ext
.open
->err
, code
);
11691 if (!gfc_resolve_close (code
->ext
.close
))
11694 resolve_branch (code
->ext
.close
->err
, code
);
11697 case EXEC_BACKSPACE
:
11701 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
11704 resolve_branch (code
->ext
.filepos
->err
, code
);
11708 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11711 resolve_branch (code
->ext
.inquire
->err
, code
);
11714 case EXEC_IOLENGTH
:
11715 gcc_assert (code
->ext
.inquire
!= NULL
);
11716 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11719 resolve_branch (code
->ext
.inquire
->err
, code
);
11723 if (!gfc_resolve_wait (code
->ext
.wait
))
11726 resolve_branch (code
->ext
.wait
->err
, code
);
11727 resolve_branch (code
->ext
.wait
->end
, code
);
11728 resolve_branch (code
->ext
.wait
->eor
, code
);
11733 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11736 resolve_branch (code
->ext
.dt
->err
, code
);
11737 resolve_branch (code
->ext
.dt
->end
, code
);
11738 resolve_branch (code
->ext
.dt
->eor
, code
);
11741 case EXEC_TRANSFER
:
11742 resolve_transfer (code
);
11745 case EXEC_DO_CONCURRENT
:
11747 resolve_forall_iterators (code
->ext
.forall_iterator
);
11749 if (code
->expr1
!= NULL
11750 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11751 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11752 "expression", &code
->expr1
->where
);
11755 case EXEC_OACC_PARALLEL_LOOP
:
11756 case EXEC_OACC_PARALLEL
:
11757 case EXEC_OACC_KERNELS_LOOP
:
11758 case EXEC_OACC_KERNELS
:
11759 case EXEC_OACC_DATA
:
11760 case EXEC_OACC_HOST_DATA
:
11761 case EXEC_OACC_LOOP
:
11762 case EXEC_OACC_UPDATE
:
11763 case EXEC_OACC_WAIT
:
11764 case EXEC_OACC_CACHE
:
11765 case EXEC_OACC_ENTER_DATA
:
11766 case EXEC_OACC_EXIT_DATA
:
11767 case EXEC_OACC_ATOMIC
:
11768 case EXEC_OACC_DECLARE
:
11769 gfc_resolve_oacc_directive (code
, ns
);
11772 case EXEC_OMP_ATOMIC
:
11773 case EXEC_OMP_BARRIER
:
11774 case EXEC_OMP_CANCEL
:
11775 case EXEC_OMP_CANCELLATION_POINT
:
11776 case EXEC_OMP_CRITICAL
:
11777 case EXEC_OMP_FLUSH
:
11778 case EXEC_OMP_DISTRIBUTE
:
11779 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11780 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11781 case EXEC_OMP_DISTRIBUTE_SIMD
:
11783 case EXEC_OMP_DO_SIMD
:
11784 case EXEC_OMP_MASTER
:
11785 case EXEC_OMP_ORDERED
:
11786 case EXEC_OMP_SECTIONS
:
11787 case EXEC_OMP_SIMD
:
11788 case EXEC_OMP_SINGLE
:
11789 case EXEC_OMP_TARGET
:
11790 case EXEC_OMP_TARGET_DATA
:
11791 case EXEC_OMP_TARGET_ENTER_DATA
:
11792 case EXEC_OMP_TARGET_EXIT_DATA
:
11793 case EXEC_OMP_TARGET_PARALLEL
:
11794 case EXEC_OMP_TARGET_PARALLEL_DO
:
11795 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11796 case EXEC_OMP_TARGET_SIMD
:
11797 case EXEC_OMP_TARGET_TEAMS
:
11798 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11799 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11800 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11801 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11802 case EXEC_OMP_TARGET_UPDATE
:
11803 case EXEC_OMP_TASK
:
11804 case EXEC_OMP_TASKGROUP
:
11805 case EXEC_OMP_TASKLOOP
:
11806 case EXEC_OMP_TASKLOOP_SIMD
:
11807 case EXEC_OMP_TASKWAIT
:
11808 case EXEC_OMP_TASKYIELD
:
11809 case EXEC_OMP_TEAMS
:
11810 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11811 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11812 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11813 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11814 case EXEC_OMP_WORKSHARE
:
11815 gfc_resolve_omp_directive (code
, ns
);
11818 case EXEC_OMP_PARALLEL
:
11819 case EXEC_OMP_PARALLEL_DO
:
11820 case EXEC_OMP_PARALLEL_DO_SIMD
:
11821 case EXEC_OMP_PARALLEL_SECTIONS
:
11822 case EXEC_OMP_PARALLEL_WORKSHARE
:
11823 omp_workshare_save
= omp_workshare_flag
;
11824 omp_workshare_flag
= 0;
11825 gfc_resolve_omp_directive (code
, ns
);
11826 omp_workshare_flag
= omp_workshare_save
;
11830 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11834 cs_base
= frame
.prev
;
11838 /* Resolve initial values and make sure they are compatible with
11842 resolve_values (gfc_symbol
*sym
)
11846 if (sym
->value
== NULL
)
11849 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11850 t
= resolve_structure_cons (sym
->value
, 1);
11852 t
= gfc_resolve_expr (sym
->value
);
11857 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11861 /* Verify any BIND(C) derived types in the namespace so we can report errors
11862 for them once, rather than for each variable declared of that type. */
11865 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11867 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11868 && derived_sym
->attr
.is_bind_c
== 1)
11869 verify_bind_c_derived_type (derived_sym
);
11875 /* Check the interfaces of DTIO procedures associated with derived
11876 type 'sym'. These procedures can either have typebound bindings or
11877 can appear in DTIO generic interfaces. */
11880 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11882 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11885 gfc_check_dtio_interfaces (sym
);
11890 /* Verify that any binding labels used in a given namespace do not collide
11891 with the names or binding labels of any global symbols. Multiple INTERFACE
11892 for the same procedure are permitted. */
11895 gfc_verify_binding_labels (gfc_symbol
*sym
)
11898 const char *module
;
11900 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11901 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11904 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11907 module
= sym
->module
;
11908 else if (sym
->ns
&& sym
->ns
->proc_name
11909 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11910 module
= sym
->ns
->proc_name
->name
;
11911 else if (sym
->ns
&& sym
->ns
->parent
11912 && sym
->ns
&& sym
->ns
->parent
->proc_name
11913 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11914 module
= sym
->ns
->parent
->proc_name
->name
;
11920 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11923 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
11924 gsym
->where
= sym
->declared_at
;
11925 gsym
->sym_name
= sym
->name
;
11926 gsym
->binding_label
= sym
->binding_label
;
11927 gsym
->ns
= sym
->ns
;
11928 gsym
->mod_name
= module
;
11929 if (sym
->attr
.function
)
11930 gsym
->type
= GSYM_FUNCTION
;
11931 else if (sym
->attr
.subroutine
)
11932 gsym
->type
= GSYM_SUBROUTINE
;
11933 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11934 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11938 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11940 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
11941 "identifier as entity at %L", sym
->name
,
11942 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11943 /* Clear the binding label to prevent checking multiple times. */
11944 sym
->binding_label
= NULL
;
11948 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11949 && (strcmp (module
, gsym
->mod_name
) != 0
11950 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11952 /* This can only happen if the variable is defined in a module - if it
11953 isn't the same module, reject it. */
11954 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
11955 "uses the same global identifier as entity at %L from module %qs",
11956 sym
->name
, module
, sym
->binding_label
,
11957 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11958 sym
->binding_label
= NULL
;
11962 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11963 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11964 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11965 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
11966 && (module
!= gsym
->mod_name
11967 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11968 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11970 /* Print an error if the procedure is defined multiple times; we have to
11971 exclude references to the same procedure via module association or
11972 multiple checks for the same procedure. */
11973 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
11974 "global identifier as entity at %L", sym
->name
,
11975 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11976 sym
->binding_label
= NULL
;
11981 /* Resolve an index expression. */
11984 resolve_index_expr (gfc_expr
*e
)
11986 if (!gfc_resolve_expr (e
))
11989 if (!gfc_simplify_expr (e
, 0))
11992 if (!gfc_specification_expr (e
))
11999 /* Resolve a charlen structure. */
12002 resolve_charlen (gfc_charlen
*cl
)
12005 bool saved_specification_expr
;
12011 saved_specification_expr
= specification_expr
;
12012 specification_expr
= true;
12014 if (cl
->length_from_typespec
)
12016 if (!gfc_resolve_expr (cl
->length
))
12018 specification_expr
= saved_specification_expr
;
12022 if (!gfc_simplify_expr (cl
->length
, 0))
12024 specification_expr
= saved_specification_expr
;
12028 /* cl->length has been resolved. It should have an integer type. */
12029 if (cl
->length
->ts
.type
!= BT_INTEGER
)
12031 gfc_error ("Scalar INTEGER expression expected at %L",
12032 &cl
->length
->where
);
12038 if (!resolve_index_expr (cl
->length
))
12040 specification_expr
= saved_specification_expr
;
12045 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12046 a negative value, the length of character entities declared is zero. */
12047 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12048 && mpz_sgn (cl
->length
->value
.integer
) < 0)
12049 gfc_replace_expr (cl
->length
,
12050 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
12052 /* Check that the character length is not too large. */
12053 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
12054 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12055 && cl
->length
->ts
.type
== BT_INTEGER
12056 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
12058 gfc_error ("String length at %L is too large", &cl
->length
->where
);
12059 specification_expr
= saved_specification_expr
;
12063 specification_expr
= saved_specification_expr
;
12068 /* Test for non-constant shape arrays. */
12071 is_non_constant_shape_array (gfc_symbol
*sym
)
12077 not_constant
= false;
12078 if (sym
->as
!= NULL
)
12080 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12081 has not been simplified; parameter array references. Do the
12082 simplification now. */
12083 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12085 e
= sym
->as
->lower
[i
];
12086 if (e
&& (!resolve_index_expr(e
)
12087 || !gfc_is_constant_expr (e
)))
12088 not_constant
= true;
12089 e
= sym
->as
->upper
[i
];
12090 if (e
&& (!resolve_index_expr(e
)
12091 || !gfc_is_constant_expr (e
)))
12092 not_constant
= true;
12095 return not_constant
;
12098 /* Given a symbol and an initialization expression, add code to initialize
12099 the symbol to the function entry. */
12101 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12105 gfc_namespace
*ns
= sym
->ns
;
12107 /* Search for the function namespace if this is a contained
12108 function without an explicit result. */
12109 if (sym
->attr
.function
&& sym
== sym
->result
12110 && sym
->name
!= sym
->ns
->proc_name
->name
)
12112 ns
= ns
->contained
;
12113 for (;ns
; ns
= ns
->sibling
)
12114 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12120 gfc_free_expr (init
);
12124 /* Build an l-value expression for the result. */
12125 lval
= gfc_lval_expr_from_sym (sym
);
12127 /* Add the code at scope entry. */
12128 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
12129 init_st
->next
= ns
->code
;
12130 ns
->code
= init_st
;
12132 /* Assign the default initializer to the l-value. */
12133 init_st
->loc
= sym
->declared_at
;
12134 init_st
->expr1
= lval
;
12135 init_st
->expr2
= init
;
12139 /* Whether or not we can generate a default initializer for a symbol. */
12142 can_generate_init (gfc_symbol
*sym
)
12144 symbol_attribute
*a
;
12149 /* These symbols should never have a default initialization. */
12154 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
12155 && (CLASS_DATA (sym
)->attr
.class_pointer
12156 || CLASS_DATA (sym
)->attr
.proc_pointer
))
12157 || a
->in_equivalence
12164 || (!a
->referenced
&& !a
->result
)
12165 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
12166 || (a
->function
&& sym
!= sym
->result
)
12171 /* Assign the default initializer to a derived type variable or result. */
12174 apply_default_init (gfc_symbol
*sym
)
12176 gfc_expr
*init
= NULL
;
12178 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12181 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12182 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12184 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12187 build_init_assign (sym
, init
);
12188 sym
->attr
.referenced
= 1;
12192 /* Build an initializer for a local. Returns null if the symbol should not have
12193 a default initialization. */
12196 build_default_init_expr (gfc_symbol
*sym
)
12198 /* These symbols should never have a default initialization. */
12199 if (sym
->attr
.allocatable
12200 || sym
->attr
.external
12202 || sym
->attr
.pointer
12203 || sym
->attr
.in_equivalence
12204 || sym
->attr
.in_common
12207 || sym
->attr
.cray_pointee
12208 || sym
->attr
.cray_pointer
12212 /* Get the appropriate init expression. */
12213 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12216 /* Add an initialization expression to a local variable. */
12218 apply_default_init_local (gfc_symbol
*sym
)
12220 gfc_expr
*init
= NULL
;
12222 /* The symbol should be a variable or a function return value. */
12223 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12224 || (sym
->attr
.function
&& sym
->result
!= sym
))
12227 /* Try to build the initializer expression. If we can't initialize
12228 this symbol, then init will be NULL. */
12229 init
= build_default_init_expr (sym
);
12233 /* For saved variables, we don't want to add an initializer at function
12234 entry, so we just add a static initializer. Note that automatic variables
12235 are stack allocated even with -fno-automatic; we have also to exclude
12236 result variable, which are also nonstatic. */
12237 if (!sym
->attr
.automatic
12238 && (sym
->attr
.save
|| sym
->ns
->save_all
12239 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12240 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12241 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12243 /* Don't clobber an existing initializer! */
12244 gcc_assert (sym
->value
== NULL
);
12249 build_init_assign (sym
, init
);
12253 /* Resolution of common features of flavors variable and procedure. */
12256 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12258 gfc_array_spec
*as
;
12260 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12261 as
= CLASS_DATA (sym
)->as
;
12265 /* Constraints on deferred shape variable. */
12266 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12268 bool pointer
, allocatable
, dimension
;
12270 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12272 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12273 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12274 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12278 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12279 allocatable
= sym
->attr
.allocatable
;
12280 dimension
= sym
->attr
.dimension
;
12285 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12287 gfc_error ("Allocatable array %qs at %L must have a deferred "
12288 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12291 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12292 "%qs at %L may not be ALLOCATABLE",
12293 sym
->name
, &sym
->declared_at
))
12297 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12299 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12300 "assumed rank", sym
->name
, &sym
->declared_at
);
12306 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12307 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12309 gfc_error ("Array %qs at %L cannot have a deferred shape",
12310 sym
->name
, &sym
->declared_at
);
12315 /* Constraints on polymorphic variables. */
12316 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12319 if (sym
->attr
.class_ok
12320 && !sym
->attr
.select_type_temporary
12321 && !UNLIMITED_POLY (sym
)
12322 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12324 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12325 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12326 &sym
->declared_at
);
12331 /* Assume that use associated symbols were checked in the module ns.
12332 Class-variables that are associate-names are also something special
12333 and excepted from the test. */
12334 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12336 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12337 "or pointer", sym
->name
, &sym
->declared_at
);
12346 /* Additional checks for symbols with flavor variable and derived
12347 type. To be called from resolve_fl_variable. */
12350 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12352 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12354 /* Check to see if a derived type is blocked from being host
12355 associated by the presence of another class I symbol in the same
12356 namespace. 14.6.1.3 of the standard and the discussion on
12357 comp.lang.fortran. */
12358 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12359 && !sym
->ts
.u
.derived
->attr
.use_assoc
12360 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12363 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12364 if (s
&& s
->attr
.generic
)
12365 s
= gfc_find_dt_in_generic (s
);
12366 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12368 gfc_error ("The type %qs cannot be host associated at %L "
12369 "because it is blocked by an incompatible object "
12370 "of the same name declared at %L",
12371 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12377 /* 4th constraint in section 11.3: "If an object of a type for which
12378 component-initialization is specified (R429) appears in the
12379 specification-part of a module and does not have the ALLOCATABLE
12380 or POINTER attribute, the object shall have the SAVE attribute."
12382 The check for initializers is performed with
12383 gfc_has_default_initializer because gfc_default_initializer generates
12384 a hidden default for allocatable components. */
12385 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12386 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12387 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12388 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12389 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12390 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12391 "%qs at %L, needed due to the default "
12392 "initialization", sym
->name
, &sym
->declared_at
))
12395 /* Assign default initializer. */
12396 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12397 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12398 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12404 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12405 except in the declaration of an entity or component that has the POINTER
12406 or ALLOCATABLE attribute. */
12409 deferred_requirements (gfc_symbol
*sym
)
12411 if (sym
->ts
.deferred
12412 && !(sym
->attr
.pointer
12413 || sym
->attr
.allocatable
12414 || sym
->attr
.associate_var
12415 || sym
->attr
.omp_udr_artificial_var
))
12417 /* If a function has a result variable, only check the variable. */
12418 if (sym
->result
&& sym
->name
!= sym
->result
->name
)
12421 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12422 "requires either the POINTER or ALLOCATABLE attribute",
12423 sym
->name
, &sym
->declared_at
);
12430 /* Resolve symbols with flavor variable. */
12433 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12435 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
12438 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12441 /* Set this flag to check that variables are parameters of all entries.
12442 This check is effected by the call to gfc_resolve_expr through
12443 is_non_constant_shape_array. */
12444 bool saved_specification_expr
= specification_expr
;
12445 specification_expr
= true;
12447 if (sym
->ns
->proc_name
12448 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12449 || sym
->ns
->proc_name
->attr
.is_main_program
)
12450 && !sym
->attr
.use_assoc
12451 && !sym
->attr
.allocatable
12452 && !sym
->attr
.pointer
12453 && is_non_constant_shape_array (sym
))
12455 /* F08:C541. The shape of an array defined in a main program or module
12456 * needs to be constant. */
12457 gfc_error ("The module or main program array %qs at %L must "
12458 "have constant shape", sym
->name
, &sym
->declared_at
);
12459 specification_expr
= saved_specification_expr
;
12463 /* Constraints on deferred type parameter. */
12464 if (!deferred_requirements (sym
))
12467 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12469 /* Make sure that character string variables with assumed length are
12470 dummy arguments. */
12471 gfc_expr
*e
= NULL
;
12474 e
= sym
->ts
.u
.cl
->length
;
12478 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12479 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12480 && !sym
->attr
.omp_udr_artificial_var
)
12482 gfc_error ("Entity with assumed character length at %L must be a "
12483 "dummy argument or a PARAMETER", &sym
->declared_at
);
12484 specification_expr
= saved_specification_expr
;
12488 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12490 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12491 specification_expr
= saved_specification_expr
;
12495 if (!gfc_is_constant_expr (e
)
12496 && !(e
->expr_type
== EXPR_VARIABLE
12497 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12499 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12500 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12501 || sym
->ns
->proc_name
->attr
.is_main_program
))
12503 gfc_error ("%qs at %L must have constant character length "
12504 "in this context", sym
->name
, &sym
->declared_at
);
12505 specification_expr
= saved_specification_expr
;
12508 if (sym
->attr
.in_common
)
12510 gfc_error ("COMMON variable %qs at %L must have constant "
12511 "character length", sym
->name
, &sym
->declared_at
);
12512 specification_expr
= saved_specification_expr
;
12518 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12519 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12521 /* Determine if the symbol may not have an initializer. */
12522 int no_init_flag
= 0, automatic_flag
= 0;
12523 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12524 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12526 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12527 && is_non_constant_shape_array (sym
))
12529 no_init_flag
= automatic_flag
= 1;
12531 /* Also, they must not have the SAVE attribute.
12532 SAVE_IMPLICIT is checked below. */
12533 if (sym
->as
&& sym
->attr
.codimension
)
12535 int corank
= sym
->as
->corank
;
12536 sym
->as
->corank
= 0;
12537 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12538 sym
->as
->corank
= corank
;
12540 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12542 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12543 specification_expr
= saved_specification_expr
;
12548 /* Ensure that any initializer is simplified. */
12550 gfc_simplify_expr (sym
->value
, 1);
12552 /* Reject illegal initializers. */
12553 if (!sym
->mark
&& sym
->value
)
12555 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12556 && CLASS_DATA (sym
)->attr
.allocatable
))
12557 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12558 sym
->name
, &sym
->declared_at
);
12559 else if (sym
->attr
.external
)
12560 gfc_error ("External %qs at %L cannot have an initializer",
12561 sym
->name
, &sym
->declared_at
);
12562 else if (sym
->attr
.dummy
12563 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12564 gfc_error ("Dummy %qs at %L cannot have an initializer",
12565 sym
->name
, &sym
->declared_at
);
12566 else if (sym
->attr
.intrinsic
)
12567 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12568 sym
->name
, &sym
->declared_at
);
12569 else if (sym
->attr
.result
)
12570 gfc_error ("Function result %qs at %L cannot have an initializer",
12571 sym
->name
, &sym
->declared_at
);
12572 else if (automatic_flag
)
12573 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12574 sym
->name
, &sym
->declared_at
);
12576 goto no_init_error
;
12577 specification_expr
= saved_specification_expr
;
12582 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12584 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12585 specification_expr
= saved_specification_expr
;
12589 specification_expr
= saved_specification_expr
;
12594 /* Compare the dummy characteristics of a module procedure interface
12595 declaration with the corresponding declaration in a submodule. */
12596 static gfc_formal_arglist
*new_formal
;
12597 static char errmsg
[200];
12600 compare_fsyms (gfc_symbol
*sym
)
12604 if (sym
== NULL
|| new_formal
== NULL
)
12607 fsym
= new_formal
->sym
;
12612 if (strcmp (sym
->name
, fsym
->name
) == 0)
12614 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12615 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12620 /* Resolve a procedure. */
12623 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12625 gfc_formal_arglist
*arg
;
12627 if (sym
->attr
.function
12628 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12631 /* Constraints on deferred type parameter. */
12632 if (!deferred_requirements (sym
))
12635 if (sym
->ts
.type
== BT_CHARACTER
)
12637 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12639 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12640 && !resolve_charlen (cl
))
12643 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12644 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12646 gfc_error ("Character-valued statement function %qs at %L must "
12647 "have constant length", sym
->name
, &sym
->declared_at
);
12652 /* Ensure that derived type for are not of a private type. Internal
12653 module procedures are excluded by 2.2.3.3 - i.e., they are not
12654 externally accessible and can access all the objects accessible in
12656 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
12657 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12658 && gfc_check_symbol_access (sym
))
12660 gfc_interface
*iface
;
12662 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12665 && arg
->sym
->ts
.type
== BT_DERIVED
12666 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12667 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12668 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12669 "and cannot be a dummy argument"
12670 " of %qs, which is PUBLIC at %L",
12671 arg
->sym
->name
, sym
->name
,
12672 &sym
->declared_at
))
12674 /* Stop this message from recurring. */
12675 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12680 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12681 PRIVATE to the containing module. */
12682 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12684 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12687 && arg
->sym
->ts
.type
== BT_DERIVED
12688 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12689 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12690 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12691 "PUBLIC interface %qs at %L "
12692 "takes dummy arguments of %qs which "
12693 "is PRIVATE", iface
->sym
->name
,
12694 sym
->name
, &iface
->sym
->declared_at
,
12695 gfc_typename(&arg
->sym
->ts
)))
12697 /* Stop this message from recurring. */
12698 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12705 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12706 && !sym
->attr
.proc_pointer
)
12708 gfc_error ("Function %qs at %L cannot have an initializer",
12709 sym
->name
, &sym
->declared_at
);
12711 /* Make sure no second error is issued for this. */
12712 sym
->value
->error
= 1;
12716 /* An external symbol may not have an initializer because it is taken to be
12717 a procedure. Exception: Procedure Pointers. */
12718 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12720 gfc_error ("External object %qs at %L may not have an initializer",
12721 sym
->name
, &sym
->declared_at
);
12725 /* An elemental function is required to return a scalar 12.7.1 */
12726 if (sym
->attr
.elemental
&& sym
->attr
.function
12727 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)))
12729 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12730 "result", sym
->name
, &sym
->declared_at
);
12731 /* Reset so that the error only occurs once. */
12732 sym
->attr
.elemental
= 0;
12736 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12737 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12739 gfc_error ("Statement function %qs at %L may not have pointer or "
12740 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12744 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12745 char-len-param shall not be array-valued, pointer-valued, recursive
12746 or pure. ....snip... A character value of * may only be used in the
12747 following ways: (i) Dummy arg of procedure - dummy associates with
12748 actual length; (ii) To declare a named constant; or (iii) External
12749 function - but length must be declared in calling scoping unit. */
12750 if (sym
->attr
.function
12751 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12752 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12754 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12755 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12757 if (sym
->as
&& sym
->as
->rank
)
12758 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12759 "array-valued", sym
->name
, &sym
->declared_at
);
12761 if (sym
->attr
.pointer
)
12762 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12763 "pointer-valued", sym
->name
, &sym
->declared_at
);
12765 if (sym
->attr
.pure
)
12766 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12767 "pure", sym
->name
, &sym
->declared_at
);
12769 if (sym
->attr
.recursive
)
12770 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12771 "recursive", sym
->name
, &sym
->declared_at
);
12776 /* Appendix B.2 of the standard. Contained functions give an
12777 error anyway. Deferred character length is an F2003 feature.
12778 Don't warn on intrinsic conversion functions, which start
12779 with two underscores. */
12780 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12781 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12782 gfc_notify_std (GFC_STD_F95_OBS
,
12783 "CHARACTER(*) function %qs at %L",
12784 sym
->name
, &sym
->declared_at
);
12787 /* F2008, C1218. */
12788 if (sym
->attr
.elemental
)
12790 if (sym
->attr
.proc_pointer
)
12792 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12793 sym
->name
, &sym
->declared_at
);
12796 if (sym
->attr
.dummy
)
12798 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12799 sym
->name
, &sym
->declared_at
);
12804 /* F2018, C15100: "The result of an elemental function shall be scalar,
12805 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
12806 pointer is tested and caught elsewhere. */
12807 if (sym
->attr
.elemental
&& sym
->result
12808 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
12810 gfc_error ("Function result variable %qs at %L of elemental "
12811 "function %qs shall not have an ALLOCATABLE or POINTER "
12812 "attribute", sym
->result
->name
,
12813 &sym
->result
->declared_at
, sym
->name
);
12817 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12819 gfc_formal_arglist
*curr_arg
;
12820 int has_non_interop_arg
= 0;
12822 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12823 sym
->common_block
))
12825 /* Clear these to prevent looking at them again if there was an
12827 sym
->attr
.is_bind_c
= 0;
12828 sym
->attr
.is_c_interop
= 0;
12829 sym
->ts
.is_c_interop
= 0;
12833 /* So far, no errors have been found. */
12834 sym
->attr
.is_c_interop
= 1;
12835 sym
->ts
.is_c_interop
= 1;
12838 curr_arg
= gfc_sym_get_dummy_args (sym
);
12839 while (curr_arg
!= NULL
)
12841 /* Skip implicitly typed dummy args here. */
12842 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
12843 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12844 /* If something is found to fail, record the fact so we
12845 can mark the symbol for the procedure as not being
12846 BIND(C) to try and prevent multiple errors being
12848 has_non_interop_arg
= 1;
12850 curr_arg
= curr_arg
->next
;
12853 /* See if any of the arguments were not interoperable and if so, clear
12854 the procedure symbol to prevent duplicate error messages. */
12855 if (has_non_interop_arg
!= 0)
12857 sym
->attr
.is_c_interop
= 0;
12858 sym
->ts
.is_c_interop
= 0;
12859 sym
->attr
.is_bind_c
= 0;
12863 if (!sym
->attr
.proc_pointer
)
12865 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12867 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12868 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12871 if (sym
->attr
.intent
)
12873 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12874 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12877 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12879 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12880 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12883 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12884 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12885 || sym
->attr
.contained
))
12887 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12888 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12891 if (strcmp ("ppr@", sym
->name
) == 0)
12893 gfc_error ("Procedure pointer result %qs at %L "
12894 "is missing the pointer attribute",
12895 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12900 /* Assume that a procedure whose body is not known has references
12901 to external arrays. */
12902 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12903 sym
->attr
.array_outer_dependency
= 1;
12905 /* Compare the characteristics of a module procedure with the
12906 interface declaration. Ideally this would be done with
12907 gfc_compare_interfaces but, at present, the formal interface
12908 cannot be copied to the ts.interface. */
12909 if (sym
->attr
.module_procedure
12910 && sym
->attr
.if_source
== IFSRC_DECL
)
12913 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12915 char *submodule_name
;
12916 strcpy (name
, sym
->ns
->proc_name
->name
);
12917 module_name
= strtok (name
, ".");
12918 submodule_name
= strtok (NULL
, ".");
12920 iface
= sym
->tlink
;
12923 /* Make sure that the result uses the correct charlen for deferred
12925 if (iface
&& sym
->result
12926 && iface
->ts
.type
== BT_CHARACTER
12927 && iface
->ts
.deferred
)
12928 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12933 /* Check the procedure characteristics. */
12934 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12936 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12937 "PROCEDURE at %L and its interface in %s",
12938 &sym
->declared_at
, module_name
);
12942 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12944 gfc_error ("Mismatch in PURE attribute between MODULE "
12945 "PROCEDURE at %L and its interface in %s",
12946 &sym
->declared_at
, module_name
);
12950 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12952 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12953 "PROCEDURE at %L and its interface in %s",
12954 &sym
->declared_at
, module_name
);
12958 /* Check the result characteristics. */
12959 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12961 gfc_error ("%s between the MODULE PROCEDURE declaration "
12962 "in MODULE %qs and the declaration at %L in "
12964 errmsg
, module_name
, &sym
->declared_at
,
12965 submodule_name
? submodule_name
: module_name
);
12970 /* Check the characteristics of the formal arguments. */
12971 if (sym
->formal
&& sym
->formal_ns
)
12973 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12976 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12984 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12985 been defined and we now know their defined arguments, check that they fulfill
12986 the requirements of the standard for procedures used as finalizers. */
12989 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12991 gfc_finalizer
* list
;
12992 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12993 bool result
= true;
12994 bool seen_scalar
= false;
12997 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
13000 gfc_resolve_finalizers (parent
, finalizable
);
13002 /* Ensure that derived-type components have a their finalizers resolved. */
13003 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
13004 for (c
= derived
->components
; c
; c
= c
->next
)
13005 if (c
->ts
.type
== BT_DERIVED
13006 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
13008 bool has_final2
= false;
13009 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
13010 return false; /* Error. */
13011 has_final
= has_final
|| has_final2
;
13013 /* Return early if not finalizable. */
13017 *finalizable
= false;
13021 /* Walk over the list of finalizer-procedures, check them, and if any one
13022 does not fit in with the standard's definition, print an error and remove
13023 it from the list. */
13024 prev_link
= &derived
->f2k_derived
->finalizers
;
13025 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
13027 gfc_formal_arglist
*dummy_args
;
13032 /* Skip this finalizer if we already resolved it. */
13033 if (list
->proc_tree
)
13035 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
13036 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
13037 seen_scalar
= true;
13038 prev_link
= &(list
->next
);
13042 /* Check this exists and is a SUBROUTINE. */
13043 if (!list
->proc_sym
->attr
.subroutine
)
13045 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
13046 list
->proc_sym
->name
, &list
->where
);
13050 /* We should have exactly one argument. */
13051 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
13052 if (!dummy_args
|| dummy_args
->next
)
13054 gfc_error ("FINAL procedure at %L must have exactly one argument",
13058 arg
= dummy_args
->sym
;
13060 /* This argument must be of our type. */
13061 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
13063 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
13064 &arg
->declared_at
, derived
->name
);
13068 /* It must neither be a pointer nor allocatable nor optional. */
13069 if (arg
->attr
.pointer
)
13071 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13072 &arg
->declared_at
);
13075 if (arg
->attr
.allocatable
)
13077 gfc_error ("Argument of FINAL procedure at %L must not be"
13078 " ALLOCATABLE", &arg
->declared_at
);
13081 if (arg
->attr
.optional
)
13083 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13084 &arg
->declared_at
);
13088 /* It must not be INTENT(OUT). */
13089 if (arg
->attr
.intent
== INTENT_OUT
)
13091 gfc_error ("Argument of FINAL procedure at %L must not be"
13092 " INTENT(OUT)", &arg
->declared_at
);
13096 /* Warn if the procedure is non-scalar and not assumed shape. */
13097 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
13098 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
13099 gfc_warning (OPT_Wsurprising
,
13100 "Non-scalar FINAL procedure at %L should have assumed"
13101 " shape argument", &arg
->declared_at
);
13103 /* Check that it does not match in kind and rank with a FINAL procedure
13104 defined earlier. To really loop over the *earlier* declarations,
13105 we need to walk the tail of the list as new ones were pushed at the
13107 /* TODO: Handle kind parameters once they are implemented. */
13108 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
13109 for (i
= list
->next
; i
; i
= i
->next
)
13111 gfc_formal_arglist
*dummy_args
;
13113 /* Argument list might be empty; that is an error signalled earlier,
13114 but we nevertheless continued resolving. */
13115 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
13118 gfc_symbol
* i_arg
= dummy_args
->sym
;
13119 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
13120 if (i_rank
== my_rank
)
13122 gfc_error ("FINAL procedure %qs declared at %L has the same"
13123 " rank (%d) as %qs",
13124 list
->proc_sym
->name
, &list
->where
, my_rank
,
13125 i
->proc_sym
->name
);
13131 /* Is this the/a scalar finalizer procedure? */
13133 seen_scalar
= true;
13135 /* Find the symtree for this procedure. */
13136 gcc_assert (!list
->proc_tree
);
13137 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
13139 prev_link
= &list
->next
;
13142 /* Remove wrong nodes immediately from the list so we don't risk any
13143 troubles in the future when they might fail later expectations. */
13146 *prev_link
= list
->next
;
13147 gfc_free_finalizer (i
);
13151 if (result
== false)
13154 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13155 were nodes in the list, must have been for arrays. It is surely a good
13156 idea to have a scalar version there if there's something to finalize. */
13157 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
13158 gfc_warning (OPT_Wsurprising
,
13159 "Only array FINAL procedures declared for derived type %qs"
13160 " defined at %L, suggest also scalar one",
13161 derived
->name
, &derived
->declared_at
);
13163 vtab
= gfc_find_derived_vtab (derived
);
13164 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
13165 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
13168 *finalizable
= true;
13174 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13177 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13178 const char* generic_name
, locus where
)
13180 gfc_symbol
*sym1
, *sym2
;
13181 const char *pass1
, *pass2
;
13182 gfc_formal_arglist
*dummy_args
;
13184 gcc_assert (t1
->specific
&& t2
->specific
);
13185 gcc_assert (!t1
->specific
->is_generic
);
13186 gcc_assert (!t2
->specific
->is_generic
);
13187 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13189 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13190 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13195 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13196 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13197 || sym1
->attr
.function
!= sym2
->attr
.function
)
13199 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
13200 " GENERIC %qs at %L",
13201 sym1
->name
, sym2
->name
, generic_name
, &where
);
13205 /* Determine PASS arguments. */
13206 if (t1
->specific
->nopass
)
13208 else if (t1
->specific
->pass_arg
)
13209 pass1
= t1
->specific
->pass_arg
;
13212 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13214 pass1
= dummy_args
->sym
->name
;
13218 if (t2
->specific
->nopass
)
13220 else if (t2
->specific
->pass_arg
)
13221 pass2
= t2
->specific
->pass_arg
;
13224 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13226 pass2
= dummy_args
->sym
->name
;
13231 /* Compare the interfaces. */
13232 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13233 NULL
, 0, pass1
, pass2
))
13235 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13236 sym1
->name
, sym2
->name
, generic_name
, &where
);
13244 /* Worker function for resolving a generic procedure binding; this is used to
13245 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13247 The difference between those cases is finding possible inherited bindings
13248 that are overridden, as one has to look for them in tb_sym_root,
13249 tb_uop_root or tb_op, respectively. Thus the caller must already find
13250 the super-type and set p->overridden correctly. */
13253 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13254 gfc_typebound_proc
* p
, const char* name
)
13256 gfc_tbp_generic
* target
;
13257 gfc_symtree
* first_target
;
13258 gfc_symtree
* inherited
;
13260 gcc_assert (p
&& p
->is_generic
);
13262 /* Try to find the specific bindings for the symtrees in our target-list. */
13263 gcc_assert (p
->u
.generic
);
13264 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13265 if (!target
->specific
)
13267 gfc_typebound_proc
* overridden_tbp
;
13268 gfc_tbp_generic
* g
;
13269 const char* target_name
;
13271 target_name
= target
->specific_st
->name
;
13273 /* Defined for this type directly. */
13274 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13276 target
->specific
= target
->specific_st
->n
.tb
;
13277 goto specific_found
;
13280 /* Look for an inherited specific binding. */
13283 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13288 gcc_assert (inherited
->n
.tb
);
13289 target
->specific
= inherited
->n
.tb
;
13290 goto specific_found
;
13294 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13295 " at %L", target_name
, name
, &p
->where
);
13298 /* Once we've found the specific binding, check it is not ambiguous with
13299 other specifics already found or inherited for the same GENERIC. */
13301 gcc_assert (target
->specific
);
13303 /* This must really be a specific binding! */
13304 if (target
->specific
->is_generic
)
13306 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13307 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13311 /* Check those already resolved on this type directly. */
13312 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13313 if (g
!= target
&& g
->specific
13314 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13317 /* Check for ambiguity with inherited specific targets. */
13318 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13319 overridden_tbp
= overridden_tbp
->overridden
)
13320 if (overridden_tbp
->is_generic
)
13322 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13324 gcc_assert (g
->specific
);
13325 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13331 /* If we attempt to "overwrite" a specific binding, this is an error. */
13332 if (p
->overridden
&& !p
->overridden
->is_generic
)
13334 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
13335 " the same name", name
, &p
->where
);
13339 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13340 all must have the same attributes here. */
13341 first_target
= p
->u
.generic
->specific
->u
.specific
;
13342 gcc_assert (first_target
);
13343 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13344 p
->function
= first_target
->n
.sym
->attr
.function
;
13350 /* Resolve a GENERIC procedure binding for a derived type. */
13353 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13355 gfc_symbol
* super_type
;
13357 /* Find the overridden binding if any. */
13358 st
->n
.tb
->overridden
= NULL
;
13359 super_type
= gfc_get_derived_super_type (derived
);
13362 gfc_symtree
* overridden
;
13363 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13366 if (overridden
&& overridden
->n
.tb
)
13367 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13370 /* Resolve using worker function. */
13371 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13375 /* Retrieve the target-procedure of an operator binding and do some checks in
13376 common for intrinsic and user-defined type-bound operators. */
13379 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13381 gfc_symbol
* target_proc
;
13383 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13384 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13385 gcc_assert (target_proc
);
13387 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13388 if (target
->specific
->nopass
)
13390 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
13394 return target_proc
;
13398 /* Resolve a type-bound intrinsic operator. */
13401 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13402 gfc_typebound_proc
* p
)
13404 gfc_symbol
* super_type
;
13405 gfc_tbp_generic
* target
;
13407 /* If there's already an error here, do nothing (but don't fail again). */
13411 /* Operators should always be GENERIC bindings. */
13412 gcc_assert (p
->is_generic
);
13414 /* Look for an overridden binding. */
13415 super_type
= gfc_get_derived_super_type (derived
);
13416 if (super_type
&& super_type
->f2k_derived
)
13417 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13420 p
->overridden
= NULL
;
13422 /* Resolve general GENERIC properties using worker function. */
13423 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13426 /* Check the targets to be procedures of correct interface. */
13427 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13429 gfc_symbol
* target_proc
;
13431 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13435 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13438 /* Add target to non-typebound operator list. */
13439 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13440 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13442 gfc_interface
*head
, *intr
;
13444 /* Preempt 'gfc_check_new_interface' for submodules, where the
13445 mechanism for handling module procedures winds up resolving
13446 operator interfaces twice and would otherwise cause an error. */
13447 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13448 if (intr
->sym
== target_proc
13449 && target_proc
->attr
.used_in_submodule
)
13452 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13453 target_proc
, p
->where
))
13455 head
= derived
->ns
->op
[op
];
13456 intr
= gfc_get_interface ();
13457 intr
->sym
= target_proc
;
13458 intr
->where
= p
->where
;
13460 derived
->ns
->op
[op
] = intr
;
13472 /* Resolve a type-bound user operator (tree-walker callback). */
13474 static gfc_symbol
* resolve_bindings_derived
;
13475 static bool resolve_bindings_result
;
13477 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13480 resolve_typebound_user_op (gfc_symtree
* stree
)
13482 gfc_symbol
* super_type
;
13483 gfc_tbp_generic
* target
;
13485 gcc_assert (stree
&& stree
->n
.tb
);
13487 if (stree
->n
.tb
->error
)
13490 /* Operators should always be GENERIC bindings. */
13491 gcc_assert (stree
->n
.tb
->is_generic
);
13493 /* Find overridden procedure, if any. */
13494 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13495 if (super_type
&& super_type
->f2k_derived
)
13497 gfc_symtree
* overridden
;
13498 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13499 stree
->name
, true, NULL
);
13501 if (overridden
&& overridden
->n
.tb
)
13502 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13505 stree
->n
.tb
->overridden
= NULL
;
13507 /* Resolve basically using worker function. */
13508 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13511 /* Check the targets to be functions of correct interface. */
13512 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13514 gfc_symbol
* target_proc
;
13516 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13520 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13527 resolve_bindings_result
= false;
13528 stree
->n
.tb
->error
= 1;
13532 /* Resolve the type-bound procedures for a derived type. */
13535 resolve_typebound_procedure (gfc_symtree
* stree
)
13539 gfc_symbol
* me_arg
;
13540 gfc_symbol
* super_type
;
13541 gfc_component
* comp
;
13543 gcc_assert (stree
);
13545 /* Undefined specific symbol from GENERIC target definition. */
13549 if (stree
->n
.tb
->error
)
13552 /* If this is a GENERIC binding, use that routine. */
13553 if (stree
->n
.tb
->is_generic
)
13555 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13560 /* Get the target-procedure to check it. */
13561 gcc_assert (!stree
->n
.tb
->is_generic
);
13562 gcc_assert (stree
->n
.tb
->u
.specific
);
13563 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13564 where
= stree
->n
.tb
->where
;
13566 /* Default access should already be resolved from the parser. */
13567 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13569 if (stree
->n
.tb
->deferred
)
13571 if (!check_proc_interface (proc
, &where
))
13576 /* If proc has not been resolved at this point, proc->name may
13577 actually be a USE associated entity. See PR fortran/89647. */
13578 if (!proc
->resolved
13579 && proc
->attr
.function
== 0 && proc
->attr
.subroutine
== 0)
13582 gfc_find_symbol (proc
->name
, gfc_current_ns
->parent
, 1, &tmp
);
13583 if (tmp
&& tmp
->attr
.use_assoc
)
13585 proc
->module
= tmp
->module
;
13586 proc
->attr
.proc
= tmp
->attr
.proc
;
13587 proc
->attr
.function
= tmp
->attr
.function
;
13588 proc
->attr
.subroutine
= tmp
->attr
.subroutine
;
13589 proc
->attr
.use_assoc
= tmp
->attr
.use_assoc
;
13590 proc
->ts
= tmp
->ts
;
13591 proc
->result
= tmp
->result
;
13595 /* Check for F08:C465. */
13596 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13597 || (proc
->attr
.proc
!= PROC_MODULE
13598 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13599 || proc
->attr
.abstract
)
13601 gfc_error ("%qs must be a module procedure or an external "
13602 "procedure with an explicit interface at %L",
13603 proc
->name
, &where
);
13608 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13609 stree
->n
.tb
->function
= proc
->attr
.function
;
13611 /* Find the super-type of the current derived type. We could do this once and
13612 store in a global if speed is needed, but as long as not I believe this is
13613 more readable and clearer. */
13614 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13616 /* If PASS, resolve and check arguments if not already resolved / loaded
13617 from a .mod file. */
13618 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13620 gfc_formal_arglist
*dummy_args
;
13622 dummy_args
= gfc_sym_get_dummy_args (proc
);
13623 if (stree
->n
.tb
->pass_arg
)
13625 gfc_formal_arglist
*i
;
13627 /* If an explicit passing argument name is given, walk the arg-list
13628 and look for it. */
13631 stree
->n
.tb
->pass_arg_num
= 1;
13632 for (i
= dummy_args
; i
; i
= i
->next
)
13634 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13639 ++stree
->n
.tb
->pass_arg_num
;
13644 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13646 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13647 stree
->n
.tb
->pass_arg
);
13653 /* Otherwise, take the first one; there should in fact be at least
13655 stree
->n
.tb
->pass_arg_num
= 1;
13658 gfc_error ("Procedure %qs with PASS at %L must have at"
13659 " least one argument", proc
->name
, &where
);
13662 me_arg
= dummy_args
->sym
;
13665 /* Now check that the argument-type matches and the passed-object
13666 dummy argument is generally fine. */
13668 gcc_assert (me_arg
);
13670 if (me_arg
->ts
.type
!= BT_CLASS
)
13672 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13673 " at %L", proc
->name
, &where
);
13677 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13678 != resolve_bindings_derived
)
13680 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13681 " the derived-type %qs", me_arg
->name
, proc
->name
,
13682 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13686 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13687 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13689 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13690 " scalar", proc
->name
, &where
);
13693 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13695 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13696 " be ALLOCATABLE", proc
->name
, &where
);
13699 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13701 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13702 " be POINTER", proc
->name
, &where
);
13707 /* If we are extending some type, check that we don't override a procedure
13708 flagged NON_OVERRIDABLE. */
13709 stree
->n
.tb
->overridden
= NULL
;
13712 gfc_symtree
* overridden
;
13713 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13714 stree
->name
, true, NULL
);
13718 if (overridden
->n
.tb
)
13719 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13721 if (!gfc_check_typebound_override (stree
, overridden
))
13726 /* See if there's a name collision with a component directly in this type. */
13727 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13728 if (!strcmp (comp
->name
, stree
->name
))
13730 gfc_error ("Procedure %qs at %L has the same name as a component of"
13732 stree
->name
, &where
, resolve_bindings_derived
->name
);
13736 /* Try to find a name collision with an inherited component. */
13737 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13740 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13741 " component of %qs",
13742 stree
->name
, &where
, resolve_bindings_derived
->name
);
13746 stree
->n
.tb
->error
= 0;
13750 resolve_bindings_result
= false;
13751 stree
->n
.tb
->error
= 1;
13756 resolve_typebound_procedures (gfc_symbol
* derived
)
13759 gfc_symbol
* super_type
;
13761 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13764 super_type
= gfc_get_derived_super_type (derived
);
13766 resolve_symbol (super_type
);
13768 resolve_bindings_derived
= derived
;
13769 resolve_bindings_result
= true;
13771 if (derived
->f2k_derived
->tb_sym_root
)
13772 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13773 &resolve_typebound_procedure
);
13775 if (derived
->f2k_derived
->tb_uop_root
)
13776 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13777 &resolve_typebound_user_op
);
13779 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13781 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13782 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13783 (gfc_intrinsic_op
)op
, p
))
13784 resolve_bindings_result
= false;
13787 return resolve_bindings_result
;
13791 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13792 to give all identical derived types the same backend_decl. */
13794 add_dt_to_dt_list (gfc_symbol
*derived
)
13796 if (!derived
->dt_next
)
13798 if (gfc_derived_types
)
13800 derived
->dt_next
= gfc_derived_types
->dt_next
;
13801 gfc_derived_types
->dt_next
= derived
;
13805 derived
->dt_next
= derived
;
13807 gfc_derived_types
= derived
;
13812 /* Ensure that a derived-type is really not abstract, meaning that every
13813 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13816 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13821 if (!ensure_not_abstract_walker (sub
, st
->left
))
13823 if (!ensure_not_abstract_walker (sub
, st
->right
))
13826 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13828 gfc_symtree
* overriding
;
13829 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13832 gcc_assert (overriding
->n
.tb
);
13833 if (overriding
->n
.tb
->deferred
)
13835 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13836 " %qs is DEFERRED and not overridden",
13837 sub
->name
, &sub
->declared_at
, st
->name
);
13846 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13848 /* The algorithm used here is to recursively travel up the ancestry of sub
13849 and for each ancestor-type, check all bindings. If any of them is
13850 DEFERRED, look it up starting from sub and see if the found (overriding)
13851 binding is not DEFERRED.
13852 This is not the most efficient way to do this, but it should be ok and is
13853 clearer than something sophisticated. */
13855 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13857 if (!ancestor
->attr
.abstract
)
13860 /* Walk bindings of this ancestor. */
13861 if (ancestor
->f2k_derived
)
13864 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13869 /* Find next ancestor type and recurse on it. */
13870 ancestor
= gfc_get_derived_super_type (ancestor
);
13872 return ensure_not_abstract (sub
, ancestor
);
13878 /* This check for typebound defined assignments is done recursively
13879 since the order in which derived types are resolved is not always in
13880 order of the declarations. */
13883 check_defined_assignments (gfc_symbol
*derived
)
13887 for (c
= derived
->components
; c
; c
= c
->next
)
13889 if (!gfc_bt_struct (c
->ts
.type
)
13891 || c
->attr
.allocatable
13892 || c
->attr
.proc_pointer_comp
13893 || c
->attr
.class_pointer
13894 || c
->attr
.proc_pointer
)
13897 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13898 || (c
->ts
.u
.derived
->f2k_derived
13899 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13901 derived
->attr
.defined_assign_comp
= 1;
13905 check_defined_assignments (c
->ts
.u
.derived
);
13906 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13908 derived
->attr
.defined_assign_comp
= 1;
13915 /* Resolve a single component of a derived type or structure. */
13918 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13920 gfc_symbol
*super_type
;
13921 symbol_attribute
*attr
;
13923 if (c
->attr
.artificial
)
13926 /* Do not allow vtype components to be resolved in nameless namespaces
13927 such as block data because the procedure pointers will cause ICEs
13928 and vtables are not needed in these contexts. */
13929 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
13930 && sym
->ns
->proc_name
== NULL
)
13934 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13935 && c
->attr
.codimension
13936 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13938 gfc_error ("Coarray component %qs at %L must be allocatable with "
13939 "deferred shape", c
->name
, &c
->loc
);
13944 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13945 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13947 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13948 "shall not be a coarray", c
->name
, &c
->loc
);
13953 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13954 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13955 || c
->attr
.allocatable
))
13957 gfc_error ("Component %qs at %L with coarray component "
13958 "shall be a nonpointer, nonallocatable scalar",
13964 if (c
->ts
.type
== BT_CLASS
)
13966 if (CLASS_DATA (c
))
13968 attr
= &(CLASS_DATA (c
)->attr
);
13970 /* Fix up contiguous attribute. */
13971 if (c
->attr
.contiguous
)
13972 attr
->contiguous
= 1;
13980 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
13982 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13983 "is not an array pointer", c
->name
, &c
->loc
);
13987 /* F2003, 15.2.1 - length has to be one. */
13988 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
13989 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
13990 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
13991 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
13993 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
13998 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
14000 gfc_symbol
*ifc
= c
->ts
.interface
;
14002 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
14008 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
14010 /* Resolve interface and copy attributes. */
14011 if (ifc
->formal
&& !ifc
->formal_ns
)
14012 resolve_symbol (ifc
);
14013 if (ifc
->attr
.intrinsic
)
14014 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
14018 c
->ts
= ifc
->result
->ts
;
14019 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
14020 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
14021 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
14022 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
14023 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
14028 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
14029 c
->attr
.pointer
= ifc
->attr
.pointer
;
14030 c
->attr
.dimension
= ifc
->attr
.dimension
;
14031 c
->as
= gfc_copy_array_spec (ifc
->as
);
14032 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
14034 c
->ts
.interface
= ifc
;
14035 c
->attr
.function
= ifc
->attr
.function
;
14036 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
14038 c
->attr
.pure
= ifc
->attr
.pure
;
14039 c
->attr
.elemental
= ifc
->attr
.elemental
;
14040 c
->attr
.recursive
= ifc
->attr
.recursive
;
14041 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
14042 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
14043 /* Copy char length. */
14044 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
14046 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
14047 if (cl
->length
&& !cl
->resolved
14048 && !gfc_resolve_expr (cl
->length
))
14057 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
14059 /* Since PPCs are not implicitly typed, a PPC without an explicit
14060 interface must be a subroutine. */
14061 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
14064 /* Procedure pointer components: Check PASS arg. */
14065 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
14066 && !sym
->attr
.vtype
)
14068 gfc_symbol
* me_arg
;
14070 if (c
->tb
->pass_arg
)
14072 gfc_formal_arglist
* i
;
14074 /* If an explicit passing argument name is given, walk the arg-list
14075 and look for it. */
14078 c
->tb
->pass_arg_num
= 1;
14079 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
14081 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
14086 c
->tb
->pass_arg_num
++;
14091 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14092 "at %L has no argument %qs", c
->name
,
14093 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
14100 /* Otherwise, take the first one; there should in fact be at least
14102 c
->tb
->pass_arg_num
= 1;
14103 if (!c
->ts
.interface
->formal
)
14105 gfc_error ("Procedure pointer component %qs with PASS at %L "
14106 "must have at least one argument",
14111 me_arg
= c
->ts
.interface
->formal
->sym
;
14114 /* Now check that the argument-type matches. */
14115 gcc_assert (me_arg
);
14116 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
14117 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
14118 || (me_arg
->ts
.type
== BT_CLASS
14119 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
14121 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14122 " the derived type %qs", me_arg
->name
, c
->name
,
14123 me_arg
->name
, &c
->loc
, sym
->name
);
14128 /* Check for F03:C453. */
14129 if (CLASS_DATA (me_arg
)->attr
.dimension
)
14131 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14132 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
14138 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14140 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14141 "may not have the POINTER attribute", me_arg
->name
,
14142 c
->name
, me_arg
->name
, &c
->loc
);
14147 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14149 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14150 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
14151 me_arg
->name
, &c
->loc
);
14156 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
14158 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14159 " at %L", c
->name
, &c
->loc
);
14165 /* Check type-spec if this is not the parent-type component. */
14166 if (((sym
->attr
.is_class
14167 && (!sym
->components
->ts
.u
.derived
->attr
.extension
14168 || c
!= sym
->components
->ts
.u
.derived
->components
))
14169 || (!sym
->attr
.is_class
14170 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
14171 && !sym
->attr
.vtype
14172 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
14175 super_type
= gfc_get_derived_super_type (sym
);
14177 /* If this type is an extension, set the accessibility of the parent
14180 && ((sym
->attr
.is_class
14181 && c
== sym
->components
->ts
.u
.derived
->components
)
14182 || (!sym
->attr
.is_class
&& c
== sym
->components
))
14183 && strcmp (super_type
->name
, c
->name
) == 0)
14184 c
->attr
.access
= super_type
->attr
.access
;
14186 /* If this type is an extension, see if this component has the same name
14187 as an inherited type-bound procedure. */
14188 if (super_type
&& !sym
->attr
.is_class
14189 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
14191 gfc_error ("Component %qs of %qs at %L has the same name as an"
14192 " inherited type-bound procedure",
14193 c
->name
, sym
->name
, &c
->loc
);
14197 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
14198 && !c
->ts
.deferred
)
14200 if (c
->ts
.u
.cl
->length
== NULL
14201 || (!resolve_charlen(c
->ts
.u
.cl
))
14202 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
14204 gfc_error ("Character length of component %qs needs to "
14205 "be a constant specification expression at %L",
14207 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14212 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14213 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14215 gfc_error ("Character component %qs of %qs at %L with deferred "
14216 "length must be a POINTER or ALLOCATABLE",
14217 c
->name
, sym
->name
, &c
->loc
);
14221 /* Add the hidden deferred length field. */
14222 if (c
->ts
.type
== BT_CHARACTER
14223 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14224 && !c
->attr
.function
14225 && !sym
->attr
.is_class
)
14227 char name
[GFC_MAX_SYMBOL_LEN
+9];
14228 gfc_component
*strlen
;
14229 sprintf (name
, "_%s_length", c
->name
);
14230 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14231 if (strlen
== NULL
)
14233 if (!gfc_add_component (sym
, name
, &strlen
))
14235 strlen
->ts
.type
= BT_INTEGER
;
14236 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14237 strlen
->attr
.access
= ACCESS_PRIVATE
;
14238 strlen
->attr
.artificial
= 1;
14242 if (c
->ts
.type
== BT_DERIVED
14243 && sym
->component_access
!= ACCESS_PRIVATE
14244 && gfc_check_symbol_access (sym
)
14245 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14246 && !c
->ts
.u
.derived
->attr
.use_assoc
14247 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14248 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14249 "PRIVATE type and cannot be a component of "
14250 "%qs, which is PUBLIC at %L", c
->name
,
14251 sym
->name
, &sym
->declared_at
))
14254 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14256 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14257 "type %s", c
->name
, &c
->loc
, sym
->name
);
14261 if (sym
->attr
.sequence
)
14263 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14265 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14266 "not have the SEQUENCE attribute",
14267 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14272 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14273 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14274 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14275 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14276 CLASS_DATA (c
)->ts
.u
.derived
14277 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14279 /* If an allocatable component derived type is of the same type as
14280 the enclosing derived type, we need a vtable generating so that
14281 the __deallocate procedure is created. */
14282 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14283 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14284 gfc_find_vtab (&c
->ts
);
14286 /* Ensure that all the derived type components are put on the
14287 derived type list; even in formal namespaces, where derived type
14288 pointer components might not have been declared. */
14289 if (c
->ts
.type
== BT_DERIVED
14291 && c
->ts
.u
.derived
->components
14293 && sym
!= c
->ts
.u
.derived
)
14294 add_dt_to_dt_list (c
->ts
.u
.derived
);
14296 if (!gfc_resolve_array_spec (c
->as
,
14297 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
14298 || c
->attr
.allocatable
)))
14301 if (c
->initializer
&& !sym
->attr
.vtype
14302 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
14303 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
14310 /* Be nice about the locus for a structure expression - show the locus of the
14311 first non-null sub-expression if we can. */
14314 cons_where (gfc_expr
*struct_expr
)
14316 gfc_constructor
*cons
;
14318 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
14320 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
14321 for (; cons
; cons
= gfc_constructor_next (cons
))
14323 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
14324 return &cons
->expr
->where
;
14327 return &struct_expr
->where
;
14330 /* Resolve the components of a structure type. Much less work than derived
14334 resolve_fl_struct (gfc_symbol
*sym
)
14337 gfc_expr
*init
= NULL
;
14340 /* Make sure UNIONs do not have overlapping initializers. */
14341 if (sym
->attr
.flavor
== FL_UNION
)
14343 for (c
= sym
->components
; c
; c
= c
->next
)
14345 if (init
&& c
->initializer
)
14347 gfc_error ("Conflicting initializers in union at %L and %L",
14348 cons_where (init
), cons_where (c
->initializer
));
14349 gfc_free_expr (c
->initializer
);
14350 c
->initializer
= NULL
;
14353 init
= c
->initializer
;
14358 for (c
= sym
->components
; c
; c
= c
->next
)
14359 if (!resolve_component (c
, sym
))
14365 if (sym
->components
)
14366 add_dt_to_dt_list (sym
);
14372 /* Resolve the components of a derived type. This does not have to wait until
14373 resolution stage, but can be done as soon as the dt declaration has been
14377 resolve_fl_derived0 (gfc_symbol
*sym
)
14379 gfc_symbol
* super_type
;
14381 gfc_formal_arglist
*f
;
14384 if (sym
->attr
.unlimited_polymorphic
)
14387 super_type
= gfc_get_derived_super_type (sym
);
14390 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14392 gfc_error ("As extending type %qs at %L has a coarray component, "
14393 "parent type %qs shall also have one", sym
->name
,
14394 &sym
->declared_at
, super_type
->name
);
14398 /* Ensure the extended type gets resolved before we do. */
14399 if (super_type
&& !resolve_fl_derived0 (super_type
))
14402 /* An ABSTRACT type must be extensible. */
14403 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14405 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14406 sym
->name
, &sym
->declared_at
);
14410 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14414 for ( ; c
!= NULL
; c
= c
->next
)
14415 if (!resolve_component (c
, sym
))
14421 /* Now add the caf token field, where needed. */
14422 if (flag_coarray
!= GFC_FCOARRAY_NONE
14423 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14425 for (c
= sym
->components
; c
; c
= c
->next
)
14426 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14427 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14429 char name
[GFC_MAX_SYMBOL_LEN
+9];
14430 gfc_component
*token
;
14431 sprintf (name
, "_caf_%s", c
->name
);
14432 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14435 if (!gfc_add_component (sym
, name
, &token
))
14437 token
->ts
.type
= BT_VOID
;
14438 token
->ts
.kind
= gfc_default_integer_kind
;
14439 token
->attr
.access
= ACCESS_PRIVATE
;
14440 token
->attr
.artificial
= 1;
14441 token
->attr
.caf_token
= 1;
14446 check_defined_assignments (sym
);
14448 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14449 sym
->attr
.defined_assign_comp
14450 = super_type
->attr
.defined_assign_comp
;
14452 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14453 all DEFERRED bindings are overridden. */
14454 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14455 && !sym
->attr
.is_class
14456 && !ensure_not_abstract (sym
, super_type
))
14459 /* Check that there is a component for every PDT parameter. */
14460 if (sym
->attr
.pdt_template
)
14462 for (f
= sym
->formal
; f
; f
= f
->next
)
14466 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14469 gfc_error ("Parameterized type %qs does not have a component "
14470 "corresponding to parameter %qs at %L", sym
->name
,
14471 f
->sym
->name
, &sym
->declared_at
);
14477 /* Add derived type to the derived type list. */
14478 add_dt_to_dt_list (sym
);
14484 /* The following procedure does the full resolution of a derived type,
14485 including resolution of all type-bound procedures (if present). In contrast
14486 to 'resolve_fl_derived0' this can only be done after the module has been
14487 parsed completely. */
14490 resolve_fl_derived (gfc_symbol
*sym
)
14492 gfc_symbol
*gen_dt
= NULL
;
14494 if (sym
->attr
.unlimited_polymorphic
)
14497 if (!sym
->attr
.is_class
)
14498 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14499 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14500 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14501 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14502 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14503 "%qs at %L being the same name as derived "
14504 "type at %L", sym
->name
,
14505 gen_dt
->generic
->sym
== sym
14506 ? gen_dt
->generic
->next
->sym
->name
14507 : gen_dt
->generic
->sym
->name
,
14508 gen_dt
->generic
->sym
== sym
14509 ? &gen_dt
->generic
->next
->sym
->declared_at
14510 : &gen_dt
->generic
->sym
->declared_at
,
14511 &sym
->declared_at
))
14514 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
14516 gfc_error ("Derived type %qs at %L has not been declared",
14517 sym
->name
, &sym
->declared_at
);
14521 /* Resolve the finalizer procedures. */
14522 if (!gfc_resolve_finalizers (sym
, NULL
))
14525 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14527 /* Fix up incomplete CLASS symbols. */
14528 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14529 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14531 /* Nothing more to do for unlimited polymorphic entities. */
14532 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14534 else if (vptr
->ts
.u
.derived
== NULL
)
14536 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14538 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14539 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14544 if (!resolve_fl_derived0 (sym
))
14547 /* Resolve the type-bound procedures. */
14548 if (!resolve_typebound_procedures (sym
))
14551 /* Generate module vtables subject to their accessibility and their not
14552 being vtables or pdt templates. If this is not done class declarations
14553 in external procedures wind up with their own version and so SELECT TYPE
14554 fails because the vptrs do not have the same address. */
14555 if (gfc_option
.allow_std
& GFC_STD_F2003
14556 && sym
->ns
->proc_name
14557 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14558 && sym
->attr
.access
!= ACCESS_PRIVATE
14559 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14561 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14562 gfc_set_sym_referenced (vtab
);
14570 resolve_fl_namelist (gfc_symbol
*sym
)
14575 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14577 /* Check again, the check in match only works if NAMELIST comes
14579 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14581 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14582 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14586 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14587 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14588 "with assumed shape in namelist %qs at %L",
14589 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14592 if (is_non_constant_shape_array (nl
->sym
)
14593 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14594 "with nonconstant shape in namelist %qs at %L",
14595 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14598 if (nl
->sym
->ts
.type
== BT_CHARACTER
14599 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14600 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14601 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14602 "nonconstant character length in "
14603 "namelist %qs at %L", nl
->sym
->name
,
14604 sym
->name
, &sym
->declared_at
))
14609 /* Reject PRIVATE objects in a PUBLIC namelist. */
14610 if (gfc_check_symbol_access (sym
))
14612 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14614 if (!nl
->sym
->attr
.use_assoc
14615 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14616 && !gfc_check_symbol_access (nl
->sym
))
14618 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14619 "cannot be member of PUBLIC namelist %qs at %L",
14620 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14624 if (nl
->sym
->ts
.type
== BT_DERIVED
14625 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14626 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14628 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14629 "namelist %qs at %L with ALLOCATABLE "
14630 "or POINTER components", nl
->sym
->name
,
14631 sym
->name
, &sym
->declared_at
))
14636 /* Types with private components that came here by USE-association. */
14637 if (nl
->sym
->ts
.type
== BT_DERIVED
14638 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14640 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14641 "components and cannot be member of namelist %qs at %L",
14642 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14646 /* Types with private components that are defined in the same module. */
14647 if (nl
->sym
->ts
.type
== BT_DERIVED
14648 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14649 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14651 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14652 "cannot be a member of PUBLIC namelist %qs at %L",
14653 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14660 /* 14.1.2 A module or internal procedure represent local entities
14661 of the same type as a namelist member and so are not allowed. */
14662 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14664 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14667 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14668 if ((nl
->sym
== sym
->ns
->proc_name
)
14670 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14675 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14676 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14678 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14679 "attribute in %qs at %L", nlsym
->name
,
14680 &sym
->declared_at
);
14687 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14688 nl
->sym
->attr
.asynchronous
= 1;
14695 resolve_fl_parameter (gfc_symbol
*sym
)
14697 /* A parameter array's shape needs to be constant. */
14698 if (sym
->as
!= NULL
14699 && (sym
->as
->type
== AS_DEFERRED
14700 || is_non_constant_shape_array (sym
)))
14702 gfc_error ("Parameter array %qs at %L cannot be automatic "
14703 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14707 /* Constraints on deferred type parameter. */
14708 if (!deferred_requirements (sym
))
14711 /* Make sure a parameter that has been implicitly typed still
14712 matches the implicit type, since PARAMETER statements can precede
14713 IMPLICIT statements. */
14714 if (sym
->attr
.implicit_type
14715 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14718 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14719 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14723 /* Make sure the types of derived parameters are consistent. This
14724 type checking is deferred until resolution because the type may
14725 refer to a derived type from the host. */
14726 if (sym
->ts
.type
== BT_DERIVED
14727 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14729 gfc_error ("Incompatible derived type in PARAMETER at %L",
14730 &sym
->value
->where
);
14734 /* F03:C509,C514. */
14735 if (sym
->ts
.type
== BT_CLASS
)
14737 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14738 sym
->name
, &sym
->declared_at
);
14746 /* Called by resolve_symbol to check PDTs. */
14749 resolve_pdt (gfc_symbol
* sym
)
14751 gfc_symbol
*derived
= NULL
;
14752 gfc_actual_arglist
*param
;
14754 bool const_len_exprs
= true;
14755 bool assumed_len_exprs
= false;
14756 symbol_attribute
*attr
;
14758 if (sym
->ts
.type
== BT_DERIVED
)
14760 derived
= sym
->ts
.u
.derived
;
14761 attr
= &(sym
->attr
);
14763 else if (sym
->ts
.type
== BT_CLASS
)
14765 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14766 attr
= &(CLASS_DATA (sym
)->attr
);
14769 gcc_unreachable ();
14771 gcc_assert (derived
->attr
.pdt_type
);
14773 for (param
= sym
->param_list
; param
; param
= param
->next
)
14775 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14777 if (c
->attr
.pdt_kind
)
14780 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14781 && c
->attr
.pdt_len
)
14782 const_len_exprs
= false;
14783 else if (param
->spec_type
== SPEC_ASSUMED
)
14784 assumed_len_exprs
= true;
14786 if (param
->spec_type
== SPEC_DEFERRED
14787 && !attr
->allocatable
&& !attr
->pointer
)
14788 gfc_error ("The object %qs at %L has a deferred LEN "
14789 "parameter %qs and is neither allocatable "
14790 "nor a pointer", sym
->name
, &sym
->declared_at
,
14795 if (!const_len_exprs
14796 && (sym
->ns
->proc_name
->attr
.is_main_program
14797 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14798 || sym
->attr
.save
!= SAVE_NONE
))
14799 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14800 "SAVE attribute or be a variable declared in the "
14801 "main program, a module or a submodule(F08/C513)",
14802 sym
->name
, &sym
->declared_at
);
14804 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14805 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14806 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14807 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14808 sym
->name
, &sym
->declared_at
);
14812 /* Do anything necessary to resolve a symbol. Right now, we just
14813 assume that an otherwise unknown symbol is a variable. This sort
14814 of thing commonly happens for symbols in module. */
14817 resolve_symbol (gfc_symbol
*sym
)
14819 int check_constant
, mp_flag
;
14820 gfc_symtree
*symtree
;
14821 gfc_symtree
*this_symtree
;
14824 symbol_attribute class_attr
;
14825 gfc_array_spec
*as
;
14826 bool saved_specification_expr
;
14832 /* No symbol will ever have union type; only components can be unions.
14833 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14834 (just like derived type declaration symbols have flavor FL_DERIVED). */
14835 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14837 /* Coarrayed polymorphic objects with allocatable or pointer components are
14838 yet unsupported for -fcoarray=lib. */
14839 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14840 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14841 && CLASS_DATA (sym
)->attr
.codimension
14842 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14843 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14845 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14846 "type coarrays at %L are unsupported", &sym
->declared_at
);
14850 if (sym
->attr
.artificial
)
14853 if (sym
->attr
.unlimited_polymorphic
)
14856 if (sym
->attr
.flavor
== FL_UNKNOWN
14857 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14858 && !sym
->attr
.generic
&& !sym
->attr
.external
14859 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14860 && sym
->ts
.type
== BT_UNKNOWN
))
14863 /* If we find that a flavorless symbol is an interface in one of the
14864 parent namespaces, find its symtree in this namespace, free the
14865 symbol and set the symtree to point to the interface symbol. */
14866 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14868 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14869 if (symtree
&& (symtree
->n
.sym
->generic
||
14870 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14871 && sym
->ns
->construct_entities
)))
14873 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14875 if (this_symtree
->n
.sym
== sym
)
14877 symtree
->n
.sym
->refs
++;
14878 gfc_release_symbol (sym
);
14879 this_symtree
->n
.sym
= symtree
->n
.sym
;
14885 /* Otherwise give it a flavor according to such attributes as
14887 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14888 && sym
->attr
.intrinsic
== 0)
14889 sym
->attr
.flavor
= FL_VARIABLE
;
14890 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14892 sym
->attr
.flavor
= FL_PROCEDURE
;
14893 if (sym
->attr
.dimension
)
14894 sym
->attr
.function
= 1;
14898 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14899 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14901 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14902 && !resolve_procedure_interface (sym
))
14905 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14906 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14908 if (sym
->attr
.external
)
14909 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14910 "at %L", &sym
->declared_at
);
14912 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14913 "at %L", &sym
->declared_at
);
14918 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14921 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14922 && !resolve_fl_struct (sym
))
14925 /* Symbols that are module procedures with results (functions) have
14926 the types and array specification copied for type checking in
14927 procedures that call them, as well as for saving to a module
14928 file. These symbols can't stand the scrutiny that their results
14930 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14932 /* Make sure that the intrinsic is consistent with its internal
14933 representation. This needs to be done before assigning a default
14934 type to avoid spurious warnings. */
14935 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14936 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14939 /* Resolve associate names. */
14941 resolve_assoc_var (sym
, true);
14943 /* Assign default type to symbols that need one and don't have one. */
14944 if (sym
->ts
.type
== BT_UNKNOWN
)
14946 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14948 gfc_set_default_type (sym
, 1, NULL
);
14951 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14952 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14953 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14954 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14956 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14958 /* The specific case of an external procedure should emit an error
14959 in the case that there is no implicit type. */
14962 if (!sym
->attr
.mixed_entry_master
)
14963 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14967 /* Result may be in another namespace. */
14968 resolve_symbol (sym
->result
);
14970 if (!sym
->result
->attr
.proc_pointer
)
14972 sym
->ts
= sym
->result
->ts
;
14973 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14974 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14975 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14976 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14977 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14982 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14984 bool saved_specification_expr
= specification_expr
;
14985 specification_expr
= true;
14986 gfc_resolve_array_spec (sym
->result
->as
, false);
14987 specification_expr
= saved_specification_expr
;
14990 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14992 as
= CLASS_DATA (sym
)->as
;
14993 class_attr
= CLASS_DATA (sym
)->attr
;
14994 class_attr
.pointer
= class_attr
.class_pointer
;
14998 class_attr
= sym
->attr
;
15003 if (sym
->attr
.contiguous
15004 && (!class_attr
.dimension
15005 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
15006 && !class_attr
.pointer
)))
15008 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
15009 "array pointer or an assumed-shape or assumed-rank array",
15010 sym
->name
, &sym
->declared_at
);
15014 /* Assumed size arrays and assumed shape arrays must be dummy
15015 arguments. Array-spec's of implied-shape should have been resolved to
15016 AS_EXPLICIT already. */
15020 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
15021 specification expression. */
15022 if (as
->type
== AS_IMPLIED_SHAPE
)
15025 for (i
=0; i
<as
->rank
; i
++)
15027 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
15029 gfc_error ("Bad specification for assumed size array at %L",
15030 &as
->lower
[i
]->where
);
15037 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
15038 || as
->type
== AS_ASSUMED_SHAPE
)
15039 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
15041 if (as
->type
== AS_ASSUMED_SIZE
)
15042 gfc_error ("Assumed size array at %L must be a dummy argument",
15043 &sym
->declared_at
);
15045 gfc_error ("Assumed shape array at %L must be a dummy argument",
15046 &sym
->declared_at
);
15049 /* TS 29113, C535a. */
15050 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
15051 && !sym
->attr
.select_type_temporary
)
15053 gfc_error ("Assumed-rank array at %L must be a dummy argument",
15054 &sym
->declared_at
);
15057 if (as
->type
== AS_ASSUMED_RANK
15058 && (sym
->attr
.codimension
|| sym
->attr
.value
))
15060 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15061 "CODIMENSION attribute", &sym
->declared_at
);
15066 /* Make sure symbols with known intent or optional are really dummy
15067 variable. Because of ENTRY statement, this has to be deferred
15068 until resolution time. */
15070 if (!sym
->attr
.dummy
15071 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
15073 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
15077 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
15079 gfc_error ("%qs at %L cannot have the VALUE attribute because "
15080 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
15084 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
15086 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
15087 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
15089 gfc_error ("Character dummy variable %qs at %L with VALUE "
15090 "attribute must have constant length",
15091 sym
->name
, &sym
->declared_at
);
15095 if (sym
->ts
.is_c_interop
15096 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
15098 gfc_error ("C interoperable character dummy variable %qs at %L "
15099 "with VALUE attribute must have length one",
15100 sym
->name
, &sym
->declared_at
);
15105 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15106 && sym
->ts
.u
.derived
->attr
.generic
)
15108 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
15109 if (!sym
->ts
.u
.derived
)
15111 gfc_error ("The derived type %qs at %L is of type %qs, "
15112 "which has not been defined", sym
->name
,
15113 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15114 sym
->ts
.type
= BT_UNKNOWN
;
15119 /* Use the same constraints as TYPE(*), except for the type check
15120 and that only scalars and assumed-size arrays are permitted. */
15121 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
15123 if (!sym
->attr
.dummy
)
15125 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15126 "a dummy argument", sym
->name
, &sym
->declared_at
);
15130 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
15131 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
15132 && sym
->ts
.type
!= BT_COMPLEX
)
15134 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15135 "of type TYPE(*) or of an numeric intrinsic type",
15136 sym
->name
, &sym
->declared_at
);
15140 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15141 || sym
->attr
.pointer
|| sym
->attr
.value
)
15143 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15144 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15145 "attribute", sym
->name
, &sym
->declared_at
);
15149 if (sym
->attr
.intent
== INTENT_OUT
)
15151 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15152 "have the INTENT(OUT) attribute",
15153 sym
->name
, &sym
->declared_at
);
15156 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
15158 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15159 "either be a scalar or an assumed-size array",
15160 sym
->name
, &sym
->declared_at
);
15164 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15165 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15167 sym
->ts
.type
= BT_ASSUMED
;
15168 sym
->as
= gfc_get_array_spec ();
15169 sym
->as
->type
= AS_ASSUMED_SIZE
;
15171 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
15173 else if (sym
->ts
.type
== BT_ASSUMED
)
15175 /* TS 29113, C407a. */
15176 if (!sym
->attr
.dummy
)
15178 gfc_error ("Assumed type of variable %s at %L is only permitted "
15179 "for dummy variables", sym
->name
, &sym
->declared_at
);
15182 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15183 || sym
->attr
.pointer
|| sym
->attr
.value
)
15185 gfc_error ("Assumed-type variable %s at %L may not have the "
15186 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15187 sym
->name
, &sym
->declared_at
);
15190 if (sym
->attr
.intent
== INTENT_OUT
)
15192 gfc_error ("Assumed-type variable %s at %L may not have the "
15193 "INTENT(OUT) attribute",
15194 sym
->name
, &sym
->declared_at
);
15197 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
15199 gfc_error ("Assumed-type variable %s at %L shall not be an "
15200 "explicit-shape array", sym
->name
, &sym
->declared_at
);
15205 /* If the symbol is marked as bind(c), that it is declared at module level
15206 scope and verify its type and kind. Do not do the latter for symbols
15207 that are implicitly typed because that is handled in
15208 gfc_set_default_type. Handle dummy arguments and procedure definitions
15209 separately. Also, anything that is use associated is not handled here
15210 but instead is handled in the module it is declared in. Finally, derived
15211 type definitions are allowed to be BIND(C) since that only implies that
15212 they're interoperable, and they are checked fully for interoperability
15213 when a variable is declared of that type. */
15214 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15215 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15216 && sym
->attr
.flavor
!= FL_DERIVED
)
15220 /* First, make sure the variable is declared at the
15221 module-level scope (J3/04-007, Section 15.3). */
15222 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
15223 sym
->attr
.in_common
== 0)
15225 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15226 "is neither a COMMON block nor declared at the "
15227 "module level scope", sym
->name
, &(sym
->declared_at
));
15230 else if (sym
->ts
.type
== BT_CHARACTER
15231 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15232 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15233 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15235 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15236 sym
->name
, &sym
->declared_at
);
15239 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15241 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15243 else if (sym
->attr
.implicit_type
== 0)
15245 /* If type() declaration, we need to verify that the components
15246 of the given type are all C interoperable, etc. */
15247 if (sym
->ts
.type
== BT_DERIVED
&&
15248 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15250 /* Make sure the user marked the derived type as BIND(C). If
15251 not, call the verify routine. This could print an error
15252 for the derived type more than once if multiple variables
15253 of that type are declared. */
15254 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15255 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15259 /* Verify the variable itself as C interoperable if it
15260 is BIND(C). It is not possible for this to succeed if
15261 the verify_bind_c_derived_type failed, so don't have to handle
15262 any error returned by verify_bind_c_derived_type. */
15263 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15264 sym
->common_block
);
15269 /* clear the is_bind_c flag to prevent reporting errors more than
15270 once if something failed. */
15271 sym
->attr
.is_bind_c
= 0;
15276 /* If a derived type symbol has reached this point, without its
15277 type being declared, we have an error. Notice that most
15278 conditions that produce undefined derived types have already
15279 been dealt with. However, the likes of:
15280 implicit type(t) (t) ..... call foo (t) will get us here if
15281 the type is not declared in the scope of the implicit
15282 statement. Change the type to BT_UNKNOWN, both because it is so
15283 and to prevent an ICE. */
15284 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15285 && sym
->ts
.u
.derived
->components
== NULL
15286 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
15288 gfc_error ("The derived type %qs at %L is of type %qs, "
15289 "which has not been defined", sym
->name
,
15290 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15291 sym
->ts
.type
= BT_UNKNOWN
;
15295 /* Make sure that the derived type has been resolved and that the
15296 derived type is visible in the symbol's namespace, if it is a
15297 module function and is not PRIVATE. */
15298 if (sym
->ts
.type
== BT_DERIVED
15299 && sym
->ts
.u
.derived
->attr
.use_assoc
15300 && sym
->ns
->proc_name
15301 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15302 && !resolve_fl_derived (sym
->ts
.u
.derived
))
15305 /* Unless the derived-type declaration is use associated, Fortran 95
15306 does not allow public entries of private derived types.
15307 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15308 161 in 95-006r3. */
15309 if (sym
->ts
.type
== BT_DERIVED
15310 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15311 && !sym
->ts
.u
.derived
->attr
.use_assoc
15312 && gfc_check_symbol_access (sym
)
15313 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15314 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
15315 "derived type %qs",
15316 (sym
->attr
.flavor
== FL_PARAMETER
)
15317 ? "parameter" : "variable",
15318 sym
->name
, &sym
->declared_at
,
15319 sym
->ts
.u
.derived
->name
))
15322 /* F2008, C1302. */
15323 if (sym
->ts
.type
== BT_DERIVED
15324 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15325 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
15326 || sym
->ts
.u
.derived
->attr
.lock_comp
)
15327 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15329 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15330 "type LOCK_TYPE must be a coarray", sym
->name
,
15331 &sym
->declared_at
);
15335 /* TS18508, C702/C703. */
15336 if (sym
->ts
.type
== BT_DERIVED
15337 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15338 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
15339 || sym
->ts
.u
.derived
->attr
.event_comp
)
15340 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15342 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15343 "type EVENT_TYPE must be a coarray", sym
->name
,
15344 &sym
->declared_at
);
15348 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15349 default initialization is defined (5.1.2.4.4). */
15350 if (sym
->ts
.type
== BT_DERIVED
15352 && sym
->attr
.intent
== INTENT_OUT
15354 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15356 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15358 if (c
->initializer
)
15360 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15361 "ASSUMED SIZE and so cannot have a default initializer",
15362 sym
->name
, &sym
->declared_at
);
15369 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15370 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15372 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15373 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15378 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15379 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15381 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15382 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15387 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15388 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15389 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15390 || class_attr
.codimension
)
15391 && (sym
->attr
.result
|| sym
->result
== sym
))
15393 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15394 "a coarray component", sym
->name
, &sym
->declared_at
);
15399 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15400 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15402 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15403 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15408 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15409 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15410 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15411 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15412 || class_attr
.allocatable
))
15414 gfc_error ("Variable %qs at %L with coarray component shall be a "
15415 "nonpointer, nonallocatable scalar, which is not a coarray",
15416 sym
->name
, &sym
->declared_at
);
15420 /* F2008, C526. The function-result case was handled above. */
15421 if (class_attr
.codimension
15422 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15423 || sym
->attr
.select_type_temporary
15424 || sym
->attr
.associate_var
15425 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15426 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15427 || sym
->ns
->proc_name
->attr
.is_main_program
15428 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15430 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15431 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15435 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15436 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15438 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15439 "deferred shape", sym
->name
, &sym
->declared_at
);
15442 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15443 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15445 gfc_error ("Allocatable coarray variable %qs at %L must have "
15446 "deferred shape", sym
->name
, &sym
->declared_at
);
15451 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15452 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15453 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15454 || (class_attr
.codimension
&& class_attr
.allocatable
))
15455 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15457 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15458 "allocatable coarray or have coarray components",
15459 sym
->name
, &sym
->declared_at
);
15463 if (class_attr
.codimension
&& sym
->attr
.dummy
15464 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15466 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15467 "procedure %qs", sym
->name
, &sym
->declared_at
,
15468 sym
->ns
->proc_name
->name
);
15472 if (sym
->ts
.type
== BT_LOGICAL
15473 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15474 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15475 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15478 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15479 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15481 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15482 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15483 "%L with non-C_Bool kind in BIND(C) procedure "
15484 "%qs", sym
->name
, &sym
->declared_at
,
15485 sym
->ns
->proc_name
->name
))
15487 else if (!gfc_logical_kinds
[i
].c_bool
15488 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15489 "%qs at %L with non-C_Bool kind in "
15490 "BIND(C) procedure %qs", sym
->name
,
15492 sym
->attr
.function
? sym
->name
15493 : sym
->ns
->proc_name
->name
))
15497 switch (sym
->attr
.flavor
)
15500 if (!resolve_fl_variable (sym
, mp_flag
))
15505 if (sym
->formal
&& !sym
->formal_ns
)
15507 /* Check that none of the arguments are a namelist. */
15508 gfc_formal_arglist
*formal
= sym
->formal
;
15510 for (; formal
; formal
= formal
->next
)
15511 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15513 gfc_error ("Namelist %qs cannot be an argument to "
15514 "subroutine or function at %L",
15515 formal
->sym
->name
, &sym
->declared_at
);
15520 if (!resolve_fl_procedure (sym
, mp_flag
))
15525 if (!resolve_fl_namelist (sym
))
15530 if (!resolve_fl_parameter (sym
))
15538 /* Resolve array specifier. Check as well some constraints
15539 on COMMON blocks. */
15541 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15543 /* Set the formal_arg_flag so that check_conflict will not throw
15544 an error for host associated variables in the specification
15545 expression for an array_valued function. */
15546 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
15547 formal_arg_flag
= true;
15549 saved_specification_expr
= specification_expr
;
15550 specification_expr
= true;
15551 gfc_resolve_array_spec (sym
->as
, check_constant
);
15552 specification_expr
= saved_specification_expr
;
15554 formal_arg_flag
= false;
15556 /* Resolve formal namespaces. */
15557 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15558 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15559 gfc_resolve (sym
->formal_ns
);
15561 /* Make sure the formal namespace is present. */
15562 if (sym
->formal
&& !sym
->formal_ns
)
15564 gfc_formal_arglist
*formal
= sym
->formal
;
15565 while (formal
&& !formal
->sym
)
15566 formal
= formal
->next
;
15570 sym
->formal_ns
= formal
->sym
->ns
;
15571 if (sym
->ns
!= formal
->sym
->ns
)
15572 sym
->formal_ns
->refs
++;
15576 /* Check threadprivate restrictions. */
15577 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15578 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15579 && (!sym
->attr
.in_common
15580 && sym
->module
== NULL
15581 && (sym
->ns
->proc_name
== NULL
15582 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15583 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15585 /* Check omp declare target restrictions. */
15586 if (sym
->attr
.omp_declare_target
15587 && sym
->attr
.flavor
== FL_VARIABLE
15589 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15590 && (!sym
->attr
.in_common
15591 && sym
->module
== NULL
15592 && (sym
->ns
->proc_name
== NULL
15593 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15594 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15595 sym
->name
, &sym
->declared_at
);
15597 /* If we have come this far we can apply default-initializers, as
15598 described in 14.7.5, to those variables that have not already
15599 been assigned one. */
15600 if (sym
->ts
.type
== BT_DERIVED
15602 && !sym
->attr
.allocatable
15603 && !sym
->attr
.alloc_comp
)
15605 symbol_attribute
*a
= &sym
->attr
;
15607 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15608 && !a
->in_common
&& !a
->use_assoc
15610 && !((a
->function
|| a
->result
)
15612 || sym
->ts
.u
.derived
->attr
.alloc_comp
15613 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15614 && !(a
->function
&& sym
!= sym
->result
))
15615 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15616 apply_default_init (sym
);
15617 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15618 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15619 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15620 /* Mark the result symbol to be referenced, when it has allocatable
15622 sym
->result
->attr
.referenced
= 1;
15625 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15626 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15627 && !CLASS_DATA (sym
)->attr
.class_pointer
15628 && !CLASS_DATA (sym
)->attr
.allocatable
)
15629 apply_default_init (sym
);
15631 /* If this symbol has a type-spec, check it. */
15632 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15633 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15634 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15637 if (sym
->param_list
)
15642 /************* Resolve DATA statements *************/
15646 gfc_data_value
*vnode
;
15652 /* Advance the values structure to point to the next value in the data list. */
15655 next_data_value (void)
15657 while (mpz_cmp_ui (values
.left
, 0) == 0)
15660 if (values
.vnode
->next
== NULL
)
15663 values
.vnode
= values
.vnode
->next
;
15664 mpz_set (values
.left
, values
.vnode
->repeat
);
15672 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15678 ar_type mark
= AR_UNKNOWN
;
15680 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15686 if (!gfc_resolve_expr (var
->expr
))
15690 mpz_init_set_si (offset
, 0);
15693 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15694 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15695 e
= e
->value
.function
.actual
->expr
;
15697 if (e
->expr_type
!= EXPR_VARIABLE
)
15699 gfc_error ("Expecting definable entity near %L", where
);
15703 sym
= e
->symtree
->n
.sym
;
15705 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15707 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15708 sym
->name
, &sym
->declared_at
);
15712 if (e
->ref
== NULL
&& sym
->as
)
15714 gfc_error ("DATA array %qs at %L must be specified in a previous"
15715 " declaration", sym
->name
, where
);
15719 if (gfc_is_coindexed (e
))
15721 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15726 has_pointer
= sym
->attr
.pointer
;
15728 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15730 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15735 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_FULL
)
15737 gfc_error ("DATA element %qs at %L is a pointer and so must "
15738 "be a full array", sym
->name
, where
);
15742 if (values
.vnode
->expr
->expr_type
== EXPR_CONSTANT
)
15744 gfc_error ("DATA object near %L has the pointer attribute "
15745 "and the corresponding DATA value is not a valid "
15746 "initial-data-target", where
);
15752 if (e
->rank
== 0 || has_pointer
)
15754 mpz_init_set_ui (size
, 1);
15761 /* Find the array section reference. */
15762 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15764 if (ref
->type
!= REF_ARRAY
)
15766 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15772 /* Set marks according to the reference pattern. */
15773 switch (ref
->u
.ar
.type
)
15781 /* Get the start position of array section. */
15782 gfc_get_section_index (ar
, section_index
, &offset
);
15787 gcc_unreachable ();
15790 if (!gfc_array_size (e
, &size
))
15792 gfc_error ("Nonconstant array section at %L in DATA statement",
15794 mpz_clear (offset
);
15801 while (mpz_cmp_ui (size
, 0) > 0)
15803 if (!next_data_value ())
15805 gfc_error ("DATA statement at %L has more variables than values",
15811 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
15815 /* If we have more than one element left in the repeat count,
15816 and we have more than one element left in the target variable,
15817 then create a range assignment. */
15818 /* FIXME: Only done for full arrays for now, since array sections
15820 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
15821 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
15825 if (mpz_cmp (size
, values
.left
) >= 0)
15827 mpz_init_set (range
, values
.left
);
15828 mpz_sub (size
, size
, values
.left
);
15829 mpz_set_ui (values
.left
, 0);
15833 mpz_init_set (range
, size
);
15834 mpz_sub (values
.left
, values
.left
, size
);
15835 mpz_set_ui (size
, 0);
15838 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15841 mpz_add (offset
, offset
, range
);
15848 /* Assign initial value to symbol. */
15851 mpz_sub_ui (values
.left
, values
.left
, 1);
15852 mpz_sub_ui (size
, size
, 1);
15854 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15859 if (mark
== AR_FULL
)
15860 mpz_add_ui (offset
, offset
, 1);
15862 /* Modify the array section indexes and recalculate the offset
15863 for next element. */
15864 else if (mark
== AR_SECTION
)
15865 gfc_advance_section (section_index
, ar
, &offset
);
15869 if (mark
== AR_SECTION
)
15871 for (i
= 0; i
< ar
->dimen
; i
++)
15872 mpz_clear (section_index
[i
]);
15876 mpz_clear (offset
);
15882 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15884 /* Iterate over a list of elements in a DATA statement. */
15887 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15890 iterator_stack frame
;
15891 gfc_expr
*e
, *start
, *end
, *step
;
15892 bool retval
= true;
15894 mpz_init (frame
.value
);
15897 start
= gfc_copy_expr (var
->iter
.start
);
15898 end
= gfc_copy_expr (var
->iter
.end
);
15899 step
= gfc_copy_expr (var
->iter
.step
);
15901 if (!gfc_simplify_expr (start
, 1)
15902 || start
->expr_type
!= EXPR_CONSTANT
)
15904 gfc_error ("start of implied-do loop at %L could not be "
15905 "simplified to a constant value", &start
->where
);
15909 if (!gfc_simplify_expr (end
, 1)
15910 || end
->expr_type
!= EXPR_CONSTANT
)
15912 gfc_error ("end of implied-do loop at %L could not be "
15913 "simplified to a constant value", &start
->where
);
15917 if (!gfc_simplify_expr (step
, 1)
15918 || step
->expr_type
!= EXPR_CONSTANT
)
15920 gfc_error ("step of implied-do loop at %L could not be "
15921 "simplified to a constant value", &start
->where
);
15926 mpz_set (trip
, end
->value
.integer
);
15927 mpz_sub (trip
, trip
, start
->value
.integer
);
15928 mpz_add (trip
, trip
, step
->value
.integer
);
15930 mpz_div (trip
, trip
, step
->value
.integer
);
15932 mpz_set (frame
.value
, start
->value
.integer
);
15934 frame
.prev
= iter_stack
;
15935 frame
.variable
= var
->iter
.var
->symtree
;
15936 iter_stack
= &frame
;
15938 while (mpz_cmp_ui (trip
, 0) > 0)
15940 if (!traverse_data_var (var
->list
, where
))
15946 e
= gfc_copy_expr (var
->expr
);
15947 if (!gfc_simplify_expr (e
, 1))
15954 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15956 mpz_sub_ui (trip
, trip
, 1);
15960 mpz_clear (frame
.value
);
15963 gfc_free_expr (start
);
15964 gfc_free_expr (end
);
15965 gfc_free_expr (step
);
15967 iter_stack
= frame
.prev
;
15972 /* Type resolve variables in the variable list of a DATA statement. */
15975 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15979 for (; var
; var
= var
->next
)
15981 if (var
->expr
== NULL
)
15982 t
= traverse_data_list (var
, where
);
15984 t
= check_data_variable (var
, where
);
15994 /* Resolve the expressions and iterators associated with a data statement.
15995 This is separate from the assignment checking because data lists should
15996 only be resolved once. */
15999 resolve_data_variables (gfc_data_variable
*d
)
16001 for (; d
; d
= d
->next
)
16003 if (d
->list
== NULL
)
16005 if (!gfc_resolve_expr (d
->expr
))
16010 if (!gfc_resolve_iterator (&d
->iter
, false, true))
16013 if (!resolve_data_variables (d
->list
))
16022 /* Resolve a single DATA statement. We implement this by storing a pointer to
16023 the value list into static variables, and then recursively traversing the
16024 variables list, expanding iterators and such. */
16027 resolve_data (gfc_data
*d
)
16030 if (!resolve_data_variables (d
->var
))
16033 values
.vnode
= d
->value
;
16034 if (d
->value
== NULL
)
16035 mpz_set_ui (values
.left
, 0);
16037 mpz_set (values
.left
, d
->value
->repeat
);
16039 if (!traverse_data_var (d
->var
, &d
->where
))
16042 /* At this point, we better not have any values left. */
16044 if (next_data_value ())
16045 gfc_error ("DATA statement at %L has more values than variables",
16050 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
16051 accessed by host or use association, is a dummy argument to a pure function,
16052 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
16053 is storage associated with any such variable, shall not be used in the
16054 following contexts: (clients of this function). */
16056 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
16057 procedure. Returns zero if assignment is OK, nonzero if there is a
16060 gfc_impure_variable (gfc_symbol
*sym
)
16065 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
16068 /* Check if the symbol's ns is inside the pure procedure. */
16069 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16073 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
16077 proc
= sym
->ns
->proc_name
;
16078 if (sym
->attr
.dummy
16079 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
16080 || proc
->attr
.function
))
16083 /* TODO: Sort out what can be storage associated, if anything, and include
16084 it here. In principle equivalences should be scanned but it does not
16085 seem to be possible to storage associate an impure variable this way. */
16090 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
16091 current namespace is inside a pure procedure. */
16094 gfc_pure (gfc_symbol
*sym
)
16096 symbol_attribute attr
;
16101 /* Check if the current namespace or one of its parents
16102 belongs to a pure procedure. */
16103 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16105 sym
= ns
->proc_name
;
16109 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
16117 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
16121 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16122 checks if the current namespace is implicitly pure. Note that this
16123 function returns false for a PURE procedure. */
16126 gfc_implicit_pure (gfc_symbol
*sym
)
16132 /* Check if the current procedure is implicit_pure. Walk up
16133 the procedure list until we find a procedure. */
16134 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16136 sym
= ns
->proc_name
;
16140 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16145 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
16146 && !sym
->attr
.pure
;
16151 gfc_unset_implicit_pure (gfc_symbol
*sym
)
16157 /* Check if the current procedure is implicit_pure. Walk up
16158 the procedure list until we find a procedure. */
16159 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16161 sym
= ns
->proc_name
;
16165 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16170 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16171 sym
->attr
.implicit_pure
= 0;
16173 sym
->attr
.pure
= 0;
16177 /* Test whether the current procedure is elemental or not. */
16180 gfc_elemental (gfc_symbol
*sym
)
16182 symbol_attribute attr
;
16185 sym
= gfc_current_ns
->proc_name
;
16190 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
16194 /* Warn about unused labels. */
16197 warn_unused_fortran_label (gfc_st_label
*label
)
16202 warn_unused_fortran_label (label
->left
);
16204 if (label
->defined
== ST_LABEL_UNKNOWN
)
16207 switch (label
->referenced
)
16209 case ST_LABEL_UNKNOWN
:
16210 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
16211 label
->value
, &label
->where
);
16214 case ST_LABEL_BAD_TARGET
:
16215 gfc_warning (OPT_Wunused_label
,
16216 "Label %d at %L defined but cannot be used",
16217 label
->value
, &label
->where
);
16224 warn_unused_fortran_label (label
->right
);
16228 /* Returns the sequence type of a symbol or sequence. */
16231 sequence_type (gfc_typespec ts
)
16240 if (ts
.u
.derived
->components
== NULL
)
16241 return SEQ_NONDEFAULT
;
16243 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16244 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16245 if (sequence_type (c
->ts
) != result
)
16251 if (ts
.kind
!= gfc_default_character_kind
)
16252 return SEQ_NONDEFAULT
;
16254 return SEQ_CHARACTER
;
16257 if (ts
.kind
!= gfc_default_integer_kind
)
16258 return SEQ_NONDEFAULT
;
16260 return SEQ_NUMERIC
;
16263 if (!(ts
.kind
== gfc_default_real_kind
16264 || ts
.kind
== gfc_default_double_kind
))
16265 return SEQ_NONDEFAULT
;
16267 return SEQ_NUMERIC
;
16270 if (ts
.kind
!= gfc_default_complex_kind
)
16271 return SEQ_NONDEFAULT
;
16273 return SEQ_NUMERIC
;
16276 if (ts
.kind
!= gfc_default_logical_kind
)
16277 return SEQ_NONDEFAULT
;
16279 return SEQ_NUMERIC
;
16282 return SEQ_NONDEFAULT
;
16287 /* Resolve derived type EQUIVALENCE object. */
16290 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
16292 gfc_component
*c
= derived
->components
;
16297 /* Shall not be an object of nonsequence derived type. */
16298 if (!derived
->attr
.sequence
)
16300 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16301 "attribute to be an EQUIVALENCE object", sym
->name
,
16306 /* Shall not have allocatable components. */
16307 if (derived
->attr
.alloc_comp
)
16309 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16310 "components to be an EQUIVALENCE object",sym
->name
,
16315 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
16317 gfc_error ("Derived type variable %qs at %L with default "
16318 "initialization cannot be in EQUIVALENCE with a variable "
16319 "in COMMON", sym
->name
, &e
->where
);
16323 for (; c
; c
= c
->next
)
16325 if (gfc_bt_struct (c
->ts
.type
)
16326 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
16329 /* Shall not be an object of sequence derived type containing a pointer
16330 in the structure. */
16331 if (c
->attr
.pointer
)
16333 gfc_error ("Derived type variable %qs at %L with pointer "
16334 "component(s) cannot be an EQUIVALENCE object",
16335 sym
->name
, &e
->where
);
16343 /* Resolve equivalence object.
16344 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16345 an allocatable array, an object of nonsequence derived type, an object of
16346 sequence derived type containing a pointer at any level of component
16347 selection, an automatic object, a function name, an entry name, a result
16348 name, a named constant, a structure component, or a subobject of any of
16349 the preceding objects. A substring shall not have length zero. A
16350 derived type shall not have components with default initialization nor
16351 shall two objects of an equivalence group be initialized.
16352 Either all or none of the objects shall have an protected attribute.
16353 The simple constraints are done in symbol.c(check_conflict) and the rest
16354 are implemented here. */
16357 resolve_equivalence (gfc_equiv
*eq
)
16360 gfc_symbol
*first_sym
;
16363 locus
*last_where
= NULL
;
16364 seq_type eq_type
, last_eq_type
;
16365 gfc_typespec
*last_ts
;
16366 int object
, cnt_protected
;
16369 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16371 first_sym
= eq
->expr
->symtree
->n
.sym
;
16375 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16379 e
->ts
= e
->symtree
->n
.sym
->ts
;
16380 /* match_varspec might not know yet if it is seeing
16381 array reference or substring reference, as it doesn't
16383 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16385 gfc_ref
*ref
= e
->ref
;
16386 sym
= e
->symtree
->n
.sym
;
16388 if (sym
->attr
.dimension
)
16390 ref
->u
.ar
.as
= sym
->as
;
16394 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16395 if (e
->ts
.type
== BT_CHARACTER
16397 && ref
->type
== REF_ARRAY
16398 && ref
->u
.ar
.dimen
== 1
16399 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16400 && ref
->u
.ar
.stride
[0] == NULL
)
16402 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16403 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16406 /* Optimize away the (:) reference. */
16407 if (start
== NULL
&& end
== NULL
)
16410 e
->ref
= ref
->next
;
16412 e
->ref
->next
= ref
->next
;
16417 ref
->type
= REF_SUBSTRING
;
16419 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16421 ref
->u
.ss
.start
= start
;
16422 if (end
== NULL
&& e
->ts
.u
.cl
)
16423 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16424 ref
->u
.ss
.end
= end
;
16425 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16432 /* Any further ref is an error. */
16435 gcc_assert (ref
->type
== REF_ARRAY
);
16436 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16442 if (!gfc_resolve_expr (e
))
16445 sym
= e
->symtree
->n
.sym
;
16447 if (sym
->attr
.is_protected
)
16449 if (cnt_protected
> 0 && cnt_protected
!= object
)
16451 gfc_error ("Either all or none of the objects in the "
16452 "EQUIVALENCE set at %L shall have the "
16453 "PROTECTED attribute",
16458 /* Shall not equivalence common block variables in a PURE procedure. */
16459 if (sym
->ns
->proc_name
16460 && sym
->ns
->proc_name
->attr
.pure
16461 && sym
->attr
.in_common
)
16463 /* Need to check for symbols that may have entered the pure
16464 procedure via a USE statement. */
16465 bool saw_sym
= false;
16466 if (sym
->ns
->use_stmts
)
16469 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16470 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16476 gfc_error ("COMMON block member %qs at %L cannot be an "
16477 "EQUIVALENCE object in the pure procedure %qs",
16478 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16482 /* Shall not be a named constant. */
16483 if (e
->expr_type
== EXPR_CONSTANT
)
16485 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16486 "object", sym
->name
, &e
->where
);
16490 if (e
->ts
.type
== BT_DERIVED
16491 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16494 /* Check that the types correspond correctly:
16496 A numeric sequence structure may be equivalenced to another sequence
16497 structure, an object of default integer type, default real type, double
16498 precision real type, default logical type such that components of the
16499 structure ultimately only become associated to objects of the same
16500 kind. A character sequence structure may be equivalenced to an object
16501 of default character kind or another character sequence structure.
16502 Other objects may be equivalenced only to objects of the same type and
16503 kind parameters. */
16505 /* Identical types are unconditionally OK. */
16506 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16507 goto identical_types
;
16509 last_eq_type
= sequence_type (*last_ts
);
16510 eq_type
= sequence_type (sym
->ts
);
16512 /* Since the pair of objects is not of the same type, mixed or
16513 non-default sequences can be rejected. */
16515 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16516 "statement at %L with different type objects";
16518 && last_eq_type
== SEQ_MIXED
16519 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16520 || (eq_type
== SEQ_MIXED
16521 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16524 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16525 "statement at %L with objects of different type";
16527 && last_eq_type
== SEQ_NONDEFAULT
16528 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16529 || (eq_type
== SEQ_NONDEFAULT
16530 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16533 msg
="Non-CHARACTER object %qs in default CHARACTER "
16534 "EQUIVALENCE statement at %L";
16535 if (last_eq_type
== SEQ_CHARACTER
16536 && eq_type
!= SEQ_CHARACTER
16537 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16540 msg
="Non-NUMERIC object %qs in default NUMERIC "
16541 "EQUIVALENCE statement at %L";
16542 if (last_eq_type
== SEQ_NUMERIC
16543 && eq_type
!= SEQ_NUMERIC
16544 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16549 last_where
= &e
->where
;
16554 /* Shall not be an automatic array. */
16555 if (e
->ref
->type
== REF_ARRAY
16556 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16558 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16559 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16566 /* Shall not be a structure component. */
16567 if (r
->type
== REF_COMPONENT
)
16569 gfc_error ("Structure component %qs at %L cannot be an "
16570 "EQUIVALENCE object",
16571 r
->u
.c
.component
->name
, &e
->where
);
16575 /* A substring shall not have length zero. */
16576 if (r
->type
== REF_SUBSTRING
)
16578 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16580 gfc_error ("Substring at %L has length zero",
16581 &r
->u
.ss
.start
->where
);
16591 /* Function called by resolve_fntype to flag other symbol used in the
16592 length type parameter specification of function resuls. */
16595 flag_fn_result_spec (gfc_expr
*expr
,
16597 int *f ATTRIBUTE_UNUSED
)
16602 if (expr
->expr_type
== EXPR_VARIABLE
)
16604 s
= expr
->symtree
->n
.sym
;
16605 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16611 gfc_error ("Self reference in character length expression "
16612 "for %qs at %L", sym
->name
, &expr
->where
);
16616 if (!s
->fn_result_spec
16617 && s
->attr
.flavor
== FL_PARAMETER
)
16619 /* Function contained in a module.... */
16620 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16623 s
->fn_result_spec
= 1;
16624 /* Make sure that this symbol is translated as a module
16626 st
= gfc_get_unique_symtree (ns
);
16630 /* ... which is use associated and called. */
16631 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16633 /* External function matched with an interface. */
16636 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16637 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16638 && s
->ns
->proc_name
->attr
.function
))
16639 s
->fn_result_spec
= 1;
16646 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16649 resolve_fntype (gfc_namespace
*ns
)
16651 gfc_entry_list
*el
;
16654 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16657 /* If there are any entries, ns->proc_name is the entry master
16658 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16660 sym
= ns
->entries
->sym
;
16662 sym
= ns
->proc_name
;
16663 if (sym
->result
== sym
16664 && sym
->ts
.type
== BT_UNKNOWN
16665 && !gfc_set_default_type (sym
, 0, NULL
)
16666 && !sym
->attr
.untyped
)
16668 gfc_error ("Function %qs at %L has no IMPLICIT type",
16669 sym
->name
, &sym
->declared_at
);
16670 sym
->attr
.untyped
= 1;
16673 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16674 && !sym
->attr
.contained
16675 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16676 && gfc_check_symbol_access (sym
))
16678 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16679 "%L of PRIVATE type %qs", sym
->name
,
16680 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16684 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16686 if (el
->sym
->result
== el
->sym
16687 && el
->sym
->ts
.type
== BT_UNKNOWN
16688 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16689 && !el
->sym
->attr
.untyped
)
16691 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16692 el
->sym
->name
, &el
->sym
->declared_at
);
16693 el
->sym
->attr
.untyped
= 1;
16697 if (sym
->ts
.type
== BT_CHARACTER
)
16698 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16702 /* 12.3.2.1.1 Defined operators. */
16705 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16707 gfc_formal_arglist
*formal
;
16709 if (!sym
->attr
.function
)
16711 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16712 sym
->name
, &where
);
16716 if (sym
->ts
.type
== BT_CHARACTER
16717 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16718 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16719 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16721 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16722 "character length", sym
->name
, &where
);
16726 formal
= gfc_sym_get_dummy_args (sym
);
16727 if (!formal
|| !formal
->sym
)
16729 gfc_error ("User operator procedure %qs at %L must have at least "
16730 "one argument", sym
->name
, &where
);
16734 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16736 gfc_error ("First argument of operator interface at %L must be "
16737 "INTENT(IN)", &where
);
16741 if (formal
->sym
->attr
.optional
)
16743 gfc_error ("First argument of operator interface at %L cannot be "
16744 "optional", &where
);
16748 formal
= formal
->next
;
16749 if (!formal
|| !formal
->sym
)
16752 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16754 gfc_error ("Second argument of operator interface at %L must be "
16755 "INTENT(IN)", &where
);
16759 if (formal
->sym
->attr
.optional
)
16761 gfc_error ("Second argument of operator interface at %L cannot be "
16762 "optional", &where
);
16768 gfc_error ("Operator interface at %L must have, at most, two "
16769 "arguments", &where
);
16777 gfc_resolve_uops (gfc_symtree
*symtree
)
16779 gfc_interface
*itr
;
16781 if (symtree
== NULL
)
16784 gfc_resolve_uops (symtree
->left
);
16785 gfc_resolve_uops (symtree
->right
);
16787 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16788 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16792 /* Examine all of the expressions associated with a program unit,
16793 assign types to all intermediate expressions, make sure that all
16794 assignments are to compatible types and figure out which names
16795 refer to which functions or subroutines. It doesn't check code
16796 block, which is handled by gfc_resolve_code. */
16799 resolve_types (gfc_namespace
*ns
)
16805 gfc_namespace
* old_ns
= gfc_current_ns
;
16807 if (ns
->types_resolved
)
16810 /* Check that all IMPLICIT types are ok. */
16811 if (!ns
->seen_implicit_none
)
16814 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
16815 if (ns
->set_flag
[letter
]
16816 && !resolve_typespec_used (&ns
->default_type
[letter
],
16817 &ns
->implicit_loc
[letter
], NULL
))
16821 gfc_current_ns
= ns
;
16823 resolve_entries (ns
);
16825 resolve_common_vars (&ns
->blank_common
, false);
16826 resolve_common_blocks (ns
->common_root
);
16828 resolve_contained_functions (ns
);
16830 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
16831 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16832 resolve_formal_arglist (ns
->proc_name
);
16834 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
16836 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
16837 resolve_charlen (cl
);
16839 gfc_traverse_ns (ns
, resolve_symbol
);
16841 resolve_fntype (ns
);
16843 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16845 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
16846 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16847 "also be PURE", n
->proc_name
->name
,
16848 &n
->proc_name
->declared_at
);
16854 gfc_do_concurrent_flag
= 0;
16855 gfc_check_interfaces (ns
);
16857 gfc_traverse_ns (ns
, resolve_values
);
16859 if (ns
->save_all
|| !flag_automatic
)
16863 for (d
= ns
->data
; d
; d
= d
->next
)
16867 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16869 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16871 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16872 resolve_equivalence (eq
);
16874 /* Warn about unused labels. */
16875 if (warn_unused_label
)
16876 warn_unused_fortran_label (ns
->st_labels
);
16878 gfc_resolve_uops (ns
->uop_root
);
16880 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16882 gfc_resolve_omp_declare_simd (ns
);
16884 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16886 ns
->types_resolved
= 1;
16888 gfc_current_ns
= old_ns
;
16892 /* Call gfc_resolve_code recursively. */
16895 resolve_codes (gfc_namespace
*ns
)
16898 bitmap_obstack old_obstack
;
16900 if (ns
->resolved
== 1)
16903 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16906 gfc_current_ns
= ns
;
16908 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16909 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16912 /* Set to an out of range value. */
16913 current_entry_id
= -1;
16915 old_obstack
= labels_obstack
;
16916 bitmap_obstack_initialize (&labels_obstack
);
16918 gfc_resolve_oacc_declare (ns
);
16919 gfc_resolve_oacc_routines (ns
);
16920 gfc_resolve_omp_local_vars (ns
);
16921 gfc_resolve_code (ns
->code
, ns
);
16923 bitmap_obstack_release (&labels_obstack
);
16924 labels_obstack
= old_obstack
;
16928 /* This function is called after a complete program unit has been compiled.
16929 Its purpose is to examine all of the expressions associated with a program
16930 unit, assign types to all intermediate expressions, make sure that all
16931 assignments are to compatible types and figure out which names refer to
16932 which functions or subroutines. */
16935 gfc_resolve (gfc_namespace
*ns
)
16937 gfc_namespace
*old_ns
;
16938 code_stack
*old_cs_base
;
16939 struct gfc_omp_saved_state old_omp_state
;
16945 old_ns
= gfc_current_ns
;
16946 old_cs_base
= cs_base
;
16948 /* As gfc_resolve can be called during resolution of an OpenMP construct
16949 body, we should clear any state associated to it, so that say NS's
16950 DO loops are not interpreted as OpenMP loops. */
16951 if (!ns
->construct_entities
)
16952 gfc_omp_save_and_clear_state (&old_omp_state
);
16954 resolve_types (ns
);
16955 component_assignment_level
= 0;
16956 resolve_codes (ns
);
16958 gfc_current_ns
= old_ns
;
16959 cs_base
= old_cs_base
;
16962 gfc_run_passes (ns
);
16964 if (!ns
->construct_entities
)
16965 gfc_omp_restore_state (&old_omp_state
);