1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2019 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 #include "target-memory.h" /* for gfc_simplify_transfer */
31 #include "constructor.h"
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and gfc_resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code
*head
, *current
;
46 struct code_stack
*prev
;
48 /* This bitmap keeps track of the targets valid for a branch from
49 inside this block except for END {IF|SELECT}s of enclosing
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
60 static int forall_flag
;
61 int gfc_do_concurrent_flag
;
63 /* True when we are resolving an expression that is an actual argument to
65 static bool actual_arg
= false;
66 /* True when we are resolving an expression that is the first actual argument
68 static bool first_actual_arg
= false;
71 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
73 static int omp_workshare_flag
;
75 /* True if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static bool formal_arg_flag
= false;
79 /* True if we are resolving a specification expression. */
80 static bool specification_expr
= false;
82 /* The id of the last entry seen. */
83 static int current_entry_id
;
85 /* We use bitmaps to determine if a branch target is valid. */
86 static bitmap_obstack labels_obstack
;
88 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89 static bool inquiry_argument
= false;
93 gfc_is_formal_arg (void)
95 return formal_arg_flag
;
98 /* Is the symbol host associated? */
100 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
102 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
111 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
116 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
118 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name
, where
, ts
->u
.derived
->name
);
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts
->u
.derived
->name
, where
);
138 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
140 /* Several checks for F08:C1216. */
141 if (ifc
->attr
.procedure
)
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc
->name
, where
);
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface
*gen
= ifc
->generic
;
152 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
156 gfc_error ("Interface %qs at %L may not be generic",
161 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
163 gfc_error ("Interface %qs at %L may not be a statement function",
167 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
168 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
169 ifc
->attr
.intrinsic
= 1;
170 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc
->name
, where
);
176 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
178 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
185 static void resolve_symbol (gfc_symbol
*sym
);
188 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
191 resolve_procedure_interface (gfc_symbol
*sym
)
193 gfc_symbol
*ifc
= sym
->ts
.interface
;
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym
->name
, &sym
->declared_at
);
204 if (!check_proc_interface (ifc
, &sym
->declared_at
))
207 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc
);
211 if (ifc
->attr
.intrinsic
)
212 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
216 sym
->ts
= ifc
->result
->ts
;
217 sym
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
218 sym
->attr
.pointer
= ifc
->result
->attr
.pointer
;
219 sym
->attr
.dimension
= ifc
->result
->attr
.dimension
;
220 sym
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
221 sym
->as
= gfc_copy_array_spec (ifc
->result
->as
);
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.dimension
= ifc
->attr
.dimension
;
230 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
231 sym
->as
= gfc_copy_array_spec (ifc
->as
);
233 sym
->ts
.interface
= ifc
;
234 sym
->attr
.function
= ifc
->attr
.function
;
235 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
237 sym
->attr
.pure
= ifc
->attr
.pure
;
238 sym
->attr
.elemental
= ifc
->attr
.elemental
;
239 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
240 sym
->attr
.recursive
= ifc
->attr
.recursive
;
241 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
242 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
243 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
244 /* Copy char length. */
245 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
247 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
248 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
249 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
258 /* Resolve types of formal argument lists. These have to be done early so that
259 the formal argument lists of module procedures can be copied to the
260 containing module before the individual procedures are resolved
261 individually. We also resolve argument lists of procedures in interface
262 blocks because they are self-contained scoping units.
264 Since a dummy argument cannot be a non-dummy procedure, the only
265 resort left for untyped names are the IMPLICIT types. */
268 resolve_formal_arglist (gfc_symbol
*proc
)
270 gfc_formal_arglist
*f
;
272 bool saved_specification_expr
;
275 if (proc
->result
!= NULL
)
280 if (gfc_elemental (proc
)
281 || sym
->attr
.pointer
|| sym
->attr
.allocatable
282 || (sym
->as
&& sym
->as
->rank
!= 0))
284 proc
->attr
.always_explicit
= 1;
285 sym
->attr
.always_explicit
= 1;
288 formal_arg_flag
= true;
290 for (f
= proc
->formal
; f
; f
= f
->next
)
298 /* Alternate return placeholder. */
299 if (gfc_elemental (proc
))
300 gfc_error ("Alternate return specifier in elemental subroutine "
301 "%qs at %L is not allowed", proc
->name
,
303 if (proc
->attr
.function
)
304 gfc_error ("Alternate return specifier in function "
305 "%qs at %L is not allowed", proc
->name
,
309 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
310 && !resolve_procedure_interface (sym
))
313 if (strcmp (proc
->name
, sym
->name
) == 0)
315 gfc_error ("Self-referential argument "
316 "%qs at %L is not allowed", sym
->name
,
321 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
322 resolve_formal_arglist (sym
);
324 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
326 if (sym
->attr
.flavor
== FL_UNKNOWN
)
327 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
331 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
332 && (!sym
->attr
.function
|| sym
->result
== sym
))
333 gfc_set_default_type (sym
, 1, sym
->ns
);
336 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
337 ? CLASS_DATA (sym
)->as
: sym
->as
;
339 saved_specification_expr
= specification_expr
;
340 specification_expr
= true;
341 gfc_resolve_array_spec (as
, 0);
342 specification_expr
= saved_specification_expr
;
344 /* We can't tell if an array with dimension (:) is assumed or deferred
345 shape until we know if it has the pointer or allocatable attributes.
347 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
348 && ((sym
->ts
.type
!= BT_CLASS
349 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
350 || (sym
->ts
.type
== BT_CLASS
351 && !(CLASS_DATA (sym
)->attr
.class_pointer
352 || CLASS_DATA (sym
)->attr
.allocatable
)))
353 && sym
->attr
.flavor
!= FL_PROCEDURE
)
355 as
->type
= AS_ASSUMED_SHAPE
;
356 for (i
= 0; i
< as
->rank
; i
++)
357 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
360 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
361 || (as
&& as
->type
== AS_ASSUMED_RANK
)
362 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
363 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
364 && (CLASS_DATA (sym
)->attr
.class_pointer
365 || CLASS_DATA (sym
)->attr
.allocatable
366 || CLASS_DATA (sym
)->attr
.target
))
367 || sym
->attr
.optional
)
369 proc
->attr
.always_explicit
= 1;
371 proc
->result
->attr
.always_explicit
= 1;
374 /* If the flavor is unknown at this point, it has to be a variable.
375 A procedure specification would have already set the type. */
377 if (sym
->attr
.flavor
== FL_UNKNOWN
)
378 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
382 if (sym
->attr
.flavor
== FL_PROCEDURE
)
387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 "also be PURE", sym
->name
, &sym
->declared_at
);
392 else if (!sym
->attr
.pointer
)
394 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
397 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
398 " of pure function %qs at %L with VALUE "
399 "attribute but without INTENT(IN)",
400 sym
->name
, proc
->name
, &sym
->declared_at
);
402 gfc_error ("Argument %qs of pure function %qs at %L must "
403 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
407 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
410 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
411 " of pure subroutine %qs at %L with VALUE "
412 "attribute but without INTENT", sym
->name
,
413 proc
->name
, &sym
->declared_at
);
415 gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 "must have its INTENT specified or have the "
417 "VALUE attribute", sym
->name
, proc
->name
,
423 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 " may not be polymorphic", sym
->name
, proc
->name
,
432 if (proc
->attr
.implicit_pure
)
434 if (sym
->attr
.flavor
== FL_PROCEDURE
)
437 proc
->attr
.implicit_pure
= 0;
439 else if (!sym
->attr
.pointer
)
441 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
443 proc
->attr
.implicit_pure
= 0;
445 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
447 proc
->attr
.implicit_pure
= 0;
451 if (gfc_elemental (proc
))
454 if (sym
->attr
.codimension
455 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
456 && CLASS_DATA (sym
)->attr
.codimension
))
458 gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 "procedure", sym
->name
, &sym
->declared_at
);
463 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
464 && CLASS_DATA (sym
)->as
))
466 gfc_error ("Argument %qs of elemental procedure at %L must "
467 "be scalar", sym
->name
, &sym
->declared_at
);
471 if (sym
->attr
.allocatable
472 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
473 && CLASS_DATA (sym
)->attr
.allocatable
))
475 gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 "have the ALLOCATABLE attribute", sym
->name
,
481 if (sym
->attr
.pointer
482 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
483 && CLASS_DATA (sym
)->attr
.class_pointer
))
485 gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 "have the POINTER attribute", sym
->name
,
491 if (sym
->attr
.flavor
== FL_PROCEDURE
)
493 gfc_error ("Dummy procedure %qs not allowed in elemental "
494 "procedure %qs at %L", sym
->name
, proc
->name
,
499 /* Fortran 2008 Corrigendum 1, C1290a. */
500 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
502 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 "have its INTENT specified or have the VALUE "
504 "attribute", sym
->name
, proc
->name
,
510 /* Each dummy shall be specified to be scalar. */
511 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
515 /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 shall be specified, explicitly or implicitly, to be scalar. */
517 gfc_error ("Argument '%s' of statement function '%s' at %L "
518 "must be scalar", sym
->name
, proc
->name
,
523 if (sym
->ts
.type
== BT_CHARACTER
)
525 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
526 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
528 gfc_error ("Character-valued argument %qs of statement "
529 "function at %L must have constant length",
530 sym
->name
, &sym
->declared_at
);
536 formal_arg_flag
= false;
540 /* Work function called when searching for symbols that have argument lists
541 associated with them. */
544 find_arglists (gfc_symbol
*sym
)
546 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
547 || gfc_fl_struct (sym
->attr
.flavor
) || sym
->attr
.intrinsic
)
550 resolve_formal_arglist (sym
);
554 /* Given a namespace, resolve all formal argument lists within the namespace.
558 resolve_formal_arglists (gfc_namespace
*ns
)
563 gfc_traverse_ns (ns
, find_arglists
);
568 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
572 if (sym
&& sym
->attr
.flavor
== FL_PROCEDURE
574 && sym
->ns
->parent
->proc_name
575 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_PROCEDURE
576 && !strcmp (sym
->name
, sym
->ns
->parent
->proc_name
->name
))
577 gfc_error ("Contained procedure %qs at %L has the same name as its "
578 "encompassing procedure", sym
->name
, &sym
->declared_at
);
580 /* If this namespace is not a function or an entry master function,
582 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
583 || sym
->attr
.entry_master
)
589 /* Try to find out of what the return type is. */
590 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
592 t
= gfc_set_default_type (sym
->result
, 0, ns
);
594 if (!t
&& !sym
->result
->attr
.untyped
)
596 if (sym
->result
== sym
)
597 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
598 sym
->name
, &sym
->declared_at
);
599 else if (!sym
->result
->attr
.proc_pointer
)
600 gfc_error ("Result %qs of contained function %qs at %L has "
601 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
602 &sym
->result
->declared_at
);
603 sym
->result
->attr
.untyped
= 1;
607 /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
608 type, lists the only ways a character length value of * can be used:
609 dummy arguments of procedures, named constants, function results and
610 in allocate statements if the allocate_object is an assumed length dummy
611 in external functions. Internal function results and results of module
612 procedures are not on this list, ergo, not permitted. */
614 if (sym
->result
->ts
.type
== BT_CHARACTER
)
616 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
617 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
619 /* See if this is a module-procedure and adapt error message
622 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
623 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
625 gfc_error (module_proc
626 ? G_("Character-valued module procedure %qs at %L"
627 " must not be assumed length")
628 : G_("Character-valued internal function %qs at %L"
629 " must not be assumed length"),
630 sym
->name
, &sym
->declared_at
);
636 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
637 introduce duplicates. */
640 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
642 gfc_formal_arglist
*f
, *new_arglist
;
645 for (; new_args
!= NULL
; new_args
= new_args
->next
)
647 new_sym
= new_args
->sym
;
648 /* See if this arg is already in the formal argument list. */
649 for (f
= proc
->formal
; f
; f
= f
->next
)
651 if (new_sym
== f
->sym
)
658 /* Add a new argument. Argument order is not important. */
659 new_arglist
= gfc_get_formal_arglist ();
660 new_arglist
->sym
= new_sym
;
661 new_arglist
->next
= proc
->formal
;
662 proc
->formal
= new_arglist
;
667 /* Flag the arguments that are not present in all entries. */
670 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
672 gfc_formal_arglist
*f
, *head
;
675 for (f
= proc
->formal
; f
; f
= f
->next
)
680 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
682 if (new_args
->sym
== f
->sym
)
689 f
->sym
->attr
.not_always_present
= 1;
694 /* Resolve alternate entry points. If a symbol has multiple entry points we
695 create a new master symbol for the main routine, and turn the existing
696 symbol into an entry point. */
699 resolve_entries (gfc_namespace
*ns
)
701 gfc_namespace
*old_ns
;
705 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
706 static int master_count
= 0;
708 if (ns
->proc_name
== NULL
)
711 /* No need to do anything if this procedure doesn't have alternate entry
716 /* We may already have resolved alternate entry points. */
717 if (ns
->proc_name
->attr
.entry_master
)
720 /* If this isn't a procedure something has gone horribly wrong. */
721 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
723 /* Remember the current namespace. */
724 old_ns
= gfc_current_ns
;
728 /* Add the main entry point to the list of entry points. */
729 el
= gfc_get_entry_list ();
730 el
->sym
= ns
->proc_name
;
732 el
->next
= ns
->entries
;
734 ns
->proc_name
->attr
.entry
= 1;
736 /* If it is a module function, it needs to be in the right namespace
737 so that gfc_get_fake_result_decl can gather up the results. The
738 need for this arose in get_proc_name, where these beasts were
739 left in their own namespace, to keep prior references linked to
740 the entry declaration.*/
741 if (ns
->proc_name
->attr
.function
742 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
745 /* Do the same for entries where the master is not a module
746 procedure. These are retained in the module namespace because
747 of the module procedure declaration. */
748 for (el
= el
->next
; el
; el
= el
->next
)
749 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
750 && el
->sym
->attr
.mod_proc
)
754 /* Add an entry statement for it. */
755 c
= gfc_get_code (EXEC_ENTRY
);
760 /* Create a new symbol for the master function. */
761 /* Give the internal function a unique name (within this file).
762 Also include the function name so the user has some hope of figuring
763 out what is going on. */
764 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
765 master_count
++, ns
->proc_name
->name
);
766 gfc_get_ha_symbol (name
, &proc
);
767 gcc_assert (proc
!= NULL
);
769 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
770 if (ns
->proc_name
->attr
.subroutine
)
771 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
775 gfc_typespec
*ts
, *fts
;
776 gfc_array_spec
*as
, *fas
;
777 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
779 fas
= ns
->entries
->sym
->as
;
780 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
781 fts
= &ns
->entries
->sym
->result
->ts
;
782 if (fts
->type
== BT_UNKNOWN
)
783 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
784 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
786 ts
= &el
->sym
->result
->ts
;
788 as
= as
? as
: el
->sym
->result
->as
;
789 if (ts
->type
== BT_UNKNOWN
)
790 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
792 if (! gfc_compare_types (ts
, fts
)
793 || (el
->sym
->result
->attr
.dimension
794 != ns
->entries
->sym
->result
->attr
.dimension
)
795 || (el
->sym
->result
->attr
.pointer
796 != ns
->entries
->sym
->result
->attr
.pointer
))
798 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
799 && gfc_compare_array_spec (as
, fas
) == 0)
800 gfc_error ("Function %s at %L has entries with mismatched "
801 "array specifications", ns
->entries
->sym
->name
,
802 &ns
->entries
->sym
->declared_at
);
803 /* The characteristics need to match and thus both need to have
804 the same string length, i.e. both len=*, or both len=4.
805 Having both len=<variable> is also possible, but difficult to
806 check at compile time. */
807 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
808 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
809 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
811 && ts
->u
.cl
->length
->expr_type
812 != fts
->u
.cl
->length
->expr_type
)
814 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
815 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
816 fts
->u
.cl
->length
->value
.integer
) != 0)))
817 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
818 "entries returning variables of different "
819 "string lengths", ns
->entries
->sym
->name
,
820 &ns
->entries
->sym
->declared_at
);
825 sym
= ns
->entries
->sym
->result
;
826 /* All result types the same. */
828 if (sym
->attr
.dimension
)
829 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
830 if (sym
->attr
.pointer
)
831 gfc_add_pointer (&proc
->attr
, NULL
);
835 /* Otherwise the result will be passed through a union by
837 proc
->attr
.mixed_entry_master
= 1;
838 for (el
= ns
->entries
; el
; el
= el
->next
)
840 sym
= el
->sym
->result
;
841 if (sym
->attr
.dimension
)
843 if (el
== ns
->entries
)
844 gfc_error ("FUNCTION result %s cannot be an array in "
845 "FUNCTION %s at %L", sym
->name
,
846 ns
->entries
->sym
->name
, &sym
->declared_at
);
848 gfc_error ("ENTRY result %s cannot be an array in "
849 "FUNCTION %s at %L", sym
->name
,
850 ns
->entries
->sym
->name
, &sym
->declared_at
);
852 else if (sym
->attr
.pointer
)
854 if (el
== ns
->entries
)
855 gfc_error ("FUNCTION result %s cannot be a POINTER in "
856 "FUNCTION %s at %L", sym
->name
,
857 ns
->entries
->sym
->name
, &sym
->declared_at
);
859 gfc_error ("ENTRY result %s cannot be a POINTER in "
860 "FUNCTION %s at %L", sym
->name
,
861 ns
->entries
->sym
->name
, &sym
->declared_at
);
866 if (ts
->type
== BT_UNKNOWN
)
867 ts
= gfc_get_default_type (sym
->name
, NULL
);
871 if (ts
->kind
== gfc_default_integer_kind
)
875 if (ts
->kind
== gfc_default_real_kind
876 || ts
->kind
== gfc_default_double_kind
)
880 if (ts
->kind
== gfc_default_complex_kind
)
884 if (ts
->kind
== gfc_default_logical_kind
)
888 /* We will issue error elsewhere. */
896 if (el
== ns
->entries
)
897 gfc_error ("FUNCTION result %s cannot be of type %s "
898 "in FUNCTION %s at %L", sym
->name
,
899 gfc_typename (ts
), ns
->entries
->sym
->name
,
902 gfc_error ("ENTRY result %s cannot be of type %s "
903 "in FUNCTION %s at %L", sym
->name
,
904 gfc_typename (ts
), ns
->entries
->sym
->name
,
911 proc
->attr
.access
= ACCESS_PRIVATE
;
912 proc
->attr
.entry_master
= 1;
914 /* Merge all the entry point arguments. */
915 for (el
= ns
->entries
; el
; el
= el
->next
)
916 merge_argument_lists (proc
, el
->sym
->formal
);
918 /* Check the master formal arguments for any that are not
919 present in all entry points. */
920 for (el
= ns
->entries
; el
; el
= el
->next
)
921 check_argument_lists (proc
, el
->sym
->formal
);
923 /* Use the master function for the function body. */
924 ns
->proc_name
= proc
;
926 /* Finalize the new symbols. */
927 gfc_commit_symbols ();
929 /* Restore the original namespace. */
930 gfc_current_ns
= old_ns
;
934 /* Resolve common variables. */
936 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
938 gfc_symbol
*csym
= common_block
->head
;
940 for (; csym
; csym
= csym
->common_next
)
942 /* gfc_add_in_common may have been called before, but the reported errors
943 have been ignored to continue parsing.
944 We do the checks again here. */
945 if (!csym
->attr
.use_assoc
)
947 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
948 gfc_notify_std (GFC_STD_F2018_OBS
, "COMMON block at %L",
949 &common_block
->where
);
952 if (csym
->value
|| csym
->attr
.data
)
954 if (!csym
->ns
->is_block_data
)
955 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
956 "but only in BLOCK DATA initialization is "
957 "allowed", csym
->name
, &csym
->declared_at
);
958 else if (!named_common
)
959 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
960 "in a blank COMMON but initialization is only "
961 "allowed in named common blocks", csym
->name
,
965 if (UNLIMITED_POLY (csym
))
966 gfc_error_now ("%qs in cannot appear in COMMON at %L "
967 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
969 if (csym
->ts
.type
!= BT_DERIVED
)
972 if (!(csym
->ts
.u
.derived
->attr
.sequence
973 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
974 gfc_error_now ("Derived type variable %qs in COMMON at %L "
975 "has neither the SEQUENCE nor the BIND(C) "
976 "attribute", csym
->name
, &csym
->declared_at
);
977 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
978 gfc_error_now ("Derived type variable %qs in COMMON at %L "
979 "has an ultimate component that is "
980 "allocatable", csym
->name
, &csym
->declared_at
);
981 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
982 gfc_error_now ("Derived type variable %qs in COMMON at %L "
983 "may not have default initializer", csym
->name
,
986 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
987 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
991 /* Resolve common blocks. */
993 resolve_common_blocks (gfc_symtree
*common_root
)
998 if (common_root
== NULL
)
1001 if (common_root
->left
)
1002 resolve_common_blocks (common_root
->left
);
1003 if (common_root
->right
)
1004 resolve_common_blocks (common_root
->right
);
1006 resolve_common_vars (common_root
->n
.common
, true);
1008 /* The common name is a global name - in Fortran 2003 also if it has a
1009 C binding name, since Fortran 2008 only the C binding name is a global
1011 if (!common_root
->n
.common
->binding_label
1012 || gfc_notification_std (GFC_STD_F2008
))
1014 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1015 common_root
->n
.common
->name
);
1017 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1018 && gsym
->type
== GSYM_COMMON
1019 && ((common_root
->n
.common
->binding_label
1020 && (!gsym
->binding_label
1021 || strcmp (common_root
->n
.common
->binding_label
,
1022 gsym
->binding_label
) != 0))
1023 || (!common_root
->n
.common
->binding_label
1024 && gsym
->binding_label
)))
1026 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1027 "identifier and must thus have the same binding name "
1028 "as the same-named COMMON block at %L: %s vs %s",
1029 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1031 common_root
->n
.common
->binding_label
1032 ? common_root
->n
.common
->binding_label
: "(blank)",
1033 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1037 if (gsym
&& gsym
->type
!= GSYM_COMMON
1038 && !common_root
->n
.common
->binding_label
)
1040 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1042 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1046 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1048 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1049 "%L sharing the identifier with global non-COMMON-block "
1050 "entity at %L", common_root
->n
.common
->name
,
1051 &common_root
->n
.common
->where
, &gsym
->where
);
1056 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
, false);
1057 gsym
->type
= GSYM_COMMON
;
1058 gsym
->where
= common_root
->n
.common
->where
;
1064 if (common_root
->n
.common
->binding_label
)
1066 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1067 common_root
->n
.common
->binding_label
);
1068 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1070 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1071 "global identifier as entity at %L",
1072 &common_root
->n
.common
->where
,
1073 common_root
->n
.common
->binding_label
, &gsym
->where
);
1078 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
, true);
1079 gsym
->type
= GSYM_COMMON
;
1080 gsym
->where
= common_root
->n
.common
->where
;
1086 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1090 if (sym
->attr
.flavor
== FL_PARAMETER
)
1091 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1092 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1094 if (sym
->attr
.external
)
1095 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1096 sym
->name
, &common_root
->n
.common
->where
);
1098 if (sym
->attr
.intrinsic
)
1099 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1100 sym
->name
, &common_root
->n
.common
->where
);
1101 else if (sym
->attr
.result
1102 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1103 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1104 "that is also a function result", sym
->name
,
1105 &common_root
->n
.common
->where
);
1106 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1107 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1108 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1109 "that is also a global procedure", sym
->name
,
1110 &common_root
->n
.common
->where
);
1114 /* Resolve contained function types. Because contained functions can call one
1115 another, they have to be worked out before any of the contained procedures
1118 The good news is that if a function doesn't already have a type, the only
1119 way it can get one is through an IMPLICIT type or a RESULT variable, because
1120 by definition contained functions are contained namespace they're contained
1121 in, not in a sibling or parent namespace. */
1124 resolve_contained_functions (gfc_namespace
*ns
)
1126 gfc_namespace
*child
;
1129 resolve_formal_arglists (ns
);
1131 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1133 /* Resolve alternate entry points first. */
1134 resolve_entries (child
);
1136 /* Then check function return types. */
1137 resolve_contained_fntype (child
->proc_name
, child
);
1138 for (el
= child
->entries
; el
; el
= el
->next
)
1139 resolve_contained_fntype (el
->sym
, child
);
1145 /* A Parameterized Derived Type constructor must contain values for
1146 the PDT KIND parameters or they must have a default initializer.
1147 Go through the constructor picking out the KIND expressions,
1148 storing them in 'param_list' and then call gfc_get_pdt_instance
1149 to obtain the PDT instance. */
1151 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1154 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1156 param
= gfc_get_actual_arglist ();
1158 param_list
= param_tail
= param
;
1161 param_tail
->next
= param
;
1162 param_tail
= param_tail
->next
;
1165 param_tail
->name
= c
->name
;
1167 param_tail
->expr
= gfc_copy_expr (expr
);
1168 else if (c
->initializer
)
1169 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1172 param_tail
->spec_type
= SPEC_ASSUMED
;
1173 if (c
->attr
.pdt_kind
)
1175 gfc_error ("The KIND parameter %qs in the PDT constructor "
1176 "at %C has no value", param
->name
);
1185 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1186 gfc_symbol
*derived
)
1188 gfc_constructor
*cons
= NULL
;
1189 gfc_component
*comp
;
1192 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1193 cons
= gfc_constructor_first (expr
->value
.constructor
);
1198 comp
= derived
->components
;
1200 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1203 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1204 && comp
->ts
.type
== BT_DERIVED
)
1206 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1210 else if (comp
->ts
.type
== BT_DERIVED
)
1212 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1216 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1217 && derived
->attr
.pdt_template
)
1219 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1228 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1229 static bool resolve_fl_struct (gfc_symbol
*sym
);
1232 /* Resolve all of the elements of a structure constructor and make sure that
1233 the types are correct. The 'init' flag indicates that the given
1234 constructor is an initializer. */
1237 resolve_structure_cons (gfc_expr
*expr
, int init
)
1239 gfc_constructor
*cons
;
1240 gfc_component
*comp
;
1246 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1248 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1249 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1251 resolve_fl_struct (expr
->ts
.u
.derived
);
1253 /* If this is a Parameterized Derived Type template, find the
1254 instance corresponding to the PDT kind parameters. */
1255 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1258 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1261 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1263 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1266 gfc_free_actual_arglist (param_list
);
1268 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1273 cons
= gfc_constructor_first (expr
->value
.constructor
);
1275 /* A constructor may have references if it is the result of substituting a
1276 parameter variable. In this case we just pull out the component we
1279 comp
= expr
->ref
->u
.c
.sym
->components
;
1281 comp
= expr
->ts
.u
.derived
->components
;
1283 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1290 /* Unions use an EXPR_NULL contrived expression to tell the translation
1291 phase to generate an initializer of the appropriate length.
1293 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1296 if (!gfc_resolve_expr (cons
->expr
))
1302 rank
= comp
->as
? comp
->as
->rank
: 0;
1303 if (comp
->ts
.type
== BT_CLASS
1304 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1305 && CLASS_DATA (comp
)->as
)
1306 rank
= CLASS_DATA (comp
)->as
->rank
;
1308 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1309 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1311 gfc_error ("The rank of the element in the structure "
1312 "constructor at %L does not match that of the "
1313 "component (%d/%d)", &cons
->expr
->where
,
1314 cons
->expr
->rank
, rank
);
1318 /* If we don't have the right type, try to convert it. */
1320 if (!comp
->attr
.proc_pointer
&&
1321 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1323 if (strcmp (comp
->name
, "_extends") == 0)
1325 /* Can afford to be brutal with the _extends initializer.
1326 The derived type can get lost because it is PRIVATE
1327 but it is not usage constrained by the standard. */
1328 cons
->expr
->ts
= comp
->ts
;
1330 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1332 gfc_error ("The element in the structure constructor at %L, "
1333 "for pointer component %qs, is %s but should be %s",
1334 &cons
->expr
->where
, comp
->name
,
1335 gfc_basic_typename (cons
->expr
->ts
.type
),
1336 gfc_basic_typename (comp
->ts
.type
));
1341 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1347 /* For strings, the length of the constructor should be the same as
1348 the one of the structure, ensure this if the lengths are known at
1349 compile time and when we are dealing with PARAMETER or structure
1351 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1352 && comp
->ts
.u
.cl
->length
1353 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1354 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1355 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1356 && cons
->expr
->rank
!= 0
1357 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1358 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1360 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1361 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1363 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1364 to make use of the gfc_resolve_character_array_constructor
1365 machinery. The expression is later simplified away to
1366 an array of string literals. */
1367 gfc_expr
*para
= cons
->expr
;
1368 cons
->expr
= gfc_get_expr ();
1369 cons
->expr
->ts
= para
->ts
;
1370 cons
->expr
->where
= para
->where
;
1371 cons
->expr
->expr_type
= EXPR_ARRAY
;
1372 cons
->expr
->rank
= para
->rank
;
1373 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1374 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1375 para
, &cons
->expr
->where
);
1378 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1380 /* Rely on the cleanup of the namespace to deal correctly with
1381 the old charlen. (There was a block here that attempted to
1382 remove the charlen but broke the chain in so doing.) */
1383 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1384 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1385 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1386 gfc_resolve_character_array_constructor (cons
->expr
);
1390 if (cons
->expr
->expr_type
== EXPR_NULL
1391 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1392 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1393 || (comp
->ts
.type
== BT_CLASS
1394 && (CLASS_DATA (comp
)->attr
.class_pointer
1395 || CLASS_DATA (comp
)->attr
.allocatable
))))
1398 gfc_error ("The NULL in the structure constructor at %L is "
1399 "being applied to component %qs, which is neither "
1400 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1404 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1406 /* Check procedure pointer interface. */
1407 gfc_symbol
*s2
= NULL
;
1412 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1415 s2
= c2
->ts
.interface
;
1418 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1420 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1421 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1423 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1425 s2
= cons
->expr
->symtree
->n
.sym
;
1426 name
= cons
->expr
->symtree
->n
.sym
->name
;
1429 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1430 err
, sizeof (err
), NULL
, NULL
))
1432 gfc_error_opt (OPT_Wargument_mismatch
,
1433 "Interface mismatch for procedure-pointer "
1434 "component %qs in structure constructor at %L:"
1435 " %s", comp
->name
, &cons
->expr
->where
, err
);
1440 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1441 || cons
->expr
->expr_type
== EXPR_NULL
)
1444 a
= gfc_expr_attr (cons
->expr
);
1446 if (!a
.pointer
&& !a
.target
)
1449 gfc_error ("The element in the structure constructor at %L, "
1450 "for pointer component %qs should be a POINTER or "
1451 "a TARGET", &cons
->expr
->where
, comp
->name
);
1456 /* F08:C461. Additional checks for pointer initialization. */
1460 gfc_error ("Pointer initialization target at %L "
1461 "must not be ALLOCATABLE", &cons
->expr
->where
);
1466 gfc_error ("Pointer initialization target at %L "
1467 "must have the SAVE attribute", &cons
->expr
->where
);
1471 /* F2003, C1272 (3). */
1472 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1473 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1474 || gfc_is_coindexed (cons
->expr
));
1475 if (impure
&& gfc_pure (NULL
))
1478 gfc_error ("Invalid expression in the structure constructor for "
1479 "pointer component %qs at %L in PURE procedure",
1480 comp
->name
, &cons
->expr
->where
);
1484 gfc_unset_implicit_pure (NULL
);
1491 /****************** Expression name resolution ******************/
1493 /* Returns 0 if a symbol was not declared with a type or
1494 attribute declaration statement, nonzero otherwise. */
1497 was_declared (gfc_symbol
*sym
)
1503 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1506 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1507 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1508 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1509 || a
.asynchronous
|| a
.codimension
)
1516 /* Determine if a symbol is generic or not. */
1519 generic_sym (gfc_symbol
*sym
)
1523 if (sym
->attr
.generic
||
1524 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1527 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1530 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1537 return generic_sym (s
);
1544 /* Determine if a symbol is specific or not. */
1547 specific_sym (gfc_symbol
*sym
)
1551 if (sym
->attr
.if_source
== IFSRC_IFBODY
1552 || sym
->attr
.proc
== PROC_MODULE
1553 || sym
->attr
.proc
== PROC_INTERNAL
1554 || sym
->attr
.proc
== PROC_ST_FUNCTION
1555 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1556 || sym
->attr
.external
)
1559 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1562 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1564 return (s
== NULL
) ? 0 : specific_sym (s
);
1568 /* Figure out if the procedure is specific, generic or unknown. */
1571 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1574 procedure_kind (gfc_symbol
*sym
)
1576 if (generic_sym (sym
))
1577 return PTYPE_GENERIC
;
1579 if (specific_sym (sym
))
1580 return PTYPE_SPECIFIC
;
1582 return PTYPE_UNKNOWN
;
1585 /* Check references to assumed size arrays. The flag need_full_assumed_size
1586 is nonzero when matching actual arguments. */
1588 static int need_full_assumed_size
= 0;
1591 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1593 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1596 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1597 What should it be? */
1598 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1599 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1600 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1602 gfc_error ("The upper bound in the last dimension must "
1603 "appear in the reference to the assumed size "
1604 "array %qs at %L", sym
->name
, &e
->where
);
1611 /* Look for bad assumed size array references in argument expressions
1612 of elemental and array valued intrinsic procedures. Since this is
1613 called from procedure resolution functions, it only recurses at
1617 resolve_assumed_size_actual (gfc_expr
*e
)
1622 switch (e
->expr_type
)
1625 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1630 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1631 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1642 /* Check a generic procedure, passed as an actual argument, to see if
1643 there is a matching specific name. If none, it is an error, and if
1644 more than one, the reference is ambiguous. */
1646 count_specific_procs (gfc_expr
*e
)
1653 sym
= e
->symtree
->n
.sym
;
1655 for (p
= sym
->generic
; p
; p
= p
->next
)
1656 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1658 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1664 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1668 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1669 "argument at %L", sym
->name
, &e
->where
);
1675 /* See if a call to sym could possibly be a not allowed RECURSION because of
1676 a missing RECURSIVE declaration. This means that either sym is the current
1677 context itself, or sym is the parent of a contained procedure calling its
1678 non-RECURSIVE containing procedure.
1679 This also works if sym is an ENTRY. */
1682 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1684 gfc_symbol
* proc_sym
;
1685 gfc_symbol
* context_proc
;
1686 gfc_namespace
* real_context
;
1688 if (sym
->attr
.flavor
== FL_PROGRAM
1689 || gfc_fl_struct (sym
->attr
.flavor
))
1692 /* If we've got an ENTRY, find real procedure. */
1693 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1694 proc_sym
= sym
->ns
->entries
->sym
;
1698 /* If sym is RECURSIVE, all is well of course. */
1699 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1702 /* Find the context procedure's "real" symbol if it has entries.
1703 We look for a procedure symbol, so recurse on the parents if we don't
1704 find one (like in case of a BLOCK construct). */
1705 for (real_context
= context
; ; real_context
= real_context
->parent
)
1707 /* We should find something, eventually! */
1708 gcc_assert (real_context
);
1710 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1711 : real_context
->proc_name
);
1713 /* In some special cases, there may not be a proc_name, like for this
1715 real(bad_kind()) function foo () ...
1716 when checking the call to bad_kind ().
1717 In these cases, we simply return here and assume that the
1722 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1726 /* A call from sym's body to itself is recursion, of course. */
1727 if (context_proc
== proc_sym
)
1730 /* The same is true if context is a contained procedure and sym the
1732 if (context_proc
->attr
.contained
)
1734 gfc_symbol
* parent_proc
;
1736 gcc_assert (context
->parent
);
1737 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1738 : context
->parent
->proc_name
);
1740 if (parent_proc
== proc_sym
)
1748 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1749 its typespec and formal argument list. */
1752 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1754 gfc_intrinsic_sym
* isym
= NULL
;
1760 /* Already resolved. */
1761 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1764 /* We already know this one is an intrinsic, so we don't call
1765 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1766 gfc_find_subroutine directly to check whether it is a function or
1769 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1771 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1772 isym
= gfc_intrinsic_subroutine_by_id (id
);
1774 else if (sym
->intmod_sym_id
)
1776 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1777 isym
= gfc_intrinsic_function_by_id (id
);
1779 else if (!sym
->attr
.subroutine
)
1780 isym
= gfc_find_function (sym
->name
);
1782 if (isym
&& !sym
->attr
.subroutine
)
1784 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1785 && !sym
->attr
.implicit_type
)
1786 gfc_warning (OPT_Wsurprising
,
1787 "Type specified for intrinsic function %qs at %L is"
1788 " ignored", sym
->name
, &sym
->declared_at
);
1790 if (!sym
->attr
.function
&&
1791 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1796 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1798 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1800 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1801 " specifier", sym
->name
, &sym
->declared_at
);
1805 if (!sym
->attr
.subroutine
&&
1806 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1811 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1816 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1818 sym
->attr
.pure
= isym
->pure
;
1819 sym
->attr
.elemental
= isym
->elemental
;
1821 /* Check it is actually available in the standard settings. */
1822 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1824 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1825 "available in the current standard settings but %s. Use "
1826 "an appropriate %<-std=*%> option or enable "
1827 "%<-fall-intrinsics%> in order to use it.",
1828 sym
->name
, &sym
->declared_at
, symstd
);
1836 /* Resolve a procedure expression, like passing it to a called procedure or as
1837 RHS for a procedure pointer assignment. */
1840 resolve_procedure_expression (gfc_expr
* expr
)
1844 if (expr
->expr_type
!= EXPR_VARIABLE
)
1846 gcc_assert (expr
->symtree
);
1848 sym
= expr
->symtree
->n
.sym
;
1850 if (sym
->attr
.intrinsic
)
1851 gfc_resolve_intrinsic (sym
, &expr
->where
);
1853 if (sym
->attr
.flavor
!= FL_PROCEDURE
1854 || (sym
->attr
.function
&& sym
->result
== sym
))
1857 /* A non-RECURSIVE procedure that is used as procedure expression within its
1858 own body is in danger of being called recursively. */
1859 if (is_illegal_recursion (sym
, gfc_current_ns
))
1860 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1861 " itself recursively. Declare it RECURSIVE or use"
1862 " %<-frecursive%>", sym
->name
, &expr
->where
);
1868 /* Check that name is not a derived type. */
1871 is_dt_name (const char *name
)
1873 gfc_symbol
*dt_list
, *dt_first
;
1875 dt_list
= dt_first
= gfc_derived_types
;
1876 for (; dt_list
; dt_list
= dt_list
->dt_next
)
1878 if (strcmp(dt_list
->name
, name
) == 0)
1880 if (dt_first
== dt_list
->dt_next
)
1887 /* Resolve an actual argument list. Most of the time, this is just
1888 resolving the expressions in the list.
1889 The exception is that we sometimes have to decide whether arguments
1890 that look like procedure arguments are really simple variable
1894 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1895 bool no_formal_args
)
1898 gfc_symtree
*parent_st
;
1900 gfc_component
*comp
;
1901 int save_need_full_assumed_size
;
1902 bool return_value
= false;
1903 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1906 first_actual_arg
= true;
1908 for (; arg
; arg
= arg
->next
)
1913 /* Check the label is a valid branching target. */
1916 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1918 gfc_error ("Label %d referenced at %L is never defined",
1919 arg
->label
->value
, &arg
->label
->where
);
1923 first_actual_arg
= false;
1927 if (e
->expr_type
== EXPR_VARIABLE
1928 && e
->symtree
->n
.sym
->attr
.generic
1930 && count_specific_procs (e
) != 1)
1933 if (e
->ts
.type
!= BT_PROCEDURE
)
1935 save_need_full_assumed_size
= need_full_assumed_size
;
1936 if (e
->expr_type
!= EXPR_VARIABLE
)
1937 need_full_assumed_size
= 0;
1938 if (!gfc_resolve_expr (e
))
1940 need_full_assumed_size
= save_need_full_assumed_size
;
1944 /* See if the expression node should really be a variable reference. */
1946 sym
= e
->symtree
->n
.sym
;
1948 if (sym
->attr
.flavor
== FL_PROCEDURE
&& is_dt_name (sym
->name
))
1950 gfc_error ("Derived type %qs is used as an actual "
1951 "argument at %L", sym
->name
, &e
->where
);
1955 if (sym
->attr
.flavor
== FL_PROCEDURE
1956 || sym
->attr
.intrinsic
1957 || sym
->attr
.external
)
1961 /* If a procedure is not already determined to be something else
1962 check if it is intrinsic. */
1963 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1964 sym
->attr
.intrinsic
= 1;
1966 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1968 gfc_error ("Statement function %qs at %L is not allowed as an "
1969 "actual argument", sym
->name
, &e
->where
);
1972 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1973 sym
->attr
.subroutine
);
1974 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1976 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1977 "actual argument", sym
->name
, &e
->where
);
1980 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1981 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1983 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1984 " used as actual argument at %L",
1985 sym
->name
, &e
->where
))
1989 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1991 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1992 "allowed as an actual argument at %L", sym
->name
,
1996 /* Check if a generic interface has a specific procedure
1997 with the same name before emitting an error. */
1998 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
2001 /* Just in case a specific was found for the expression. */
2002 sym
= e
->symtree
->n
.sym
;
2004 /* If the symbol is the function that names the current (or
2005 parent) scope, then we really have a variable reference. */
2007 if (gfc_is_function_return_value (sym
, sym
->ns
))
2010 /* If all else fails, see if we have a specific intrinsic. */
2011 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
2013 gfc_intrinsic_sym
*isym
;
2015 isym
= gfc_find_function (sym
->name
);
2016 if (isym
== NULL
|| !isym
->specific
)
2018 gfc_error ("Unable to find a specific INTRINSIC procedure "
2019 "for the reference %qs at %L", sym
->name
,
2024 sym
->attr
.intrinsic
= 1;
2025 sym
->attr
.function
= 1;
2028 if (!gfc_resolve_expr (e
))
2033 /* See if the name is a module procedure in a parent unit. */
2035 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2038 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2040 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2044 if (parent_st
== NULL
)
2047 sym
= parent_st
->n
.sym
;
2048 e
->symtree
= parent_st
; /* Point to the right thing. */
2050 if (sym
->attr
.flavor
== FL_PROCEDURE
2051 || sym
->attr
.intrinsic
2052 || sym
->attr
.external
)
2054 if (!gfc_resolve_expr (e
))
2060 e
->expr_type
= EXPR_VARIABLE
;
2062 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2063 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2064 && CLASS_DATA (sym
)->as
))
2066 e
->rank
= sym
->ts
.type
== BT_CLASS
2067 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2068 e
->ref
= gfc_get_ref ();
2069 e
->ref
->type
= REF_ARRAY
;
2070 e
->ref
->u
.ar
.type
= AR_FULL
;
2071 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2072 ? CLASS_DATA (sym
)->as
: sym
->as
;
2075 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2076 primary.c (match_actual_arg). If above code determines that it
2077 is a variable instead, it needs to be resolved as it was not
2078 done at the beginning of this function. */
2079 save_need_full_assumed_size
= need_full_assumed_size
;
2080 if (e
->expr_type
!= EXPR_VARIABLE
)
2081 need_full_assumed_size
= 0;
2082 if (!gfc_resolve_expr (e
))
2084 need_full_assumed_size
= save_need_full_assumed_size
;
2087 /* Check argument list functions %VAL, %LOC and %REF. There is
2088 nothing to do for %REF. */
2089 if (arg
->name
&& arg
->name
[0] == '%')
2091 if (strcmp ("%VAL", arg
->name
) == 0)
2093 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2095 gfc_error ("By-value argument at %L is not of numeric "
2102 gfc_error ("By-value argument at %L cannot be an array or "
2103 "an array section", &e
->where
);
2107 /* Intrinsics are still PROC_UNKNOWN here. However,
2108 since same file external procedures are not resolvable
2109 in gfortran, it is a good deal easier to leave them to
2111 if (ptype
!= PROC_UNKNOWN
2112 && ptype
!= PROC_DUMMY
2113 && ptype
!= PROC_EXTERNAL
2114 && ptype
!= PROC_MODULE
)
2116 gfc_error ("By-value argument at %L is not allowed "
2117 "in this context", &e
->where
);
2122 /* Statement functions have already been excluded above. */
2123 else if (strcmp ("%LOC", arg
->name
) == 0
2124 && e
->ts
.type
== BT_PROCEDURE
)
2126 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2128 gfc_error ("Passing internal procedure at %L by location "
2129 "not allowed", &e
->where
);
2135 comp
= gfc_get_proc_ptr_comp(e
);
2136 if (e
->expr_type
== EXPR_VARIABLE
2137 && comp
&& comp
->attr
.elemental
)
2139 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2140 "allowed as an actual argument at %L", comp
->name
,
2144 /* Fortran 2008, C1237. */
2145 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2146 && gfc_has_ultimate_pointer (e
))
2148 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2149 "component", &e
->where
);
2153 first_actual_arg
= false;
2156 return_value
= true;
2159 actual_arg
= actual_arg_sav
;
2160 first_actual_arg
= first_actual_arg_sav
;
2162 return return_value
;
2166 /* Do the checks of the actual argument list that are specific to elemental
2167 procedures. If called with c == NULL, we have a function, otherwise if
2168 expr == NULL, we have a subroutine. */
2171 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2173 gfc_actual_arglist
*arg0
;
2174 gfc_actual_arglist
*arg
;
2175 gfc_symbol
*esym
= NULL
;
2176 gfc_intrinsic_sym
*isym
= NULL
;
2178 gfc_intrinsic_arg
*iformal
= NULL
;
2179 gfc_formal_arglist
*eformal
= NULL
;
2180 bool formal_optional
= false;
2181 bool set_by_optional
= false;
2185 /* Is this an elemental procedure? */
2186 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2188 if (expr
->value
.function
.esym
!= NULL
2189 && expr
->value
.function
.esym
->attr
.elemental
)
2191 arg0
= expr
->value
.function
.actual
;
2192 esym
= expr
->value
.function
.esym
;
2194 else if (expr
->value
.function
.isym
!= NULL
2195 && expr
->value
.function
.isym
->elemental
)
2197 arg0
= expr
->value
.function
.actual
;
2198 isym
= expr
->value
.function
.isym
;
2203 else if (c
&& c
->ext
.actual
!= NULL
)
2205 arg0
= c
->ext
.actual
;
2207 if (c
->resolved_sym
)
2208 esym
= c
->resolved_sym
;
2210 esym
= c
->symtree
->n
.sym
;
2213 if (!esym
->attr
.elemental
)
2219 /* The rank of an elemental is the rank of its array argument(s). */
2220 for (arg
= arg0
; arg
; arg
= arg
->next
)
2222 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2224 rank
= arg
->expr
->rank
;
2225 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2226 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2227 set_by_optional
= true;
2229 /* Function specific; set the result rank and shape. */
2233 if (!expr
->shape
&& arg
->expr
->shape
)
2235 expr
->shape
= gfc_get_shape (rank
);
2236 for (i
= 0; i
< rank
; i
++)
2237 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2244 /* If it is an array, it shall not be supplied as an actual argument
2245 to an elemental procedure unless an array of the same rank is supplied
2246 as an actual argument corresponding to a nonoptional dummy argument of
2247 that elemental procedure(12.4.1.5). */
2248 formal_optional
= false;
2250 iformal
= isym
->formal
;
2252 eformal
= esym
->formal
;
2254 for (arg
= arg0
; arg
; arg
= arg
->next
)
2258 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2259 formal_optional
= true;
2260 eformal
= eformal
->next
;
2262 else if (isym
&& iformal
)
2264 if (iformal
->optional
)
2265 formal_optional
= true;
2266 iformal
= iformal
->next
;
2269 formal_optional
= true;
2271 if (pedantic
&& arg
->expr
!= NULL
2272 && arg
->expr
->expr_type
== EXPR_VARIABLE
2273 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2276 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2277 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2279 gfc_warning (OPT_Wpedantic
,
2280 "%qs at %L is an array and OPTIONAL; IF IT IS "
2281 "MISSING, it cannot be the actual argument of an "
2282 "ELEMENTAL procedure unless there is a non-optional "
2283 "argument with the same rank (12.4.1.5)",
2284 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2288 for (arg
= arg0
; arg
; arg
= arg
->next
)
2290 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2293 /* Being elemental, the last upper bound of an assumed size array
2294 argument must be present. */
2295 if (resolve_assumed_size_actual (arg
->expr
))
2298 /* Elemental procedure's array actual arguments must conform. */
2301 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2308 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2309 is an array, the intent inout/out variable needs to be also an array. */
2310 if (rank
> 0 && esym
&& expr
== NULL
)
2311 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2312 arg
= arg
->next
, eformal
= eformal
->next
)
2313 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2314 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2315 && arg
->expr
&& arg
->expr
->rank
== 0)
2317 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2318 "ELEMENTAL subroutine %qs is a scalar, but another "
2319 "actual argument is an array", &arg
->expr
->where
,
2320 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2321 : "INOUT", eformal
->sym
->name
, esym
->name
);
2328 /* This function does the checking of references to global procedures
2329 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2330 77 and 95 standards. It checks for a gsymbol for the name, making
2331 one if it does not already exist. If it already exists, then the
2332 reference being resolved must correspond to the type of gsymbol.
2333 Otherwise, the new symbol is equipped with the attributes of the
2334 reference. The corresponding code that is called in creating
2335 global entities is parse.c.
2337 In addition, for all but -std=legacy, the gsymbols are used to
2338 check the interfaces of external procedures from the same file.
2339 The namespace of the gsymbol is resolved and then, once this is
2340 done the interface is checked. */
2344 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2346 if (!gsym_ns
->proc_name
->attr
.recursive
)
2349 if (sym
->ns
== gsym_ns
)
2352 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2359 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2361 if (gsym_ns
->entries
)
2363 gfc_entry_list
*entry
= gsym_ns
->entries
;
2365 for (; entry
; entry
= entry
->next
)
2367 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2369 if (strcmp (gsym_ns
->proc_name
->name
,
2370 sym
->ns
->proc_name
->name
) == 0)
2374 && strcmp (gsym_ns
->proc_name
->name
,
2375 sym
->ns
->parent
->proc_name
->name
) == 0)
2384 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2387 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2389 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2391 for ( ; arg
; arg
= arg
->next
)
2396 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2398 strncpy (errmsg
, _("allocatable argument"), err_len
);
2401 else if (arg
->sym
->attr
.asynchronous
)
2403 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2406 else if (arg
->sym
->attr
.optional
)
2408 strncpy (errmsg
, _("optional argument"), err_len
);
2411 else if (arg
->sym
->attr
.pointer
)
2413 strncpy (errmsg
, _("pointer argument"), err_len
);
2416 else if (arg
->sym
->attr
.target
)
2418 strncpy (errmsg
, _("target argument"), err_len
);
2421 else if (arg
->sym
->attr
.value
)
2423 strncpy (errmsg
, _("value argument"), err_len
);
2426 else if (arg
->sym
->attr
.volatile_
)
2428 strncpy (errmsg
, _("volatile argument"), err_len
);
2431 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2433 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2436 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2438 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2441 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2443 strncpy (errmsg
, _("coarray argument"), err_len
);
2446 else if (false) /* (2d) TODO: parametrized derived type */
2448 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2451 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2453 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2456 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2458 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2461 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2463 /* As assumed-type is unlimited polymorphic (cf. above).
2464 See also TS 29113, Note 6.1. */
2465 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2470 if (sym
->attr
.function
)
2472 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2474 if (res
->attr
.dimension
) /* (3a) */
2476 strncpy (errmsg
, _("array result"), err_len
);
2479 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2481 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2484 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2485 && res
->ts
.u
.cl
->length
2486 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2488 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2493 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2495 strncpy (errmsg
, _("elemental procedure"), err_len
);
2498 else if (sym
->attr
.is_bind_c
) /* (5) */
2500 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2509 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2510 gfc_actual_arglist
**actual
, int sub
)
2514 enum gfc_symbol_type type
;
2517 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2519 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2520 sym
->binding_label
!= NULL
);
2522 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2523 gfc_global_used (gsym
, where
);
2525 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2526 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2527 && gsym
->type
!= GSYM_UNKNOWN
2528 && !gsym
->binding_label
2530 && gsym
->ns
->proc_name
2531 && not_in_recursive (sym
, gsym
->ns
)
2532 && not_entry_self_reference (sym
, gsym
->ns
))
2534 gfc_symbol
*def_sym
;
2535 def_sym
= gsym
->ns
->proc_name
;
2537 if (gsym
->ns
->resolved
!= -1)
2540 /* Resolve the gsymbol namespace if needed. */
2541 if (!gsym
->ns
->resolved
)
2543 gfc_symbol
*old_dt_list
;
2545 /* Stash away derived types so that the backend_decls
2546 do not get mixed up. */
2547 old_dt_list
= gfc_derived_types
;
2548 gfc_derived_types
= NULL
;
2550 gfc_resolve (gsym
->ns
);
2552 /* Store the new derived types with the global namespace. */
2553 if (gfc_derived_types
)
2554 gsym
->ns
->derived_types
= gfc_derived_types
;
2556 /* Restore the derived types of this namespace. */
2557 gfc_derived_types
= old_dt_list
;
2560 /* Make sure that translation for the gsymbol occurs before
2561 the procedure currently being resolved. */
2562 ns
= gfc_global_ns_list
;
2563 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2565 if (ns
->sibling
== gsym
->ns
)
2567 ns
->sibling
= gsym
->ns
->sibling
;
2568 gsym
->ns
->sibling
= gfc_global_ns_list
;
2569 gfc_global_ns_list
= gsym
->ns
;
2574 /* This can happen if a binding name has been specified. */
2575 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2576 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2578 if (def_sym
->attr
.entry_master
|| def_sym
->attr
.entry
)
2580 gfc_entry_list
*entry
;
2581 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2582 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2584 def_sym
= entry
->sym
;
2590 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2592 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2593 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2594 gfc_typename (&def_sym
->ts
));
2598 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2599 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2601 gfc_error ("Explicit interface required for %qs at %L: %s",
2602 sym
->name
, &sym
->declared_at
, reason
);
2606 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2607 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2608 gfc_errors_to_warnings (true);
2610 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2611 reason
, sizeof(reason
), NULL
, NULL
))
2613 gfc_error_opt (OPT_Wargument_mismatch
,
2614 "Interface mismatch in global procedure %qs at %L:"
2615 " %s", sym
->name
, &sym
->declared_at
, reason
);
2620 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2621 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2622 gfc_errors_to_warnings (true);
2624 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2625 gfc_procedure_use (def_sym
, actual
, where
);
2629 gfc_errors_to_warnings (false);
2631 if (gsym
->type
== GSYM_UNKNOWN
)
2634 gsym
->where
= *where
;
2641 /************* Function resolution *************/
2643 /* Resolve a function call known to be generic.
2644 Section 14.1.2.4.1. */
2647 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2651 if (sym
->attr
.generic
)
2653 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2656 expr
->value
.function
.name
= s
->name
;
2657 expr
->value
.function
.esym
= s
;
2659 if (s
->ts
.type
!= BT_UNKNOWN
)
2661 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2662 expr
->ts
= s
->result
->ts
;
2665 expr
->rank
= s
->as
->rank
;
2666 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2667 expr
->rank
= s
->result
->as
->rank
;
2669 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2674 /* TODO: Need to search for elemental references in generic
2678 if (sym
->attr
.intrinsic
)
2679 return gfc_intrinsic_func_interface (expr
, 0);
2686 resolve_generic_f (gfc_expr
*expr
)
2690 gfc_interface
*intr
= NULL
;
2692 sym
= expr
->symtree
->n
.sym
;
2696 m
= resolve_generic_f0 (expr
, sym
);
2699 else if (m
== MATCH_ERROR
)
2704 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2705 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2708 if (sym
->ns
->parent
== NULL
)
2710 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2714 if (!generic_sym (sym
))
2718 /* Last ditch attempt. See if the reference is to an intrinsic
2719 that possesses a matching interface. 14.1.2.4 */
2720 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2722 if (gfc_init_expr_flag
)
2723 gfc_error ("Function %qs in initialization expression at %L "
2724 "must be an intrinsic function",
2725 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2727 gfc_error ("There is no specific function for the generic %qs "
2728 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2734 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2737 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2739 return resolve_structure_cons (expr
, 0);
2742 m
= gfc_intrinsic_func_interface (expr
, 0);
2747 gfc_error ("Generic function %qs at %L is not consistent with a "
2748 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2755 /* Resolve a function call known to be specific. */
2758 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2762 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2764 if (sym
->attr
.dummy
)
2766 sym
->attr
.proc
= PROC_DUMMY
;
2770 sym
->attr
.proc
= PROC_EXTERNAL
;
2774 if (sym
->attr
.proc
== PROC_MODULE
2775 || sym
->attr
.proc
== PROC_ST_FUNCTION
2776 || sym
->attr
.proc
== PROC_INTERNAL
)
2779 if (sym
->attr
.intrinsic
)
2781 m
= gfc_intrinsic_func_interface (expr
, 1);
2785 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2786 "with an intrinsic", sym
->name
, &expr
->where
);
2794 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2797 expr
->ts
= sym
->result
->ts
;
2800 expr
->value
.function
.name
= sym
->name
;
2801 expr
->value
.function
.esym
= sym
;
2802 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2804 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2806 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2807 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2808 else if (sym
->as
!= NULL
)
2809 expr
->rank
= sym
->as
->rank
;
2816 resolve_specific_f (gfc_expr
*expr
)
2821 sym
= expr
->symtree
->n
.sym
;
2825 m
= resolve_specific_f0 (sym
, expr
);
2828 if (m
== MATCH_ERROR
)
2831 if (sym
->ns
->parent
== NULL
)
2834 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2840 gfc_error ("Unable to resolve the specific function %qs at %L",
2841 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2846 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2847 candidates in CANDIDATES_LEN. */
2850 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2852 size_t &candidates_len
)
2858 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2859 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2860 vec_push (candidates
, candidates_len
, sym
->name
);
2864 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2868 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2872 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2875 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2877 char **candidates
= NULL
;
2878 size_t candidates_len
= 0;
2879 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2880 return gfc_closest_fuzzy_match (fn
, candidates
);
2884 /* Resolve a procedure call not known to be generic nor specific. */
2887 resolve_unknown_f (gfc_expr
*expr
)
2892 sym
= expr
->symtree
->n
.sym
;
2894 if (sym
->attr
.dummy
)
2896 sym
->attr
.proc
= PROC_DUMMY
;
2897 expr
->value
.function
.name
= sym
->name
;
2901 /* See if we have an intrinsic function reference. */
2903 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2905 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2910 /* The reference is to an external name. */
2912 sym
->attr
.proc
= PROC_EXTERNAL
;
2913 expr
->value
.function
.name
= sym
->name
;
2914 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2916 if (sym
->as
!= NULL
)
2917 expr
->rank
= sym
->as
->rank
;
2919 /* Type of the expression is either the type of the symbol or the
2920 default type of the symbol. */
2923 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2925 if (sym
->ts
.type
!= BT_UNKNOWN
)
2929 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2931 if (ts
->type
== BT_UNKNOWN
)
2934 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2936 gfc_error ("Function %qs at %L has no IMPLICIT type"
2937 "; did you mean %qs?",
2938 sym
->name
, &expr
->where
, guessed
);
2940 gfc_error ("Function %qs at %L has no IMPLICIT type",
2941 sym
->name
, &expr
->where
);
2952 /* Return true, if the symbol is an external procedure. */
2954 is_external_proc (gfc_symbol
*sym
)
2956 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2957 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2958 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2959 && !sym
->attr
.proc_pointer
2960 && !sym
->attr
.use_assoc
2968 /* Figure out if a function reference is pure or not. Also set the name
2969 of the function for a potential error message. Return nonzero if the
2970 function is PURE, zero if not. */
2972 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2975 gfc_pure_function (gfc_expr
*e
, const char **name
)
2978 gfc_component
*comp
;
2982 if (e
->symtree
!= NULL
2983 && e
->symtree
->n
.sym
!= NULL
2984 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2985 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2987 comp
= gfc_get_proc_ptr_comp (e
);
2990 pure
= gfc_pure (comp
->ts
.interface
);
2993 else if (e
->value
.function
.esym
)
2995 pure
= gfc_pure (e
->value
.function
.esym
);
2996 *name
= e
->value
.function
.esym
->name
;
2998 else if (e
->value
.function
.isym
)
3000 pure
= e
->value
.function
.isym
->pure
3001 || e
->value
.function
.isym
->elemental
;
3002 *name
= e
->value
.function
.isym
->name
;
3006 /* Implicit functions are not pure. */
3008 *name
= e
->value
.function
.name
;
3015 /* Check if the expression is a reference to an implicitly pure function. */
3018 gfc_implicit_pure_function (gfc_expr
*e
)
3020 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
3022 return gfc_implicit_pure (comp
->ts
.interface
);
3023 else if (e
->value
.function
.esym
)
3024 return gfc_implicit_pure (e
->value
.function
.esym
);
3031 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3032 int *f ATTRIBUTE_UNUSED
)
3036 /* Don't bother recursing into other statement functions
3037 since they will be checked individually for purity. */
3038 if (e
->expr_type
!= EXPR_FUNCTION
3040 || e
->symtree
->n
.sym
== sym
3041 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3044 return gfc_pure_function (e
, &name
) ? false : true;
3049 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3051 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3055 /* Check if an impure function is allowed in the current context. */
3057 static bool check_pure_function (gfc_expr
*e
)
3059 const char *name
= NULL
;
3060 if (!gfc_pure_function (e
, &name
) && name
)
3064 gfc_error ("Reference to impure function %qs at %L inside a "
3065 "FORALL %s", name
, &e
->where
,
3066 forall_flag
== 2 ? "mask" : "block");
3069 else if (gfc_do_concurrent_flag
)
3071 gfc_error ("Reference to impure function %qs at %L inside a "
3072 "DO CONCURRENT %s", name
, &e
->where
,
3073 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3076 else if (gfc_pure (NULL
))
3078 gfc_error ("Reference to impure function %qs at %L "
3079 "within a PURE procedure", name
, &e
->where
);
3082 if (!gfc_implicit_pure_function (e
))
3083 gfc_unset_implicit_pure (NULL
);
3089 /* Update current procedure's array_outer_dependency flag, considering
3090 a call to procedure SYM. */
3093 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3095 /* Check to see if this is a sibling function that has not yet
3097 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3098 for (; sibling
; sibling
= sibling
->sibling
)
3100 if (sibling
->proc_name
== sym
)
3102 gfc_resolve (sibling
);
3107 /* If SYM has references to outer arrays, so has the procedure calling
3108 SYM. If SYM is a procedure pointer, we can assume the worst. */
3109 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3110 && gfc_current_ns
->proc_name
)
3111 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3115 /* Resolve a function call, which means resolving the arguments, then figuring
3116 out which entity the name refers to. */
3119 resolve_function (gfc_expr
*expr
)
3121 gfc_actual_arglist
*arg
;
3125 procedure_type p
= PROC_INTRINSIC
;
3126 bool no_formal_args
;
3130 sym
= expr
->symtree
->n
.sym
;
3132 /* If this is a procedure pointer component, it has already been resolved. */
3133 if (gfc_is_proc_ptr_comp (expr
))
3136 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3138 if (sym
&& sym
->attr
.intrinsic
3139 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3140 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3143 if (sym
&& sym
->attr
.intrinsic
3144 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3147 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3149 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3153 /* If this is a deferred TBP with an abstract interface (which may
3154 of course be referenced), expr->value.function.esym will be set. */
3155 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3157 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3158 sym
->name
, &expr
->where
);
3162 /* If this is a deferred TBP with an abstract interface, its result
3163 cannot be an assumed length character (F2003: C418). */
3164 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3165 && sym
->result
->ts
.u
.cl
3166 && sym
->result
->ts
.u
.cl
->length
== NULL
3167 && !sym
->result
->ts
.deferred
)
3169 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3170 "character length result (F2008: C418)", sym
->name
,
3175 /* Switch off assumed size checking and do this again for certain kinds
3176 of procedure, once the procedure itself is resolved. */
3177 need_full_assumed_size
++;
3179 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3180 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3182 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3183 inquiry_argument
= true;
3184 no_formal_args
= sym
&& is_external_proc (sym
)
3185 && gfc_sym_get_dummy_args (sym
) == NULL
;
3187 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3190 inquiry_argument
= false;
3194 inquiry_argument
= false;
3196 /* Resume assumed_size checking. */
3197 need_full_assumed_size
--;
3199 /* If the procedure is external, check for usage. */
3200 if (sym
&& is_external_proc (sym
))
3201 resolve_global_procedure (sym
, &expr
->where
,
3202 &expr
->value
.function
.actual
, 0);
3204 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3206 && sym
->ts
.u
.cl
->length
== NULL
3208 && !sym
->ts
.deferred
3209 && expr
->value
.function
.esym
== NULL
3210 && !sym
->attr
.contained
)
3212 /* Internal procedures are taken care of in resolve_contained_fntype. */
3213 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3214 "be used at %L since it is not a dummy argument",
3215 sym
->name
, &expr
->where
);
3219 /* See if function is already resolved. */
3221 if (expr
->value
.function
.name
!= NULL
3222 || expr
->value
.function
.isym
!= NULL
)
3224 if (expr
->ts
.type
== BT_UNKNOWN
)
3230 /* Apply the rules of section 14.1.2. */
3232 switch (procedure_kind (sym
))
3235 t
= resolve_generic_f (expr
);
3238 case PTYPE_SPECIFIC
:
3239 t
= resolve_specific_f (expr
);
3243 t
= resolve_unknown_f (expr
);
3247 gfc_internal_error ("resolve_function(): bad function type");
3251 /* If the expression is still a function (it might have simplified),
3252 then we check to see if we are calling an elemental function. */
3254 if (expr
->expr_type
!= EXPR_FUNCTION
)
3257 temp
= need_full_assumed_size
;
3258 need_full_assumed_size
= 0;
3260 if (!resolve_elemental_actual (expr
, NULL
))
3263 if (omp_workshare_flag
3264 && expr
->value
.function
.esym
3265 && ! gfc_elemental (expr
->value
.function
.esym
))
3267 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3268 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3273 #define GENERIC_ID expr->value.function.isym->id
3274 else if (expr
->value
.function
.actual
!= NULL
3275 && expr
->value
.function
.isym
!= NULL
3276 && GENERIC_ID
!= GFC_ISYM_LBOUND
3277 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3278 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3279 && GENERIC_ID
!= GFC_ISYM_LEN
3280 && GENERIC_ID
!= GFC_ISYM_LOC
3281 && GENERIC_ID
!= GFC_ISYM_C_LOC
3282 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3284 /* Array intrinsics must also have the last upper bound of an
3285 assumed size array argument. UBOUND and SIZE have to be
3286 excluded from the check if the second argument is anything
3289 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3291 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3292 && arg
== expr
->value
.function
.actual
3293 && arg
->next
!= NULL
&& arg
->next
->expr
)
3295 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3298 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3301 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3306 if (arg
->expr
!= NULL
3307 && arg
->expr
->rank
> 0
3308 && resolve_assumed_size_actual (arg
->expr
))
3314 need_full_assumed_size
= temp
;
3316 if (!check_pure_function(expr
))
3319 /* Functions without the RECURSIVE attribution are not allowed to
3320 * call themselves. */
3321 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3324 esym
= expr
->value
.function
.esym
;
3326 if (is_illegal_recursion (esym
, gfc_current_ns
))
3328 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3329 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3330 " function %qs is not RECURSIVE",
3331 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3333 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3334 " is not RECURSIVE", esym
->name
, &expr
->where
);
3340 /* Character lengths of use associated functions may contains references to
3341 symbols not referenced from the current program unit otherwise. Make sure
3342 those symbols are marked as referenced. */
3344 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3345 && expr
->value
.function
.esym
->attr
.use_assoc
)
3347 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3350 /* Make sure that the expression has a typespec that works. */
3351 if (expr
->ts
.type
== BT_UNKNOWN
)
3353 if (expr
->symtree
->n
.sym
->result
3354 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3355 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3356 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3359 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3361 if (expr
->value
.function
.esym
)
3362 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3364 update_current_proc_array_outer_dependency (sym
);
3367 /* typebound procedure: Assume the worst. */
3368 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3374 /************* Subroutine resolution *************/
3377 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3384 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3388 else if (gfc_do_concurrent_flag
)
3390 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3394 else if (gfc_pure (NULL
))
3396 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3400 gfc_unset_implicit_pure (NULL
);
3406 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3410 if (sym
->attr
.generic
)
3412 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3415 c
->resolved_sym
= s
;
3416 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3421 /* TODO: Need to search for elemental references in generic interface. */
3424 if (sym
->attr
.intrinsic
)
3425 return gfc_intrinsic_sub_interface (c
, 0);
3432 resolve_generic_s (gfc_code
*c
)
3437 sym
= c
->symtree
->n
.sym
;
3441 m
= resolve_generic_s0 (c
, sym
);
3444 else if (m
== MATCH_ERROR
)
3448 if (sym
->ns
->parent
== NULL
)
3450 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3454 if (!generic_sym (sym
))
3458 /* Last ditch attempt. See if the reference is to an intrinsic
3459 that possesses a matching interface. 14.1.2.4 */
3460 sym
= c
->symtree
->n
.sym
;
3462 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3464 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3465 sym
->name
, &c
->loc
);
3469 m
= gfc_intrinsic_sub_interface (c
, 0);
3473 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3474 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3480 /* Resolve a subroutine call known to be specific. */
3483 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3487 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3489 if (sym
->attr
.dummy
)
3491 sym
->attr
.proc
= PROC_DUMMY
;
3495 sym
->attr
.proc
= PROC_EXTERNAL
;
3499 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3502 if (sym
->attr
.intrinsic
)
3504 m
= gfc_intrinsic_sub_interface (c
, 1);
3508 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3509 "with an intrinsic", sym
->name
, &c
->loc
);
3517 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3519 c
->resolved_sym
= sym
;
3520 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3528 resolve_specific_s (gfc_code
*c
)
3533 sym
= c
->symtree
->n
.sym
;
3537 m
= resolve_specific_s0 (c
, sym
);
3540 if (m
== MATCH_ERROR
)
3543 if (sym
->ns
->parent
== NULL
)
3546 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3552 sym
= c
->symtree
->n
.sym
;
3553 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3554 sym
->name
, &c
->loc
);
3560 /* Resolve a subroutine call not known to be generic nor specific. */
3563 resolve_unknown_s (gfc_code
*c
)
3567 sym
= c
->symtree
->n
.sym
;
3569 if (sym
->attr
.dummy
)
3571 sym
->attr
.proc
= PROC_DUMMY
;
3575 /* See if we have an intrinsic function reference. */
3577 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3579 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3584 /* The reference is to an external name. */
3587 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3589 c
->resolved_sym
= sym
;
3591 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3595 /* Resolve a subroutine call. Although it was tempting to use the same code
3596 for functions, subroutines and functions are stored differently and this
3597 makes things awkward. */
3600 resolve_call (gfc_code
*c
)
3603 procedure_type ptype
= PROC_INTRINSIC
;
3604 gfc_symbol
*csym
, *sym
;
3605 bool no_formal_args
;
3607 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3609 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3611 gfc_error ("%qs at %L has a type, which is not consistent with "
3612 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3616 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3619 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3620 sym
= st
? st
->n
.sym
: NULL
;
3621 if (sym
&& csym
!= sym
3622 && sym
->ns
== gfc_current_ns
3623 && sym
->attr
.flavor
== FL_PROCEDURE
3624 && sym
->attr
.contained
)
3627 if (csym
->attr
.generic
)
3628 c
->symtree
->n
.sym
= sym
;
3631 csym
= c
->symtree
->n
.sym
;
3635 /* If this ia a deferred TBP, c->expr1 will be set. */
3636 if (!c
->expr1
&& csym
)
3638 if (csym
->attr
.abstract
)
3640 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3641 csym
->name
, &c
->loc
);
3645 /* Subroutines without the RECURSIVE attribution are not allowed to
3647 if (is_illegal_recursion (csym
, gfc_current_ns
))
3649 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3650 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3651 "as subroutine %qs is not RECURSIVE",
3652 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3654 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3655 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3661 /* Switch off assumed size checking and do this again for certain kinds
3662 of procedure, once the procedure itself is resolved. */
3663 need_full_assumed_size
++;
3666 ptype
= csym
->attr
.proc
;
3668 no_formal_args
= csym
&& is_external_proc (csym
)
3669 && gfc_sym_get_dummy_args (csym
) == NULL
;
3670 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3673 /* Resume assumed_size checking. */
3674 need_full_assumed_size
--;
3676 /* If external, check for usage. */
3677 if (csym
&& is_external_proc (csym
))
3678 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3681 if (c
->resolved_sym
== NULL
)
3683 c
->resolved_isym
= NULL
;
3684 switch (procedure_kind (csym
))
3687 t
= resolve_generic_s (c
);
3690 case PTYPE_SPECIFIC
:
3691 t
= resolve_specific_s (c
);
3695 t
= resolve_unknown_s (c
);
3699 gfc_internal_error ("resolve_subroutine(): bad function type");
3703 /* Some checks of elemental subroutine actual arguments. */
3704 if (!resolve_elemental_actual (NULL
, c
))
3708 update_current_proc_array_outer_dependency (csym
);
3710 /* Typebound procedure: Assume the worst. */
3711 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3717 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3718 op1->shape and op2->shape are non-NULL return true if their shapes
3719 match. If both op1->shape and op2->shape are non-NULL return false
3720 if their shapes do not match. If either op1->shape or op2->shape is
3721 NULL, return true. */
3724 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3731 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3733 for (i
= 0; i
< op1
->rank
; i
++)
3735 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3737 gfc_error ("Shapes for operands at %L and %L are not conformable",
3738 &op1
->where
, &op2
->where
);
3748 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3749 For example A .AND. B becomes IAND(A, B). */
3751 logical_to_bitwise (gfc_expr
*e
)
3753 gfc_expr
*tmp
, *op1
, *op2
;
3755 gfc_actual_arglist
*args
= NULL
;
3757 gcc_assert (e
->expr_type
== EXPR_OP
);
3759 isym
= GFC_ISYM_NONE
;
3760 op1
= e
->value
.op
.op1
;
3761 op2
= e
->value
.op
.op2
;
3763 switch (e
->value
.op
.op
)
3766 isym
= GFC_ISYM_NOT
;
3769 isym
= GFC_ISYM_IAND
;
3772 isym
= GFC_ISYM_IOR
;
3774 case INTRINSIC_NEQV
:
3775 isym
= GFC_ISYM_IEOR
;
3778 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3779 Change the old expression to NEQV, which will get replaced by IEOR,
3780 and wrap it in NOT. */
3781 tmp
= gfc_copy_expr (e
);
3782 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3783 tmp
= logical_to_bitwise (tmp
);
3784 isym
= GFC_ISYM_NOT
;
3789 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3792 /* Inherit the original operation's operands as arguments. */
3793 args
= gfc_get_actual_arglist ();
3797 args
->next
= gfc_get_actual_arglist ();
3798 args
->next
->expr
= op2
;
3801 /* Convert the expression to a function call. */
3802 e
->expr_type
= EXPR_FUNCTION
;
3803 e
->value
.function
.actual
= args
;
3804 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3805 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3806 e
->value
.function
.esym
= NULL
;
3808 /* Make up a pre-resolved function call symtree if we need to. */
3809 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3812 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3813 sym
= e
->symtree
->n
.sym
;
3815 sym
->attr
.flavor
= FL_PROCEDURE
;
3816 sym
->attr
.function
= 1;
3817 sym
->attr
.elemental
= 1;
3819 sym
->attr
.referenced
= 1;
3820 gfc_intrinsic_symbol (sym
);
3821 gfc_commit_symbol (sym
);
3824 args
->name
= e
->value
.function
.isym
->formal
->name
;
3825 if (e
->value
.function
.isym
->formal
->next
)
3826 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3831 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3832 candidates in CANDIDATES_LEN. */
3834 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3836 size_t &candidates_len
)
3843 /* Not sure how to properly filter here. Use all for a start.
3844 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3845 these as i suppose they don't make terribly sense. */
3847 if (uop
->n
.uop
->op
!= NULL
)
3848 vec_push (candidates
, candidates_len
, uop
->name
);
3852 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3856 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3859 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3862 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3864 char **candidates
= NULL
;
3865 size_t candidates_len
= 0;
3866 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3867 return gfc_closest_fuzzy_match (op
, candidates
);
3871 /* Callback finding an impure function as an operand to an .and. or
3872 .or. expression. Remember the last function warned about to
3873 avoid double warnings when recursing. */
3876 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3881 static gfc_expr
*last
= NULL
;
3882 bool *found
= (bool *) data
;
3884 if (f
->expr_type
== EXPR_FUNCTION
)
3887 if (f
!= last
&& !gfc_pure_function (f
, &name
)
3888 && !gfc_implicit_pure_function (f
))
3891 gfc_warning (OPT_Wfunction_elimination
,
3892 "Impure function %qs at %L might not be evaluated",
3895 gfc_warning (OPT_Wfunction_elimination
,
3896 "Impure function at %L might not be evaluated",
3906 /* Resolve an operator expression node. This can involve replacing the
3907 operation with a user defined function call. */
3910 resolve_operator (gfc_expr
*e
)
3912 gfc_expr
*op1
, *op2
;
3914 bool dual_locus_error
;
3917 /* Resolve all subnodes-- give them types. */
3919 switch (e
->value
.op
.op
)
3922 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3928 case INTRINSIC_UPLUS
:
3929 case INTRINSIC_UMINUS
:
3930 case INTRINSIC_PARENTHESES
:
3931 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3936 /* Typecheck the new node. */
3938 op1
= e
->value
.op
.op1
;
3939 op2
= e
->value
.op
.op2
;
3940 dual_locus_error
= false;
3942 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3943 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3945 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3949 switch (e
->value
.op
.op
)
3951 case INTRINSIC_UPLUS
:
3952 case INTRINSIC_UMINUS
:
3953 if (op1
->ts
.type
== BT_INTEGER
3954 || op1
->ts
.type
== BT_REAL
3955 || op1
->ts
.type
== BT_COMPLEX
)
3961 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3962 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3965 case INTRINSIC_PLUS
:
3966 case INTRINSIC_MINUS
:
3967 case INTRINSIC_TIMES
:
3968 case INTRINSIC_DIVIDE
:
3969 case INTRINSIC_POWER
:
3970 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3972 gfc_type_convert_binary (e
, 1);
3976 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
3978 _("Unexpected derived-type entities in binary intrinsic "
3979 "numeric operator %%<%s%%> at %%L"),
3980 gfc_op2string (e
->value
.op
.op
));
3983 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3984 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3985 gfc_typename (&op2
->ts
));
3988 case INTRINSIC_CONCAT
:
3989 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3990 && op1
->ts
.kind
== op2
->ts
.kind
)
3992 e
->ts
.type
= BT_CHARACTER
;
3993 e
->ts
.kind
= op1
->ts
.kind
;
3998 _("Operands of string concatenation operator at %%L are %s/%s"),
3999 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
4005 case INTRINSIC_NEQV
:
4006 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4008 e
->ts
.type
= BT_LOGICAL
;
4009 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4010 if (op1
->ts
.kind
< e
->ts
.kind
)
4011 gfc_convert_type (op1
, &e
->ts
, 2);
4012 else if (op2
->ts
.kind
< e
->ts
.kind
)
4013 gfc_convert_type (op2
, &e
->ts
, 2);
4015 if (flag_frontend_optimize
&&
4016 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4018 /* Warn about short-circuiting
4019 with impure function as second operand. */
4021 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4026 /* Logical ops on integers become bitwise ops with -fdec. */
4028 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4030 e
->ts
.type
= BT_INTEGER
;
4031 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4032 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4033 gfc_convert_type (op1
, &e
->ts
, 1);
4034 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4035 gfc_convert_type (op2
, &e
->ts
, 1);
4036 e
= logical_to_bitwise (e
);
4040 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4041 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4042 gfc_typename (&op2
->ts
));
4047 /* Logical ops on integers become bitwise ops with -fdec. */
4048 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4050 e
->ts
.type
= BT_INTEGER
;
4051 e
->ts
.kind
= op1
->ts
.kind
;
4052 e
= logical_to_bitwise (e
);
4056 if (op1
->ts
.type
== BT_LOGICAL
)
4058 e
->ts
.type
= BT_LOGICAL
;
4059 e
->ts
.kind
= op1
->ts
.kind
;
4063 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4064 gfc_typename (&op1
->ts
));
4068 case INTRINSIC_GT_OS
:
4070 case INTRINSIC_GE_OS
:
4072 case INTRINSIC_LT_OS
:
4074 case INTRINSIC_LE_OS
:
4075 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4077 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4084 case INTRINSIC_EQ_OS
:
4086 case INTRINSIC_NE_OS
:
4087 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4088 && op1
->ts
.kind
== op2
->ts
.kind
)
4090 e
->ts
.type
= BT_LOGICAL
;
4091 e
->ts
.kind
= gfc_default_logical_kind
;
4095 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4097 gfc_type_convert_binary (e
, 1);
4099 e
->ts
.type
= BT_LOGICAL
;
4100 e
->ts
.kind
= gfc_default_logical_kind
;
4102 if (warn_compare_reals
)
4104 gfc_intrinsic_op op
= e
->value
.op
.op
;
4106 /* Type conversion has made sure that the types of op1 and op2
4107 agree, so it is only necessary to check the first one. */
4108 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4109 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4110 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4114 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4115 msg
= "Equality comparison for %s at %L";
4117 msg
= "Inequality comparison for %s at %L";
4119 gfc_warning (OPT_Wcompare_reals
, msg
,
4120 gfc_typename (&op1
->ts
), &op1
->where
);
4127 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4129 _("Logicals at %%L must be compared with %s instead of %s"),
4130 (e
->value
.op
.op
== INTRINSIC_EQ
4131 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4132 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4135 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4136 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4137 gfc_typename (&op2
->ts
));
4141 case INTRINSIC_USER
:
4142 if (e
->value
.op
.uop
->op
== NULL
)
4144 const char *name
= e
->value
.op
.uop
->name
;
4145 const char *guessed
;
4146 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4148 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4151 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4153 else if (op2
== NULL
)
4154 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4155 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4158 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4159 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4160 gfc_typename (&op2
->ts
));
4161 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4166 case INTRINSIC_PARENTHESES
:
4168 if (e
->ts
.type
== BT_CHARACTER
)
4169 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4173 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4176 /* Deal with arrayness of an operand through an operator. */
4178 switch (e
->value
.op
.op
)
4180 case INTRINSIC_PLUS
:
4181 case INTRINSIC_MINUS
:
4182 case INTRINSIC_TIMES
:
4183 case INTRINSIC_DIVIDE
:
4184 case INTRINSIC_POWER
:
4185 case INTRINSIC_CONCAT
:
4189 case INTRINSIC_NEQV
:
4191 case INTRINSIC_EQ_OS
:
4193 case INTRINSIC_NE_OS
:
4195 case INTRINSIC_GT_OS
:
4197 case INTRINSIC_GE_OS
:
4199 case INTRINSIC_LT_OS
:
4201 case INTRINSIC_LE_OS
:
4203 if (op1
->rank
== 0 && op2
->rank
== 0)
4206 if (op1
->rank
== 0 && op2
->rank
!= 0)
4208 e
->rank
= op2
->rank
;
4210 if (e
->shape
== NULL
)
4211 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4214 if (op1
->rank
!= 0 && op2
->rank
== 0)
4216 e
->rank
= op1
->rank
;
4218 if (e
->shape
== NULL
)
4219 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4222 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4224 if (op1
->rank
== op2
->rank
)
4226 e
->rank
= op1
->rank
;
4227 if (e
->shape
== NULL
)
4229 t
= compare_shapes (op1
, op2
);
4233 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4238 /* Allow higher level expressions to work. */
4241 /* Try user-defined operators, and otherwise throw an error. */
4242 dual_locus_error
= true;
4244 _("Inconsistent ranks for operator at %%L and %%L"));
4251 case INTRINSIC_PARENTHESES
:
4253 case INTRINSIC_UPLUS
:
4254 case INTRINSIC_UMINUS
:
4255 /* Simply copy arrayness attribute */
4256 e
->rank
= op1
->rank
;
4258 if (e
->shape
== NULL
)
4259 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4269 /* Attempt to simplify the expression. */
4272 t
= gfc_simplify_expr (e
, 0);
4273 /* Some calls do not succeed in simplification and return false
4274 even though there is no error; e.g. variable references to
4275 PARAMETER arrays. */
4276 if (!gfc_is_constant_expr (e
))
4284 match m
= gfc_extend_expr (e
);
4287 if (m
== MATCH_ERROR
)
4291 if (dual_locus_error
)
4292 gfc_error (msg
, &op1
->where
, &op2
->where
);
4294 gfc_error (msg
, &e
->where
);
4300 /************** Array resolution subroutines **************/
4303 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4305 /* Compare two integer expressions. */
4307 static compare_result
4308 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4312 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4313 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4316 /* If either of the types isn't INTEGER, we must have
4317 raised an error earlier. */
4319 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4322 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4332 /* Compare an integer expression with an integer. */
4334 static compare_result
4335 compare_bound_int (gfc_expr
*a
, int b
)
4339 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4342 if (a
->ts
.type
!= BT_INTEGER
)
4343 gfc_internal_error ("compare_bound_int(): Bad expression");
4345 i
= mpz_cmp_si (a
->value
.integer
, b
);
4355 /* Compare an integer expression with a mpz_t. */
4357 static compare_result
4358 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4362 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4365 if (a
->ts
.type
!= BT_INTEGER
)
4366 gfc_internal_error ("compare_bound_int(): Bad expression");
4368 i
= mpz_cmp (a
->value
.integer
, b
);
4378 /* Compute the last value of a sequence given by a triplet.
4379 Return 0 if it wasn't able to compute the last value, or if the
4380 sequence if empty, and 1 otherwise. */
4383 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4384 gfc_expr
*stride
, mpz_t last
)
4388 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4389 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4390 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4393 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4394 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4397 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4399 if (compare_bound (start
, end
) == CMP_GT
)
4401 mpz_set (last
, end
->value
.integer
);
4405 if (compare_bound_int (stride
, 0) == CMP_GT
)
4407 /* Stride is positive */
4408 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4413 /* Stride is negative */
4414 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4419 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4420 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4421 mpz_sub (last
, end
->value
.integer
, rem
);
4428 /* Compare a single dimension of an array reference to the array
4432 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4436 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4438 gcc_assert (ar
->stride
[i
] == NULL
);
4439 /* This implies [*] as [*:] and [*:3] are not possible. */
4440 if (ar
->start
[i
] == NULL
)
4442 gcc_assert (ar
->end
[i
] == NULL
);
4447 /* Given start, end and stride values, calculate the minimum and
4448 maximum referenced indexes. */
4450 switch (ar
->dimen_type
[i
])
4453 case DIMEN_THIS_IMAGE
:
4458 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4461 gfc_warning (0, "Array reference at %L is out of bounds "
4462 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4463 mpz_get_si (ar
->start
[i
]->value
.integer
),
4464 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4466 gfc_warning (0, "Array reference at %L is out of bounds "
4467 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4468 mpz_get_si (ar
->start
[i
]->value
.integer
),
4469 mpz_get_si (as
->lower
[i
]->value
.integer
),
4473 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4476 gfc_warning (0, "Array reference at %L is out of bounds "
4477 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4478 mpz_get_si (ar
->start
[i
]->value
.integer
),
4479 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4481 gfc_warning (0, "Array reference at %L is out of bounds "
4482 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4483 mpz_get_si (ar
->start
[i
]->value
.integer
),
4484 mpz_get_si (as
->upper
[i
]->value
.integer
),
4493 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4494 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4496 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4498 /* Check for zero stride, which is not allowed. */
4499 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4501 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4505 /* if start == len || (stride > 0 && start < len)
4506 || (stride < 0 && start > len),
4507 then the array section contains at least one element. In this
4508 case, there is an out-of-bounds access if
4509 (start < lower || start > upper). */
4510 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4511 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4512 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4513 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4514 && comp_start_end
== CMP_GT
))
4516 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4518 gfc_warning (0, "Lower array reference at %L is out of bounds "
4519 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4520 mpz_get_si (AR_START
->value
.integer
),
4521 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4524 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4526 gfc_warning (0, "Lower array reference at %L is out of bounds "
4527 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4528 mpz_get_si (AR_START
->value
.integer
),
4529 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4534 /* If we can compute the highest index of the array section,
4535 then it also has to be between lower and upper. */
4536 mpz_init (last_value
);
4537 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4540 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4542 gfc_warning (0, "Upper array reference at %L is out of bounds "
4543 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4544 mpz_get_si (last_value
),
4545 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4546 mpz_clear (last_value
);
4549 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4551 gfc_warning (0, "Upper array reference at %L is out of bounds "
4552 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4553 mpz_get_si (last_value
),
4554 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4555 mpz_clear (last_value
);
4559 mpz_clear (last_value
);
4567 gfc_internal_error ("check_dimension(): Bad array reference");
4574 /* Compare an array reference with an array specification. */
4577 compare_spec_to_ref (gfc_array_ref
*ar
)
4584 /* TODO: Full array sections are only allowed as actual parameters. */
4585 if (as
->type
== AS_ASSUMED_SIZE
4586 && (/*ar->type == AR_FULL
4587 ||*/ (ar
->type
== AR_SECTION
4588 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4590 gfc_error ("Rightmost upper bound of assumed size array section "
4591 "not specified at %L", &ar
->where
);
4595 if (ar
->type
== AR_FULL
)
4598 if (as
->rank
!= ar
->dimen
)
4600 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4601 &ar
->where
, ar
->dimen
, as
->rank
);
4605 /* ar->codimen == 0 is a local array. */
4606 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4608 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4609 &ar
->where
, ar
->codimen
, as
->corank
);
4613 for (i
= 0; i
< as
->rank
; i
++)
4614 if (!check_dimension (i
, ar
, as
))
4617 /* Local access has no coarray spec. */
4618 if (ar
->codimen
!= 0)
4619 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4621 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4622 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4624 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4625 i
+ 1 - as
->rank
, &ar
->where
);
4628 if (!check_dimension (i
, ar
, as
))
4636 /* Resolve one part of an array index. */
4639 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4640 int force_index_integer_kind
)
4647 if (!gfc_resolve_expr (index
))
4650 if (check_scalar
&& index
->rank
!= 0)
4652 gfc_error ("Array index at %L must be scalar", &index
->where
);
4656 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4658 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4659 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4663 if (index
->ts
.type
== BT_REAL
)
4664 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4668 if ((index
->ts
.kind
!= gfc_index_integer_kind
4669 && force_index_integer_kind
)
4670 || index
->ts
.type
!= BT_INTEGER
)
4673 ts
.type
= BT_INTEGER
;
4674 ts
.kind
= gfc_index_integer_kind
;
4676 gfc_convert_type_warn (index
, &ts
, 2, 0);
4682 /* Resolve one part of an array index. */
4685 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4687 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4690 /* Resolve a dim argument to an intrinsic function. */
4693 gfc_resolve_dim_arg (gfc_expr
*dim
)
4698 if (!gfc_resolve_expr (dim
))
4703 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4708 if (dim
->ts
.type
!= BT_INTEGER
)
4710 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4714 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4719 ts
.type
= BT_INTEGER
;
4720 ts
.kind
= gfc_index_integer_kind
;
4722 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4728 /* Given an expression that contains array references, update those array
4729 references to point to the right array specifications. While this is
4730 filled in during matching, this information is difficult to save and load
4731 in a module, so we take care of it here.
4733 The idea here is that the original array reference comes from the
4734 base symbol. We traverse the list of reference structures, setting
4735 the stored reference to references. Component references can
4736 provide an additional array specification. */
4739 find_array_spec (gfc_expr
*e
)
4744 bool class_as
= false;
4746 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4748 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4752 as
= e
->symtree
->n
.sym
->as
;
4754 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4759 gfc_internal_error ("find_array_spec(): Missing spec");
4766 c
= ref
->u
.c
.component
;
4767 if (c
->attr
.dimension
)
4769 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
4770 gfc_internal_error ("find_array_spec(): unused as(1)");
4782 gfc_internal_error ("find_array_spec(): unused as(2)");
4786 /* Resolve an array reference. */
4789 resolve_array_ref (gfc_array_ref
*ar
)
4791 int i
, check_scalar
;
4794 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4796 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4798 /* Do not force gfc_index_integer_kind for the start. We can
4799 do fine with any integer kind. This avoids temporary arrays
4800 created for indexing with a vector. */
4801 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4803 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4805 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4810 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4814 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4818 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4819 if (e
->expr_type
== EXPR_VARIABLE
4820 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4821 ar
->start
[i
] = gfc_get_parentheses (e
);
4825 gfc_error ("Array index at %L is an array of rank %d",
4826 &ar
->c_where
[i
], e
->rank
);
4830 /* Fill in the upper bound, which may be lower than the
4831 specified one for something like a(2:10:5), which is
4832 identical to a(2:7:5). Only relevant for strides not equal
4833 to one. Don't try a division by zero. */
4834 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4835 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4836 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4837 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4841 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4843 if (ar
->end
[i
] == NULL
)
4846 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4848 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4850 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4851 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4853 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4864 if (ar
->type
== AR_FULL
)
4866 if (ar
->as
->rank
== 0)
4867 ar
->type
= AR_ELEMENT
;
4869 /* Make sure array is the same as array(:,:), this way
4870 we don't need to special case all the time. */
4871 ar
->dimen
= ar
->as
->rank
;
4872 for (i
= 0; i
< ar
->dimen
; i
++)
4874 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4876 gcc_assert (ar
->start
[i
] == NULL
);
4877 gcc_assert (ar
->end
[i
] == NULL
);
4878 gcc_assert (ar
->stride
[i
] == NULL
);
4882 /* If the reference type is unknown, figure out what kind it is. */
4884 if (ar
->type
== AR_UNKNOWN
)
4886 ar
->type
= AR_ELEMENT
;
4887 for (i
= 0; i
< ar
->dimen
; i
++)
4888 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4889 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4891 ar
->type
= AR_SECTION
;
4896 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4899 if (ar
->as
->corank
&& ar
->codimen
== 0)
4902 ar
->codimen
= ar
->as
->corank
;
4903 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4904 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4912 resolve_substring (gfc_ref
*ref
, bool *equal_length
)
4914 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4916 if (ref
->u
.ss
.start
!= NULL
)
4918 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4921 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4923 gfc_error ("Substring start index at %L must be of type INTEGER",
4924 &ref
->u
.ss
.start
->where
);
4928 if (ref
->u
.ss
.start
->rank
!= 0)
4930 gfc_error ("Substring start index at %L must be scalar",
4931 &ref
->u
.ss
.start
->where
);
4935 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4936 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4937 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4939 gfc_error ("Substring start index at %L is less than one",
4940 &ref
->u
.ss
.start
->where
);
4945 if (ref
->u
.ss
.end
!= NULL
)
4947 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4950 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4952 gfc_error ("Substring end index at %L must be of type INTEGER",
4953 &ref
->u
.ss
.end
->where
);
4957 if (ref
->u
.ss
.end
->rank
!= 0)
4959 gfc_error ("Substring end index at %L must be scalar",
4960 &ref
->u
.ss
.end
->where
);
4964 if (ref
->u
.ss
.length
!= NULL
4965 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4966 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4967 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4969 gfc_error ("Substring end index at %L exceeds the string length",
4970 &ref
->u
.ss
.start
->where
);
4974 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4975 gfc_integer_kinds
[k
].huge
) == CMP_GT
4976 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4977 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4979 gfc_error ("Substring end index at %L is too large",
4980 &ref
->u
.ss
.end
->where
);
4983 /* If the substring has the same length as the original
4984 variable, the reference itself can be deleted. */
4986 if (ref
->u
.ss
.length
!= NULL
4987 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
4988 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
4989 *equal_length
= true;
4996 /* This function supplies missing substring charlens. */
4999 gfc_resolve_substring_charlen (gfc_expr
*e
)
5002 gfc_expr
*start
, *end
;
5003 gfc_typespec
*ts
= NULL
;
5006 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5008 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5010 if (char_ref
->type
== REF_COMPONENT
)
5011 ts
= &char_ref
->u
.c
.component
->ts
;
5014 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5017 gcc_assert (char_ref
->next
== NULL
);
5021 if (e
->ts
.u
.cl
->length
)
5022 gfc_free_expr (e
->ts
.u
.cl
->length
);
5023 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5027 e
->ts
.type
= BT_CHARACTER
;
5028 e
->ts
.kind
= gfc_default_character_kind
;
5031 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5033 if (char_ref
->u
.ss
.start
)
5034 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5036 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5038 if (char_ref
->u
.ss
.end
)
5039 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5040 else if (e
->expr_type
== EXPR_VARIABLE
)
5043 ts
= &e
->symtree
->n
.sym
->ts
;
5044 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5051 gfc_free_expr (start
);
5052 gfc_free_expr (end
);
5056 /* Length = (end - start + 1).
5057 Check first whether it has a constant length. */
5058 if (gfc_dep_difference (end
, start
, &diff
))
5060 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5063 mpz_add_ui (len
->value
.integer
, diff
, 1);
5065 e
->ts
.u
.cl
->length
= len
;
5066 /* The check for length < 0 is handled below */
5070 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5071 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5072 gfc_get_int_expr (gfc_charlen_int_kind
,
5076 /* F2008, 6.4.1: Both the starting point and the ending point shall
5077 be within the range 1, 2, ..., n unless the starting point exceeds
5078 the ending point, in which case the substring has length zero. */
5080 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5081 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5083 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5084 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5086 /* Make sure that the length is simplified. */
5087 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5088 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5092 /* Resolve subtype references. */
5095 resolve_ref (gfc_expr
*expr
)
5097 int current_part_dimension
, n_components
, seen_part_dimension
;
5098 gfc_ref
*ref
, **prev
;
5101 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5102 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5104 find_array_spec (expr
);
5108 for (prev
= &expr
->ref
; *prev
!= NULL
;
5109 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5110 switch ((*prev
)->type
)
5113 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5122 equal_length
= false;
5123 if (!resolve_substring (*prev
, &equal_length
))
5126 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5128 /* Remove the reference and move the charlen, if any. */
5132 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5133 ref
->u
.ss
.length
= NULL
;
5134 gfc_free_ref_list (ref
);
5139 /* Check constraints on part references. */
5141 current_part_dimension
= 0;
5142 seen_part_dimension
= 0;
5145 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5150 switch (ref
->u
.ar
.type
)
5153 /* Coarray scalar. */
5154 if (ref
->u
.ar
.as
->rank
== 0)
5156 current_part_dimension
= 0;
5161 current_part_dimension
= 1;
5165 current_part_dimension
= 0;
5169 gfc_internal_error ("resolve_ref(): Bad array reference");
5175 if (current_part_dimension
|| seen_part_dimension
)
5178 if (ref
->u
.c
.component
->attr
.pointer
5179 || ref
->u
.c
.component
->attr
.proc_pointer
5180 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5181 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5183 gfc_error ("Component to the right of a part reference "
5184 "with nonzero rank must not have the POINTER "
5185 "attribute at %L", &expr
->where
);
5188 else if (ref
->u
.c
.component
->attr
.allocatable
5189 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5190 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5193 gfc_error ("Component to the right of a part reference "
5194 "with nonzero rank must not have the ALLOCATABLE "
5195 "attribute at %L", &expr
->where
);
5208 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5209 || ref
->next
== NULL
)
5210 && current_part_dimension
5211 && seen_part_dimension
)
5213 gfc_error ("Two or more part references with nonzero rank must "
5214 "not be specified at %L", &expr
->where
);
5218 if (ref
->type
== REF_COMPONENT
)
5220 if (current_part_dimension
)
5221 seen_part_dimension
= 1;
5223 /* reset to make sure */
5224 current_part_dimension
= 0;
5232 /* Given an expression, determine its shape. This is easier than it sounds.
5233 Leaves the shape array NULL if it is not possible to determine the shape. */
5236 expression_shape (gfc_expr
*e
)
5238 mpz_t array
[GFC_MAX_DIMENSIONS
];
5241 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5244 for (i
= 0; i
< e
->rank
; i
++)
5245 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5248 e
->shape
= gfc_get_shape (e
->rank
);
5250 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5255 for (i
--; i
>= 0; i
--)
5256 mpz_clear (array
[i
]);
5260 /* Given a variable expression node, compute the rank of the expression by
5261 examining the base symbol and any reference structures it may have. */
5264 expression_rank (gfc_expr
*e
)
5269 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5270 could lead to serious confusion... */
5271 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5275 if (e
->expr_type
== EXPR_ARRAY
)
5277 /* Constructors can have a rank different from one via RESHAPE(). */
5279 if (e
->symtree
== NULL
)
5285 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5286 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5292 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5294 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5295 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5296 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5298 if (ref
->type
!= REF_ARRAY
)
5301 if (ref
->u
.ar
.type
== AR_FULL
)
5303 rank
= ref
->u
.ar
.as
->rank
;
5307 if (ref
->u
.ar
.type
== AR_SECTION
)
5309 /* Figure out the rank of the section. */
5311 gfc_internal_error ("expression_rank(): Two array specs");
5313 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5314 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5315 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5325 expression_shape (e
);
5330 add_caf_get_intrinsic (gfc_expr
*e
)
5332 gfc_expr
*wrapper
, *tmp_expr
;
5336 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5337 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5342 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5343 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5346 tmp_expr
= XCNEW (gfc_expr
);
5348 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5349 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5350 wrapper
->ts
= e
->ts
;
5351 wrapper
->rank
= e
->rank
;
5353 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5360 remove_caf_get_intrinsic (gfc_expr
*e
)
5362 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5363 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5364 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5365 e
->value
.function
.actual
->expr
= NULL
;
5366 gfc_free_actual_arglist (e
->value
.function
.actual
);
5367 gfc_free_shape (&e
->shape
, e
->rank
);
5373 /* Resolve a variable expression. */
5376 resolve_variable (gfc_expr
*e
)
5383 if (e
->symtree
== NULL
)
5385 sym
= e
->symtree
->n
.sym
;
5387 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5388 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5389 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5391 if (!actual_arg
|| inquiry_argument
)
5393 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5394 "be used as actual argument", sym
->name
, &e
->where
);
5398 /* TS 29113, 407b. */
5399 else if (e
->ts
.type
== BT_ASSUMED
)
5403 gfc_error ("Assumed-type variable %s at %L may only be used "
5404 "as actual argument", sym
->name
, &e
->where
);
5407 else if (inquiry_argument
&& !first_actual_arg
)
5409 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5410 for all inquiry functions in resolve_function; the reason is
5411 that the function-name resolution happens too late in that
5413 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5414 "an inquiry function shall be the first argument",
5415 sym
->name
, &e
->where
);
5419 /* TS 29113, C535b. */
5420 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5421 && CLASS_DATA (sym
)->as
5422 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5423 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5424 && sym
->as
->type
== AS_ASSUMED_RANK
))
5428 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5429 "actual argument", sym
->name
, &e
->where
);
5432 else if (inquiry_argument
&& !first_actual_arg
)
5434 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5435 for all inquiry functions in resolve_function; the reason is
5436 that the function-name resolution happens too late in that
5438 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5439 "to an inquiry function shall be the first argument",
5440 sym
->name
, &e
->where
);
5445 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5446 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5447 && e
->ref
->next
== NULL
))
5449 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5450 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5453 /* TS 29113, 407b. */
5454 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5455 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5456 && e
->ref
->next
== NULL
))
5458 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5459 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5463 /* TS 29113, C535b. */
5464 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5465 && CLASS_DATA (sym
)->as
5466 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5467 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5468 && sym
->as
->type
== AS_ASSUMED_RANK
))
5470 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5471 && e
->ref
->next
== NULL
))
5473 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5474 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5478 /* For variables that are used in an associate (target => object) where
5479 the object's basetype is array valued while the target is scalar,
5480 the ts' type of the component refs is still array valued, which
5481 can't be translated that way. */
5482 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5483 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5484 && CLASS_DATA (sym
->assoc
->target
)->as
)
5486 gfc_ref
*ref
= e
->ref
;
5492 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5493 /* Stop the loop. */
5503 /* If this is an associate-name, it may be parsed with an array reference
5504 in error even though the target is scalar. Fail directly in this case.
5505 TODO Understand why class scalar expressions must be excluded. */
5506 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5508 if (sym
->ts
.type
== BT_CLASS
)
5509 gfc_fix_class_refs (e
);
5510 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5512 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5514 /* This can happen because the parser did not detect that the
5515 associate name is an array and the expression had no array
5517 gfc_ref
*ref
= gfc_get_ref ();
5518 ref
->type
= REF_ARRAY
;
5519 ref
->u
.ar
= *gfc_get_array_ref();
5520 ref
->u
.ar
.type
= AR_FULL
;
5523 ref
->u
.ar
.as
= sym
->as
;
5524 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5532 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5533 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5535 /* On the other hand, the parser may not have known this is an array;
5536 in this case, we have to add a FULL reference. */
5537 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5539 e
->ref
= gfc_get_ref ();
5540 e
->ref
->type
= REF_ARRAY
;
5541 e
->ref
->u
.ar
.type
= AR_FULL
;
5542 e
->ref
->u
.ar
.dimen
= 0;
5545 /* Like above, but for class types, where the checking whether an array
5546 ref is present is more complicated. Furthermore make sure not to add
5547 the full array ref to _vptr or _len refs. */
5548 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5549 && CLASS_DATA (sym
)->attr
.dimension
5550 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5552 gfc_ref
*ref
, *newref
;
5554 newref
= gfc_get_ref ();
5555 newref
->type
= REF_ARRAY
;
5556 newref
->u
.ar
.type
= AR_FULL
;
5557 newref
->u
.ar
.dimen
= 0;
5558 /* Because this is an associate var and the first ref either is a ref to
5559 the _data component or not, no traversal of the ref chain is
5560 needed. The array ref needs to be inserted after the _data ref,
5561 or when that is not present, which may happend for polymorphic
5562 types, then at the first position. */
5566 else if (ref
->type
== REF_COMPONENT
5567 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5569 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5571 newref
->next
= ref
->next
;
5575 /* Array ref present already. */
5576 gfc_free_ref_list (newref
);
5578 else if (ref
->type
== REF_ARRAY
)
5579 /* Array ref present already. */
5580 gfc_free_ref_list (newref
);
5588 if (e
->ref
&& !resolve_ref (e
))
5591 if (sym
->attr
.flavor
== FL_PROCEDURE
5592 && (!sym
->attr
.function
5593 || (sym
->attr
.function
&& sym
->result
5594 && sym
->result
->attr
.proc_pointer
5595 && !sym
->result
->attr
.function
)))
5597 e
->ts
.type
= BT_PROCEDURE
;
5598 goto resolve_procedure
;
5601 if (sym
->ts
.type
!= BT_UNKNOWN
)
5602 gfc_variable_attr (e
, &e
->ts
);
5603 else if (sym
->attr
.flavor
== FL_PROCEDURE
5604 && sym
->attr
.function
&& sym
->result
5605 && sym
->result
->ts
.type
!= BT_UNKNOWN
5606 && sym
->result
->attr
.proc_pointer
)
5607 e
->ts
= sym
->result
->ts
;
5610 /* Must be a simple variable reference. */
5611 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5616 if (check_assumed_size_reference (sym
, e
))
5619 /* Deal with forward references to entries during gfc_resolve_code, to
5620 satisfy, at least partially, 12.5.2.5. */
5621 if (gfc_current_ns
->entries
5622 && current_entry_id
== sym
->entry_id
5625 && cs_base
->current
->op
!= EXEC_ENTRY
)
5627 gfc_entry_list
*entry
;
5628 gfc_formal_arglist
*formal
;
5630 bool seen
, saved_specification_expr
;
5632 /* If the symbol is a dummy... */
5633 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5635 entry
= gfc_current_ns
->entries
;
5638 /* ...test if the symbol is a parameter of previous entries. */
5639 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5640 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5642 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5649 /* If it has not been seen as a dummy, this is an error. */
5652 if (specification_expr
)
5653 gfc_error ("Variable %qs, used in a specification expression"
5654 ", is referenced at %L before the ENTRY statement "
5655 "in which it is a parameter",
5656 sym
->name
, &cs_base
->current
->loc
);
5658 gfc_error ("Variable %qs is used at %L before the ENTRY "
5659 "statement in which it is a parameter",
5660 sym
->name
, &cs_base
->current
->loc
);
5665 /* Now do the same check on the specification expressions. */
5666 saved_specification_expr
= specification_expr
;
5667 specification_expr
= true;
5668 if (sym
->ts
.type
== BT_CHARACTER
5669 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5673 for (n
= 0; n
< sym
->as
->rank
; n
++)
5675 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5677 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5680 specification_expr
= saved_specification_expr
;
5683 /* Update the symbol's entry level. */
5684 sym
->entry_id
= current_entry_id
+ 1;
5687 /* If a symbol has been host_associated mark it. This is used latter,
5688 to identify if aliasing is possible via host association. */
5689 if (sym
->attr
.flavor
== FL_VARIABLE
5690 && gfc_current_ns
->parent
5691 && (gfc_current_ns
->parent
== sym
->ns
5692 || (gfc_current_ns
->parent
->parent
5693 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5694 sym
->attr
.host_assoc
= 1;
5696 if (gfc_current_ns
->proc_name
5697 && sym
->attr
.dimension
5698 && (sym
->ns
!= gfc_current_ns
5699 || sym
->attr
.use_assoc
5700 || sym
->attr
.in_common
))
5701 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5704 if (t
&& !resolve_procedure_expression (e
))
5707 /* F2008, C617 and C1229. */
5708 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5709 && gfc_is_coindexed (e
))
5711 gfc_ref
*ref
, *ref2
= NULL
;
5713 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5715 if (ref
->type
== REF_COMPONENT
)
5717 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5721 for ( ; ref
; ref
= ref
->next
)
5722 if (ref
->type
== REF_COMPONENT
)
5725 /* Expression itself is not coindexed object. */
5726 if (ref
&& e
->ts
.type
== BT_CLASS
)
5728 gfc_error ("Polymorphic subobject of coindexed object at %L",
5733 /* Expression itself is coindexed object. */
5737 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5738 for ( ; c
; c
= c
->next
)
5739 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5741 gfc_error ("Coindexed object with polymorphic allocatable "
5742 "subcomponent at %L", &e
->where
);
5750 expression_rank (e
);
5752 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5753 add_caf_get_intrinsic (e
);
5755 /* Simplify cases where access to a parameter array results in a
5756 single constant. Suppress errors since those will have been
5757 issued before, as warnings. */
5758 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5760 gfc_push_suppress_errors ();
5761 gfc_simplify_expr (e
, 1);
5762 gfc_pop_suppress_errors ();
5769 /* Checks to see that the correct symbol has been host associated.
5770 The only situation where this arises is that in which a twice
5771 contained function is parsed after the host association is made.
5772 Therefore, on detecting this, change the symbol in the expression
5773 and convert the array reference into an actual arglist if the old
5774 symbol is a variable. */
5776 check_host_association (gfc_expr
*e
)
5778 gfc_symbol
*sym
, *old_sym
;
5782 gfc_actual_arglist
*arg
, *tail
= NULL
;
5783 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5785 /* If the expression is the result of substitution in
5786 interface.c(gfc_extend_expr) because there is no way in
5787 which the host association can be wrong. */
5788 if (e
->symtree
== NULL
5789 || e
->symtree
->n
.sym
== NULL
5790 || e
->user_operator
)
5793 old_sym
= e
->symtree
->n
.sym
;
5795 if (gfc_current_ns
->parent
5796 && old_sym
->ns
!= gfc_current_ns
)
5798 /* Use the 'USE' name so that renamed module symbols are
5799 correctly handled. */
5800 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5802 if (sym
&& old_sym
!= sym
5803 && sym
->ts
.type
== old_sym
->ts
.type
5804 && sym
->attr
.flavor
== FL_PROCEDURE
5805 && sym
->attr
.contained
)
5807 /* Clear the shape, since it might not be valid. */
5808 gfc_free_shape (&e
->shape
, e
->rank
);
5810 /* Give the expression the right symtree! */
5811 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5812 gcc_assert (st
!= NULL
);
5814 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5815 || e
->expr_type
== EXPR_FUNCTION
)
5817 /* Original was function so point to the new symbol, since
5818 the actual argument list is already attached to the
5820 e
->value
.function
.esym
= NULL
;
5825 /* Original was variable so convert array references into
5826 an actual arglist. This does not need any checking now
5827 since resolve_function will take care of it. */
5828 e
->value
.function
.actual
= NULL
;
5829 e
->expr_type
= EXPR_FUNCTION
;
5832 /* Ambiguity will not arise if the array reference is not
5833 the last reference. */
5834 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5835 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5838 gcc_assert (ref
->type
== REF_ARRAY
);
5840 /* Grab the start expressions from the array ref and
5841 copy them into actual arguments. */
5842 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5844 arg
= gfc_get_actual_arglist ();
5845 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5846 if (e
->value
.function
.actual
== NULL
)
5847 tail
= e
->value
.function
.actual
= arg
;
5855 /* Dump the reference list and set the rank. */
5856 gfc_free_ref_list (e
->ref
);
5858 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5861 gfc_resolve_expr (e
);
5865 /* This might have changed! */
5866 return e
->expr_type
== EXPR_FUNCTION
;
5871 gfc_resolve_character_operator (gfc_expr
*e
)
5873 gfc_expr
*op1
= e
->value
.op
.op1
;
5874 gfc_expr
*op2
= e
->value
.op
.op2
;
5875 gfc_expr
*e1
= NULL
;
5876 gfc_expr
*e2
= NULL
;
5878 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5880 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5881 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5882 else if (op1
->expr_type
== EXPR_CONSTANT
)
5883 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5884 op1
->value
.character
.length
);
5886 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5887 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5888 else if (op2
->expr_type
== EXPR_CONSTANT
)
5889 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5890 op2
->value
.character
.length
);
5892 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5902 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5903 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5904 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5905 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5906 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5912 /* Ensure that an character expression has a charlen and, if possible, a
5913 length expression. */
5916 fixup_charlen (gfc_expr
*e
)
5918 /* The cases fall through so that changes in expression type and the need
5919 for multiple fixes are picked up. In all circumstances, a charlen should
5920 be available for the middle end to hang a backend_decl on. */
5921 switch (e
->expr_type
)
5924 gfc_resolve_character_operator (e
);
5928 if (e
->expr_type
== EXPR_ARRAY
)
5929 gfc_resolve_character_array_constructor (e
);
5932 case EXPR_SUBSTRING
:
5933 if (!e
->ts
.u
.cl
&& e
->ref
)
5934 gfc_resolve_substring_charlen (e
);
5939 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5946 /* Update an actual argument to include the passed-object for type-bound
5947 procedures at the right position. */
5949 static gfc_actual_arglist
*
5950 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5953 gcc_assert (argpos
> 0);
5957 gfc_actual_arglist
* result
;
5959 result
= gfc_get_actual_arglist ();
5963 result
->name
= name
;
5969 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5971 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5976 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5979 extract_compcall_passed_object (gfc_expr
* e
)
5983 if (e
->expr_type
== EXPR_UNKNOWN
)
5985 gfc_error ("Error in typebound call at %L",
5990 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5992 if (e
->value
.compcall
.base_object
)
5993 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5996 po
= gfc_get_expr ();
5997 po
->expr_type
= EXPR_VARIABLE
;
5998 po
->symtree
= e
->symtree
;
5999 po
->ref
= gfc_copy_ref (e
->ref
);
6000 po
->where
= e
->where
;
6003 if (!gfc_resolve_expr (po
))
6010 /* Update the arglist of an EXPR_COMPCALL expression to include the
6014 update_compcall_arglist (gfc_expr
* e
)
6017 gfc_typebound_proc
* tbp
;
6019 tbp
= e
->value
.compcall
.tbp
;
6024 po
= extract_compcall_passed_object (e
);
6028 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6034 if (tbp
->pass_arg_num
<= 0)
6037 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6045 /* Extract the passed object from a PPC call (a copy of it). */
6048 extract_ppc_passed_object (gfc_expr
*e
)
6053 po
= gfc_get_expr ();
6054 po
->expr_type
= EXPR_VARIABLE
;
6055 po
->symtree
= e
->symtree
;
6056 po
->ref
= gfc_copy_ref (e
->ref
);
6057 po
->where
= e
->where
;
6059 /* Remove PPC reference. */
6061 while ((*ref
)->next
)
6062 ref
= &(*ref
)->next
;
6063 gfc_free_ref_list (*ref
);
6066 if (!gfc_resolve_expr (po
))
6073 /* Update the actual arglist of a procedure pointer component to include the
6077 update_ppc_arglist (gfc_expr
* e
)
6081 gfc_typebound_proc
* tb
;
6083 ppc
= gfc_get_proc_ptr_comp (e
);
6091 else if (tb
->nopass
)
6094 po
= extract_ppc_passed_object (e
);
6101 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6106 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6108 gfc_error ("Base object for procedure-pointer component call at %L is of"
6109 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6113 gcc_assert (tb
->pass_arg_num
> 0);
6114 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6122 /* Check that the object a TBP is called on is valid, i.e. it must not be
6123 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6126 check_typebound_baseobject (gfc_expr
* e
)
6129 bool return_value
= false;
6131 base
= extract_compcall_passed_object (e
);
6135 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6137 gfc_error ("Error in typebound call at %L", &e
->where
);
6141 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6145 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6147 gfc_error ("Base object for type-bound procedure call at %L is of"
6148 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6152 /* F08:C1230. If the procedure called is NOPASS,
6153 the base object must be scalar. */
6154 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6156 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6157 " be scalar", &e
->where
);
6161 return_value
= true;
6164 gfc_free_expr (base
);
6165 return return_value
;
6169 /* Resolve a call to a type-bound procedure, either function or subroutine,
6170 statically from the data in an EXPR_COMPCALL expression. The adapted
6171 arglist and the target-procedure symtree are returned. */
6174 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6175 gfc_actual_arglist
** actual
)
6177 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6178 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6180 /* Update the actual arglist for PASS. */
6181 if (!update_compcall_arglist (e
))
6184 *actual
= e
->value
.compcall
.actual
;
6185 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6187 gfc_free_ref_list (e
->ref
);
6189 e
->value
.compcall
.actual
= NULL
;
6191 /* If we find a deferred typebound procedure, check for derived types
6192 that an overriding typebound procedure has not been missed. */
6193 if (e
->value
.compcall
.name
6194 && !e
->value
.compcall
.tbp
->non_overridable
6195 && e
->value
.compcall
.base_object
6196 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6199 gfc_symbol
*derived
;
6201 /* Use the derived type of the base_object. */
6202 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6205 /* If necessary, go through the inheritance chain. */
6206 while (!st
&& derived
)
6208 /* Look for the typebound procedure 'name'. */
6209 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6210 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6211 e
->value
.compcall
.name
);
6213 derived
= gfc_get_derived_super_type (derived
);
6216 /* Now find the specific name in the derived type namespace. */
6217 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6218 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6219 derived
->ns
, 1, &st
);
6227 /* Get the ultimate declared type from an expression. In addition,
6228 return the last class/derived type reference and the copy of the
6229 reference list. If check_types is set true, derived types are
6230 identified as well as class references. */
6232 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6233 gfc_expr
*e
, bool check_types
)
6235 gfc_symbol
*declared
;
6242 *new_ref
= gfc_copy_ref (e
->ref
);
6244 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6246 if (ref
->type
!= REF_COMPONENT
)
6249 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6250 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6251 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6253 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6259 if (declared
== NULL
)
6260 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6266 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6267 which of the specific bindings (if any) matches the arglist and transform
6268 the expression into a call of that binding. */
6271 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6273 gfc_typebound_proc
* genproc
;
6274 const char* genname
;
6276 gfc_symbol
*derived
;
6278 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6279 genname
= e
->value
.compcall
.name
;
6280 genproc
= e
->value
.compcall
.tbp
;
6282 if (!genproc
->is_generic
)
6285 /* Try the bindings on this type and in the inheritance hierarchy. */
6286 for (; genproc
; genproc
= genproc
->overridden
)
6290 gcc_assert (genproc
->is_generic
);
6291 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6294 gfc_actual_arglist
* args
;
6297 gcc_assert (g
->specific
);
6299 if (g
->specific
->error
)
6302 target
= g
->specific
->u
.specific
->n
.sym
;
6304 /* Get the right arglist by handling PASS/NOPASS. */
6305 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6306 if (!g
->specific
->nopass
)
6309 po
= extract_compcall_passed_object (e
);
6312 gfc_free_actual_arglist (args
);
6316 gcc_assert (g
->specific
->pass_arg_num
> 0);
6317 gcc_assert (!g
->specific
->error
);
6318 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6319 g
->specific
->pass_arg
);
6321 resolve_actual_arglist (args
, target
->attr
.proc
,
6322 is_external_proc (target
)
6323 && gfc_sym_get_dummy_args (target
) == NULL
);
6325 /* Check if this arglist matches the formal. */
6326 matches
= gfc_arglist_matches_symbol (&args
, target
);
6328 /* Clean up and break out of the loop if we've found it. */
6329 gfc_free_actual_arglist (args
);
6332 e
->value
.compcall
.tbp
= g
->specific
;
6333 genname
= g
->specific_st
->name
;
6334 /* Pass along the name for CLASS methods, where the vtab
6335 procedure pointer component has to be referenced. */
6343 /* Nothing matching found! */
6344 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6345 " %qs at %L", genname
, &e
->where
);
6349 /* Make sure that we have the right specific instance for the name. */
6350 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6352 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6354 e
->value
.compcall
.tbp
= st
->n
.tb
;
6360 /* Resolve a call to a type-bound subroutine. */
6363 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6365 gfc_actual_arglist
* newactual
;
6366 gfc_symtree
* target
;
6368 /* Check that's really a SUBROUTINE. */
6369 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6371 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6372 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6373 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6374 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6375 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6378 gfc_error ("%qs at %L should be a SUBROUTINE",
6379 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6384 if (!check_typebound_baseobject (c
->expr1
))
6387 /* Pass along the name for CLASS methods, where the vtab
6388 procedure pointer component has to be referenced. */
6390 *name
= c
->expr1
->value
.compcall
.name
;
6392 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6395 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6397 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6399 /* Transform into an ordinary EXEC_CALL for now. */
6401 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6404 c
->ext
.actual
= newactual
;
6405 c
->symtree
= target
;
6406 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6408 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6410 gfc_free_expr (c
->expr1
);
6411 c
->expr1
= gfc_get_expr ();
6412 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6413 c
->expr1
->symtree
= target
;
6414 c
->expr1
->where
= c
->loc
;
6416 return resolve_call (c
);
6420 /* Resolve a component-call expression. */
6422 resolve_compcall (gfc_expr
* e
, const char **name
)
6424 gfc_actual_arglist
* newactual
;
6425 gfc_symtree
* target
;
6427 /* Check that's really a FUNCTION. */
6428 if (!e
->value
.compcall
.tbp
->function
)
6430 gfc_error ("%qs at %L should be a FUNCTION",
6431 e
->value
.compcall
.name
, &e
->where
);
6435 /* These must not be assign-calls! */
6436 gcc_assert (!e
->value
.compcall
.assign
);
6438 if (!check_typebound_baseobject (e
))
6441 /* Pass along the name for CLASS methods, where the vtab
6442 procedure pointer component has to be referenced. */
6444 *name
= e
->value
.compcall
.name
;
6446 if (!resolve_typebound_generic_call (e
, name
))
6448 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6450 /* Take the rank from the function's symbol. */
6451 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6452 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6454 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6455 arglist to the TBP's binding target. */
6457 if (!resolve_typebound_static (e
, &target
, &newactual
))
6460 e
->value
.function
.actual
= newactual
;
6461 e
->value
.function
.name
= NULL
;
6462 e
->value
.function
.esym
= target
->n
.sym
;
6463 e
->value
.function
.isym
= NULL
;
6464 e
->symtree
= target
;
6465 e
->ts
= target
->n
.sym
->ts
;
6466 e
->expr_type
= EXPR_FUNCTION
;
6468 /* Resolution is not necessary if this is a class subroutine; this
6469 function only has to identify the specific proc. Resolution of
6470 the call will be done next in resolve_typebound_call. */
6471 return gfc_resolve_expr (e
);
6475 static bool resolve_fl_derived (gfc_symbol
*sym
);
6478 /* Resolve a typebound function, or 'method'. First separate all
6479 the non-CLASS references by calling resolve_compcall directly. */
6482 resolve_typebound_function (gfc_expr
* e
)
6484 gfc_symbol
*declared
;
6496 /* Deal with typebound operators for CLASS objects. */
6497 expr
= e
->value
.compcall
.base_object
;
6498 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6499 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6501 /* If the base_object is not a variable, the corresponding actual
6502 argument expression must be stored in e->base_expression so
6503 that the corresponding tree temporary can be used as the base
6504 object in gfc_conv_procedure_call. */
6505 if (expr
->expr_type
!= EXPR_VARIABLE
)
6507 gfc_actual_arglist
*args
;
6509 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6511 if (expr
== args
->expr
)
6516 /* Since the typebound operators are generic, we have to ensure
6517 that any delays in resolution are corrected and that the vtab
6520 declared
= ts
.u
.derived
;
6521 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6522 if (c
->ts
.u
.derived
== NULL
)
6523 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6525 if (!resolve_compcall (e
, &name
))
6528 /* Use the generic name if it is there. */
6529 name
= name
? name
: e
->value
.function
.esym
->name
;
6530 e
->symtree
= expr
->symtree
;
6531 e
->ref
= gfc_copy_ref (expr
->ref
);
6532 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6534 /* Trim away the extraneous references that emerge from nested
6535 use of interface.c (extend_expr). */
6536 if (class_ref
&& class_ref
->next
)
6538 gfc_free_ref_list (class_ref
->next
);
6539 class_ref
->next
= NULL
;
6541 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6543 gfc_free_ref_list (e
->ref
);
6547 gfc_add_vptr_component (e
);
6548 gfc_add_component_ref (e
, name
);
6549 e
->value
.function
.esym
= NULL
;
6550 if (expr
->expr_type
!= EXPR_VARIABLE
)
6551 e
->base_expr
= expr
;
6556 return resolve_compcall (e
, NULL
);
6558 if (!resolve_ref (e
))
6561 /* Get the CLASS declared type. */
6562 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6564 if (!resolve_fl_derived (declared
))
6567 /* Weed out cases of the ultimate component being a derived type. */
6568 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6569 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6571 gfc_free_ref_list (new_ref
);
6572 return resolve_compcall (e
, NULL
);
6575 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6576 declared
= c
->ts
.u
.derived
;
6578 /* Treat the call as if it is a typebound procedure, in order to roll
6579 out the correct name for the specific function. */
6580 if (!resolve_compcall (e
, &name
))
6582 gfc_free_ref_list (new_ref
);
6589 /* Convert the expression to a procedure pointer component call. */
6590 e
->value
.function
.esym
= NULL
;
6596 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6597 gfc_add_vptr_component (e
);
6598 gfc_add_component_ref (e
, name
);
6600 /* Recover the typespec for the expression. This is really only
6601 necessary for generic procedures, where the additional call
6602 to gfc_add_component_ref seems to throw the collection of the
6603 correct typespec. */
6607 gfc_free_ref_list (new_ref
);
6612 /* Resolve a typebound subroutine, or 'method'. First separate all
6613 the non-CLASS references by calling resolve_typebound_call
6617 resolve_typebound_subroutine (gfc_code
*code
)
6619 gfc_symbol
*declared
;
6629 st
= code
->expr1
->symtree
;
6631 /* Deal with typebound operators for CLASS objects. */
6632 expr
= code
->expr1
->value
.compcall
.base_object
;
6633 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6634 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6636 /* If the base_object is not a variable, the corresponding actual
6637 argument expression must be stored in e->base_expression so
6638 that the corresponding tree temporary can be used as the base
6639 object in gfc_conv_procedure_call. */
6640 if (expr
->expr_type
!= EXPR_VARIABLE
)
6642 gfc_actual_arglist
*args
;
6644 args
= code
->expr1
->value
.function
.actual
;
6645 for (; args
; args
= args
->next
)
6646 if (expr
== args
->expr
)
6650 /* Since the typebound operators are generic, we have to ensure
6651 that any delays in resolution are corrected and that the vtab
6653 declared
= expr
->ts
.u
.derived
;
6654 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6655 if (c
->ts
.u
.derived
== NULL
)
6656 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6658 if (!resolve_typebound_call (code
, &name
, NULL
))
6661 /* Use the generic name if it is there. */
6662 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6663 code
->expr1
->symtree
= expr
->symtree
;
6664 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6666 /* Trim away the extraneous references that emerge from nested
6667 use of interface.c (extend_expr). */
6668 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6669 if (class_ref
&& class_ref
->next
)
6671 gfc_free_ref_list (class_ref
->next
);
6672 class_ref
->next
= NULL
;
6674 else if (code
->expr1
->ref
&& !class_ref
)
6676 gfc_free_ref_list (code
->expr1
->ref
);
6677 code
->expr1
->ref
= NULL
;
6680 /* Now use the procedure in the vtable. */
6681 gfc_add_vptr_component (code
->expr1
);
6682 gfc_add_component_ref (code
->expr1
, name
);
6683 code
->expr1
->value
.function
.esym
= NULL
;
6684 if (expr
->expr_type
!= EXPR_VARIABLE
)
6685 code
->expr1
->base_expr
= expr
;
6690 return resolve_typebound_call (code
, NULL
, NULL
);
6692 if (!resolve_ref (code
->expr1
))
6695 /* Get the CLASS declared type. */
6696 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6698 /* Weed out cases of the ultimate component being a derived type. */
6699 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6700 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6702 gfc_free_ref_list (new_ref
);
6703 return resolve_typebound_call (code
, NULL
, NULL
);
6706 if (!resolve_typebound_call (code
, &name
, &overridable
))
6708 gfc_free_ref_list (new_ref
);
6711 ts
= code
->expr1
->ts
;
6715 /* Convert the expression to a procedure pointer component call. */
6716 code
->expr1
->value
.function
.esym
= NULL
;
6717 code
->expr1
->symtree
= st
;
6720 code
->expr1
->ref
= new_ref
;
6722 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6723 gfc_add_vptr_component (code
->expr1
);
6724 gfc_add_component_ref (code
->expr1
, name
);
6726 /* Recover the typespec for the expression. This is really only
6727 necessary for generic procedures, where the additional call
6728 to gfc_add_component_ref seems to throw the collection of the
6729 correct typespec. */
6730 code
->expr1
->ts
= ts
;
6733 gfc_free_ref_list (new_ref
);
6739 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6742 resolve_ppc_call (gfc_code
* c
)
6744 gfc_component
*comp
;
6746 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6747 gcc_assert (comp
!= NULL
);
6749 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6750 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6752 if (!comp
->attr
.subroutine
)
6753 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6755 if (!resolve_ref (c
->expr1
))
6758 if (!update_ppc_arglist (c
->expr1
))
6761 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6763 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6764 !(comp
->ts
.interface
6765 && comp
->ts
.interface
->formal
)))
6768 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6771 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6777 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6780 resolve_expr_ppc (gfc_expr
* e
)
6782 gfc_component
*comp
;
6784 comp
= gfc_get_proc_ptr_comp (e
);
6785 gcc_assert (comp
!= NULL
);
6787 /* Convert to EXPR_FUNCTION. */
6788 e
->expr_type
= EXPR_FUNCTION
;
6789 e
->value
.function
.isym
= NULL
;
6790 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6792 if (comp
->as
!= NULL
)
6793 e
->rank
= comp
->as
->rank
;
6795 if (!comp
->attr
.function
)
6796 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6798 if (!resolve_ref (e
))
6801 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6802 !(comp
->ts
.interface
6803 && comp
->ts
.interface
->formal
)))
6806 if (!update_ppc_arglist (e
))
6809 if (!check_pure_function(e
))
6812 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6819 gfc_is_expandable_expr (gfc_expr
*e
)
6821 gfc_constructor
*con
;
6823 if (e
->expr_type
== EXPR_ARRAY
)
6825 /* Traverse the constructor looking for variables that are flavor
6826 parameter. Parameters must be expanded since they are fully used at
6828 con
= gfc_constructor_first (e
->value
.constructor
);
6829 for (; con
; con
= gfc_constructor_next (con
))
6831 if (con
->expr
->expr_type
== EXPR_VARIABLE
6832 && con
->expr
->symtree
6833 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6834 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6836 if (con
->expr
->expr_type
== EXPR_ARRAY
6837 && gfc_is_expandable_expr (con
->expr
))
6846 /* Sometimes variables in specification expressions of the result
6847 of module procedures in submodules wind up not being the 'real'
6848 dummy. Find this, if possible, in the namespace of the first
6852 fixup_unique_dummy (gfc_expr
*e
)
6854 gfc_symtree
*st
= NULL
;
6855 gfc_symbol
*s
= NULL
;
6857 if (e
->symtree
->n
.sym
->ns
->proc_name
6858 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6859 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6862 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6865 && st
->n
.sym
!= NULL
6866 && st
->n
.sym
->attr
.dummy
)
6870 /* Resolve an expression. That is, make sure that types of operands agree
6871 with their operators, intrinsic operators are converted to function calls
6872 for overloaded types and unresolved function references are resolved. */
6875 gfc_resolve_expr (gfc_expr
*e
)
6878 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6883 /* inquiry_argument only applies to variables. */
6884 inquiry_save
= inquiry_argument
;
6885 actual_arg_save
= actual_arg
;
6886 first_actual_arg_save
= first_actual_arg
;
6888 if (e
->expr_type
!= EXPR_VARIABLE
)
6890 inquiry_argument
= false;
6892 first_actual_arg
= false;
6894 else if (e
->symtree
!= NULL
6895 && *e
->symtree
->name
== '@'
6896 && e
->symtree
->n
.sym
->attr
.dummy
)
6898 /* Deal with submodule specification expressions that are not
6899 found to be referenced in module.c(read_cleanup). */
6900 fixup_unique_dummy (e
);
6903 switch (e
->expr_type
)
6906 t
= resolve_operator (e
);
6912 if (check_host_association (e
))
6913 t
= resolve_function (e
);
6915 t
= resolve_variable (e
);
6917 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6918 && e
->ref
->type
!= REF_SUBSTRING
)
6919 gfc_resolve_substring_charlen (e
);
6924 t
= resolve_typebound_function (e
);
6927 case EXPR_SUBSTRING
:
6928 t
= resolve_ref (e
);
6937 t
= resolve_expr_ppc (e
);
6942 if (!resolve_ref (e
))
6945 t
= gfc_resolve_array_constructor (e
);
6946 /* Also try to expand a constructor. */
6949 expression_rank (e
);
6950 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6951 gfc_expand_constructor (e
, false);
6954 /* This provides the opportunity for the length of constructors with
6955 character valued function elements to propagate the string length
6956 to the expression. */
6957 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6959 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6960 here rather then add a duplicate test for it above. */
6961 gfc_expand_constructor (e
, false);
6962 t
= gfc_resolve_character_array_constructor (e
);
6967 case EXPR_STRUCTURE
:
6968 t
= resolve_ref (e
);
6972 t
= resolve_structure_cons (e
, 0);
6976 t
= gfc_simplify_expr (e
, 0);
6980 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6983 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6986 inquiry_argument
= inquiry_save
;
6987 actual_arg
= actual_arg_save
;
6988 first_actual_arg
= first_actual_arg_save
;
6994 /* Resolve an expression from an iterator. They must be scalar and have
6995 INTEGER or (optionally) REAL type. */
6998 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6999 const char *name_msgid
)
7001 if (!gfc_resolve_expr (expr
))
7004 if (expr
->rank
!= 0)
7006 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7010 if (expr
->ts
.type
!= BT_INTEGER
)
7012 if (expr
->ts
.type
== BT_REAL
)
7015 return gfc_notify_std (GFC_STD_F95_DEL
,
7016 "%s at %L must be integer",
7017 _(name_msgid
), &expr
->where
);
7020 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7027 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7035 /* Resolve the expressions in an iterator structure. If REAL_OK is
7036 false allow only INTEGER type iterators, otherwise allow REAL types.
7037 Set own_scope to true for ac-implied-do and data-implied-do as those
7038 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7041 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7043 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7046 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7047 _("iterator variable")))
7050 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7051 "Start expression in DO loop"))
7054 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7055 "End expression in DO loop"))
7058 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7059 "Step expression in DO loop"))
7062 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7064 if ((iter
->step
->ts
.type
== BT_INTEGER
7065 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7066 || (iter
->step
->ts
.type
== BT_REAL
7067 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7069 gfc_error ("Step expression in DO loop at %L cannot be zero",
7070 &iter
->step
->where
);
7075 /* Convert start, end, and step to the same type as var. */
7076 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7077 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7078 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7080 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7081 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7082 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7084 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7085 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7086 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7088 if (iter
->start
->expr_type
== EXPR_CONSTANT
7089 && iter
->end
->expr_type
== EXPR_CONSTANT
7090 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7093 if (iter
->start
->ts
.type
== BT_INTEGER
)
7095 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7096 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7100 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7101 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7103 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7104 gfc_warning (OPT_Wzerotrip
,
7105 "DO loop at %L will be executed zero times",
7106 &iter
->step
->where
);
7109 if (iter
->end
->expr_type
== EXPR_CONSTANT
7110 && iter
->end
->ts
.type
== BT_INTEGER
7111 && iter
->step
->expr_type
== EXPR_CONSTANT
7112 && iter
->step
->ts
.type
== BT_INTEGER
7113 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7114 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7116 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7117 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7119 if (is_step_positive
7120 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7121 gfc_warning (OPT_Wundefined_do_loop
,
7122 "DO loop at %L is undefined as it overflows",
7123 &iter
->step
->where
);
7124 else if (!is_step_positive
7125 && mpz_cmp (iter
->end
->value
.integer
,
7126 gfc_integer_kinds
[k
].min_int
) == 0)
7127 gfc_warning (OPT_Wundefined_do_loop
,
7128 "DO loop at %L is undefined as it underflows",
7129 &iter
->step
->where
);
7136 /* Traversal function for find_forall_index. f == 2 signals that
7137 that variable itself is not to be checked - only the references. */
7140 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7142 if (expr
->expr_type
!= EXPR_VARIABLE
)
7145 /* A scalar assignment */
7146 if (!expr
->ref
|| *f
== 1)
7148 if (expr
->symtree
->n
.sym
== sym
)
7160 /* Check whether the FORALL index appears in the expression or not.
7161 Returns true if SYM is found in EXPR. */
7164 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7166 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7173 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7174 to be a scalar INTEGER variable. The subscripts and stride are scalar
7175 INTEGERs, and if stride is a constant it must be nonzero.
7176 Furthermore "A subscript or stride in a forall-triplet-spec shall
7177 not contain a reference to any index-name in the
7178 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7181 resolve_forall_iterators (gfc_forall_iterator
*it
)
7183 gfc_forall_iterator
*iter
, *iter2
;
7185 for (iter
= it
; iter
; iter
= iter
->next
)
7187 if (gfc_resolve_expr (iter
->var
)
7188 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7189 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7192 if (gfc_resolve_expr (iter
->start
)
7193 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7194 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7195 &iter
->start
->where
);
7196 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7197 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7199 if (gfc_resolve_expr (iter
->end
)
7200 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7201 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7203 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7204 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7206 if (gfc_resolve_expr (iter
->stride
))
7208 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7209 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7210 &iter
->stride
->where
, "INTEGER");
7212 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7213 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7214 gfc_error ("FORALL stride expression at %L cannot be zero",
7215 &iter
->stride
->where
);
7217 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7218 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7221 for (iter
= it
; iter
; iter
= iter
->next
)
7222 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7224 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7225 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7226 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7227 gfc_error ("FORALL index %qs may not appear in triplet "
7228 "specification at %L", iter
->var
->symtree
->name
,
7229 &iter2
->start
->where
);
7234 /* Given a pointer to a symbol that is a derived type, see if it's
7235 inaccessible, i.e. if it's defined in another module and the components are
7236 PRIVATE. The search is recursive if necessary. Returns zero if no
7237 inaccessible components are found, nonzero otherwise. */
7240 derived_inaccessible (gfc_symbol
*sym
)
7244 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7247 for (c
= sym
->components
; c
; c
= c
->next
)
7249 /* Prevent an infinite loop through this function. */
7250 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7251 && sym
== c
->ts
.u
.derived
)
7254 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7262 /* Resolve the argument of a deallocate expression. The expression must be
7263 a pointer or a full array. */
7266 resolve_deallocate_expr (gfc_expr
*e
)
7268 symbol_attribute attr
;
7269 int allocatable
, pointer
;
7275 if (!gfc_resolve_expr (e
))
7278 if (e
->expr_type
!= EXPR_VARIABLE
)
7281 sym
= e
->symtree
->n
.sym
;
7282 unlimited
= UNLIMITED_POLY(sym
);
7284 if (sym
->ts
.type
== BT_CLASS
)
7286 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7287 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7291 allocatable
= sym
->attr
.allocatable
;
7292 pointer
= sym
->attr
.pointer
;
7294 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7299 if (ref
->u
.ar
.type
!= AR_FULL
7300 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7301 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7306 c
= ref
->u
.c
.component
;
7307 if (c
->ts
.type
== BT_CLASS
)
7309 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7310 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7314 allocatable
= c
->attr
.allocatable
;
7315 pointer
= c
->attr
.pointer
;
7326 attr
= gfc_expr_attr (e
);
7328 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7331 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7337 if (gfc_is_coindexed (e
))
7339 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7344 && !gfc_check_vardef_context (e
, true, true, false,
7345 _("DEALLOCATE object")))
7347 if (!gfc_check_vardef_context (e
, false, true, false,
7348 _("DEALLOCATE object")))
7355 /* Returns true if the expression e contains a reference to the symbol sym. */
7357 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7359 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7366 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7368 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7372 /* Given the expression node e for an allocatable/pointer of derived type to be
7373 allocated, get the expression node to be initialized afterwards (needed for
7374 derived types with default initializers, and derived types with allocatable
7375 components that need nullification.) */
7378 gfc_expr_to_initialize (gfc_expr
*e
)
7384 result
= gfc_copy_expr (e
);
7386 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7387 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7388 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7390 ref
->u
.ar
.type
= AR_FULL
;
7392 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7393 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7398 gfc_free_shape (&result
->shape
, result
->rank
);
7400 /* Recalculate rank, shape, etc. */
7401 gfc_resolve_expr (result
);
7406 /* If the last ref of an expression is an array ref, return a copy of the
7407 expression with that one removed. Otherwise, a copy of the original
7408 expression. This is used for allocate-expressions and pointer assignment
7409 LHS, where there may be an array specification that needs to be stripped
7410 off when using gfc_check_vardef_context. */
7413 remove_last_array_ref (gfc_expr
* e
)
7418 e2
= gfc_copy_expr (e
);
7419 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7420 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7422 gfc_free_ref_list (*r
);
7431 /* Used in resolve_allocate_expr to check that a allocation-object and
7432 a source-expr are conformable. This does not catch all possible
7433 cases; in particular a runtime checking is needed. */
7436 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7439 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7441 /* First compare rank. */
7442 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7443 || (!tail
&& e1
->rank
!= e2
->rank
))
7445 gfc_error ("Source-expr at %L must be scalar or have the "
7446 "same rank as the allocate-object at %L",
7447 &e1
->where
, &e2
->where
);
7458 for (i
= 0; i
< e1
->rank
; i
++)
7460 if (tail
->u
.ar
.start
[i
] == NULL
)
7463 if (tail
->u
.ar
.end
[i
])
7465 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7466 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7467 mpz_add_ui (s
, s
, 1);
7471 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7474 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7476 gfc_error ("Source-expr at %L and allocate-object at %L must "
7477 "have the same shape", &e1
->where
, &e2
->where
);
7490 /* Resolve the expression in an ALLOCATE statement, doing the additional
7491 checks to see whether the expression is OK or not. The expression must
7492 have a trailing array reference that gives the size of the array. */
7495 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7497 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7501 symbol_attribute attr
;
7502 gfc_ref
*ref
, *ref2
;
7505 gfc_symbol
*sym
= NULL
;
7510 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7511 checking of coarrays. */
7512 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7513 if (ref
->next
== NULL
)
7516 if (ref
&& ref
->type
== REF_ARRAY
)
7517 ref
->u
.ar
.in_allocate
= true;
7519 if (!gfc_resolve_expr (e
))
7522 /* Make sure the expression is allocatable or a pointer. If it is
7523 pointer, the next-to-last reference must be a pointer. */
7527 sym
= e
->symtree
->n
.sym
;
7529 /* Check whether ultimate component is abstract and CLASS. */
7532 /* Is the allocate-object unlimited polymorphic? */
7533 unlimited
= UNLIMITED_POLY(e
);
7535 if (e
->expr_type
!= EXPR_VARIABLE
)
7538 attr
= gfc_expr_attr (e
);
7539 pointer
= attr
.pointer
;
7540 dimension
= attr
.dimension
;
7541 codimension
= attr
.codimension
;
7545 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7547 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7548 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7549 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7550 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7551 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7555 allocatable
= sym
->attr
.allocatable
;
7556 pointer
= sym
->attr
.pointer
;
7557 dimension
= sym
->attr
.dimension
;
7558 codimension
= sym
->attr
.codimension
;
7563 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7568 if (ref
->u
.ar
.codimen
> 0)
7571 for (n
= ref
->u
.ar
.dimen
;
7572 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7573 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7580 if (ref
->next
!= NULL
)
7588 gfc_error ("Coindexed allocatable object at %L",
7593 c
= ref
->u
.c
.component
;
7594 if (c
->ts
.type
== BT_CLASS
)
7596 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7597 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7598 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7599 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7600 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7604 allocatable
= c
->attr
.allocatable
;
7605 pointer
= c
->attr
.pointer
;
7606 dimension
= c
->attr
.dimension
;
7607 codimension
= c
->attr
.codimension
;
7608 is_abstract
= c
->attr
.abstract
;
7621 /* Check for F08:C628. */
7622 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7624 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7629 /* Some checks for the SOURCE tag. */
7632 /* Check F03:C631. */
7633 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7635 gfc_error ("Type of entity at %L is type incompatible with "
7636 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7640 /* Check F03:C632 and restriction following Note 6.18. */
7641 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7644 /* Check F03:C633. */
7645 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7647 gfc_error ("The allocate-object at %L and the source-expr at %L "
7648 "shall have the same kind type parameter",
7649 &e
->where
, &code
->expr3
->where
);
7653 /* Check F2008, C642. */
7654 if (code
->expr3
->ts
.type
== BT_DERIVED
7655 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7656 || (code
->expr3
->ts
.u
.derived
->from_intmod
7657 == INTMOD_ISO_FORTRAN_ENV
7658 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7659 == ISOFORTRAN_LOCK_TYPE
)))
7661 gfc_error ("The source-expr at %L shall neither be of type "
7662 "LOCK_TYPE nor have a LOCK_TYPE component if "
7663 "allocate-object at %L is a coarray",
7664 &code
->expr3
->where
, &e
->where
);
7668 /* Check TS18508, C702/C703. */
7669 if (code
->expr3
->ts
.type
== BT_DERIVED
7670 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7671 || (code
->expr3
->ts
.u
.derived
->from_intmod
7672 == INTMOD_ISO_FORTRAN_ENV
7673 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7674 == ISOFORTRAN_EVENT_TYPE
)))
7676 gfc_error ("The source-expr at %L shall neither be of type "
7677 "EVENT_TYPE nor have a EVENT_TYPE component if "
7678 "allocate-object at %L is a coarray",
7679 &code
->expr3
->where
, &e
->where
);
7684 /* Check F08:C629. */
7685 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7688 gcc_assert (e
->ts
.type
== BT_CLASS
);
7689 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7690 "type-spec or source-expr", sym
->name
, &e
->where
);
7694 /* Check F08:C632. */
7695 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7696 && !UNLIMITED_POLY (e
))
7700 if (!e
->ts
.u
.cl
->length
)
7703 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7704 code
->ext
.alloc
.ts
.u
.cl
->length
);
7705 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7707 gfc_error ("Allocating %s at %L with type-spec requires the same "
7708 "character-length parameter as in the declaration",
7709 sym
->name
, &e
->where
);
7714 /* In the variable definition context checks, gfc_expr_attr is used
7715 on the expression. This is fooled by the array specification
7716 present in e, thus we have to eliminate that one temporarily. */
7717 e2
= remove_last_array_ref (e
);
7720 t
= gfc_check_vardef_context (e2
, true, true, false,
7721 _("ALLOCATE object"));
7723 t
= gfc_check_vardef_context (e2
, false, true, false,
7724 _("ALLOCATE object"));
7729 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7730 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7732 /* For class arrays, the initialization with SOURCE is done
7733 using _copy and trans_call. It is convenient to exploit that
7734 when the allocated type is different from the declared type but
7735 no SOURCE exists by setting expr3. */
7736 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7738 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7739 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7740 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7742 /* We have to zero initialize the integer variable. */
7743 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7746 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7748 /* Make sure the vtab symbol is present when
7749 the module variables are generated. */
7750 gfc_typespec ts
= e
->ts
;
7752 ts
= code
->expr3
->ts
;
7753 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7754 ts
= code
->ext
.alloc
.ts
;
7756 /* Finding the vtab also publishes the type's symbol. Therefore this
7757 statement is necessary. */
7758 gfc_find_derived_vtab (ts
.u
.derived
);
7760 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7762 /* Again, make sure the vtab symbol is present when
7763 the module variables are generated. */
7764 gfc_typespec
*ts
= NULL
;
7766 ts
= &code
->expr3
->ts
;
7768 ts
= &code
->ext
.alloc
.ts
;
7772 /* Finding the vtab also publishes the type's symbol. Therefore this
7773 statement is necessary. */
7777 if (dimension
== 0 && codimension
== 0)
7780 /* Make sure the last reference node is an array specification. */
7782 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7783 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7788 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7789 "in ALLOCATE statement at %L", &e
->where
))
7791 if (code
->expr3
->rank
!= 0)
7792 *array_alloc_wo_spec
= true;
7795 gfc_error ("Array specification or array-valued SOURCE= "
7796 "expression required in ALLOCATE statement at %L",
7803 gfc_error ("Array specification required in ALLOCATE statement "
7804 "at %L", &e
->where
);
7809 /* Make sure that the array section reference makes sense in the
7810 context of an ALLOCATE specification. */
7815 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7817 switch (ar
->dimen_type
[i
])
7819 case DIMEN_THIS_IMAGE
:
7820 gfc_error ("Coarray specification required in ALLOCATE statement "
7821 "at %L", &e
->where
);
7825 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0)
7827 /* If ar->stride[i] is NULL, we issued a previous error. */
7828 if (ar
->stride
[i
] == NULL
)
7829 gfc_error ("Bad array specification in ALLOCATE statement "
7830 "at %L", &e
->where
);
7833 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
7835 gfc_error ("Upper cobound is less than lower cobound at %L",
7836 &ar
->start
[i
]->where
);
7842 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
7844 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
7845 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
7847 gfc_error ("Upper cobound is less than lower cobound "
7848 "of 1 at %L", &ar
->start
[i
]->where
);
7858 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7864 for (i
= 0; i
< ar
->dimen
; i
++)
7866 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7869 switch (ar
->dimen_type
[i
])
7875 if (ar
->start
[i
] != NULL
7876 && ar
->end
[i
] != NULL
7877 && ar
->stride
[i
] == NULL
)
7885 case DIMEN_THIS_IMAGE
:
7886 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7892 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7894 sym
= a
->expr
->symtree
->n
.sym
;
7896 /* TODO - check derived type components. */
7897 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7900 if ((ar
->start
[i
] != NULL
7901 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7902 || (ar
->end
[i
] != NULL
7903 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7905 gfc_error ("%qs must not appear in the array specification at "
7906 "%L in the same ALLOCATE statement where it is "
7907 "itself allocated", sym
->name
, &ar
->where
);
7913 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7915 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7916 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7918 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7920 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7921 "statement at %L", &e
->where
);
7927 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7928 && ar
->stride
[i
] == NULL
)
7931 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7945 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7947 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7948 gfc_alloc
*a
, *p
, *q
;
7951 errmsg
= code
->expr2
;
7953 /* Check the stat variable. */
7956 gfc_check_vardef_context (stat
, false, false, false,
7957 _("STAT variable"));
7959 if ((stat
->ts
.type
!= BT_INTEGER
7960 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7961 || stat
->ref
->type
== REF_COMPONENT
)))
7963 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7964 "variable", &stat
->where
);
7966 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7967 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7969 gfc_ref
*ref1
, *ref2
;
7972 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7973 ref1
= ref1
->next
, ref2
= ref2
->next
)
7975 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7977 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7986 gfc_error ("Stat-variable at %L shall not be %sd within "
7987 "the same %s statement", &stat
->where
, fcn
, fcn
);
7993 /* Check the errmsg variable. */
7997 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8000 gfc_check_vardef_context (errmsg
, false, false, false,
8001 _("ERRMSG variable"));
8003 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8004 F18:R930 errmsg-variable is scalar-default-char-variable
8005 F18:R906 default-char-variable is variable
8006 F18:C906 default-char-variable shall be default character. */
8007 if ((errmsg
->ts
.type
!= BT_CHARACTER
8009 && (errmsg
->ref
->type
== REF_ARRAY
8010 || errmsg
->ref
->type
== REF_COMPONENT
)))
8012 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8013 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8014 "variable", &errmsg
->where
);
8016 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8017 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8019 gfc_ref
*ref1
, *ref2
;
8022 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
8023 ref1
= ref1
->next
, ref2
= ref2
->next
)
8025 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8027 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8036 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8037 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8043 /* Check that an allocate-object appears only once in the statement. */
8045 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8048 for (q
= p
->next
; q
; q
= q
->next
)
8051 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8053 /* This is a potential collision. */
8054 gfc_ref
*pr
= pe
->ref
;
8055 gfc_ref
*qr
= qe
->ref
;
8057 /* Follow the references until
8058 a) They start to differ, in which case there is no error;
8059 you can deallocate a%b and a%c in a single statement
8060 b) Both of them stop, which is an error
8061 c) One of them stops, which is also an error. */
8064 if (pr
== NULL
&& qr
== NULL
)
8066 gfc_error ("Allocate-object at %L also appears at %L",
8067 &pe
->where
, &qe
->where
);
8070 else if (pr
!= NULL
&& qr
== NULL
)
8072 gfc_error ("Allocate-object at %L is subobject of"
8073 " object at %L", &pe
->where
, &qe
->where
);
8076 else if (pr
== NULL
&& qr
!= NULL
)
8078 gfc_error ("Allocate-object at %L is subobject of"
8079 " object at %L", &qe
->where
, &pe
->where
);
8082 /* Here, pr != NULL && qr != NULL */
8083 gcc_assert(pr
->type
== qr
->type
);
8084 if (pr
->type
== REF_ARRAY
)
8086 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8088 gcc_assert (qr
->type
== REF_ARRAY
);
8090 if (pr
->next
&& qr
->next
)
8093 gfc_array_ref
*par
= &(pr
->u
.ar
);
8094 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8096 for (i
=0; i
<par
->dimen
; i
++)
8098 if ((par
->start
[i
] != NULL
8099 || qar
->start
[i
] != NULL
)
8100 && gfc_dep_compare_expr (par
->start
[i
],
8101 qar
->start
[i
]) != 0)
8108 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8121 if (strcmp (fcn
, "ALLOCATE") == 0)
8123 bool arr_alloc_wo_spec
= false;
8125 /* Resolving the expr3 in the loop over all objects to allocate would
8126 execute loop invariant code for each loop item. Therefore do it just
8128 if (code
->expr3
&& code
->expr3
->mold
8129 && code
->expr3
->ts
.type
== BT_DERIVED
)
8131 /* Default initialization via MOLD (non-polymorphic). */
8132 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8135 gfc_resolve_expr (rhs
);
8136 gfc_free_expr (code
->expr3
);
8140 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8141 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8143 if (arr_alloc_wo_spec
&& code
->expr3
)
8145 /* Mark the allocate to have to take the array specification
8147 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8152 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8153 resolve_deallocate_expr (a
->expr
);
8158 /************ SELECT CASE resolution subroutines ************/
8160 /* Callback function for our mergesort variant. Determines interval
8161 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8162 op1 > op2. Assumes we're not dealing with the default case.
8163 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8164 There are nine situations to check. */
8167 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8171 if (op1
->low
== NULL
) /* op1 = (:L) */
8173 /* op2 = (:N), so overlap. */
8175 /* op2 = (M:) or (M:N), L < M */
8176 if (op2
->low
!= NULL
8177 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8180 else if (op1
->high
== NULL
) /* op1 = (K:) */
8182 /* op2 = (M:), so overlap. */
8184 /* op2 = (:N) or (M:N), K > N */
8185 if (op2
->high
!= NULL
8186 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8189 else /* op1 = (K:L) */
8191 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8192 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8194 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8195 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8197 else /* op2 = (M:N) */
8201 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8204 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8213 /* Merge-sort a double linked case list, detecting overlap in the
8214 process. LIST is the head of the double linked case list before it
8215 is sorted. Returns the head of the sorted list if we don't see any
8216 overlap, or NULL otherwise. */
8219 check_case_overlap (gfc_case
*list
)
8221 gfc_case
*p
, *q
, *e
, *tail
;
8222 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8224 /* If the passed list was empty, return immediately. */
8231 /* Loop unconditionally. The only exit from this loop is a return
8232 statement, when we've finished sorting the case list. */
8239 /* Count the number of merges we do in this pass. */
8242 /* Loop while there exists a merge to be done. */
8247 /* Count this merge. */
8250 /* Cut the list in two pieces by stepping INSIZE places
8251 forward in the list, starting from P. */
8254 for (i
= 0; i
< insize
; i
++)
8263 /* Now we have two lists. Merge them! */
8264 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8266 /* See from which the next case to merge comes from. */
8269 /* P is empty so the next case must come from Q. */
8274 else if (qsize
== 0 || q
== NULL
)
8283 cmp
= compare_cases (p
, q
);
8286 /* The whole case range for P is less than the
8294 /* The whole case range for Q is greater than
8295 the case range for P. */
8302 /* The cases overlap, or they are the same
8303 element in the list. Either way, we must
8304 issue an error and get the next case from P. */
8305 /* FIXME: Sort P and Q by line number. */
8306 gfc_error ("CASE label at %L overlaps with CASE "
8307 "label at %L", &p
->where
, &q
->where
);
8315 /* Add the next element to the merged list. */
8324 /* P has now stepped INSIZE places along, and so has Q. So
8325 they're the same. */
8330 /* If we have done only one merge or none at all, we've
8331 finished sorting the cases. */
8340 /* Otherwise repeat, merging lists twice the size. */
8346 /* Check to see if an expression is suitable for use in a CASE statement.
8347 Makes sure that all case expressions are scalar constants of the same
8348 type. Return false if anything is wrong. */
8351 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8353 if (e
== NULL
) return true;
8355 if (e
->ts
.type
!= case_expr
->ts
.type
)
8357 gfc_error ("Expression in CASE statement at %L must be of type %s",
8358 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8362 /* C805 (R808) For a given case-construct, each case-value shall be of
8363 the same type as case-expr. For character type, length differences
8364 are allowed, but the kind type parameters shall be the same. */
8366 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8368 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8369 &e
->where
, case_expr
->ts
.kind
);
8373 /* Convert the case value kind to that of case expression kind,
8376 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8377 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8381 gfc_error ("Expression in CASE statement at %L must be scalar",
8390 /* Given a completely parsed select statement, we:
8392 - Validate all expressions and code within the SELECT.
8393 - Make sure that the selection expression is not of the wrong type.
8394 - Make sure that no case ranges overlap.
8395 - Eliminate unreachable cases and unreachable code resulting from
8396 removing case labels.
8398 The standard does allow unreachable cases, e.g. CASE (5:3). But
8399 they are a hassle for code generation, and to prevent that, we just
8400 cut them out here. This is not necessary for overlapping cases
8401 because they are illegal and we never even try to generate code.
8403 We have the additional caveat that a SELECT construct could have
8404 been a computed GOTO in the source code. Fortunately we can fairly
8405 easily work around that here: The case_expr for a "real" SELECT CASE
8406 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8407 we have to do is make sure that the case_expr is a scalar integer
8411 resolve_select (gfc_code
*code
, bool select_type
)
8414 gfc_expr
*case_expr
;
8415 gfc_case
*cp
, *default_case
, *tail
, *head
;
8416 int seen_unreachable
;
8422 if (code
->expr1
== NULL
)
8424 /* This was actually a computed GOTO statement. */
8425 case_expr
= code
->expr2
;
8426 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8427 gfc_error ("Selection expression in computed GOTO statement "
8428 "at %L must be a scalar integer expression",
8431 /* Further checking is not necessary because this SELECT was built
8432 by the compiler, so it should always be OK. Just move the
8433 case_expr from expr2 to expr so that we can handle computed
8434 GOTOs as normal SELECTs from here on. */
8435 code
->expr1
= code
->expr2
;
8440 case_expr
= code
->expr1
;
8441 type
= case_expr
->ts
.type
;
8444 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8446 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8447 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8449 /* Punt. Going on here just produce more garbage error messages. */
8454 if (!select_type
&& case_expr
->rank
!= 0)
8456 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8457 "expression", &case_expr
->where
);
8463 /* Raise a warning if an INTEGER case value exceeds the range of
8464 the case-expr. Later, all expressions will be promoted to the
8465 largest kind of all case-labels. */
8467 if (type
== BT_INTEGER
)
8468 for (body
= code
->block
; body
; body
= body
->block
)
8469 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8472 && gfc_check_integer_range (cp
->low
->value
.integer
,
8473 case_expr
->ts
.kind
) != ARITH_OK
)
8474 gfc_warning (0, "Expression in CASE statement at %L is "
8475 "not in the range of %s", &cp
->low
->where
,
8476 gfc_typename (&case_expr
->ts
));
8479 && cp
->low
!= cp
->high
8480 && gfc_check_integer_range (cp
->high
->value
.integer
,
8481 case_expr
->ts
.kind
) != ARITH_OK
)
8482 gfc_warning (0, "Expression in CASE statement at %L is "
8483 "not in the range of %s", &cp
->high
->where
,
8484 gfc_typename (&case_expr
->ts
));
8487 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8488 of the SELECT CASE expression and its CASE values. Walk the lists
8489 of case values, and if we find a mismatch, promote case_expr to
8490 the appropriate kind. */
8492 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8494 for (body
= code
->block
; body
; body
= body
->block
)
8496 /* Walk the case label list. */
8497 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8499 /* Intercept the DEFAULT case. It does not have a kind. */
8500 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8503 /* Unreachable case ranges are discarded, so ignore. */
8504 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8505 && cp
->low
!= cp
->high
8506 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8510 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8511 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8513 if (cp
->high
!= NULL
8514 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8515 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8520 /* Assume there is no DEFAULT case. */
8521 default_case
= NULL
;
8526 for (body
= code
->block
; body
; body
= body
->block
)
8528 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8530 seen_unreachable
= 0;
8532 /* Walk the case label list, making sure that all case labels
8534 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8536 /* Count the number of cases in the whole construct. */
8539 /* Intercept the DEFAULT case. */
8540 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8542 if (default_case
!= NULL
)
8544 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8545 "by a second DEFAULT CASE at %L",
8546 &default_case
->where
, &cp
->where
);
8557 /* Deal with single value cases and case ranges. Errors are
8558 issued from the validation function. */
8559 if (!validate_case_label_expr (cp
->low
, case_expr
)
8560 || !validate_case_label_expr (cp
->high
, case_expr
))
8566 if (type
== BT_LOGICAL
8567 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8568 || cp
->low
!= cp
->high
))
8570 gfc_error ("Logical range in CASE statement at %L is not "
8571 "allowed", &cp
->low
->where
);
8576 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8579 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8580 if (value
& seen_logical
)
8582 gfc_error ("Constant logical value in CASE statement "
8583 "is repeated at %L",
8588 seen_logical
|= value
;
8591 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8592 && cp
->low
!= cp
->high
8593 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8595 if (warn_surprising
)
8596 gfc_warning (OPT_Wsurprising
,
8597 "Range specification at %L can never be matched",
8600 cp
->unreachable
= 1;
8601 seen_unreachable
= 1;
8605 /* If the case range can be matched, it can also overlap with
8606 other cases. To make sure it does not, we put it in a
8607 double linked list here. We sort that with a merge sort
8608 later on to detect any overlapping cases. */
8612 head
->right
= head
->left
= NULL
;
8617 tail
->right
->left
= tail
;
8624 /* It there was a failure in the previous case label, give up
8625 for this case label list. Continue with the next block. */
8629 /* See if any case labels that are unreachable have been seen.
8630 If so, we eliminate them. This is a bit of a kludge because
8631 the case lists for a single case statement (label) is a
8632 single forward linked lists. */
8633 if (seen_unreachable
)
8635 /* Advance until the first case in the list is reachable. */
8636 while (body
->ext
.block
.case_list
!= NULL
8637 && body
->ext
.block
.case_list
->unreachable
)
8639 gfc_case
*n
= body
->ext
.block
.case_list
;
8640 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8642 gfc_free_case_list (n
);
8645 /* Strip all other unreachable cases. */
8646 if (body
->ext
.block
.case_list
)
8648 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8650 if (cp
->next
->unreachable
)
8652 gfc_case
*n
= cp
->next
;
8653 cp
->next
= cp
->next
->next
;
8655 gfc_free_case_list (n
);
8662 /* See if there were overlapping cases. If the check returns NULL,
8663 there was overlap. In that case we don't do anything. If head
8664 is non-NULL, we prepend the DEFAULT case. The sorted list can
8665 then used during code generation for SELECT CASE constructs with
8666 a case expression of a CHARACTER type. */
8669 head
= check_case_overlap (head
);
8671 /* Prepend the default_case if it is there. */
8672 if (head
!= NULL
&& default_case
)
8674 default_case
->left
= NULL
;
8675 default_case
->right
= head
;
8676 head
->left
= default_case
;
8680 /* Eliminate dead blocks that may be the result if we've seen
8681 unreachable case labels for a block. */
8682 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8684 if (body
->block
->ext
.block
.case_list
== NULL
)
8686 /* Cut the unreachable block from the code chain. */
8687 gfc_code
*c
= body
->block
;
8688 body
->block
= c
->block
;
8690 /* Kill the dead block, but not the blocks below it. */
8692 gfc_free_statements (c
);
8696 /* More than two cases is legal but insane for logical selects.
8697 Issue a warning for it. */
8698 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8699 gfc_warning (OPT_Wsurprising
,
8700 "Logical SELECT CASE block at %L has more that two cases",
8705 /* Check if a derived type is extensible. */
8708 gfc_type_is_extensible (gfc_symbol
*sym
)
8710 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8711 || (sym
->attr
.is_class
8712 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8717 resolve_types (gfc_namespace
*ns
);
8719 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8720 correct as well as possibly the array-spec. */
8723 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8727 gcc_assert (sym
->assoc
);
8728 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8730 /* If this is for SELECT TYPE, the target may not yet be set. In that
8731 case, return. Resolution will be called later manually again when
8733 target
= sym
->assoc
->target
;
8736 gcc_assert (!sym
->assoc
->dangling
);
8738 if (resolve_target
&& !gfc_resolve_expr (target
))
8741 /* For variable targets, we get some attributes from the target. */
8742 if (target
->expr_type
== EXPR_VARIABLE
)
8746 gcc_assert (target
->symtree
);
8747 tsym
= target
->symtree
->n
.sym
;
8749 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8750 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8752 sym
->attr
.target
= tsym
->attr
.target
8753 || gfc_expr_attr (target
).pointer
;
8754 if (is_subref_array (target
))
8755 sym
->attr
.subref_array_pointer
= 1;
8758 if (target
->expr_type
== EXPR_NULL
)
8760 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8763 else if (target
->ts
.type
== BT_UNKNOWN
)
8765 gfc_error ("Selector at %L has no type", &target
->where
);
8769 /* Get type if this was not already set. Note that it can be
8770 some other type than the target in case this is a SELECT TYPE
8771 selector! So we must not update when the type is already there. */
8772 if (sym
->ts
.type
== BT_UNKNOWN
)
8773 sym
->ts
= target
->ts
;
8775 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8777 /* See if this is a valid association-to-variable. */
8778 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8779 && !gfc_has_vector_subscript (target
));
8781 /* Finally resolve if this is an array or not. */
8782 if (sym
->attr
.dimension
&& target
->rank
== 0)
8784 /* primary.c makes the assumption that a reference to an associate
8785 name followed by a left parenthesis is an array reference. */
8786 if (sym
->ts
.type
!= BT_CHARACTER
)
8787 gfc_error ("Associate-name %qs at %L is used as array",
8788 sym
->name
, &sym
->declared_at
);
8789 sym
->attr
.dimension
= 0;
8794 /* We cannot deal with class selectors that need temporaries. */
8795 if (target
->ts
.type
== BT_CLASS
8796 && gfc_ref_needs_temporary_p (target
->ref
))
8798 gfc_error ("CLASS selector at %L needs a temporary which is not "
8799 "yet implemented", &target
->where
);
8803 if (target
->ts
.type
== BT_CLASS
)
8804 gfc_fix_class_refs (target
);
8806 if (target
->rank
!= 0)
8809 /* The rank may be incorrectly guessed at parsing, therefore make sure
8810 it is corrected now. */
8811 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8814 sym
->as
= gfc_get_array_spec ();
8816 as
->rank
= target
->rank
;
8817 as
->type
= AS_DEFERRED
;
8818 as
->corank
= gfc_get_corank (target
);
8819 sym
->attr
.dimension
= 1;
8820 if (as
->corank
!= 0)
8821 sym
->attr
.codimension
= 1;
8823 else if (sym
->ts
.type
== BT_CLASS
&& (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
8825 if (!CLASS_DATA (sym
)->as
)
8826 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
8827 as
= CLASS_DATA (sym
)->as
;
8828 as
->rank
= target
->rank
;
8829 as
->type
= AS_DEFERRED
;
8830 as
->corank
= gfc_get_corank (target
);
8831 CLASS_DATA (sym
)->attr
.dimension
= 1;
8832 if (as
->corank
!= 0)
8833 CLASS_DATA (sym
)->attr
.codimension
= 1;
8838 /* target's rank is 0, but the type of the sym is still array valued,
8839 which has to be corrected. */
8840 if (sym
->ts
.type
== BT_CLASS
8841 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
8844 symbol_attribute attr
;
8845 /* The associated variable's type is still the array type
8846 correct this now. */
8847 gfc_typespec
*ts
= &target
->ts
;
8850 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8855 ts
= &ref
->u
.c
.component
->ts
;
8858 if (ts
->type
== BT_CLASS
)
8859 ts
= &ts
->u
.derived
->components
->ts
;
8865 /* Create a scalar instance of the current class type. Because the
8866 rank of a class array goes into its name, the type has to be
8867 rebuild. The alternative of (re-)setting just the attributes
8868 and as in the current type, destroys the type also in other
8872 sym
->ts
.type
= BT_CLASS
;
8873 attr
= CLASS_DATA (sym
)->attr
;
8875 attr
.associate_var
= 1;
8876 attr
.dimension
= attr
.codimension
= 0;
8877 attr
.class_pointer
= 1;
8878 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8880 /* Make sure the _vptr is set. */
8881 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8882 if (c
->ts
.u
.derived
== NULL
)
8883 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8884 CLASS_DATA (sym
)->attr
.pointer
= 1;
8885 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8886 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8887 gfc_commit_symbol (sym
->ts
.u
.derived
);
8888 /* _vptr now has the _vtab in it, change it to the _vtype. */
8889 if (c
->ts
.u
.derived
->attr
.vtab
)
8890 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8891 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8892 resolve_types (c
->ts
.u
.derived
->ns
);
8896 /* Mark this as an associate variable. */
8897 sym
->attr
.associate_var
= 1;
8899 /* Fix up the type-spec for CHARACTER types. */
8900 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8903 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8905 if (sym
->ts
.deferred
&& target
->expr_type
== EXPR_VARIABLE
8906 && target
->symtree
->n
.sym
->attr
.dummy
8907 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
8909 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8910 sym
->ts
.deferred
= 1;
8913 if (!sym
->ts
.u
.cl
->length
8914 && !sym
->ts
.deferred
8915 && target
->expr_type
== EXPR_CONSTANT
)
8917 sym
->ts
.u
.cl
->length
=
8918 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8919 target
->value
.character
.length
);
8921 else if ((!sym
->ts
.u
.cl
->length
8922 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8923 && target
->expr_type
!= EXPR_VARIABLE
)
8925 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8926 sym
->ts
.deferred
= 1;
8928 /* This is reset in trans-stmt.c after the assignment
8929 of the target expression to the associate name. */
8930 sym
->attr
.allocatable
= 1;
8934 /* If the target is a good class object, so is the associate variable. */
8935 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8936 sym
->attr
.class_ok
= 1;
8940 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8941 array reference, where necessary. The symbols are artificial and so
8942 the dimension attribute and arrayspec can also be set. In addition,
8943 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8944 This is corrected here as well.*/
8947 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8948 int rank
, gfc_ref
*ref
)
8950 gfc_ref
*nref
= (*expr1
)->ref
;
8951 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8952 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8953 (*expr1
)->rank
= rank
;
8954 if (sym1
->ts
.type
== BT_CLASS
)
8956 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8957 (*expr1
)->ts
= sym1
->ts
;
8959 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8960 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8961 CLASS_DATA (sym1
)->as
8962 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
8966 sym1
->attr
.dimension
= 1;
8967 if (sym1
->as
== NULL
&& sym2
)
8968 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
8971 for (; nref
; nref
= nref
->next
)
8972 if (nref
->next
== NULL
)
8975 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
8976 nref
->next
= gfc_copy_ref (ref
);
8977 else if (ref
&& !nref
)
8978 (*expr1
)->ref
= gfc_copy_ref (ref
);
8983 build_loc_call (gfc_expr
*sym_expr
)
8986 loc_call
= gfc_get_expr ();
8987 loc_call
->expr_type
= EXPR_FUNCTION
;
8988 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
8989 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
8990 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
8991 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
8992 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
8993 loc_call
->ts
.type
= BT_INTEGER
;
8994 loc_call
->ts
.kind
= gfc_index_integer_kind
;
8995 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
8996 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
8997 loc_call
->value
.function
.actual
->expr
= sym_expr
;
8998 loc_call
->where
= sym_expr
->where
;
9002 /* Resolve a SELECT TYPE statement. */
9005 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9007 gfc_symbol
*selector_type
;
9008 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9009 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9012 char name
[GFC_MAX_SYMBOL_LEN
];
9016 gfc_ref
* ref
= NULL
;
9017 gfc_expr
*selector_expr
= NULL
;
9019 ns
= code
->ext
.block
.ns
;
9022 /* Check for F03:C813. */
9023 if (code
->expr1
->ts
.type
!= BT_CLASS
9024 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9026 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9027 "at %L", &code
->loc
);
9031 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9036 gfc_ref
*ref2
= NULL
;
9037 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9038 if (ref
->type
== REF_COMPONENT
9039 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9044 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9045 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9046 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9050 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9051 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9052 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
9055 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
9056 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9058 /* F2008: C803 The selector expression must not be coindexed. */
9059 if (gfc_is_coindexed (code
->expr2
))
9061 gfc_error ("Selector at %L must not be coindexed",
9062 &code
->expr2
->where
);
9069 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9071 if (gfc_is_coindexed (code
->expr1
))
9073 gfc_error ("Selector at %L must not be coindexed",
9074 &code
->expr1
->where
);
9079 /* Loop over TYPE IS / CLASS IS cases. */
9080 for (body
= code
->block
; body
; body
= body
->block
)
9082 c
= body
->ext
.block
.case_list
;
9086 /* Check for repeated cases. */
9087 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9089 gfc_case
*d
= tail
->ext
.block
.case_list
;
9093 if (c
->ts
.type
== d
->ts
.type
9094 && ((c
->ts
.type
== BT_DERIVED
9095 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9096 && !strcmp (c
->ts
.u
.derived
->name
,
9097 d
->ts
.u
.derived
->name
))
9098 || c
->ts
.type
== BT_UNKNOWN
9099 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9100 && c
->ts
.kind
== d
->ts
.kind
)))
9102 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9103 &c
->where
, &d
->where
);
9109 /* Check F03:C815. */
9110 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9111 && !selector_type
->attr
.unlimited_polymorphic
9112 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9114 gfc_error ("Derived type %qs at %L must be extensible",
9115 c
->ts
.u
.derived
->name
, &c
->where
);
9120 /* Check F03:C816. */
9121 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
9122 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9123 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9125 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9126 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9127 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9129 gfc_error ("Unexpected intrinsic type %qs at %L",
9130 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9135 /* Check F03:C814. */
9136 if (c
->ts
.type
== BT_CHARACTER
9137 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9139 gfc_error ("The type-spec at %L shall specify that each length "
9140 "type parameter is assumed", &c
->where
);
9145 /* Intercept the DEFAULT case. */
9146 if (c
->ts
.type
== BT_UNKNOWN
)
9148 /* Check F03:C818. */
9151 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9152 "by a second DEFAULT CASE at %L",
9153 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9158 default_case
= body
;
9165 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9166 target if present. If there are any EXIT statements referring to the
9167 SELECT TYPE construct, this is no problem because the gfc_code
9168 reference stays the same and EXIT is equally possible from the BLOCK
9169 it is changed to. */
9170 code
->op
= EXEC_BLOCK
;
9173 gfc_association_list
* assoc
;
9175 assoc
= gfc_get_association_list ();
9176 assoc
->st
= code
->expr1
->symtree
;
9177 assoc
->target
= gfc_copy_expr (code
->expr2
);
9178 assoc
->target
->where
= code
->expr2
->where
;
9179 /* assoc->variable will be set by resolve_assoc_var. */
9181 code
->ext
.block
.assoc
= assoc
;
9182 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9184 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9187 code
->ext
.block
.assoc
= NULL
;
9189 /* Ensure that the selector rank and arrayspec are available to
9190 correct expressions in which they might be missing. */
9191 if (code
->expr2
&& code
->expr2
->rank
)
9193 rank
= code
->expr2
->rank
;
9194 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9195 if (ref
->next
== NULL
)
9197 if (ref
&& ref
->type
== REF_ARRAY
)
9198 ref
= gfc_copy_ref (ref
);
9200 /* Fixup expr1 if necessary. */
9202 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9204 else if (code
->expr1
->rank
)
9206 rank
= code
->expr1
->rank
;
9207 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9208 if (ref
->next
== NULL
)
9210 if (ref
&& ref
->type
== REF_ARRAY
)
9211 ref
= gfc_copy_ref (ref
);
9214 /* Add EXEC_SELECT to switch on type. */
9215 new_st
= gfc_get_code (code
->op
);
9216 new_st
->expr1
= code
->expr1
;
9217 new_st
->expr2
= code
->expr2
;
9218 new_st
->block
= code
->block
;
9219 code
->expr1
= code
->expr2
= NULL
;
9224 ns
->code
->next
= new_st
;
9226 code
->op
= EXEC_SELECT_TYPE
;
9228 /* Use the intrinsic LOC function to generate an integer expression
9229 for the vtable of the selector. Note that the rank of the selector
9230 expression has to be set to zero. */
9231 gfc_add_vptr_component (code
->expr1
);
9232 code
->expr1
->rank
= 0;
9233 code
->expr1
= build_loc_call (code
->expr1
);
9234 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9236 /* Loop over TYPE IS / CLASS IS cases. */
9237 for (body
= code
->block
; body
; body
= body
->block
)
9241 c
= body
->ext
.block
.case_list
;
9243 /* Generate an index integer expression for address of the
9244 TYPE/CLASS vtable and store it in c->low. The hash expression
9245 is stored in c->high and is used to resolve intrinsic cases. */
9246 if (c
->ts
.type
!= BT_UNKNOWN
)
9248 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9250 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9252 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9253 c
->ts
.u
.derived
->hash_value
);
9257 vtab
= gfc_find_vtab (&c
->ts
);
9258 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9259 e
= CLASS_DATA (vtab
)->initializer
;
9260 c
->high
= gfc_copy_expr (e
);
9261 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9264 ts
.kind
= gfc_integer_4_kind
;
9265 ts
.type
= BT_INTEGER
;
9266 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9270 e
= gfc_lval_expr_from_sym (vtab
);
9271 c
->low
= build_loc_call (e
);
9276 /* Associate temporary to selector. This should only be done
9277 when this case is actually true, so build a new ASSOCIATE
9278 that does precisely this here (instead of using the
9281 if (c
->ts
.type
== BT_CLASS
)
9282 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9283 else if (c
->ts
.type
== BT_DERIVED
)
9284 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9285 else if (c
->ts
.type
== BT_CHARACTER
)
9287 HOST_WIDE_INT charlen
= 0;
9288 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9289 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9290 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9291 snprintf (name
, sizeof (name
),
9292 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9293 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9296 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9299 st
= gfc_find_symtree (ns
->sym_root
, name
);
9300 gcc_assert (st
->n
.sym
->assoc
);
9301 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9302 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9303 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9305 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9306 /* Fixup the target expression if necessary. */
9308 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9311 new_st
= gfc_get_code (EXEC_BLOCK
);
9312 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9313 new_st
->ext
.block
.ns
->code
= body
->next
;
9314 body
->next
= new_st
;
9316 /* Chain in the new list only if it is marked as dangling. Otherwise
9317 there is a CASE label overlap and this is already used. Just ignore,
9318 the error is diagnosed elsewhere. */
9319 if (st
->n
.sym
->assoc
->dangling
)
9321 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9322 st
->n
.sym
->assoc
->dangling
= 0;
9325 resolve_assoc_var (st
->n
.sym
, false);
9328 /* Take out CLASS IS cases for separate treatment. */
9330 while (body
&& body
->block
)
9332 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9334 /* Add to class_is list. */
9335 if (class_is
== NULL
)
9337 class_is
= body
->block
;
9342 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9343 tail
->block
= body
->block
;
9346 /* Remove from EXEC_SELECT list. */
9347 body
->block
= body
->block
->block
;
9360 /* Add a default case to hold the CLASS IS cases. */
9361 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9362 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9364 tail
->ext
.block
.case_list
= gfc_get_case ();
9365 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9367 default_case
= tail
;
9370 /* More than one CLASS IS block? */
9371 if (class_is
->block
)
9375 /* Sort CLASS IS blocks by extension level. */
9379 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9382 /* F03:C817 (check for doubles). */
9383 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9384 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9386 gfc_error ("Double CLASS IS block in SELECT TYPE "
9388 &c2
->ext
.block
.case_list
->where
);
9391 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9392 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9395 (*c1
)->block
= c2
->block
;
9405 /* Generate IF chain. */
9406 if_st
= gfc_get_code (EXEC_IF
);
9408 for (body
= class_is
; body
; body
= body
->block
)
9410 new_st
->block
= gfc_get_code (EXEC_IF
);
9411 new_st
= new_st
->block
;
9412 /* Set up IF condition: Call _gfortran_is_extension_of. */
9413 new_st
->expr1
= gfc_get_expr ();
9414 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9415 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9416 new_st
->expr1
->ts
.kind
= 4;
9417 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9418 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9419 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9420 /* Set up arguments. */
9421 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9422 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9423 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9424 new_st
->expr1
->where
= code
->loc
;
9425 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9426 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9427 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9428 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9429 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9430 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9431 new_st
->next
= body
->next
;
9433 if (default_case
->next
)
9435 new_st
->block
= gfc_get_code (EXEC_IF
);
9436 new_st
= new_st
->block
;
9437 new_st
->next
= default_case
->next
;
9440 /* Replace CLASS DEFAULT code by the IF chain. */
9441 default_case
->next
= if_st
;
9444 /* Resolve the internal code. This cannot be done earlier because
9445 it requires that the sym->assoc of selectors is set already. */
9446 gfc_current_ns
= ns
;
9447 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9448 gfc_current_ns
= old_ns
;
9455 /* Resolve a transfer statement. This is making sure that:
9456 -- a derived type being transferred has only non-pointer components
9457 -- a derived type being transferred doesn't have private components, unless
9458 it's being transferred from the module where the type was defined
9459 -- we're not trying to transfer a whole assumed size array. */
9462 resolve_transfer (gfc_code
*code
)
9464 gfc_symbol
*sym
, *derived
;
9468 bool formatted
= false;
9469 gfc_dt
*dt
= code
->ext
.dt
;
9470 gfc_symbol
*dtio_sub
= NULL
;
9474 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9475 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9476 exp
= exp
->value
.op
.op1
;
9478 if (exp
&& exp
->expr_type
== EXPR_NULL
9481 gfc_error ("Invalid context for NULL () intrinsic at %L",
9486 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9487 && exp
->expr_type
!= EXPR_FUNCTION
9488 && exp
->expr_type
!= EXPR_STRUCTURE
))
9491 /* If we are reading, the variable will be changed. Note that
9492 code->ext.dt may be NULL if the TRANSFER is related to
9493 an INQUIRE statement -- but in this case, we are not reading, either. */
9494 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9495 && !gfc_check_vardef_context (exp
, false, false, false,
9499 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
9500 || exp
->expr_type
== EXPR_FUNCTION
9501 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9503 /* Go to actual component transferred. */
9504 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9505 if (ref
->type
== REF_COMPONENT
)
9506 ts
= &ref
->u
.c
.component
->ts
;
9508 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9509 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9511 derived
= ts
->u
.derived
;
9513 /* Determine when to use the formatted DTIO procedure. */
9514 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9517 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9518 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9519 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9521 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9524 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9525 /* Check to see if this is a nested DTIO call, with the
9526 dummy as the io-list object. */
9527 if (sym
&& sym
== dtio_sub
&& sym
->formal
9528 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9529 && exp
->ref
== NULL
)
9531 if (!sym
->attr
.recursive
)
9533 gfc_error ("DTIO %s procedure at %L must be recursive",
9534 sym
->name
, &sym
->declared_at
);
9541 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9543 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9544 "it is processed by a defined input/output procedure",
9549 if (ts
->type
== BT_DERIVED
)
9551 /* Check that transferred derived type doesn't contain POINTER
9552 components unless it is processed by a defined input/output
9554 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9556 gfc_error ("Data transfer element at %L cannot have POINTER "
9557 "components unless it is processed by a defined "
9558 "input/output procedure", &code
->loc
);
9563 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9565 gfc_error ("Data transfer element at %L cannot have "
9566 "procedure pointer components", &code
->loc
);
9570 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9572 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9573 "components unless it is processed by a defined "
9574 "input/output procedure", &code
->loc
);
9578 /* C_PTR and C_FUNPTR have private components which means they cannot
9579 be printed. However, if -std=gnu and not -pedantic, allow
9580 the component to be printed to help debugging. */
9581 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9583 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9584 "cannot have PRIVATE components", &code
->loc
))
9587 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9589 gfc_error ("Data transfer element at %L cannot have "
9590 "PRIVATE components unless it is processed by "
9591 "a defined input/output procedure", &code
->loc
);
9596 if (exp
->expr_type
== EXPR_STRUCTURE
)
9599 sym
= exp
->symtree
->n
.sym
;
9601 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9602 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9604 gfc_error ("Data transfer element at %L cannot be a full reference to "
9605 "an assumed-size array", &code
->loc
);
9609 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9610 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9614 /*********** Toplevel code resolution subroutines ***********/
9616 /* Find the set of labels that are reachable from this block. We also
9617 record the last statement in each block. */
9620 find_reachable_labels (gfc_code
*block
)
9627 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9629 /* Collect labels in this block. We don't keep those corresponding
9630 to END {IF|SELECT}, these are checked in resolve_branch by going
9631 up through the code_stack. */
9632 for (c
= block
; c
; c
= c
->next
)
9634 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9635 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9638 /* Merge with labels from parent block. */
9641 gcc_assert (cs_base
->prev
->reachable_labels
);
9642 bitmap_ior_into (cs_base
->reachable_labels
,
9643 cs_base
->prev
->reachable_labels
);
9649 resolve_lock_unlock_event (gfc_code
*code
)
9651 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9652 && code
->expr1
->value
.function
.isym
9653 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9654 remove_caf_get_intrinsic (code
->expr1
);
9656 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9657 && (code
->expr1
->ts
.type
!= BT_DERIVED
9658 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9659 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9660 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9661 || code
->expr1
->rank
!= 0
9662 || (!gfc_is_coarray (code
->expr1
) &&
9663 !gfc_is_coindexed (code
->expr1
))))
9664 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9665 &code
->expr1
->where
);
9666 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9667 && (code
->expr1
->ts
.type
!= BT_DERIVED
9668 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9669 || code
->expr1
->ts
.u
.derived
->from_intmod
9670 != INTMOD_ISO_FORTRAN_ENV
9671 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9672 != ISOFORTRAN_EVENT_TYPE
9673 || code
->expr1
->rank
!= 0))
9674 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9675 &code
->expr1
->where
);
9676 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9677 && !gfc_is_coindexed (code
->expr1
))
9678 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9679 &code
->expr1
->where
);
9680 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9681 gfc_error ("Event variable argument at %L must be a coarray but not "
9682 "coindexed", &code
->expr1
->where
);
9686 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9687 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9688 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9689 &code
->expr2
->where
);
9692 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9693 _("STAT variable")))
9698 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9699 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9700 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9701 &code
->expr3
->where
);
9704 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9705 _("ERRMSG variable")))
9708 /* Check for LOCK the ACQUIRED_LOCK. */
9709 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9710 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9711 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9712 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9713 "variable", &code
->expr4
->where
);
9715 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9716 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9717 _("ACQUIRED_LOCK variable")))
9720 /* Check for EVENT WAIT the UNTIL_COUNT. */
9721 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9723 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9724 || code
->expr4
->rank
!= 0)
9725 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9726 "expression", &code
->expr4
->where
);
9732 resolve_critical (gfc_code
*code
)
9734 gfc_symtree
*symtree
;
9735 gfc_symbol
*lock_type
;
9736 char name
[GFC_MAX_SYMBOL_LEN
];
9737 static int serial
= 0;
9739 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9742 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9743 GFC_PREFIX ("lock_type"));
9745 lock_type
= symtree
->n
.sym
;
9748 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9751 lock_type
= symtree
->n
.sym
;
9752 lock_type
->attr
.flavor
= FL_DERIVED
;
9753 lock_type
->attr
.zero_comp
= 1;
9754 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9755 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9758 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9759 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9762 code
->resolved_sym
= symtree
->n
.sym
;
9763 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9764 symtree
->n
.sym
->attr
.referenced
= 1;
9765 symtree
->n
.sym
->attr
.artificial
= 1;
9766 symtree
->n
.sym
->attr
.codimension
= 1;
9767 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9768 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9769 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9770 symtree
->n
.sym
->as
->corank
= 1;
9771 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9772 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9773 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9775 gfc_commit_symbols();
9780 resolve_sync (gfc_code
*code
)
9782 /* Check imageset. The * case matches expr1 == NULL. */
9785 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9786 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9787 "INTEGER expression", &code
->expr1
->where
);
9788 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9789 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9790 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9791 &code
->expr1
->where
);
9792 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9793 && gfc_simplify_expr (code
->expr1
, 0))
9795 gfc_constructor
*cons
;
9796 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9797 for (; cons
; cons
= gfc_constructor_next (cons
))
9798 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9799 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9800 gfc_error ("Imageset argument at %L must between 1 and "
9801 "num_images()", &cons
->expr
->where
);
9806 gfc_resolve_expr (code
->expr2
);
9808 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9809 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9810 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9811 &code
->expr2
->where
);
9814 gfc_resolve_expr (code
->expr3
);
9816 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9817 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9818 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9819 &code
->expr3
->where
);
9823 /* Given a branch to a label, see if the branch is conforming.
9824 The code node describes where the branch is located. */
9827 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9834 /* Step one: is this a valid branching target? */
9836 if (label
->defined
== ST_LABEL_UNKNOWN
)
9838 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9843 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9845 gfc_error ("Statement at %L is not a valid branch target statement "
9846 "for the branch statement at %L", &label
->where
, &code
->loc
);
9850 /* Step two: make sure this branch is not a branch to itself ;-) */
9852 if (code
->here
== label
)
9855 "Branch at %L may result in an infinite loop", &code
->loc
);
9859 /* Step three: See if the label is in the same block as the
9860 branching statement. The hard work has been done by setting up
9861 the bitmap reachable_labels. */
9863 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9865 /* Check now whether there is a CRITICAL construct; if so, check
9866 whether the label is still visible outside of the CRITICAL block,
9867 which is invalid. */
9868 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9870 if (stack
->current
->op
== EXEC_CRITICAL
9871 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9872 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9873 "label at %L", &code
->loc
, &label
->where
);
9874 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9875 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9876 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9877 "for label at %L", &code
->loc
, &label
->where
);
9883 /* Step four: If we haven't found the label in the bitmap, it may
9884 still be the label of the END of the enclosing block, in which
9885 case we find it by going up the code_stack. */
9887 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9889 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9891 if (stack
->current
->op
== EXEC_CRITICAL
)
9893 /* Note: A label at END CRITICAL does not leave the CRITICAL
9894 construct as END CRITICAL is still part of it. */
9895 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9896 " at %L", &code
->loc
, &label
->where
);
9899 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9901 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9902 "label at %L", &code
->loc
, &label
->where
);
9909 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9913 /* The label is not in an enclosing block, so illegal. This was
9914 allowed in Fortran 66, so we allow it as extension. No
9915 further checks are necessary in this case. */
9916 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9917 "as the GOTO statement at %L", &label
->where
,
9923 /* Check whether EXPR1 has the same shape as EXPR2. */
9926 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9928 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9929 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9930 bool result
= false;
9933 /* Compare the rank. */
9934 if (expr1
->rank
!= expr2
->rank
)
9937 /* Compare the size of each dimension. */
9938 for (i
=0; i
<expr1
->rank
; i
++)
9940 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9943 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9946 if (mpz_cmp (shape
[i
], shape2
[i
]))
9950 /* When either of the two expression is an assumed size array, we
9951 ignore the comparison of dimension sizes. */
9956 gfc_clear_shape (shape
, i
);
9957 gfc_clear_shape (shape2
, i
);
9962 /* Check whether a WHERE assignment target or a WHERE mask expression
9963 has the same shape as the outmost WHERE mask expression. */
9966 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9972 cblock
= code
->block
;
9974 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9975 In case of nested WHERE, only the outmost one is stored. */
9976 if (mask
== NULL
) /* outmost WHERE */
9978 else /* inner WHERE */
9985 /* Check if the mask-expr has a consistent shape with the
9986 outmost WHERE mask-expr. */
9987 if (!resolve_where_shape (cblock
->expr1
, e
))
9988 gfc_error ("WHERE mask at %L has inconsistent shape",
9989 &cblock
->expr1
->where
);
9992 /* the assignment statement of a WHERE statement, or the first
9993 statement in where-body-construct of a WHERE construct */
9994 cnext
= cblock
->next
;
9999 /* WHERE assignment statement */
10002 /* Check shape consistent for WHERE assignment target. */
10003 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10004 gfc_error ("WHERE assignment target at %L has "
10005 "inconsistent shape", &cnext
->expr1
->where
);
10009 case EXEC_ASSIGN_CALL
:
10010 resolve_call (cnext
);
10011 if (!cnext
->resolved_sym
->attr
.elemental
)
10012 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10013 &cnext
->ext
.actual
->expr
->where
);
10016 /* WHERE or WHERE construct is part of a where-body-construct */
10018 resolve_where (cnext
, e
);
10022 gfc_error ("Unsupported statement inside WHERE at %L",
10025 /* the next statement within the same where-body-construct */
10026 cnext
= cnext
->next
;
10028 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10029 cblock
= cblock
->block
;
10034 /* Resolve assignment in FORALL construct.
10035 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10036 FORALL index variables. */
10039 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10043 for (n
= 0; n
< nvar
; n
++)
10045 gfc_symbol
*forall_index
;
10047 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10049 /* Check whether the assignment target is one of the FORALL index
10051 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10052 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10053 gfc_error ("Assignment to a FORALL index variable at %L",
10054 &code
->expr1
->where
);
10057 /* If one of the FORALL index variables doesn't appear in the
10058 assignment variable, then there could be a many-to-one
10059 assignment. Emit a warning rather than an error because the
10060 mask could be resolving this problem. */
10061 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10062 gfc_warning (0, "The FORALL with index %qs is not used on the "
10063 "left side of the assignment at %L and so might "
10064 "cause multiple assignment to this object",
10065 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10071 /* Resolve WHERE statement in FORALL construct. */
10074 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10075 gfc_expr
**var_expr
)
10080 cblock
= code
->block
;
10083 /* the assignment statement of a WHERE statement, or the first
10084 statement in where-body-construct of a WHERE construct */
10085 cnext
= cblock
->next
;
10090 /* WHERE assignment statement */
10092 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10095 /* WHERE operator assignment statement */
10096 case EXEC_ASSIGN_CALL
:
10097 resolve_call (cnext
);
10098 if (!cnext
->resolved_sym
->attr
.elemental
)
10099 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10100 &cnext
->ext
.actual
->expr
->where
);
10103 /* WHERE or WHERE construct is part of a where-body-construct */
10105 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10109 gfc_error ("Unsupported statement inside WHERE at %L",
10112 /* the next statement within the same where-body-construct */
10113 cnext
= cnext
->next
;
10115 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10116 cblock
= cblock
->block
;
10121 /* Traverse the FORALL body to check whether the following errors exist:
10122 1. For assignment, check if a many-to-one assignment happens.
10123 2. For WHERE statement, check the WHERE body to see if there is any
10124 many-to-one assignment. */
10127 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10131 c
= code
->block
->next
;
10137 case EXEC_POINTER_ASSIGN
:
10138 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10141 case EXEC_ASSIGN_CALL
:
10145 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10146 there is no need to handle it here. */
10150 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10155 /* The next statement in the FORALL body. */
10161 /* Counts the number of iterators needed inside a forall construct, including
10162 nested forall constructs. This is used to allocate the needed memory
10163 in gfc_resolve_forall. */
10166 gfc_count_forall_iterators (gfc_code
*code
)
10168 int max_iters
, sub_iters
, current_iters
;
10169 gfc_forall_iterator
*fa
;
10171 gcc_assert(code
->op
== EXEC_FORALL
);
10175 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10178 code
= code
->block
->next
;
10182 if (code
->op
== EXEC_FORALL
)
10184 sub_iters
= gfc_count_forall_iterators (code
);
10185 if (sub_iters
> max_iters
)
10186 max_iters
= sub_iters
;
10191 return current_iters
+ max_iters
;
10195 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10196 gfc_resolve_forall_body to resolve the FORALL body. */
10199 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10201 static gfc_expr
**var_expr
;
10202 static int total_var
= 0;
10203 static int nvar
= 0;
10204 int i
, old_nvar
, tmp
;
10205 gfc_forall_iterator
*fa
;
10209 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10212 /* Start to resolve a FORALL construct */
10213 if (forall_save
== 0)
10215 /* Count the total number of FORALL indices in the nested FORALL
10216 construct in order to allocate the VAR_EXPR with proper size. */
10217 total_var
= gfc_count_forall_iterators (code
);
10219 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10220 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10223 /* The information about FORALL iterator, including FORALL indices start, end
10224 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10225 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10227 /* Fortran 20008: C738 (R753). */
10228 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10230 gfc_error ("FORALL index-name at %L must be a scalar variable "
10231 "of type integer", &fa
->var
->where
);
10235 /* Check if any outer FORALL index name is the same as the current
10237 for (i
= 0; i
< nvar
; i
++)
10239 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10240 gfc_error ("An outer FORALL construct already has an index "
10241 "with this name %L", &fa
->var
->where
);
10244 /* Record the current FORALL index. */
10245 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10249 /* No memory leak. */
10250 gcc_assert (nvar
<= total_var
);
10253 /* Resolve the FORALL body. */
10254 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10256 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10257 gfc_resolve_blocks (code
->block
, ns
);
10261 /* Free only the VAR_EXPRs allocated in this frame. */
10262 for (i
= nvar
; i
< tmp
; i
++)
10263 gfc_free_expr (var_expr
[i
]);
10267 /* We are in the outermost FORALL construct. */
10268 gcc_assert (forall_save
== 0);
10270 /* VAR_EXPR is not needed any more. */
10277 /* Resolve a BLOCK construct statement. */
10280 resolve_block_construct (gfc_code
* code
)
10282 /* Resolve the BLOCK's namespace. */
10283 gfc_resolve (code
->ext
.block
.ns
);
10285 /* For an ASSOCIATE block, the associations (and their targets) are already
10286 resolved during resolve_symbol. */
10290 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10294 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10298 for (; b
; b
= b
->block
)
10300 t
= gfc_resolve_expr (b
->expr1
);
10301 if (!gfc_resolve_expr (b
->expr2
))
10307 if (t
&& b
->expr1
!= NULL
10308 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10309 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10315 && b
->expr1
!= NULL
10316 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10317 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10322 resolve_branch (b
->label1
, b
);
10326 resolve_block_construct (b
);
10330 case EXEC_SELECT_TYPE
:
10333 case EXEC_DO_WHILE
:
10334 case EXEC_DO_CONCURRENT
:
10335 case EXEC_CRITICAL
:
10338 case EXEC_IOLENGTH
:
10342 case EXEC_OMP_ATOMIC
:
10343 case EXEC_OACC_ATOMIC
:
10345 gfc_omp_atomic_op aop
10346 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10348 /* Verify this before calling gfc_resolve_code, which might
10350 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10351 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10352 && b
->next
->next
== NULL
)
10353 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10354 && b
->next
->next
!= NULL
10355 && b
->next
->next
->op
== EXEC_ASSIGN
10356 && b
->next
->next
->next
== NULL
));
10360 case EXEC_OACC_PARALLEL_LOOP
:
10361 case EXEC_OACC_PARALLEL
:
10362 case EXEC_OACC_KERNELS_LOOP
:
10363 case EXEC_OACC_KERNELS
:
10364 case EXEC_OACC_DATA
:
10365 case EXEC_OACC_HOST_DATA
:
10366 case EXEC_OACC_LOOP
:
10367 case EXEC_OACC_UPDATE
:
10368 case EXEC_OACC_WAIT
:
10369 case EXEC_OACC_CACHE
:
10370 case EXEC_OACC_ENTER_DATA
:
10371 case EXEC_OACC_EXIT_DATA
:
10372 case EXEC_OACC_ROUTINE
:
10373 case EXEC_OMP_CRITICAL
:
10374 case EXEC_OMP_DISTRIBUTE
:
10375 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10376 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10377 case EXEC_OMP_DISTRIBUTE_SIMD
:
10379 case EXEC_OMP_DO_SIMD
:
10380 case EXEC_OMP_MASTER
:
10381 case EXEC_OMP_ORDERED
:
10382 case EXEC_OMP_PARALLEL
:
10383 case EXEC_OMP_PARALLEL_DO
:
10384 case EXEC_OMP_PARALLEL_DO_SIMD
:
10385 case EXEC_OMP_PARALLEL_SECTIONS
:
10386 case EXEC_OMP_PARALLEL_WORKSHARE
:
10387 case EXEC_OMP_SECTIONS
:
10388 case EXEC_OMP_SIMD
:
10389 case EXEC_OMP_SINGLE
:
10390 case EXEC_OMP_TARGET
:
10391 case EXEC_OMP_TARGET_DATA
:
10392 case EXEC_OMP_TARGET_ENTER_DATA
:
10393 case EXEC_OMP_TARGET_EXIT_DATA
:
10394 case EXEC_OMP_TARGET_PARALLEL
:
10395 case EXEC_OMP_TARGET_PARALLEL_DO
:
10396 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10397 case EXEC_OMP_TARGET_SIMD
:
10398 case EXEC_OMP_TARGET_TEAMS
:
10399 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10400 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10401 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10402 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10403 case EXEC_OMP_TARGET_UPDATE
:
10404 case EXEC_OMP_TASK
:
10405 case EXEC_OMP_TASKGROUP
:
10406 case EXEC_OMP_TASKLOOP
:
10407 case EXEC_OMP_TASKLOOP_SIMD
:
10408 case EXEC_OMP_TASKWAIT
:
10409 case EXEC_OMP_TASKYIELD
:
10410 case EXEC_OMP_TEAMS
:
10411 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10412 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10413 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10414 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10415 case EXEC_OMP_WORKSHARE
:
10419 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10422 gfc_resolve_code (b
->next
, ns
);
10427 /* Does everything to resolve an ordinary assignment. Returns true
10428 if this is an interface assignment. */
10430 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10437 symbol_attribute attr
;
10439 if (gfc_extend_assign (code
, ns
))
10443 if (code
->op
== EXEC_ASSIGN_CALL
)
10445 lhs
= code
->ext
.actual
->expr
;
10446 rhsptr
= &code
->ext
.actual
->next
->expr
;
10450 gfc_actual_arglist
* args
;
10451 gfc_typebound_proc
* tbp
;
10453 gcc_assert (code
->op
== EXEC_COMPCALL
);
10455 args
= code
->expr1
->value
.compcall
.actual
;
10457 rhsptr
= &args
->next
->expr
;
10459 tbp
= code
->expr1
->value
.compcall
.tbp
;
10460 gcc_assert (!tbp
->is_generic
);
10463 /* Make a temporary rhs when there is a default initializer
10464 and rhs is the same symbol as the lhs. */
10465 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10466 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10467 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10468 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10469 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10478 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
10479 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
10483 /* Handle the case of a BOZ literal on the RHS. */
10484 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
10487 if (warn_surprising
)
10488 gfc_warning (OPT_Wsurprising
,
10489 "BOZ literal at %L is bitwise transferred "
10490 "non-integer symbol %qs", &code
->loc
,
10491 lhs
->symtree
->n
.sym
->name
);
10493 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
10495 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
10497 if (rc
== ARITH_UNDERFLOW
)
10498 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
10499 ". This check can be disabled with the option "
10500 "%<-fno-range-check%>", &rhs
->where
);
10501 else if (rc
== ARITH_OVERFLOW
)
10502 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
10503 ". This check can be disabled with the option "
10504 "%<-fno-range-check%>", &rhs
->where
);
10505 else if (rc
== ARITH_NAN
)
10506 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
10507 ". This check can be disabled with the option "
10508 "%<-fno-range-check%>", &rhs
->where
);
10513 if (lhs
->ts
.type
== BT_CHARACTER
10514 && warn_character_truncation
)
10516 HOST_WIDE_INT llen
= 0, rlen
= 0;
10517 if (lhs
->ts
.u
.cl
!= NULL
10518 && lhs
->ts
.u
.cl
->length
!= NULL
10519 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10520 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10522 if (rhs
->expr_type
== EXPR_CONSTANT
)
10523 rlen
= rhs
->value
.character
.length
;
10525 else if (rhs
->ts
.u
.cl
!= NULL
10526 && rhs
->ts
.u
.cl
->length
!= NULL
10527 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10528 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10530 if (rlen
&& llen
&& rlen
> llen
)
10531 gfc_warning_now (OPT_Wcharacter_truncation
,
10532 "CHARACTER expression will be truncated "
10533 "in assignment (%ld/%ld) at %L",
10534 (long) llen
, (long) rlen
, &code
->loc
);
10537 /* Ensure that a vector index expression for the lvalue is evaluated
10538 to a temporary if the lvalue symbol is referenced in it. */
10541 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10542 if (ref
->type
== REF_ARRAY
)
10544 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10545 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10546 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10547 ref
->u
.ar
.start
[n
]))
10549 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10553 if (gfc_pure (NULL
))
10555 if (lhs
->ts
.type
== BT_DERIVED
10556 && lhs
->expr_type
== EXPR_VARIABLE
10557 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10558 && rhs
->expr_type
== EXPR_VARIABLE
10559 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10560 || gfc_is_coindexed (rhs
)))
10562 /* F2008, C1283. */
10563 if (gfc_is_coindexed (rhs
))
10564 gfc_error ("Coindexed expression at %L is assigned to "
10565 "a derived type variable with a POINTER "
10566 "component in a PURE procedure",
10569 gfc_error ("The impure variable at %L is assigned to "
10570 "a derived type variable with a POINTER "
10571 "component in a PURE procedure (12.6)",
10576 /* Fortran 2008, C1283. */
10577 if (gfc_is_coindexed (lhs
))
10579 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10580 "procedure", &rhs
->where
);
10585 if (gfc_implicit_pure (NULL
))
10587 if (lhs
->expr_type
== EXPR_VARIABLE
10588 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10589 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10590 gfc_unset_implicit_pure (NULL
);
10592 if (lhs
->ts
.type
== BT_DERIVED
10593 && lhs
->expr_type
== EXPR_VARIABLE
10594 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10595 && rhs
->expr_type
== EXPR_VARIABLE
10596 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10597 || gfc_is_coindexed (rhs
)))
10598 gfc_unset_implicit_pure (NULL
);
10600 /* Fortran 2008, C1283. */
10601 if (gfc_is_coindexed (lhs
))
10602 gfc_unset_implicit_pure (NULL
);
10605 /* F2008, 7.2.1.2. */
10606 attr
= gfc_expr_attr (lhs
);
10607 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10609 if (attr
.codimension
)
10611 gfc_error ("Assignment to polymorphic coarray at %L is not "
10612 "permitted", &lhs
->where
);
10615 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10616 "polymorphic variable at %L", &lhs
->where
))
10618 if (!flag_realloc_lhs
)
10620 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10621 "requires %<-frealloc-lhs%>", &lhs
->where
);
10625 else if (lhs
->ts
.type
== BT_CLASS
)
10627 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10628 "assignment at %L - check that there is a matching specific "
10629 "subroutine for '=' operator", &lhs
->where
);
10633 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10635 /* F2008, Section 7.2.1.2. */
10636 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10638 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10639 "component in assignment at %L", &lhs
->where
);
10643 /* Assign the 'data' of a class object to a derived type. */
10644 if (lhs
->ts
.type
== BT_DERIVED
10645 && rhs
->ts
.type
== BT_CLASS
10646 && rhs
->expr_type
!= EXPR_ARRAY
)
10647 gfc_add_data_component (rhs
);
10649 /* Make sure there is a vtable and, in particular, a _copy for the
10651 if (UNLIMITED_POLY (lhs
) && lhs
->rank
&& rhs
->ts
.type
!= BT_CLASS
)
10652 gfc_find_vtab (&rhs
->ts
);
10654 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10656 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10657 && code
->expr2
->value
.function
.isym
10658 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10659 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10660 && !gfc_expr_attr (rhs
).allocatable
10661 && !gfc_has_vector_subscript (rhs
)));
10663 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10665 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10666 Additionally, insert this code when the RHS is a CAF as we then use the
10667 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10668 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10669 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10671 if (caf_convert_to_send
)
10673 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10674 && code
->expr2
->value
.function
.isym
10675 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10676 remove_caf_get_intrinsic (code
->expr2
);
10677 code
->op
= EXEC_CALL
;
10678 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10679 code
->resolved_sym
= code
->symtree
->n
.sym
;
10680 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10681 code
->resolved_sym
->attr
.intrinsic
= 1;
10682 code
->resolved_sym
->attr
.subroutine
= 1;
10683 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10684 gfc_commit_symbol (code
->resolved_sym
);
10685 code
->ext
.actual
= gfc_get_actual_arglist ();
10686 code
->ext
.actual
->expr
= lhs
;
10687 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10688 code
->ext
.actual
->next
->expr
= rhs
;
10689 code
->expr1
= NULL
;
10690 code
->expr2
= NULL
;
10697 /* Add a component reference onto an expression. */
10700 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10705 ref
= &((*ref
)->next
);
10706 *ref
= gfc_get_ref ();
10707 (*ref
)->type
= REF_COMPONENT
;
10708 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10709 (*ref
)->u
.c
.component
= c
;
10712 /* Add a full array ref, as necessary. */
10715 gfc_add_full_array_ref (e
, c
->as
);
10716 e
->rank
= c
->as
->rank
;
10721 /* Build an assignment. Keep the argument 'op' for future use, so that
10722 pointer assignments can be made. */
10725 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10726 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10728 gfc_code
*this_code
;
10730 this_code
= gfc_get_code (op
);
10731 this_code
->next
= NULL
;
10732 this_code
->expr1
= gfc_copy_expr (expr1
);
10733 this_code
->expr2
= gfc_copy_expr (expr2
);
10734 this_code
->loc
= loc
;
10735 if (comp1
&& comp2
)
10737 add_comp_ref (this_code
->expr1
, comp1
);
10738 add_comp_ref (this_code
->expr2
, comp2
);
10745 /* Makes a temporary variable expression based on the characteristics of
10746 a given variable expression. */
10749 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10751 static int serial
= 0;
10752 char name
[GFC_MAX_SYMBOL_LEN
];
10754 gfc_array_spec
*as
;
10755 gfc_array_ref
*aref
;
10758 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10759 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10760 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10762 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
10763 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
10765 e
->value
.character
.length
);
10771 /* Obtain the arrayspec for the temporary. */
10772 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10773 && e
->expr_type
!= EXPR_FUNCTION
10774 && e
->expr_type
!= EXPR_OP
)
10776 aref
= gfc_find_array_ref (e
);
10777 if (e
->expr_type
== EXPR_VARIABLE
10778 && e
->symtree
->n
.sym
->as
== aref
->as
)
10782 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10783 if (ref
->type
== REF_COMPONENT
10784 && ref
->u
.c
.component
->as
== aref
->as
)
10792 /* Add the attributes and the arrayspec to the temporary. */
10793 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10794 tmp
->n
.sym
->attr
.function
= 0;
10795 tmp
->n
.sym
->attr
.result
= 0;
10796 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10797 tmp
->n
.sym
->attr
.dummy
= 0;
10798 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
10802 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10805 if (as
->type
== AS_DEFERRED
)
10806 tmp
->n
.sym
->attr
.allocatable
= 1;
10808 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10809 || e
->expr_type
== EXPR_FUNCTION
10810 || e
->expr_type
== EXPR_OP
))
10812 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10813 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10814 tmp
->n
.sym
->as
->rank
= e
->rank
;
10815 tmp
->n
.sym
->attr
.allocatable
= 1;
10816 tmp
->n
.sym
->attr
.dimension
= 1;
10819 tmp
->n
.sym
->attr
.dimension
= 0;
10821 gfc_set_sym_referenced (tmp
->n
.sym
);
10822 gfc_commit_symbol (tmp
->n
.sym
);
10823 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10825 /* Should the lhs be a section, use its array ref for the
10826 temporary expression. */
10827 if (aref
&& aref
->type
!= AR_FULL
)
10829 gfc_free_ref_list (e
->ref
);
10830 e
->ref
= gfc_copy_ref (ref
);
10836 /* Add one line of code to the code chain, making sure that 'head' and
10837 'tail' are appropriately updated. */
10840 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10842 gcc_assert (this_code
);
10844 *head
= *tail
= *this_code
;
10846 *tail
= gfc_append_code (*tail
, *this_code
);
10851 /* Counts the potential number of part array references that would
10852 result from resolution of typebound defined assignments. */
10855 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10858 int c_depth
= 0, t_depth
;
10860 for (c
= derived
->components
; c
; c
= c
->next
)
10862 if ((!gfc_bt_struct (c
->ts
.type
)
10864 || c
->attr
.allocatable
10865 || c
->attr
.proc_pointer_comp
10866 || c
->attr
.class_pointer
10867 || c
->attr
.proc_pointer
)
10868 && !c
->attr
.defined_assign_comp
)
10871 if (c
->as
&& c_depth
== 0)
10874 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10875 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10880 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10882 return depth
+ c_depth
;
10886 /* Implement 7.2.1.3 of the F08 standard:
10887 "An intrinsic assignment where the variable is of derived type is
10888 performed as if each component of the variable were assigned from the
10889 corresponding component of expr using pointer assignment (7.2.2) for
10890 each pointer component, defined assignment for each nonpointer
10891 nonallocatable component of a type that has a type-bound defined
10892 assignment consistent with the component, intrinsic assignment for
10893 each other nonpointer nonallocatable component, ..."
10895 The pointer assignments are taken care of by the intrinsic
10896 assignment of the structure itself. This function recursively adds
10897 defined assignments where required. The recursion is accomplished
10898 by calling gfc_resolve_code.
10900 When the lhs in a defined assignment has intent INOUT, we need a
10901 temporary for the lhs. In pseudo-code:
10903 ! Only call function lhs once.
10904 if (lhs is not a constant or an variable)
10907 ! Do the intrinsic assignment
10909 ! Now do the defined assignments
10910 do over components with typebound defined assignment [%cmp]
10911 #if one component's assignment procedure is INOUT
10913 #if expr2 non-variable
10919 t1%cmp {defined=} expr2%cmp
10925 expr1%cmp {defined=} expr2%cmp
10929 /* The temporary assignments have to be put on top of the additional
10930 code to avoid the result being changed by the intrinsic assignment.
10932 static int component_assignment_level
= 0;
10933 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10936 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10938 gfc_component
*comp1
, *comp2
;
10939 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10941 int error_count
, depth
;
10943 gfc_get_errors (NULL
, &error_count
);
10945 /* Filter out continuing processing after an error. */
10947 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10948 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10951 /* TODO: Handle more than one part array reference in assignments. */
10952 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10953 (*code
)->expr1
->rank
? 1 : 0);
10956 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10957 "done because multiple part array references would "
10958 "occur in intermediate expressions.", &(*code
)->loc
);
10962 component_assignment_level
++;
10964 /* Create a temporary so that functions get called only once. */
10965 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10966 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10968 gfc_expr
*tmp_expr
;
10970 /* Assign the rhs to the temporary. */
10971 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10972 this_code
= build_assignment (EXEC_ASSIGN
,
10973 tmp_expr
, (*code
)->expr2
,
10974 NULL
, NULL
, (*code
)->loc
);
10975 /* Add the code and substitute the rhs expression. */
10976 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10977 gfc_free_expr ((*code
)->expr2
);
10978 (*code
)->expr2
= tmp_expr
;
10981 /* Do the intrinsic assignment. This is not needed if the lhs is one
10982 of the temporaries generated here, since the intrinsic assignment
10983 to the final result already does this. */
10984 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10986 this_code
= build_assignment (EXEC_ASSIGN
,
10987 (*code
)->expr1
, (*code
)->expr2
,
10988 NULL
, NULL
, (*code
)->loc
);
10989 add_code_to_chain (&this_code
, &head
, &tail
);
10992 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10993 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10996 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10998 bool inout
= false;
11000 /* The intrinsic assignment does the right thing for pointers
11001 of all kinds and allocatable components. */
11002 if (!gfc_bt_struct (comp1
->ts
.type
)
11003 || comp1
->attr
.pointer
11004 || comp1
->attr
.allocatable
11005 || comp1
->attr
.proc_pointer_comp
11006 || comp1
->attr
.class_pointer
11007 || comp1
->attr
.proc_pointer
)
11010 /* Make an assigment for this component. */
11011 this_code
= build_assignment (EXEC_ASSIGN
,
11012 (*code
)->expr1
, (*code
)->expr2
,
11013 comp1
, comp2
, (*code
)->loc
);
11015 /* Convert the assignment if there is a defined assignment for
11016 this type. Otherwise, using the call from gfc_resolve_code,
11017 recurse into its components. */
11018 gfc_resolve_code (this_code
, ns
);
11020 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11022 gfc_formal_arglist
*dummy_args
;
11024 /* Check that there is a typebound defined assignment. If not,
11025 then this must be a module defined assignment. We cannot
11026 use the defined_assign_comp attribute here because it must
11027 be this derived type that has the defined assignment and not
11029 if (!(comp1
->ts
.u
.derived
->f2k_derived
11030 && comp1
->ts
.u
.derived
->f2k_derived
11031 ->tb_op
[INTRINSIC_ASSIGN
]))
11033 gfc_free_statements (this_code
);
11038 /* If the first argument of the subroutine has intent INOUT
11039 a temporary must be generated and used instead. */
11040 rsym
= this_code
->resolved_sym
;
11041 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11043 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
11045 gfc_code
*temp_code
;
11048 /* Build the temporary required for the assignment and put
11049 it at the head of the generated code. */
11052 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
11053 temp_code
= build_assignment (EXEC_ASSIGN
,
11054 t1
, (*code
)->expr1
,
11055 NULL
, NULL
, (*code
)->loc
);
11057 /* For allocatable LHS, check whether it is allocated. Note
11058 that allocatable components with defined assignment are
11059 not yet support. See PR 57696. */
11060 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11064 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11065 block
= gfc_get_code (EXEC_IF
);
11066 block
->block
= gfc_get_code (EXEC_IF
);
11067 block
->block
->expr1
11068 = gfc_build_intrinsic_call (ns
,
11069 GFC_ISYM_ALLOCATED
, "allocated",
11070 (*code
)->loc
, 1, e
);
11071 block
->block
->next
= temp_code
;
11074 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11077 /* Replace the first actual arg with the component of the
11079 gfc_free_expr (this_code
->ext
.actual
->expr
);
11080 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11081 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11083 /* If the LHS variable is allocatable and wasn't allocated and
11084 the temporary is allocatable, pointer assign the address of
11085 the freshly allocated LHS to the temporary. */
11086 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11087 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11092 cond
= gfc_get_expr ();
11093 cond
->ts
.type
= BT_LOGICAL
;
11094 cond
->ts
.kind
= gfc_default_logical_kind
;
11095 cond
->expr_type
= EXPR_OP
;
11096 cond
->where
= (*code
)->loc
;
11097 cond
->value
.op
.op
= INTRINSIC_NOT
;
11098 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11099 GFC_ISYM_ALLOCATED
, "allocated",
11100 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11101 block
= gfc_get_code (EXEC_IF
);
11102 block
->block
= gfc_get_code (EXEC_IF
);
11103 block
->block
->expr1
= cond
;
11104 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11105 t1
, (*code
)->expr1
,
11106 NULL
, NULL
, (*code
)->loc
);
11107 add_code_to_chain (&block
, &head
, &tail
);
11111 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11113 /* Don't add intrinsic assignments since they are already
11114 effected by the intrinsic assignment of the structure. */
11115 gfc_free_statements (this_code
);
11120 add_code_to_chain (&this_code
, &head
, &tail
);
11124 /* Transfer the value to the final result. */
11125 this_code
= build_assignment (EXEC_ASSIGN
,
11126 (*code
)->expr1
, t1
,
11127 comp1
, comp2
, (*code
)->loc
);
11128 add_code_to_chain (&this_code
, &head
, &tail
);
11132 /* Put the temporary assignments at the top of the generated code. */
11133 if (tmp_head
&& component_assignment_level
== 1)
11135 gfc_append_code (tmp_head
, head
);
11137 tmp_head
= tmp_tail
= NULL
;
11140 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11141 // not accidentally deallocated. Hence, nullify t1.
11142 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11143 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11149 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11150 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11151 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11152 block
= gfc_get_code (EXEC_IF
);
11153 block
->block
= gfc_get_code (EXEC_IF
);
11154 block
->block
->expr1
= cond
;
11155 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11156 t1
, gfc_get_null_expr (&(*code
)->loc
),
11157 NULL
, NULL
, (*code
)->loc
);
11158 gfc_append_code (tail
, block
);
11162 /* Now attach the remaining code chain to the input code. Step on
11163 to the end of the new code since resolution is complete. */
11164 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11165 tail
->next
= (*code
)->next
;
11166 /* Overwrite 'code' because this would place the intrinsic assignment
11167 before the temporary for the lhs is created. */
11168 gfc_free_expr ((*code
)->expr1
);
11169 gfc_free_expr ((*code
)->expr2
);
11175 component_assignment_level
--;
11179 /* F2008: Pointer function assignments are of the form:
11180 ptr_fcn (args) = expr
11181 This function breaks these assignments into two statements:
11182 temporary_pointer => ptr_fcn(args)
11183 temporary_pointer = expr */
11186 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11188 gfc_expr
*tmp_ptr_expr
;
11189 gfc_code
*this_code
;
11190 gfc_component
*comp
;
11193 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11196 /* Even if standard does not support this feature, continue to build
11197 the two statements to avoid upsetting frontend_passes.c. */
11198 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11199 "%L", &(*code
)->loc
);
11201 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11204 s
= comp
->ts
.interface
;
11206 s
= (*code
)->expr1
->symtree
->n
.sym
;
11208 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11210 gfc_error ("The function result on the lhs of the assignment at "
11211 "%L must have the pointer attribute.",
11212 &(*code
)->expr1
->where
);
11213 (*code
)->op
= EXEC_NOP
;
11217 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
11219 /* get_temp_from_expression is set up for ordinary assignments. To that
11220 end, where array bounds are not known, arrays are made allocatable.
11221 Change the temporary to a pointer here. */
11222 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11223 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11224 tmp_ptr_expr
->where
= (*code
)->loc
;
11226 this_code
= build_assignment (EXEC_ASSIGN
,
11227 tmp_ptr_expr
, (*code
)->expr2
,
11228 NULL
, NULL
, (*code
)->loc
);
11229 this_code
->next
= (*code
)->next
;
11230 (*code
)->next
= this_code
;
11231 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11232 (*code
)->expr2
= (*code
)->expr1
;
11233 (*code
)->expr1
= tmp_ptr_expr
;
11239 /* Deferred character length assignments from an operator expression
11240 require a temporary because the character length of the lhs can
11241 change in the course of the assignment. */
11244 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11246 gfc_expr
*tmp_expr
;
11247 gfc_code
*this_code
;
11249 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11250 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11251 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11254 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11257 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
11260 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11261 tmp_expr
->where
= (*code
)->loc
;
11263 /* A new charlen is required to ensure that the variable string
11264 length is different to that of the original lhs. */
11265 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11266 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11267 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11268 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11270 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11272 this_code
= build_assignment (EXEC_ASSIGN
,
11274 gfc_copy_expr (tmp_expr
),
11275 NULL
, NULL
, (*code
)->loc
);
11277 (*code
)->expr1
= tmp_expr
;
11279 this_code
->next
= (*code
)->next
;
11280 (*code
)->next
= this_code
;
11286 /* Given a block of code, recursively resolve everything pointed to by this
11290 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11292 int omp_workshare_save
;
11293 int forall_save
, do_concurrent_save
;
11297 frame
.prev
= cs_base
;
11301 find_reachable_labels (code
);
11303 for (; code
; code
= code
->next
)
11305 frame
.current
= code
;
11306 forall_save
= forall_flag
;
11307 do_concurrent_save
= gfc_do_concurrent_flag
;
11309 if (code
->op
== EXEC_FORALL
)
11312 gfc_resolve_forall (code
, ns
, forall_save
);
11315 else if (code
->block
)
11317 omp_workshare_save
= -1;
11320 case EXEC_OACC_PARALLEL_LOOP
:
11321 case EXEC_OACC_PARALLEL
:
11322 case EXEC_OACC_KERNELS_LOOP
:
11323 case EXEC_OACC_KERNELS
:
11324 case EXEC_OACC_DATA
:
11325 case EXEC_OACC_HOST_DATA
:
11326 case EXEC_OACC_LOOP
:
11327 gfc_resolve_oacc_blocks (code
, ns
);
11329 case EXEC_OMP_PARALLEL_WORKSHARE
:
11330 omp_workshare_save
= omp_workshare_flag
;
11331 omp_workshare_flag
= 1;
11332 gfc_resolve_omp_parallel_blocks (code
, ns
);
11334 case EXEC_OMP_PARALLEL
:
11335 case EXEC_OMP_PARALLEL_DO
:
11336 case EXEC_OMP_PARALLEL_DO_SIMD
:
11337 case EXEC_OMP_PARALLEL_SECTIONS
:
11338 case EXEC_OMP_TARGET_PARALLEL
:
11339 case EXEC_OMP_TARGET_PARALLEL_DO
:
11340 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11341 case EXEC_OMP_TARGET_TEAMS
:
11342 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11343 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11344 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11345 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11346 case EXEC_OMP_TASK
:
11347 case EXEC_OMP_TASKLOOP
:
11348 case EXEC_OMP_TASKLOOP_SIMD
:
11349 case EXEC_OMP_TEAMS
:
11350 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11351 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11352 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11353 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11354 omp_workshare_save
= omp_workshare_flag
;
11355 omp_workshare_flag
= 0;
11356 gfc_resolve_omp_parallel_blocks (code
, ns
);
11358 case EXEC_OMP_DISTRIBUTE
:
11359 case EXEC_OMP_DISTRIBUTE_SIMD
:
11361 case EXEC_OMP_DO_SIMD
:
11362 case EXEC_OMP_SIMD
:
11363 case EXEC_OMP_TARGET_SIMD
:
11364 gfc_resolve_omp_do_blocks (code
, ns
);
11366 case EXEC_SELECT_TYPE
:
11367 /* Blocks are handled in resolve_select_type because we have
11368 to transform the SELECT TYPE into ASSOCIATE first. */
11370 case EXEC_DO_CONCURRENT
:
11371 gfc_do_concurrent_flag
= 1;
11372 gfc_resolve_blocks (code
->block
, ns
);
11373 gfc_do_concurrent_flag
= 2;
11375 case EXEC_OMP_WORKSHARE
:
11376 omp_workshare_save
= omp_workshare_flag
;
11377 omp_workshare_flag
= 1;
11380 gfc_resolve_blocks (code
->block
, ns
);
11384 if (omp_workshare_save
!= -1)
11385 omp_workshare_flag
= omp_workshare_save
;
11389 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11390 t
= gfc_resolve_expr (code
->expr1
);
11391 forall_flag
= forall_save
;
11392 gfc_do_concurrent_flag
= do_concurrent_save
;
11394 if (!gfc_resolve_expr (code
->expr2
))
11397 if (code
->op
== EXEC_ALLOCATE
11398 && !gfc_resolve_expr (code
->expr3
))
11404 case EXEC_END_BLOCK
:
11405 case EXEC_END_NESTED_BLOCK
:
11409 case EXEC_ERROR_STOP
:
11411 case EXEC_CONTINUE
:
11413 case EXEC_ASSIGN_CALL
:
11416 case EXEC_CRITICAL
:
11417 resolve_critical (code
);
11420 case EXEC_SYNC_ALL
:
11421 case EXEC_SYNC_IMAGES
:
11422 case EXEC_SYNC_MEMORY
:
11423 resolve_sync (code
);
11428 case EXEC_EVENT_POST
:
11429 case EXEC_EVENT_WAIT
:
11430 resolve_lock_unlock_event (code
);
11433 case EXEC_FAIL_IMAGE
:
11434 case EXEC_FORM_TEAM
:
11435 case EXEC_CHANGE_TEAM
:
11436 case EXEC_END_TEAM
:
11437 case EXEC_SYNC_TEAM
:
11441 /* Keep track of which entry we are up to. */
11442 current_entry_id
= code
->ext
.entry
->id
;
11446 resolve_where (code
, NULL
);
11450 if (code
->expr1
!= NULL
)
11452 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11453 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11454 "INTEGER variable", &code
->expr1
->where
);
11455 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11456 gfc_error ("Variable %qs has not been assigned a target "
11457 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11458 &code
->expr1
->where
);
11461 resolve_branch (code
->label1
, code
);
11465 if (code
->expr1
!= NULL
11466 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11467 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11468 "INTEGER return specifier", &code
->expr1
->where
);
11471 case EXEC_INIT_ASSIGN
:
11472 case EXEC_END_PROCEDURE
:
11479 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11481 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11482 && code
->expr1
->value
.function
.isym
11483 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11484 remove_caf_get_intrinsic (code
->expr1
);
11486 /* If this is a pointer function in an lvalue variable context,
11487 the new code will have to be resolved afresh. This is also the
11488 case with an error, where the code is transformed into NOP to
11489 prevent ICEs downstream. */
11490 if (resolve_ptr_fcn_assign (&code
, ns
)
11491 || code
->op
== EXEC_NOP
)
11494 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11498 if (resolve_ordinary_assign (code
, ns
))
11500 if (code
->op
== EXEC_COMPCALL
)
11506 /* Check for dependencies in deferred character length array
11507 assignments and generate a temporary, if necessary. */
11508 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11511 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11512 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11513 && code
->expr1
->ts
.u
.derived
11514 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11515 generate_component_assignments (&code
, ns
);
11519 case EXEC_LABEL_ASSIGN
:
11520 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11521 gfc_error ("Label %d referenced at %L is never defined",
11522 code
->label1
->value
, &code
->label1
->where
);
11524 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11525 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11526 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11527 != gfc_default_integer_kind
11528 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11529 gfc_error ("ASSIGN statement at %L requires a scalar "
11530 "default INTEGER variable", &code
->expr1
->where
);
11533 case EXEC_POINTER_ASSIGN
:
11540 /* This is both a variable definition and pointer assignment
11541 context, so check both of them. For rank remapping, a final
11542 array ref may be present on the LHS and fool gfc_expr_attr
11543 used in gfc_check_vardef_context. Remove it. */
11544 e
= remove_last_array_ref (code
->expr1
);
11545 t
= gfc_check_vardef_context (e
, true, false, false,
11546 _("pointer assignment"));
11548 t
= gfc_check_vardef_context (e
, false, false, false,
11549 _("pointer assignment"));
11552 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
11557 /* Assigning a class object always is a regular assign. */
11558 if (code
->expr2
->ts
.type
== BT_CLASS
11559 && code
->expr1
->ts
.type
== BT_CLASS
11560 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11561 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11562 && code
->expr2
->expr_type
== EXPR_VARIABLE
11563 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11565 code
->op
= EXEC_ASSIGN
;
11569 case EXEC_ARITHMETIC_IF
:
11571 gfc_expr
*e
= code
->expr1
;
11573 gfc_resolve_expr (e
);
11574 if (e
->expr_type
== EXPR_NULL
)
11575 gfc_error ("Invalid NULL at %L", &e
->where
);
11577 if (t
&& (e
->rank
> 0
11578 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11579 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11580 "REAL or INTEGER expression", &e
->where
);
11582 resolve_branch (code
->label1
, code
);
11583 resolve_branch (code
->label2
, code
);
11584 resolve_branch (code
->label3
, code
);
11589 if (t
&& code
->expr1
!= NULL
11590 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11591 || code
->expr1
->rank
!= 0))
11592 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11593 &code
->expr1
->where
);
11598 resolve_call (code
);
11601 case EXEC_COMPCALL
:
11603 resolve_typebound_subroutine (code
);
11606 case EXEC_CALL_PPC
:
11607 resolve_ppc_call (code
);
11611 /* Select is complicated. Also, a SELECT construct could be
11612 a transformed computed GOTO. */
11613 resolve_select (code
, false);
11616 case EXEC_SELECT_TYPE
:
11617 resolve_select_type (code
, ns
);
11621 resolve_block_construct (code
);
11625 if (code
->ext
.iterator
!= NULL
)
11627 gfc_iterator
*iter
= code
->ext
.iterator
;
11628 if (gfc_resolve_iterator (iter
, true, false))
11629 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11634 case EXEC_DO_WHILE
:
11635 if (code
->expr1
== NULL
)
11636 gfc_internal_error ("gfc_resolve_code(): No expression on "
11639 && (code
->expr1
->rank
!= 0
11640 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11641 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11642 "a scalar LOGICAL expression", &code
->expr1
->where
);
11645 case EXEC_ALLOCATE
:
11647 resolve_allocate_deallocate (code
, "ALLOCATE");
11651 case EXEC_DEALLOCATE
:
11653 resolve_allocate_deallocate (code
, "DEALLOCATE");
11658 if (!gfc_resolve_open (code
->ext
.open
))
11661 resolve_branch (code
->ext
.open
->err
, code
);
11665 if (!gfc_resolve_close (code
->ext
.close
))
11668 resolve_branch (code
->ext
.close
->err
, code
);
11671 case EXEC_BACKSPACE
:
11675 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
11678 resolve_branch (code
->ext
.filepos
->err
, code
);
11682 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11685 resolve_branch (code
->ext
.inquire
->err
, code
);
11688 case EXEC_IOLENGTH
:
11689 gcc_assert (code
->ext
.inquire
!= NULL
);
11690 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11693 resolve_branch (code
->ext
.inquire
->err
, code
);
11697 if (!gfc_resolve_wait (code
->ext
.wait
))
11700 resolve_branch (code
->ext
.wait
->err
, code
);
11701 resolve_branch (code
->ext
.wait
->end
, code
);
11702 resolve_branch (code
->ext
.wait
->eor
, code
);
11707 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11710 resolve_branch (code
->ext
.dt
->err
, code
);
11711 resolve_branch (code
->ext
.dt
->end
, code
);
11712 resolve_branch (code
->ext
.dt
->eor
, code
);
11715 case EXEC_TRANSFER
:
11716 resolve_transfer (code
);
11719 case EXEC_DO_CONCURRENT
:
11721 resolve_forall_iterators (code
->ext
.forall_iterator
);
11723 if (code
->expr1
!= NULL
11724 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11725 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11726 "expression", &code
->expr1
->where
);
11729 case EXEC_OACC_PARALLEL_LOOP
:
11730 case EXEC_OACC_PARALLEL
:
11731 case EXEC_OACC_KERNELS_LOOP
:
11732 case EXEC_OACC_KERNELS
:
11733 case EXEC_OACC_DATA
:
11734 case EXEC_OACC_HOST_DATA
:
11735 case EXEC_OACC_LOOP
:
11736 case EXEC_OACC_UPDATE
:
11737 case EXEC_OACC_WAIT
:
11738 case EXEC_OACC_CACHE
:
11739 case EXEC_OACC_ENTER_DATA
:
11740 case EXEC_OACC_EXIT_DATA
:
11741 case EXEC_OACC_ATOMIC
:
11742 case EXEC_OACC_DECLARE
:
11743 gfc_resolve_oacc_directive (code
, ns
);
11746 case EXEC_OMP_ATOMIC
:
11747 case EXEC_OMP_BARRIER
:
11748 case EXEC_OMP_CANCEL
:
11749 case EXEC_OMP_CANCELLATION_POINT
:
11750 case EXEC_OMP_CRITICAL
:
11751 case EXEC_OMP_FLUSH
:
11752 case EXEC_OMP_DISTRIBUTE
:
11753 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11754 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11755 case EXEC_OMP_DISTRIBUTE_SIMD
:
11757 case EXEC_OMP_DO_SIMD
:
11758 case EXEC_OMP_MASTER
:
11759 case EXEC_OMP_ORDERED
:
11760 case EXEC_OMP_SECTIONS
:
11761 case EXEC_OMP_SIMD
:
11762 case EXEC_OMP_SINGLE
:
11763 case EXEC_OMP_TARGET
:
11764 case EXEC_OMP_TARGET_DATA
:
11765 case EXEC_OMP_TARGET_ENTER_DATA
:
11766 case EXEC_OMP_TARGET_EXIT_DATA
:
11767 case EXEC_OMP_TARGET_PARALLEL
:
11768 case EXEC_OMP_TARGET_PARALLEL_DO
:
11769 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11770 case EXEC_OMP_TARGET_SIMD
:
11771 case EXEC_OMP_TARGET_TEAMS
:
11772 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11773 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11774 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11775 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11776 case EXEC_OMP_TARGET_UPDATE
:
11777 case EXEC_OMP_TASK
:
11778 case EXEC_OMP_TASKGROUP
:
11779 case EXEC_OMP_TASKLOOP
:
11780 case EXEC_OMP_TASKLOOP_SIMD
:
11781 case EXEC_OMP_TASKWAIT
:
11782 case EXEC_OMP_TASKYIELD
:
11783 case EXEC_OMP_TEAMS
:
11784 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11785 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11786 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11787 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11788 case EXEC_OMP_WORKSHARE
:
11789 gfc_resolve_omp_directive (code
, ns
);
11792 case EXEC_OMP_PARALLEL
:
11793 case EXEC_OMP_PARALLEL_DO
:
11794 case EXEC_OMP_PARALLEL_DO_SIMD
:
11795 case EXEC_OMP_PARALLEL_SECTIONS
:
11796 case EXEC_OMP_PARALLEL_WORKSHARE
:
11797 omp_workshare_save
= omp_workshare_flag
;
11798 omp_workshare_flag
= 0;
11799 gfc_resolve_omp_directive (code
, ns
);
11800 omp_workshare_flag
= omp_workshare_save
;
11804 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11808 cs_base
= frame
.prev
;
11812 /* Resolve initial values and make sure they are compatible with
11816 resolve_values (gfc_symbol
*sym
)
11820 if (sym
->value
== NULL
)
11823 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11824 t
= resolve_structure_cons (sym
->value
, 1);
11826 t
= gfc_resolve_expr (sym
->value
);
11831 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11835 /* Verify any BIND(C) derived types in the namespace so we can report errors
11836 for them once, rather than for each variable declared of that type. */
11839 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11841 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11842 && derived_sym
->attr
.is_bind_c
== 1)
11843 verify_bind_c_derived_type (derived_sym
);
11849 /* Check the interfaces of DTIO procedures associated with derived
11850 type 'sym'. These procedures can either have typebound bindings or
11851 can appear in DTIO generic interfaces. */
11854 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11856 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11859 gfc_check_dtio_interfaces (sym
);
11864 /* Verify that any binding labels used in a given namespace do not collide
11865 with the names or binding labels of any global symbols. Multiple INTERFACE
11866 for the same procedure are permitted. */
11869 gfc_verify_binding_labels (gfc_symbol
*sym
)
11872 const char *module
;
11874 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11875 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11878 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11881 module
= sym
->module
;
11882 else if (sym
->ns
&& sym
->ns
->proc_name
11883 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11884 module
= sym
->ns
->proc_name
->name
;
11885 else if (sym
->ns
&& sym
->ns
->parent
11886 && sym
->ns
&& sym
->ns
->parent
->proc_name
11887 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11888 module
= sym
->ns
->parent
->proc_name
->name
;
11894 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11897 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
11898 gsym
->where
= sym
->declared_at
;
11899 gsym
->sym_name
= sym
->name
;
11900 gsym
->binding_label
= sym
->binding_label
;
11901 gsym
->ns
= sym
->ns
;
11902 gsym
->mod_name
= module
;
11903 if (sym
->attr
.function
)
11904 gsym
->type
= GSYM_FUNCTION
;
11905 else if (sym
->attr
.subroutine
)
11906 gsym
->type
= GSYM_SUBROUTINE
;
11907 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11908 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11912 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11914 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
11915 "identifier as entity at %L", sym
->name
,
11916 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11917 /* Clear the binding label to prevent checking multiple times. */
11918 sym
->binding_label
= NULL
;
11922 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11923 && (strcmp (module
, gsym
->mod_name
) != 0
11924 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11926 /* This can only happen if the variable is defined in a module - if it
11927 isn't the same module, reject it. */
11928 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
11929 "uses the same global identifier as entity at %L from module %qs",
11930 sym
->name
, module
, sym
->binding_label
,
11931 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11932 sym
->binding_label
= NULL
;
11936 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11937 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11938 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11939 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
11940 && (module
!= gsym
->mod_name
11941 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11942 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11944 /* Print an error if the procedure is defined multiple times; we have to
11945 exclude references to the same procedure via module association or
11946 multiple checks for the same procedure. */
11947 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
11948 "global identifier as entity at %L", sym
->name
,
11949 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11950 sym
->binding_label
= NULL
;
11955 /* Resolve an index expression. */
11958 resolve_index_expr (gfc_expr
*e
)
11960 if (!gfc_resolve_expr (e
))
11963 if (!gfc_simplify_expr (e
, 0))
11966 if (!gfc_specification_expr (e
))
11973 /* Resolve a charlen structure. */
11976 resolve_charlen (gfc_charlen
*cl
)
11979 bool saved_specification_expr
;
11985 saved_specification_expr
= specification_expr
;
11986 specification_expr
= true;
11988 if (cl
->length_from_typespec
)
11990 if (!gfc_resolve_expr (cl
->length
))
11992 specification_expr
= saved_specification_expr
;
11996 if (!gfc_simplify_expr (cl
->length
, 0))
11998 specification_expr
= saved_specification_expr
;
12002 /* cl->length has been resolved. It should have an integer type. */
12003 if (cl
->length
->ts
.type
!= BT_INTEGER
)
12005 gfc_error ("Scalar INTEGER expression expected at %L",
12006 &cl
->length
->where
);
12012 if (!resolve_index_expr (cl
->length
))
12014 specification_expr
= saved_specification_expr
;
12019 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12020 a negative value, the length of character entities declared is zero. */
12021 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12022 && mpz_sgn (cl
->length
->value
.integer
) < 0)
12023 gfc_replace_expr (cl
->length
,
12024 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
12026 /* Check that the character length is not too large. */
12027 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
12028 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12029 && cl
->length
->ts
.type
== BT_INTEGER
12030 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
12032 gfc_error ("String length at %L is too large", &cl
->length
->where
);
12033 specification_expr
= saved_specification_expr
;
12037 specification_expr
= saved_specification_expr
;
12042 /* Test for non-constant shape arrays. */
12045 is_non_constant_shape_array (gfc_symbol
*sym
)
12051 not_constant
= false;
12052 if (sym
->as
!= NULL
)
12054 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12055 has not been simplified; parameter array references. Do the
12056 simplification now. */
12057 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12059 e
= sym
->as
->lower
[i
];
12060 if (e
&& (!resolve_index_expr(e
)
12061 || !gfc_is_constant_expr (e
)))
12062 not_constant
= true;
12063 e
= sym
->as
->upper
[i
];
12064 if (e
&& (!resolve_index_expr(e
)
12065 || !gfc_is_constant_expr (e
)))
12066 not_constant
= true;
12069 return not_constant
;
12072 /* Given a symbol and an initialization expression, add code to initialize
12073 the symbol to the function entry. */
12075 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12079 gfc_namespace
*ns
= sym
->ns
;
12081 /* Search for the function namespace if this is a contained
12082 function without an explicit result. */
12083 if (sym
->attr
.function
&& sym
== sym
->result
12084 && sym
->name
!= sym
->ns
->proc_name
->name
)
12086 ns
= ns
->contained
;
12087 for (;ns
; ns
= ns
->sibling
)
12088 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12094 gfc_free_expr (init
);
12098 /* Build an l-value expression for the result. */
12099 lval
= gfc_lval_expr_from_sym (sym
);
12101 /* Add the code at scope entry. */
12102 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
12103 init_st
->next
= ns
->code
;
12104 ns
->code
= init_st
;
12106 /* Assign the default initializer to the l-value. */
12107 init_st
->loc
= sym
->declared_at
;
12108 init_st
->expr1
= lval
;
12109 init_st
->expr2
= init
;
12113 /* Whether or not we can generate a default initializer for a symbol. */
12116 can_generate_init (gfc_symbol
*sym
)
12118 symbol_attribute
*a
;
12123 /* These symbols should never have a default initialization. */
12128 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
12129 && (CLASS_DATA (sym
)->attr
.class_pointer
12130 || CLASS_DATA (sym
)->attr
.proc_pointer
))
12131 || a
->in_equivalence
12138 || (!a
->referenced
&& !a
->result
)
12139 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
12140 || (a
->function
&& sym
!= sym
->result
)
12145 /* Assign the default initializer to a derived type variable or result. */
12148 apply_default_init (gfc_symbol
*sym
)
12150 gfc_expr
*init
= NULL
;
12152 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12155 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12156 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12158 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12161 build_init_assign (sym
, init
);
12162 sym
->attr
.referenced
= 1;
12166 /* Build an initializer for a local. Returns null if the symbol should not have
12167 a default initialization. */
12170 build_default_init_expr (gfc_symbol
*sym
)
12172 /* These symbols should never have a default initialization. */
12173 if (sym
->attr
.allocatable
12174 || sym
->attr
.external
12176 || sym
->attr
.pointer
12177 || sym
->attr
.in_equivalence
12178 || sym
->attr
.in_common
12181 || sym
->attr
.cray_pointee
12182 || sym
->attr
.cray_pointer
12186 /* Get the appropriate init expression. */
12187 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12190 /* Add an initialization expression to a local variable. */
12192 apply_default_init_local (gfc_symbol
*sym
)
12194 gfc_expr
*init
= NULL
;
12196 /* The symbol should be a variable or a function return value. */
12197 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12198 || (sym
->attr
.function
&& sym
->result
!= sym
))
12201 /* Try to build the initializer expression. If we can't initialize
12202 this symbol, then init will be NULL. */
12203 init
= build_default_init_expr (sym
);
12207 /* For saved variables, we don't want to add an initializer at function
12208 entry, so we just add a static initializer. Note that automatic variables
12209 are stack allocated even with -fno-automatic; we have also to exclude
12210 result variable, which are also nonstatic. */
12211 if (!sym
->attr
.automatic
12212 && (sym
->attr
.save
|| sym
->ns
->save_all
12213 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12214 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12215 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12217 /* Don't clobber an existing initializer! */
12218 gcc_assert (sym
->value
== NULL
);
12223 build_init_assign (sym
, init
);
12227 /* Resolution of common features of flavors variable and procedure. */
12230 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12232 gfc_array_spec
*as
;
12234 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12235 as
= CLASS_DATA (sym
)->as
;
12239 /* Constraints on deferred shape variable. */
12240 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12242 bool pointer
, allocatable
, dimension
;
12244 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12246 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12247 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12248 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12252 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12253 allocatable
= sym
->attr
.allocatable
;
12254 dimension
= sym
->attr
.dimension
;
12259 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12261 gfc_error ("Allocatable array %qs at %L must have a deferred "
12262 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12265 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12266 "%qs at %L may not be ALLOCATABLE",
12267 sym
->name
, &sym
->declared_at
))
12271 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12273 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12274 "assumed rank", sym
->name
, &sym
->declared_at
);
12280 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12281 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12283 gfc_error ("Array %qs at %L cannot have a deferred shape",
12284 sym
->name
, &sym
->declared_at
);
12289 /* Constraints on polymorphic variables. */
12290 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12293 if (sym
->attr
.class_ok
12294 && !sym
->attr
.select_type_temporary
12295 && !UNLIMITED_POLY (sym
)
12296 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12298 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12299 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12300 &sym
->declared_at
);
12305 /* Assume that use associated symbols were checked in the module ns.
12306 Class-variables that are associate-names are also something special
12307 and excepted from the test. */
12308 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12310 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12311 "or pointer", sym
->name
, &sym
->declared_at
);
12320 /* Additional checks for symbols with flavor variable and derived
12321 type. To be called from resolve_fl_variable. */
12324 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12326 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12328 /* Check to see if a derived type is blocked from being host
12329 associated by the presence of another class I symbol in the same
12330 namespace. 14.6.1.3 of the standard and the discussion on
12331 comp.lang.fortran. */
12332 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12333 && !sym
->ts
.u
.derived
->attr
.use_assoc
12334 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12337 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12338 if (s
&& s
->attr
.generic
)
12339 s
= gfc_find_dt_in_generic (s
);
12340 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12342 gfc_error ("The type %qs cannot be host associated at %L "
12343 "because it is blocked by an incompatible object "
12344 "of the same name declared at %L",
12345 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12351 /* 4th constraint in section 11.3: "If an object of a type for which
12352 component-initialization is specified (R429) appears in the
12353 specification-part of a module and does not have the ALLOCATABLE
12354 or POINTER attribute, the object shall have the SAVE attribute."
12356 The check for initializers is performed with
12357 gfc_has_default_initializer because gfc_default_initializer generates
12358 a hidden default for allocatable components. */
12359 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12360 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12361 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12362 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12363 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12364 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12365 "%qs at %L, needed due to the default "
12366 "initialization", sym
->name
, &sym
->declared_at
))
12369 /* Assign default initializer. */
12370 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12371 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12372 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12378 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12379 except in the declaration of an entity or component that has the POINTER
12380 or ALLOCATABLE attribute. */
12383 deferred_requirements (gfc_symbol
*sym
)
12385 if (sym
->ts
.deferred
12386 && !(sym
->attr
.pointer
12387 || sym
->attr
.allocatable
12388 || sym
->attr
.associate_var
12389 || sym
->attr
.omp_udr_artificial_var
))
12391 /* If a function has a result variable, only check the variable. */
12392 if (sym
->result
&& sym
->name
!= sym
->result
->name
)
12395 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12396 "requires either the POINTER or ALLOCATABLE attribute",
12397 sym
->name
, &sym
->declared_at
);
12404 /* Resolve symbols with flavor variable. */
12407 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12409 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
12412 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12415 /* Set this flag to check that variables are parameters of all entries.
12416 This check is effected by the call to gfc_resolve_expr through
12417 is_non_constant_shape_array. */
12418 bool saved_specification_expr
= specification_expr
;
12419 specification_expr
= true;
12421 if (sym
->ns
->proc_name
12422 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12423 || sym
->ns
->proc_name
->attr
.is_main_program
)
12424 && !sym
->attr
.use_assoc
12425 && !sym
->attr
.allocatable
12426 && !sym
->attr
.pointer
12427 && is_non_constant_shape_array (sym
))
12429 /* F08:C541. The shape of an array defined in a main program or module
12430 * needs to be constant. */
12431 gfc_error ("The module or main program array %qs at %L must "
12432 "have constant shape", sym
->name
, &sym
->declared_at
);
12433 specification_expr
= saved_specification_expr
;
12437 /* Constraints on deferred type parameter. */
12438 if (!deferred_requirements (sym
))
12441 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12443 /* Make sure that character string variables with assumed length are
12444 dummy arguments. */
12445 gfc_expr
*e
= NULL
;
12448 e
= sym
->ts
.u
.cl
->length
;
12452 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12453 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12454 && !sym
->attr
.omp_udr_artificial_var
)
12456 gfc_error ("Entity with assumed character length at %L must be a "
12457 "dummy argument or a PARAMETER", &sym
->declared_at
);
12458 specification_expr
= saved_specification_expr
;
12462 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12464 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12465 specification_expr
= saved_specification_expr
;
12469 if (!gfc_is_constant_expr (e
)
12470 && !(e
->expr_type
== EXPR_VARIABLE
12471 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12473 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12474 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12475 || sym
->ns
->proc_name
->attr
.is_main_program
))
12477 gfc_error ("%qs at %L must have constant character length "
12478 "in this context", sym
->name
, &sym
->declared_at
);
12479 specification_expr
= saved_specification_expr
;
12482 if (sym
->attr
.in_common
)
12484 gfc_error ("COMMON variable %qs at %L must have constant "
12485 "character length", sym
->name
, &sym
->declared_at
);
12486 specification_expr
= saved_specification_expr
;
12492 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12493 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12495 /* Determine if the symbol may not have an initializer. */
12496 int no_init_flag
= 0, automatic_flag
= 0;
12497 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12498 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12500 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12501 && is_non_constant_shape_array (sym
))
12503 no_init_flag
= automatic_flag
= 1;
12505 /* Also, they must not have the SAVE attribute.
12506 SAVE_IMPLICIT is checked below. */
12507 if (sym
->as
&& sym
->attr
.codimension
)
12509 int corank
= sym
->as
->corank
;
12510 sym
->as
->corank
= 0;
12511 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12512 sym
->as
->corank
= corank
;
12514 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12516 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12517 specification_expr
= saved_specification_expr
;
12522 /* Ensure that any initializer is simplified. */
12524 gfc_simplify_expr (sym
->value
, 1);
12526 /* Reject illegal initializers. */
12527 if (!sym
->mark
&& sym
->value
)
12529 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12530 && CLASS_DATA (sym
)->attr
.allocatable
))
12531 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12532 sym
->name
, &sym
->declared_at
);
12533 else if (sym
->attr
.external
)
12534 gfc_error ("External %qs at %L cannot have an initializer",
12535 sym
->name
, &sym
->declared_at
);
12536 else if (sym
->attr
.dummy
12537 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12538 gfc_error ("Dummy %qs at %L cannot have an initializer",
12539 sym
->name
, &sym
->declared_at
);
12540 else if (sym
->attr
.intrinsic
)
12541 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12542 sym
->name
, &sym
->declared_at
);
12543 else if (sym
->attr
.result
)
12544 gfc_error ("Function result %qs at %L cannot have an initializer",
12545 sym
->name
, &sym
->declared_at
);
12546 else if (automatic_flag
)
12547 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12548 sym
->name
, &sym
->declared_at
);
12550 goto no_init_error
;
12551 specification_expr
= saved_specification_expr
;
12556 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12558 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12559 specification_expr
= saved_specification_expr
;
12563 specification_expr
= saved_specification_expr
;
12568 /* Compare the dummy characteristics of a module procedure interface
12569 declaration with the corresponding declaration in a submodule. */
12570 static gfc_formal_arglist
*new_formal
;
12571 static char errmsg
[200];
12574 compare_fsyms (gfc_symbol
*sym
)
12578 if (sym
== NULL
|| new_formal
== NULL
)
12581 fsym
= new_formal
->sym
;
12586 if (strcmp (sym
->name
, fsym
->name
) == 0)
12588 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12589 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12594 /* Resolve a procedure. */
12597 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12599 gfc_formal_arglist
*arg
;
12601 if (sym
->attr
.function
12602 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12605 /* Constraints on deferred type parameter. */
12606 if (!deferred_requirements (sym
))
12609 if (sym
->ts
.type
== BT_CHARACTER
)
12611 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12613 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12614 && !resolve_charlen (cl
))
12617 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12618 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12620 gfc_error ("Character-valued statement function %qs at %L must "
12621 "have constant length", sym
->name
, &sym
->declared_at
);
12626 /* Ensure that derived type for are not of a private type. Internal
12627 module procedures are excluded by 2.2.3.3 - i.e., they are not
12628 externally accessible and can access all the objects accessible in
12630 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
12631 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12632 && gfc_check_symbol_access (sym
))
12634 gfc_interface
*iface
;
12636 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12639 && arg
->sym
->ts
.type
== BT_DERIVED
12640 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12641 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12642 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12643 "and cannot be a dummy argument"
12644 " of %qs, which is PUBLIC at %L",
12645 arg
->sym
->name
, sym
->name
,
12646 &sym
->declared_at
))
12648 /* Stop this message from recurring. */
12649 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12654 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12655 PRIVATE to the containing module. */
12656 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12658 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12661 && arg
->sym
->ts
.type
== BT_DERIVED
12662 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12663 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12664 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12665 "PUBLIC interface %qs at %L "
12666 "takes dummy arguments of %qs which "
12667 "is PRIVATE", iface
->sym
->name
,
12668 sym
->name
, &iface
->sym
->declared_at
,
12669 gfc_typename(&arg
->sym
->ts
)))
12671 /* Stop this message from recurring. */
12672 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12679 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12680 && !sym
->attr
.proc_pointer
)
12682 gfc_error ("Function %qs at %L cannot have an initializer",
12683 sym
->name
, &sym
->declared_at
);
12685 /* Make sure no second error is issued for this. */
12686 sym
->value
->error
= 1;
12690 /* An external symbol may not have an initializer because it is taken to be
12691 a procedure. Exception: Procedure Pointers. */
12692 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12694 gfc_error ("External object %qs at %L may not have an initializer",
12695 sym
->name
, &sym
->declared_at
);
12699 /* An elemental function is required to return a scalar 12.7.1 */
12700 if (sym
->attr
.elemental
&& sym
->attr
.function
12701 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)))
12703 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12704 "result", sym
->name
, &sym
->declared_at
);
12705 /* Reset so that the error only occurs once. */
12706 sym
->attr
.elemental
= 0;
12710 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12711 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12713 gfc_error ("Statement function %qs at %L may not have pointer or "
12714 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12718 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12719 char-len-param shall not be array-valued, pointer-valued, recursive
12720 or pure. ....snip... A character value of * may only be used in the
12721 following ways: (i) Dummy arg of procedure - dummy associates with
12722 actual length; (ii) To declare a named constant; or (iii) External
12723 function - but length must be declared in calling scoping unit. */
12724 if (sym
->attr
.function
12725 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12726 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12728 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12729 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12731 if (sym
->as
&& sym
->as
->rank
)
12732 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12733 "array-valued", sym
->name
, &sym
->declared_at
);
12735 if (sym
->attr
.pointer
)
12736 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12737 "pointer-valued", sym
->name
, &sym
->declared_at
);
12739 if (sym
->attr
.pure
)
12740 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12741 "pure", sym
->name
, &sym
->declared_at
);
12743 if (sym
->attr
.recursive
)
12744 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12745 "recursive", sym
->name
, &sym
->declared_at
);
12750 /* Appendix B.2 of the standard. Contained functions give an
12751 error anyway. Deferred character length is an F2003 feature.
12752 Don't warn on intrinsic conversion functions, which start
12753 with two underscores. */
12754 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12755 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12756 gfc_notify_std (GFC_STD_F95_OBS
,
12757 "CHARACTER(*) function %qs at %L",
12758 sym
->name
, &sym
->declared_at
);
12761 /* F2008, C1218. */
12762 if (sym
->attr
.elemental
)
12764 if (sym
->attr
.proc_pointer
)
12766 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12767 sym
->name
, &sym
->declared_at
);
12770 if (sym
->attr
.dummy
)
12772 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12773 sym
->name
, &sym
->declared_at
);
12778 /* F2018, C15100: "The result of an elemental function shall be scalar,
12779 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
12780 pointer is tested and caught elsewhere. */
12781 if (sym
->attr
.elemental
&& sym
->result
12782 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
12784 gfc_error ("Function result variable %qs at %L of elemental "
12785 "function %qs shall not have an ALLOCATABLE or POINTER "
12786 "attribute", sym
->result
->name
,
12787 &sym
->result
->declared_at
, sym
->name
);
12791 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12793 gfc_formal_arglist
*curr_arg
;
12794 int has_non_interop_arg
= 0;
12796 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12797 sym
->common_block
))
12799 /* Clear these to prevent looking at them again if there was an
12801 sym
->attr
.is_bind_c
= 0;
12802 sym
->attr
.is_c_interop
= 0;
12803 sym
->ts
.is_c_interop
= 0;
12807 /* So far, no errors have been found. */
12808 sym
->attr
.is_c_interop
= 1;
12809 sym
->ts
.is_c_interop
= 1;
12812 curr_arg
= gfc_sym_get_dummy_args (sym
);
12813 while (curr_arg
!= NULL
)
12815 /* Skip implicitly typed dummy args here. */
12816 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
12817 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12818 /* If something is found to fail, record the fact so we
12819 can mark the symbol for the procedure as not being
12820 BIND(C) to try and prevent multiple errors being
12822 has_non_interop_arg
= 1;
12824 curr_arg
= curr_arg
->next
;
12827 /* See if any of the arguments were not interoperable and if so, clear
12828 the procedure symbol to prevent duplicate error messages. */
12829 if (has_non_interop_arg
!= 0)
12831 sym
->attr
.is_c_interop
= 0;
12832 sym
->ts
.is_c_interop
= 0;
12833 sym
->attr
.is_bind_c
= 0;
12837 if (!sym
->attr
.proc_pointer
)
12839 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12841 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12842 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12845 if (sym
->attr
.intent
)
12847 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12848 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12851 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12853 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12854 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12857 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12858 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12859 || sym
->attr
.contained
))
12861 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12862 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12865 if (strcmp ("ppr@", sym
->name
) == 0)
12867 gfc_error ("Procedure pointer result %qs at %L "
12868 "is missing the pointer attribute",
12869 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12874 /* Assume that a procedure whose body is not known has references
12875 to external arrays. */
12876 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12877 sym
->attr
.array_outer_dependency
= 1;
12879 /* Compare the characteristics of a module procedure with the
12880 interface declaration. Ideally this would be done with
12881 gfc_compare_interfaces but, at present, the formal interface
12882 cannot be copied to the ts.interface. */
12883 if (sym
->attr
.module_procedure
12884 && sym
->attr
.if_source
== IFSRC_DECL
)
12887 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12889 char *submodule_name
;
12890 strcpy (name
, sym
->ns
->proc_name
->name
);
12891 module_name
= strtok (name
, ".");
12892 submodule_name
= strtok (NULL
, ".");
12894 iface
= sym
->tlink
;
12897 /* Make sure that the result uses the correct charlen for deferred
12899 if (iface
&& sym
->result
12900 && iface
->ts
.type
== BT_CHARACTER
12901 && iface
->ts
.deferred
)
12902 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12907 /* Check the procedure characteristics. */
12908 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12910 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12911 "PROCEDURE at %L and its interface in %s",
12912 &sym
->declared_at
, module_name
);
12916 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12918 gfc_error ("Mismatch in PURE attribute between MODULE "
12919 "PROCEDURE at %L and its interface in %s",
12920 &sym
->declared_at
, module_name
);
12924 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12926 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12927 "PROCEDURE at %L and its interface in %s",
12928 &sym
->declared_at
, module_name
);
12932 /* Check the result characteristics. */
12933 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12935 gfc_error ("%s between the MODULE PROCEDURE declaration "
12936 "in MODULE %qs and the declaration at %L in "
12938 errmsg
, module_name
, &sym
->declared_at
,
12939 submodule_name
? submodule_name
: module_name
);
12944 /* Check the characteristics of the formal arguments. */
12945 if (sym
->formal
&& sym
->formal_ns
)
12947 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12950 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12958 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12959 been defined and we now know their defined arguments, check that they fulfill
12960 the requirements of the standard for procedures used as finalizers. */
12963 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12965 gfc_finalizer
* list
;
12966 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12967 bool result
= true;
12968 bool seen_scalar
= false;
12971 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12974 gfc_resolve_finalizers (parent
, finalizable
);
12976 /* Ensure that derived-type components have a their finalizers resolved. */
12977 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
12978 for (c
= derived
->components
; c
; c
= c
->next
)
12979 if (c
->ts
.type
== BT_DERIVED
12980 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12982 bool has_final2
= false;
12983 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
12984 return false; /* Error. */
12985 has_final
= has_final
|| has_final2
;
12987 /* Return early if not finalizable. */
12991 *finalizable
= false;
12995 /* Walk over the list of finalizer-procedures, check them, and if any one
12996 does not fit in with the standard's definition, print an error and remove
12997 it from the list. */
12998 prev_link
= &derived
->f2k_derived
->finalizers
;
12999 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
13001 gfc_formal_arglist
*dummy_args
;
13006 /* Skip this finalizer if we already resolved it. */
13007 if (list
->proc_tree
)
13009 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
13010 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
13011 seen_scalar
= true;
13012 prev_link
= &(list
->next
);
13016 /* Check this exists and is a SUBROUTINE. */
13017 if (!list
->proc_sym
->attr
.subroutine
)
13019 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
13020 list
->proc_sym
->name
, &list
->where
);
13024 /* We should have exactly one argument. */
13025 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
13026 if (!dummy_args
|| dummy_args
->next
)
13028 gfc_error ("FINAL procedure at %L must have exactly one argument",
13032 arg
= dummy_args
->sym
;
13034 /* This argument must be of our type. */
13035 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
13037 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
13038 &arg
->declared_at
, derived
->name
);
13042 /* It must neither be a pointer nor allocatable nor optional. */
13043 if (arg
->attr
.pointer
)
13045 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13046 &arg
->declared_at
);
13049 if (arg
->attr
.allocatable
)
13051 gfc_error ("Argument of FINAL procedure at %L must not be"
13052 " ALLOCATABLE", &arg
->declared_at
);
13055 if (arg
->attr
.optional
)
13057 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13058 &arg
->declared_at
);
13062 /* It must not be INTENT(OUT). */
13063 if (arg
->attr
.intent
== INTENT_OUT
)
13065 gfc_error ("Argument of FINAL procedure at %L must not be"
13066 " INTENT(OUT)", &arg
->declared_at
);
13070 /* Warn if the procedure is non-scalar and not assumed shape. */
13071 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
13072 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
13073 gfc_warning (OPT_Wsurprising
,
13074 "Non-scalar FINAL procedure at %L should have assumed"
13075 " shape argument", &arg
->declared_at
);
13077 /* Check that it does not match in kind and rank with a FINAL procedure
13078 defined earlier. To really loop over the *earlier* declarations,
13079 we need to walk the tail of the list as new ones were pushed at the
13081 /* TODO: Handle kind parameters once they are implemented. */
13082 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
13083 for (i
= list
->next
; i
; i
= i
->next
)
13085 gfc_formal_arglist
*dummy_args
;
13087 /* Argument list might be empty; that is an error signalled earlier,
13088 but we nevertheless continued resolving. */
13089 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
13092 gfc_symbol
* i_arg
= dummy_args
->sym
;
13093 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
13094 if (i_rank
== my_rank
)
13096 gfc_error ("FINAL procedure %qs declared at %L has the same"
13097 " rank (%d) as %qs",
13098 list
->proc_sym
->name
, &list
->where
, my_rank
,
13099 i
->proc_sym
->name
);
13105 /* Is this the/a scalar finalizer procedure? */
13107 seen_scalar
= true;
13109 /* Find the symtree for this procedure. */
13110 gcc_assert (!list
->proc_tree
);
13111 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
13113 prev_link
= &list
->next
;
13116 /* Remove wrong nodes immediately from the list so we don't risk any
13117 troubles in the future when they might fail later expectations. */
13120 *prev_link
= list
->next
;
13121 gfc_free_finalizer (i
);
13125 if (result
== false)
13128 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13129 were nodes in the list, must have been for arrays. It is surely a good
13130 idea to have a scalar version there if there's something to finalize. */
13131 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
13132 gfc_warning (OPT_Wsurprising
,
13133 "Only array FINAL procedures declared for derived type %qs"
13134 " defined at %L, suggest also scalar one",
13135 derived
->name
, &derived
->declared_at
);
13137 vtab
= gfc_find_derived_vtab (derived
);
13138 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
13139 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
13142 *finalizable
= true;
13148 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13151 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13152 const char* generic_name
, locus where
)
13154 gfc_symbol
*sym1
, *sym2
;
13155 const char *pass1
, *pass2
;
13156 gfc_formal_arglist
*dummy_args
;
13158 gcc_assert (t1
->specific
&& t2
->specific
);
13159 gcc_assert (!t1
->specific
->is_generic
);
13160 gcc_assert (!t2
->specific
->is_generic
);
13161 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13163 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13164 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13169 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13170 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13171 || sym1
->attr
.function
!= sym2
->attr
.function
)
13173 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
13174 " GENERIC %qs at %L",
13175 sym1
->name
, sym2
->name
, generic_name
, &where
);
13179 /* Determine PASS arguments. */
13180 if (t1
->specific
->nopass
)
13182 else if (t1
->specific
->pass_arg
)
13183 pass1
= t1
->specific
->pass_arg
;
13186 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13188 pass1
= dummy_args
->sym
->name
;
13192 if (t2
->specific
->nopass
)
13194 else if (t2
->specific
->pass_arg
)
13195 pass2
= t2
->specific
->pass_arg
;
13198 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13200 pass2
= dummy_args
->sym
->name
;
13205 /* Compare the interfaces. */
13206 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13207 NULL
, 0, pass1
, pass2
))
13209 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13210 sym1
->name
, sym2
->name
, generic_name
, &where
);
13218 /* Worker function for resolving a generic procedure binding; this is used to
13219 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13221 The difference between those cases is finding possible inherited bindings
13222 that are overridden, as one has to look for them in tb_sym_root,
13223 tb_uop_root or tb_op, respectively. Thus the caller must already find
13224 the super-type and set p->overridden correctly. */
13227 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13228 gfc_typebound_proc
* p
, const char* name
)
13230 gfc_tbp_generic
* target
;
13231 gfc_symtree
* first_target
;
13232 gfc_symtree
* inherited
;
13234 gcc_assert (p
&& p
->is_generic
);
13236 /* Try to find the specific bindings for the symtrees in our target-list. */
13237 gcc_assert (p
->u
.generic
);
13238 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13239 if (!target
->specific
)
13241 gfc_typebound_proc
* overridden_tbp
;
13242 gfc_tbp_generic
* g
;
13243 const char* target_name
;
13245 target_name
= target
->specific_st
->name
;
13247 /* Defined for this type directly. */
13248 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13250 target
->specific
= target
->specific_st
->n
.tb
;
13251 goto specific_found
;
13254 /* Look for an inherited specific binding. */
13257 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13262 gcc_assert (inherited
->n
.tb
);
13263 target
->specific
= inherited
->n
.tb
;
13264 goto specific_found
;
13268 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13269 " at %L", target_name
, name
, &p
->where
);
13272 /* Once we've found the specific binding, check it is not ambiguous with
13273 other specifics already found or inherited for the same GENERIC. */
13275 gcc_assert (target
->specific
);
13277 /* This must really be a specific binding! */
13278 if (target
->specific
->is_generic
)
13280 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13281 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13285 /* Check those already resolved on this type directly. */
13286 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13287 if (g
!= target
&& g
->specific
13288 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13291 /* Check for ambiguity with inherited specific targets. */
13292 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13293 overridden_tbp
= overridden_tbp
->overridden
)
13294 if (overridden_tbp
->is_generic
)
13296 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13298 gcc_assert (g
->specific
);
13299 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13305 /* If we attempt to "overwrite" a specific binding, this is an error. */
13306 if (p
->overridden
&& !p
->overridden
->is_generic
)
13308 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
13309 " the same name", name
, &p
->where
);
13313 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13314 all must have the same attributes here. */
13315 first_target
= p
->u
.generic
->specific
->u
.specific
;
13316 gcc_assert (first_target
);
13317 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13318 p
->function
= first_target
->n
.sym
->attr
.function
;
13324 /* Resolve a GENERIC procedure binding for a derived type. */
13327 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13329 gfc_symbol
* super_type
;
13331 /* Find the overridden binding if any. */
13332 st
->n
.tb
->overridden
= NULL
;
13333 super_type
= gfc_get_derived_super_type (derived
);
13336 gfc_symtree
* overridden
;
13337 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13340 if (overridden
&& overridden
->n
.tb
)
13341 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13344 /* Resolve using worker function. */
13345 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13349 /* Retrieve the target-procedure of an operator binding and do some checks in
13350 common for intrinsic and user-defined type-bound operators. */
13353 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13355 gfc_symbol
* target_proc
;
13357 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13358 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13359 gcc_assert (target_proc
);
13361 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13362 if (target
->specific
->nopass
)
13364 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
13368 return target_proc
;
13372 /* Resolve a type-bound intrinsic operator. */
13375 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13376 gfc_typebound_proc
* p
)
13378 gfc_symbol
* super_type
;
13379 gfc_tbp_generic
* target
;
13381 /* If there's already an error here, do nothing (but don't fail again). */
13385 /* Operators should always be GENERIC bindings. */
13386 gcc_assert (p
->is_generic
);
13388 /* Look for an overridden binding. */
13389 super_type
= gfc_get_derived_super_type (derived
);
13390 if (super_type
&& super_type
->f2k_derived
)
13391 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13394 p
->overridden
= NULL
;
13396 /* Resolve general GENERIC properties using worker function. */
13397 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13400 /* Check the targets to be procedures of correct interface. */
13401 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13403 gfc_symbol
* target_proc
;
13405 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13409 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13412 /* Add target to non-typebound operator list. */
13413 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13414 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13416 gfc_interface
*head
, *intr
;
13418 /* Preempt 'gfc_check_new_interface' for submodules, where the
13419 mechanism for handling module procedures winds up resolving
13420 operator interfaces twice and would otherwise cause an error. */
13421 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13422 if (intr
->sym
== target_proc
13423 && target_proc
->attr
.used_in_submodule
)
13426 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13427 target_proc
, p
->where
))
13429 head
= derived
->ns
->op
[op
];
13430 intr
= gfc_get_interface ();
13431 intr
->sym
= target_proc
;
13432 intr
->where
= p
->where
;
13434 derived
->ns
->op
[op
] = intr
;
13446 /* Resolve a type-bound user operator (tree-walker callback). */
13448 static gfc_symbol
* resolve_bindings_derived
;
13449 static bool resolve_bindings_result
;
13451 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13454 resolve_typebound_user_op (gfc_symtree
* stree
)
13456 gfc_symbol
* super_type
;
13457 gfc_tbp_generic
* target
;
13459 gcc_assert (stree
&& stree
->n
.tb
);
13461 if (stree
->n
.tb
->error
)
13464 /* Operators should always be GENERIC bindings. */
13465 gcc_assert (stree
->n
.tb
->is_generic
);
13467 /* Find overridden procedure, if any. */
13468 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13469 if (super_type
&& super_type
->f2k_derived
)
13471 gfc_symtree
* overridden
;
13472 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13473 stree
->name
, true, NULL
);
13475 if (overridden
&& overridden
->n
.tb
)
13476 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13479 stree
->n
.tb
->overridden
= NULL
;
13481 /* Resolve basically using worker function. */
13482 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13485 /* Check the targets to be functions of correct interface. */
13486 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13488 gfc_symbol
* target_proc
;
13490 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13494 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13501 resolve_bindings_result
= false;
13502 stree
->n
.tb
->error
= 1;
13506 /* Resolve the type-bound procedures for a derived type. */
13509 resolve_typebound_procedure (gfc_symtree
* stree
)
13513 gfc_symbol
* me_arg
;
13514 gfc_symbol
* super_type
;
13515 gfc_component
* comp
;
13517 gcc_assert (stree
);
13519 /* Undefined specific symbol from GENERIC target definition. */
13523 if (stree
->n
.tb
->error
)
13526 /* If this is a GENERIC binding, use that routine. */
13527 if (stree
->n
.tb
->is_generic
)
13529 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13534 /* Get the target-procedure to check it. */
13535 gcc_assert (!stree
->n
.tb
->is_generic
);
13536 gcc_assert (stree
->n
.tb
->u
.specific
);
13537 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13538 where
= stree
->n
.tb
->where
;
13540 /* Default access should already be resolved from the parser. */
13541 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13543 if (stree
->n
.tb
->deferred
)
13545 if (!check_proc_interface (proc
, &where
))
13550 /* Check for F08:C465. */
13551 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13552 || (proc
->attr
.proc
!= PROC_MODULE
13553 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13554 || proc
->attr
.abstract
)
13556 gfc_error ("%qs must be a module procedure or an external procedure with"
13557 " an explicit interface at %L", proc
->name
, &where
);
13562 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13563 stree
->n
.tb
->function
= proc
->attr
.function
;
13565 /* Find the super-type of the current derived type. We could do this once and
13566 store in a global if speed is needed, but as long as not I believe this is
13567 more readable and clearer. */
13568 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13570 /* If PASS, resolve and check arguments if not already resolved / loaded
13571 from a .mod file. */
13572 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13574 gfc_formal_arglist
*dummy_args
;
13576 dummy_args
= gfc_sym_get_dummy_args (proc
);
13577 if (stree
->n
.tb
->pass_arg
)
13579 gfc_formal_arglist
*i
;
13581 /* If an explicit passing argument name is given, walk the arg-list
13582 and look for it. */
13585 stree
->n
.tb
->pass_arg_num
= 1;
13586 for (i
= dummy_args
; i
; i
= i
->next
)
13588 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13593 ++stree
->n
.tb
->pass_arg_num
;
13598 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13600 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13601 stree
->n
.tb
->pass_arg
);
13607 /* Otherwise, take the first one; there should in fact be at least
13609 stree
->n
.tb
->pass_arg_num
= 1;
13612 gfc_error ("Procedure %qs with PASS at %L must have at"
13613 " least one argument", proc
->name
, &where
);
13616 me_arg
= dummy_args
->sym
;
13619 /* Now check that the argument-type matches and the passed-object
13620 dummy argument is generally fine. */
13622 gcc_assert (me_arg
);
13624 if (me_arg
->ts
.type
!= BT_CLASS
)
13626 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13627 " at %L", proc
->name
, &where
);
13631 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13632 != resolve_bindings_derived
)
13634 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13635 " the derived-type %qs", me_arg
->name
, proc
->name
,
13636 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13640 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13641 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13643 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13644 " scalar", proc
->name
, &where
);
13647 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13649 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13650 " be ALLOCATABLE", proc
->name
, &where
);
13653 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13655 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13656 " be POINTER", proc
->name
, &where
);
13661 /* If we are extending some type, check that we don't override a procedure
13662 flagged NON_OVERRIDABLE. */
13663 stree
->n
.tb
->overridden
= NULL
;
13666 gfc_symtree
* overridden
;
13667 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13668 stree
->name
, true, NULL
);
13672 if (overridden
->n
.tb
)
13673 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13675 if (!gfc_check_typebound_override (stree
, overridden
))
13680 /* See if there's a name collision with a component directly in this type. */
13681 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13682 if (!strcmp (comp
->name
, stree
->name
))
13684 gfc_error ("Procedure %qs at %L has the same name as a component of"
13686 stree
->name
, &where
, resolve_bindings_derived
->name
);
13690 /* Try to find a name collision with an inherited component. */
13691 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13694 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13695 " component of %qs",
13696 stree
->name
, &where
, resolve_bindings_derived
->name
);
13700 stree
->n
.tb
->error
= 0;
13704 resolve_bindings_result
= false;
13705 stree
->n
.tb
->error
= 1;
13710 resolve_typebound_procedures (gfc_symbol
* derived
)
13713 gfc_symbol
* super_type
;
13715 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13718 super_type
= gfc_get_derived_super_type (derived
);
13720 resolve_symbol (super_type
);
13722 resolve_bindings_derived
= derived
;
13723 resolve_bindings_result
= true;
13725 if (derived
->f2k_derived
->tb_sym_root
)
13726 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13727 &resolve_typebound_procedure
);
13729 if (derived
->f2k_derived
->tb_uop_root
)
13730 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13731 &resolve_typebound_user_op
);
13733 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13735 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13736 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13737 (gfc_intrinsic_op
)op
, p
))
13738 resolve_bindings_result
= false;
13741 return resolve_bindings_result
;
13745 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13746 to give all identical derived types the same backend_decl. */
13748 add_dt_to_dt_list (gfc_symbol
*derived
)
13750 if (!derived
->dt_next
)
13752 if (gfc_derived_types
)
13754 derived
->dt_next
= gfc_derived_types
->dt_next
;
13755 gfc_derived_types
->dt_next
= derived
;
13759 derived
->dt_next
= derived
;
13761 gfc_derived_types
= derived
;
13766 /* Ensure that a derived-type is really not abstract, meaning that every
13767 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13770 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13775 if (!ensure_not_abstract_walker (sub
, st
->left
))
13777 if (!ensure_not_abstract_walker (sub
, st
->right
))
13780 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13782 gfc_symtree
* overriding
;
13783 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13786 gcc_assert (overriding
->n
.tb
);
13787 if (overriding
->n
.tb
->deferred
)
13789 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13790 " %qs is DEFERRED and not overridden",
13791 sub
->name
, &sub
->declared_at
, st
->name
);
13800 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13802 /* The algorithm used here is to recursively travel up the ancestry of sub
13803 and for each ancestor-type, check all bindings. If any of them is
13804 DEFERRED, look it up starting from sub and see if the found (overriding)
13805 binding is not DEFERRED.
13806 This is not the most efficient way to do this, but it should be ok and is
13807 clearer than something sophisticated. */
13809 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13811 if (!ancestor
->attr
.abstract
)
13814 /* Walk bindings of this ancestor. */
13815 if (ancestor
->f2k_derived
)
13818 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13823 /* Find next ancestor type and recurse on it. */
13824 ancestor
= gfc_get_derived_super_type (ancestor
);
13826 return ensure_not_abstract (sub
, ancestor
);
13832 /* This check for typebound defined assignments is done recursively
13833 since the order in which derived types are resolved is not always in
13834 order of the declarations. */
13837 check_defined_assignments (gfc_symbol
*derived
)
13841 for (c
= derived
->components
; c
; c
= c
->next
)
13843 if (!gfc_bt_struct (c
->ts
.type
)
13845 || c
->attr
.allocatable
13846 || c
->attr
.proc_pointer_comp
13847 || c
->attr
.class_pointer
13848 || c
->attr
.proc_pointer
)
13851 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13852 || (c
->ts
.u
.derived
->f2k_derived
13853 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13855 derived
->attr
.defined_assign_comp
= 1;
13859 check_defined_assignments (c
->ts
.u
.derived
);
13860 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13862 derived
->attr
.defined_assign_comp
= 1;
13869 /* Resolve a single component of a derived type or structure. */
13872 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13874 gfc_symbol
*super_type
;
13875 symbol_attribute
*attr
;
13877 if (c
->attr
.artificial
)
13880 /* Do not allow vtype components to be resolved in nameless namespaces
13881 such as block data because the procedure pointers will cause ICEs
13882 and vtables are not needed in these contexts. */
13883 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
13884 && sym
->ns
->proc_name
== NULL
)
13888 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13889 && c
->attr
.codimension
13890 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13892 gfc_error ("Coarray component %qs at %L must be allocatable with "
13893 "deferred shape", c
->name
, &c
->loc
);
13898 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13899 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13901 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13902 "shall not be a coarray", c
->name
, &c
->loc
);
13907 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13908 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13909 || c
->attr
.allocatable
))
13911 gfc_error ("Component %qs at %L with coarray component "
13912 "shall be a nonpointer, nonallocatable scalar",
13918 if (c
->ts
.type
== BT_CLASS
)
13920 if (CLASS_DATA (c
))
13922 attr
= &(CLASS_DATA (c
)->attr
);
13924 /* Fix up contiguous attribute. */
13925 if (c
->attr
.contiguous
)
13926 attr
->contiguous
= 1;
13934 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
13936 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13937 "is not an array pointer", c
->name
, &c
->loc
);
13941 /* F2003, 15.2.1 - length has to be one. */
13942 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
13943 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
13944 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
13945 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
13947 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
13952 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13954 gfc_symbol
*ifc
= c
->ts
.interface
;
13956 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13962 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13964 /* Resolve interface and copy attributes. */
13965 if (ifc
->formal
&& !ifc
->formal_ns
)
13966 resolve_symbol (ifc
);
13967 if (ifc
->attr
.intrinsic
)
13968 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13972 c
->ts
= ifc
->result
->ts
;
13973 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13974 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13975 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13976 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13977 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13982 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13983 c
->attr
.pointer
= ifc
->attr
.pointer
;
13984 c
->attr
.dimension
= ifc
->attr
.dimension
;
13985 c
->as
= gfc_copy_array_spec (ifc
->as
);
13986 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13988 c
->ts
.interface
= ifc
;
13989 c
->attr
.function
= ifc
->attr
.function
;
13990 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13992 c
->attr
.pure
= ifc
->attr
.pure
;
13993 c
->attr
.elemental
= ifc
->attr
.elemental
;
13994 c
->attr
.recursive
= ifc
->attr
.recursive
;
13995 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13996 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13997 /* Copy char length. */
13998 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
14000 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
14001 if (cl
->length
&& !cl
->resolved
14002 && !gfc_resolve_expr (cl
->length
))
14011 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
14013 /* Since PPCs are not implicitly typed, a PPC without an explicit
14014 interface must be a subroutine. */
14015 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
14018 /* Procedure pointer components: Check PASS arg. */
14019 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
14020 && !sym
->attr
.vtype
)
14022 gfc_symbol
* me_arg
;
14024 if (c
->tb
->pass_arg
)
14026 gfc_formal_arglist
* i
;
14028 /* If an explicit passing argument name is given, walk the arg-list
14029 and look for it. */
14032 c
->tb
->pass_arg_num
= 1;
14033 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
14035 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
14040 c
->tb
->pass_arg_num
++;
14045 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14046 "at %L has no argument %qs", c
->name
,
14047 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
14054 /* Otherwise, take the first one; there should in fact be at least
14056 c
->tb
->pass_arg_num
= 1;
14057 if (!c
->ts
.interface
->formal
)
14059 gfc_error ("Procedure pointer component %qs with PASS at %L "
14060 "must have at least one argument",
14065 me_arg
= c
->ts
.interface
->formal
->sym
;
14068 /* Now check that the argument-type matches. */
14069 gcc_assert (me_arg
);
14070 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
14071 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
14072 || (me_arg
->ts
.type
== BT_CLASS
14073 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
14075 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14076 " the derived type %qs", me_arg
->name
, c
->name
,
14077 me_arg
->name
, &c
->loc
, sym
->name
);
14082 /* Check for F03:C453. */
14083 if (CLASS_DATA (me_arg
)->attr
.dimension
)
14085 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14086 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
14092 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14094 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14095 "may not have the POINTER attribute", me_arg
->name
,
14096 c
->name
, me_arg
->name
, &c
->loc
);
14101 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14103 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14104 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
14105 me_arg
->name
, &c
->loc
);
14110 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
14112 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14113 " at %L", c
->name
, &c
->loc
);
14119 /* Check type-spec if this is not the parent-type component. */
14120 if (((sym
->attr
.is_class
14121 && (!sym
->components
->ts
.u
.derived
->attr
.extension
14122 || c
!= sym
->components
->ts
.u
.derived
->components
))
14123 || (!sym
->attr
.is_class
14124 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
14125 && !sym
->attr
.vtype
14126 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
14129 super_type
= gfc_get_derived_super_type (sym
);
14131 /* If this type is an extension, set the accessibility of the parent
14134 && ((sym
->attr
.is_class
14135 && c
== sym
->components
->ts
.u
.derived
->components
)
14136 || (!sym
->attr
.is_class
&& c
== sym
->components
))
14137 && strcmp (super_type
->name
, c
->name
) == 0)
14138 c
->attr
.access
= super_type
->attr
.access
;
14140 /* If this type is an extension, see if this component has the same name
14141 as an inherited type-bound procedure. */
14142 if (super_type
&& !sym
->attr
.is_class
14143 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
14145 gfc_error ("Component %qs of %qs at %L has the same name as an"
14146 " inherited type-bound procedure",
14147 c
->name
, sym
->name
, &c
->loc
);
14151 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
14152 && !c
->ts
.deferred
)
14154 if (c
->ts
.u
.cl
->length
== NULL
14155 || (!resolve_charlen(c
->ts
.u
.cl
))
14156 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
14158 gfc_error ("Character length of component %qs needs to "
14159 "be a constant specification expression at %L",
14161 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14166 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14167 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14169 gfc_error ("Character component %qs of %qs at %L with deferred "
14170 "length must be a POINTER or ALLOCATABLE",
14171 c
->name
, sym
->name
, &c
->loc
);
14175 /* Add the hidden deferred length field. */
14176 if (c
->ts
.type
== BT_CHARACTER
14177 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14178 && !c
->attr
.function
14179 && !sym
->attr
.is_class
)
14181 char name
[GFC_MAX_SYMBOL_LEN
+9];
14182 gfc_component
*strlen
;
14183 sprintf (name
, "_%s_length", c
->name
);
14184 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14185 if (strlen
== NULL
)
14187 if (!gfc_add_component (sym
, name
, &strlen
))
14189 strlen
->ts
.type
= BT_INTEGER
;
14190 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14191 strlen
->attr
.access
= ACCESS_PRIVATE
;
14192 strlen
->attr
.artificial
= 1;
14196 if (c
->ts
.type
== BT_DERIVED
14197 && sym
->component_access
!= ACCESS_PRIVATE
14198 && gfc_check_symbol_access (sym
)
14199 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14200 && !c
->ts
.u
.derived
->attr
.use_assoc
14201 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14202 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14203 "PRIVATE type and cannot be a component of "
14204 "%qs, which is PUBLIC at %L", c
->name
,
14205 sym
->name
, &sym
->declared_at
))
14208 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14210 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14211 "type %s", c
->name
, &c
->loc
, sym
->name
);
14215 if (sym
->attr
.sequence
)
14217 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14219 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14220 "not have the SEQUENCE attribute",
14221 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14226 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14227 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14228 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14229 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14230 CLASS_DATA (c
)->ts
.u
.derived
14231 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14233 /* If an allocatable component derived type is of the same type as
14234 the enclosing derived type, we need a vtable generating so that
14235 the __deallocate procedure is created. */
14236 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14237 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14238 gfc_find_vtab (&c
->ts
);
14240 /* Ensure that all the derived type components are put on the
14241 derived type list; even in formal namespaces, where derived type
14242 pointer components might not have been declared. */
14243 if (c
->ts
.type
== BT_DERIVED
14245 && c
->ts
.u
.derived
->components
14247 && sym
!= c
->ts
.u
.derived
)
14248 add_dt_to_dt_list (c
->ts
.u
.derived
);
14250 if (!gfc_resolve_array_spec (c
->as
,
14251 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
14252 || c
->attr
.allocatable
)))
14255 if (c
->initializer
&& !sym
->attr
.vtype
14256 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
14257 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
14264 /* Be nice about the locus for a structure expression - show the locus of the
14265 first non-null sub-expression if we can. */
14268 cons_where (gfc_expr
*struct_expr
)
14270 gfc_constructor
*cons
;
14272 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
14274 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
14275 for (; cons
; cons
= gfc_constructor_next (cons
))
14277 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
14278 return &cons
->expr
->where
;
14281 return &struct_expr
->where
;
14284 /* Resolve the components of a structure type. Much less work than derived
14288 resolve_fl_struct (gfc_symbol
*sym
)
14291 gfc_expr
*init
= NULL
;
14294 /* Make sure UNIONs do not have overlapping initializers. */
14295 if (sym
->attr
.flavor
== FL_UNION
)
14297 for (c
= sym
->components
; c
; c
= c
->next
)
14299 if (init
&& c
->initializer
)
14301 gfc_error ("Conflicting initializers in union at %L and %L",
14302 cons_where (init
), cons_where (c
->initializer
));
14303 gfc_free_expr (c
->initializer
);
14304 c
->initializer
= NULL
;
14307 init
= c
->initializer
;
14312 for (c
= sym
->components
; c
; c
= c
->next
)
14313 if (!resolve_component (c
, sym
))
14319 if (sym
->components
)
14320 add_dt_to_dt_list (sym
);
14326 /* Resolve the components of a derived type. This does not have to wait until
14327 resolution stage, but can be done as soon as the dt declaration has been
14331 resolve_fl_derived0 (gfc_symbol
*sym
)
14333 gfc_symbol
* super_type
;
14335 gfc_formal_arglist
*f
;
14338 if (sym
->attr
.unlimited_polymorphic
)
14341 super_type
= gfc_get_derived_super_type (sym
);
14344 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14346 gfc_error ("As extending type %qs at %L has a coarray component, "
14347 "parent type %qs shall also have one", sym
->name
,
14348 &sym
->declared_at
, super_type
->name
);
14352 /* Ensure the extended type gets resolved before we do. */
14353 if (super_type
&& !resolve_fl_derived0 (super_type
))
14356 /* An ABSTRACT type must be extensible. */
14357 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14359 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14360 sym
->name
, &sym
->declared_at
);
14364 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14368 for ( ; c
!= NULL
; c
= c
->next
)
14369 if (!resolve_component (c
, sym
))
14375 /* Now add the caf token field, where needed. */
14376 if (flag_coarray
!= GFC_FCOARRAY_NONE
14377 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14379 for (c
= sym
->components
; c
; c
= c
->next
)
14380 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14381 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14383 char name
[GFC_MAX_SYMBOL_LEN
+9];
14384 gfc_component
*token
;
14385 sprintf (name
, "_caf_%s", c
->name
);
14386 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14389 if (!gfc_add_component (sym
, name
, &token
))
14391 token
->ts
.type
= BT_VOID
;
14392 token
->ts
.kind
= gfc_default_integer_kind
;
14393 token
->attr
.access
= ACCESS_PRIVATE
;
14394 token
->attr
.artificial
= 1;
14395 token
->attr
.caf_token
= 1;
14400 check_defined_assignments (sym
);
14402 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14403 sym
->attr
.defined_assign_comp
14404 = super_type
->attr
.defined_assign_comp
;
14406 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14407 all DEFERRED bindings are overridden. */
14408 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14409 && !sym
->attr
.is_class
14410 && !ensure_not_abstract (sym
, super_type
))
14413 /* Check that there is a component for every PDT parameter. */
14414 if (sym
->attr
.pdt_template
)
14416 for (f
= sym
->formal
; f
; f
= f
->next
)
14420 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14423 gfc_error ("Parameterized type %qs does not have a component "
14424 "corresponding to parameter %qs at %L", sym
->name
,
14425 f
->sym
->name
, &sym
->declared_at
);
14431 /* Add derived type to the derived type list. */
14432 add_dt_to_dt_list (sym
);
14438 /* The following procedure does the full resolution of a derived type,
14439 including resolution of all type-bound procedures (if present). In contrast
14440 to 'resolve_fl_derived0' this can only be done after the module has been
14441 parsed completely. */
14444 resolve_fl_derived (gfc_symbol
*sym
)
14446 gfc_symbol
*gen_dt
= NULL
;
14448 if (sym
->attr
.unlimited_polymorphic
)
14451 if (!sym
->attr
.is_class
)
14452 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14453 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14454 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14455 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14456 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14457 "%qs at %L being the same name as derived "
14458 "type at %L", sym
->name
,
14459 gen_dt
->generic
->sym
== sym
14460 ? gen_dt
->generic
->next
->sym
->name
14461 : gen_dt
->generic
->sym
->name
,
14462 gen_dt
->generic
->sym
== sym
14463 ? &gen_dt
->generic
->next
->sym
->declared_at
14464 : &gen_dt
->generic
->sym
->declared_at
,
14465 &sym
->declared_at
))
14468 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
14470 gfc_error ("Derived type %qs at %L has not been declared",
14471 sym
->name
, &sym
->declared_at
);
14475 /* Resolve the finalizer procedures. */
14476 if (!gfc_resolve_finalizers (sym
, NULL
))
14479 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14481 /* Fix up incomplete CLASS symbols. */
14482 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14483 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14485 /* Nothing more to do for unlimited polymorphic entities. */
14486 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14488 else if (vptr
->ts
.u
.derived
== NULL
)
14490 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14492 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14493 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14498 if (!resolve_fl_derived0 (sym
))
14501 /* Resolve the type-bound procedures. */
14502 if (!resolve_typebound_procedures (sym
))
14505 /* Generate module vtables subject to their accessibility and their not
14506 being vtables or pdt templates. If this is not done class declarations
14507 in external procedures wind up with their own version and so SELECT TYPE
14508 fails because the vptrs do not have the same address. */
14509 if (gfc_option
.allow_std
& GFC_STD_F2003
14510 && sym
->ns
->proc_name
14511 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14512 && sym
->attr
.access
!= ACCESS_PRIVATE
14513 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14515 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14516 gfc_set_sym_referenced (vtab
);
14524 resolve_fl_namelist (gfc_symbol
*sym
)
14529 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14531 /* Check again, the check in match only works if NAMELIST comes
14533 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14535 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14536 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14540 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14541 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14542 "with assumed shape in namelist %qs at %L",
14543 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14546 if (is_non_constant_shape_array (nl
->sym
)
14547 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14548 "with nonconstant shape in namelist %qs at %L",
14549 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14552 if (nl
->sym
->ts
.type
== BT_CHARACTER
14553 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14554 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14555 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14556 "nonconstant character length in "
14557 "namelist %qs at %L", nl
->sym
->name
,
14558 sym
->name
, &sym
->declared_at
))
14563 /* Reject PRIVATE objects in a PUBLIC namelist. */
14564 if (gfc_check_symbol_access (sym
))
14566 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14568 if (!nl
->sym
->attr
.use_assoc
14569 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14570 && !gfc_check_symbol_access (nl
->sym
))
14572 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14573 "cannot be member of PUBLIC namelist %qs at %L",
14574 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14578 if (nl
->sym
->ts
.type
== BT_DERIVED
14579 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14580 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14582 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14583 "namelist %qs at %L with ALLOCATABLE "
14584 "or POINTER components", nl
->sym
->name
,
14585 sym
->name
, &sym
->declared_at
))
14590 /* Types with private components that came here by USE-association. */
14591 if (nl
->sym
->ts
.type
== BT_DERIVED
14592 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14594 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14595 "components and cannot be member of namelist %qs at %L",
14596 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14600 /* Types with private components that are defined in the same module. */
14601 if (nl
->sym
->ts
.type
== BT_DERIVED
14602 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14603 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14605 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14606 "cannot be a member of PUBLIC namelist %qs at %L",
14607 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14614 /* 14.1.2 A module or internal procedure represent local entities
14615 of the same type as a namelist member and so are not allowed. */
14616 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14618 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14621 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14622 if ((nl
->sym
== sym
->ns
->proc_name
)
14624 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14629 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14630 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14632 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14633 "attribute in %qs at %L", nlsym
->name
,
14634 &sym
->declared_at
);
14641 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14642 nl
->sym
->attr
.asynchronous
= 1;
14649 resolve_fl_parameter (gfc_symbol
*sym
)
14651 /* A parameter array's shape needs to be constant. */
14652 if (sym
->as
!= NULL
14653 && (sym
->as
->type
== AS_DEFERRED
14654 || is_non_constant_shape_array (sym
)))
14656 gfc_error ("Parameter array %qs at %L cannot be automatic "
14657 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14661 /* Constraints on deferred type parameter. */
14662 if (!deferred_requirements (sym
))
14665 /* Make sure a parameter that has been implicitly typed still
14666 matches the implicit type, since PARAMETER statements can precede
14667 IMPLICIT statements. */
14668 if (sym
->attr
.implicit_type
14669 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14672 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14673 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14677 /* Make sure the types of derived parameters are consistent. This
14678 type checking is deferred until resolution because the type may
14679 refer to a derived type from the host. */
14680 if (sym
->ts
.type
== BT_DERIVED
14681 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14683 gfc_error ("Incompatible derived type in PARAMETER at %L",
14684 &sym
->value
->where
);
14688 /* F03:C509,C514. */
14689 if (sym
->ts
.type
== BT_CLASS
)
14691 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14692 sym
->name
, &sym
->declared_at
);
14700 /* Called by resolve_symbol to check PDTs. */
14703 resolve_pdt (gfc_symbol
* sym
)
14705 gfc_symbol
*derived
= NULL
;
14706 gfc_actual_arglist
*param
;
14708 bool const_len_exprs
= true;
14709 bool assumed_len_exprs
= false;
14710 symbol_attribute
*attr
;
14712 if (sym
->ts
.type
== BT_DERIVED
)
14714 derived
= sym
->ts
.u
.derived
;
14715 attr
= &(sym
->attr
);
14717 else if (sym
->ts
.type
== BT_CLASS
)
14719 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14720 attr
= &(CLASS_DATA (sym
)->attr
);
14723 gcc_unreachable ();
14725 gcc_assert (derived
->attr
.pdt_type
);
14727 for (param
= sym
->param_list
; param
; param
= param
->next
)
14729 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14731 if (c
->attr
.pdt_kind
)
14734 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14735 && c
->attr
.pdt_len
)
14736 const_len_exprs
= false;
14737 else if (param
->spec_type
== SPEC_ASSUMED
)
14738 assumed_len_exprs
= true;
14740 if (param
->spec_type
== SPEC_DEFERRED
14741 && !attr
->allocatable
&& !attr
->pointer
)
14742 gfc_error ("The object %qs at %L has a deferred LEN "
14743 "parameter %qs and is neither allocatable "
14744 "nor a pointer", sym
->name
, &sym
->declared_at
,
14749 if (!const_len_exprs
14750 && (sym
->ns
->proc_name
->attr
.is_main_program
14751 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14752 || sym
->attr
.save
!= SAVE_NONE
))
14753 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14754 "SAVE attribute or be a variable declared in the "
14755 "main program, a module or a submodule(F08/C513)",
14756 sym
->name
, &sym
->declared_at
);
14758 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14759 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14760 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14761 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14762 sym
->name
, &sym
->declared_at
);
14766 /* Do anything necessary to resolve a symbol. Right now, we just
14767 assume that an otherwise unknown symbol is a variable. This sort
14768 of thing commonly happens for symbols in module. */
14771 resolve_symbol (gfc_symbol
*sym
)
14773 int check_constant
, mp_flag
;
14774 gfc_symtree
*symtree
;
14775 gfc_symtree
*this_symtree
;
14778 symbol_attribute class_attr
;
14779 gfc_array_spec
*as
;
14780 bool saved_specification_expr
;
14786 /* No symbol will ever have union type; only components can be unions.
14787 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14788 (just like derived type declaration symbols have flavor FL_DERIVED). */
14789 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14791 /* Coarrayed polymorphic objects with allocatable or pointer components are
14792 yet unsupported for -fcoarray=lib. */
14793 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14794 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14795 && CLASS_DATA (sym
)->attr
.codimension
14796 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14797 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14799 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14800 "type coarrays at %L are unsupported", &sym
->declared_at
);
14804 if (sym
->attr
.artificial
)
14807 if (sym
->attr
.unlimited_polymorphic
)
14810 if (sym
->attr
.flavor
== FL_UNKNOWN
14811 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14812 && !sym
->attr
.generic
&& !sym
->attr
.external
14813 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14814 && sym
->ts
.type
== BT_UNKNOWN
))
14817 /* If we find that a flavorless symbol is an interface in one of the
14818 parent namespaces, find its symtree in this namespace, free the
14819 symbol and set the symtree to point to the interface symbol. */
14820 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14822 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14823 if (symtree
&& (symtree
->n
.sym
->generic
||
14824 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14825 && sym
->ns
->construct_entities
)))
14827 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14829 if (this_symtree
->n
.sym
== sym
)
14831 symtree
->n
.sym
->refs
++;
14832 gfc_release_symbol (sym
);
14833 this_symtree
->n
.sym
= symtree
->n
.sym
;
14839 /* Otherwise give it a flavor according to such attributes as
14841 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14842 && sym
->attr
.intrinsic
== 0)
14843 sym
->attr
.flavor
= FL_VARIABLE
;
14844 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14846 sym
->attr
.flavor
= FL_PROCEDURE
;
14847 if (sym
->attr
.dimension
)
14848 sym
->attr
.function
= 1;
14852 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14853 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14855 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14856 && !resolve_procedure_interface (sym
))
14859 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14860 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14862 if (sym
->attr
.external
)
14863 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14864 "at %L", &sym
->declared_at
);
14866 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14867 "at %L", &sym
->declared_at
);
14872 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14875 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14876 && !resolve_fl_struct (sym
))
14879 /* Symbols that are module procedures with results (functions) have
14880 the types and array specification copied for type checking in
14881 procedures that call them, as well as for saving to a module
14882 file. These symbols can't stand the scrutiny that their results
14884 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14886 /* Make sure that the intrinsic is consistent with its internal
14887 representation. This needs to be done before assigning a default
14888 type to avoid spurious warnings. */
14889 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14890 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14893 /* Resolve associate names. */
14895 resolve_assoc_var (sym
, true);
14897 /* Assign default type to symbols that need one and don't have one. */
14898 if (sym
->ts
.type
== BT_UNKNOWN
)
14900 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14902 gfc_set_default_type (sym
, 1, NULL
);
14905 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14906 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14907 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14908 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14910 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14912 /* The specific case of an external procedure should emit an error
14913 in the case that there is no implicit type. */
14916 if (!sym
->attr
.mixed_entry_master
)
14917 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14921 /* Result may be in another namespace. */
14922 resolve_symbol (sym
->result
);
14924 if (!sym
->result
->attr
.proc_pointer
)
14926 sym
->ts
= sym
->result
->ts
;
14927 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14928 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14929 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14930 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14931 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14936 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14938 bool saved_specification_expr
= specification_expr
;
14939 specification_expr
= true;
14940 gfc_resolve_array_spec (sym
->result
->as
, false);
14941 specification_expr
= saved_specification_expr
;
14944 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14946 as
= CLASS_DATA (sym
)->as
;
14947 class_attr
= CLASS_DATA (sym
)->attr
;
14948 class_attr
.pointer
= class_attr
.class_pointer
;
14952 class_attr
= sym
->attr
;
14957 if (sym
->attr
.contiguous
14958 && (!class_attr
.dimension
14959 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
14960 && !class_attr
.pointer
)))
14962 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14963 "array pointer or an assumed-shape or assumed-rank array",
14964 sym
->name
, &sym
->declared_at
);
14968 /* Assumed size arrays and assumed shape arrays must be dummy
14969 arguments. Array-spec's of implied-shape should have been resolved to
14970 AS_EXPLICIT already. */
14974 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
14975 specification expression. */
14976 if (as
->type
== AS_IMPLIED_SHAPE
)
14979 for (i
=0; i
<as
->rank
; i
++)
14981 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
14983 gfc_error ("Bad specification for assumed size array at %L",
14984 &as
->lower
[i
]->where
);
14991 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
14992 || as
->type
== AS_ASSUMED_SHAPE
)
14993 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
14995 if (as
->type
== AS_ASSUMED_SIZE
)
14996 gfc_error ("Assumed size array at %L must be a dummy argument",
14997 &sym
->declared_at
);
14999 gfc_error ("Assumed shape array at %L must be a dummy argument",
15000 &sym
->declared_at
);
15003 /* TS 29113, C535a. */
15004 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
15005 && !sym
->attr
.select_type_temporary
)
15007 gfc_error ("Assumed-rank array at %L must be a dummy argument",
15008 &sym
->declared_at
);
15011 if (as
->type
== AS_ASSUMED_RANK
15012 && (sym
->attr
.codimension
|| sym
->attr
.value
))
15014 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15015 "CODIMENSION attribute", &sym
->declared_at
);
15020 /* Make sure symbols with known intent or optional are really dummy
15021 variable. Because of ENTRY statement, this has to be deferred
15022 until resolution time. */
15024 if (!sym
->attr
.dummy
15025 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
15027 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
15031 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
15033 gfc_error ("%qs at %L cannot have the VALUE attribute because "
15034 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
15038 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
15040 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
15041 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
15043 gfc_error ("Character dummy variable %qs at %L with VALUE "
15044 "attribute must have constant length",
15045 sym
->name
, &sym
->declared_at
);
15049 if (sym
->ts
.is_c_interop
15050 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
15052 gfc_error ("C interoperable character dummy variable %qs at %L "
15053 "with VALUE attribute must have length one",
15054 sym
->name
, &sym
->declared_at
);
15059 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15060 && sym
->ts
.u
.derived
->attr
.generic
)
15062 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
15063 if (!sym
->ts
.u
.derived
)
15065 gfc_error ("The derived type %qs at %L is of type %qs, "
15066 "which has not been defined", sym
->name
,
15067 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15068 sym
->ts
.type
= BT_UNKNOWN
;
15073 /* Use the same constraints as TYPE(*), except for the type check
15074 and that only scalars and assumed-size arrays are permitted. */
15075 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
15077 if (!sym
->attr
.dummy
)
15079 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15080 "a dummy argument", sym
->name
, &sym
->declared_at
);
15084 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
15085 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
15086 && sym
->ts
.type
!= BT_COMPLEX
)
15088 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15089 "of type TYPE(*) or of an numeric intrinsic type",
15090 sym
->name
, &sym
->declared_at
);
15094 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15095 || sym
->attr
.pointer
|| sym
->attr
.value
)
15097 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15098 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15099 "attribute", sym
->name
, &sym
->declared_at
);
15103 if (sym
->attr
.intent
== INTENT_OUT
)
15105 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15106 "have the INTENT(OUT) attribute",
15107 sym
->name
, &sym
->declared_at
);
15110 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
15112 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15113 "either be a scalar or an assumed-size array",
15114 sym
->name
, &sym
->declared_at
);
15118 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15119 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15121 sym
->ts
.type
= BT_ASSUMED
;
15122 sym
->as
= gfc_get_array_spec ();
15123 sym
->as
->type
= AS_ASSUMED_SIZE
;
15125 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
15127 else if (sym
->ts
.type
== BT_ASSUMED
)
15129 /* TS 29113, C407a. */
15130 if (!sym
->attr
.dummy
)
15132 gfc_error ("Assumed type of variable %s at %L is only permitted "
15133 "for dummy variables", sym
->name
, &sym
->declared_at
);
15136 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15137 || sym
->attr
.pointer
|| sym
->attr
.value
)
15139 gfc_error ("Assumed-type variable %s at %L may not have the "
15140 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15141 sym
->name
, &sym
->declared_at
);
15144 if (sym
->attr
.intent
== INTENT_OUT
)
15146 gfc_error ("Assumed-type variable %s at %L may not have the "
15147 "INTENT(OUT) attribute",
15148 sym
->name
, &sym
->declared_at
);
15151 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
15153 gfc_error ("Assumed-type variable %s at %L shall not be an "
15154 "explicit-shape array", sym
->name
, &sym
->declared_at
);
15159 /* If the symbol is marked as bind(c), that it is declared at module level
15160 scope and verify its type and kind. Do not do the latter for symbols
15161 that are implicitly typed because that is handled in
15162 gfc_set_default_type. Handle dummy arguments and procedure definitions
15163 separately. Also, anything that is use associated is not handled here
15164 but instead is handled in the module it is declared in. Finally, derived
15165 type definitions are allowed to be BIND(C) since that only implies that
15166 they're interoperable, and they are checked fully for interoperability
15167 when a variable is declared of that type. */
15168 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15169 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15170 && sym
->attr
.flavor
!= FL_DERIVED
)
15174 /* First, make sure the variable is declared at the
15175 module-level scope (J3/04-007, Section 15.3). */
15176 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
15177 sym
->attr
.in_common
== 0)
15179 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15180 "is neither a COMMON block nor declared at the "
15181 "module level scope", sym
->name
, &(sym
->declared_at
));
15184 else if (sym
->ts
.type
== BT_CHARACTER
15185 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15186 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15187 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15189 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15190 sym
->name
, &sym
->declared_at
);
15193 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15195 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15197 else if (sym
->attr
.implicit_type
== 0)
15199 /* If type() declaration, we need to verify that the components
15200 of the given type are all C interoperable, etc. */
15201 if (sym
->ts
.type
== BT_DERIVED
&&
15202 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15204 /* Make sure the user marked the derived type as BIND(C). If
15205 not, call the verify routine. This could print an error
15206 for the derived type more than once if multiple variables
15207 of that type are declared. */
15208 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15209 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15213 /* Verify the variable itself as C interoperable if it
15214 is BIND(C). It is not possible for this to succeed if
15215 the verify_bind_c_derived_type failed, so don't have to handle
15216 any error returned by verify_bind_c_derived_type. */
15217 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15218 sym
->common_block
);
15223 /* clear the is_bind_c flag to prevent reporting errors more than
15224 once if something failed. */
15225 sym
->attr
.is_bind_c
= 0;
15230 /* If a derived type symbol has reached this point, without its
15231 type being declared, we have an error. Notice that most
15232 conditions that produce undefined derived types have already
15233 been dealt with. However, the likes of:
15234 implicit type(t) (t) ..... call foo (t) will get us here if
15235 the type is not declared in the scope of the implicit
15236 statement. Change the type to BT_UNKNOWN, both because it is so
15237 and to prevent an ICE. */
15238 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15239 && sym
->ts
.u
.derived
->components
== NULL
15240 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
15242 gfc_error ("The derived type %qs at %L is of type %qs, "
15243 "which has not been defined", sym
->name
,
15244 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15245 sym
->ts
.type
= BT_UNKNOWN
;
15249 /* Make sure that the derived type has been resolved and that the
15250 derived type is visible in the symbol's namespace, if it is a
15251 module function and is not PRIVATE. */
15252 if (sym
->ts
.type
== BT_DERIVED
15253 && sym
->ts
.u
.derived
->attr
.use_assoc
15254 && sym
->ns
->proc_name
15255 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15256 && !resolve_fl_derived (sym
->ts
.u
.derived
))
15259 /* Unless the derived-type declaration is use associated, Fortran 95
15260 does not allow public entries of private derived types.
15261 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15262 161 in 95-006r3. */
15263 if (sym
->ts
.type
== BT_DERIVED
15264 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15265 && !sym
->ts
.u
.derived
->attr
.use_assoc
15266 && gfc_check_symbol_access (sym
)
15267 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15268 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
15269 "derived type %qs",
15270 (sym
->attr
.flavor
== FL_PARAMETER
)
15271 ? "parameter" : "variable",
15272 sym
->name
, &sym
->declared_at
,
15273 sym
->ts
.u
.derived
->name
))
15276 /* F2008, C1302. */
15277 if (sym
->ts
.type
== BT_DERIVED
15278 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15279 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
15280 || sym
->ts
.u
.derived
->attr
.lock_comp
)
15281 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15283 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15284 "type LOCK_TYPE must be a coarray", sym
->name
,
15285 &sym
->declared_at
);
15289 /* TS18508, C702/C703. */
15290 if (sym
->ts
.type
== BT_DERIVED
15291 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15292 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
15293 || sym
->ts
.u
.derived
->attr
.event_comp
)
15294 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15296 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15297 "type EVENT_TYPE must be a coarray", sym
->name
,
15298 &sym
->declared_at
);
15302 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15303 default initialization is defined (5.1.2.4.4). */
15304 if (sym
->ts
.type
== BT_DERIVED
15306 && sym
->attr
.intent
== INTENT_OUT
15308 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15310 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15312 if (c
->initializer
)
15314 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15315 "ASSUMED SIZE and so cannot have a default initializer",
15316 sym
->name
, &sym
->declared_at
);
15323 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15324 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15326 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15327 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15332 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15333 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15335 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15336 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15341 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15342 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15343 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15344 || class_attr
.codimension
)
15345 && (sym
->attr
.result
|| sym
->result
== sym
))
15347 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15348 "a coarray component", sym
->name
, &sym
->declared_at
);
15353 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15354 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15356 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15357 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15362 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15363 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15364 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15365 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15366 || class_attr
.allocatable
))
15368 gfc_error ("Variable %qs at %L with coarray component shall be a "
15369 "nonpointer, nonallocatable scalar, which is not a coarray",
15370 sym
->name
, &sym
->declared_at
);
15374 /* F2008, C526. The function-result case was handled above. */
15375 if (class_attr
.codimension
15376 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15377 || sym
->attr
.select_type_temporary
15378 || sym
->attr
.associate_var
15379 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15380 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15381 || sym
->ns
->proc_name
->attr
.is_main_program
15382 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15384 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15385 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15389 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15390 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15392 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15393 "deferred shape", sym
->name
, &sym
->declared_at
);
15396 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15397 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15399 gfc_error ("Allocatable coarray variable %qs at %L must have "
15400 "deferred shape", sym
->name
, &sym
->declared_at
);
15405 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15406 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15407 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15408 || (class_attr
.codimension
&& class_attr
.allocatable
))
15409 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15411 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15412 "allocatable coarray or have coarray components",
15413 sym
->name
, &sym
->declared_at
);
15417 if (class_attr
.codimension
&& sym
->attr
.dummy
15418 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15420 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15421 "procedure %qs", sym
->name
, &sym
->declared_at
,
15422 sym
->ns
->proc_name
->name
);
15426 if (sym
->ts
.type
== BT_LOGICAL
15427 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15428 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15429 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15432 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15433 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15435 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15436 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15437 "%L with non-C_Bool kind in BIND(C) procedure "
15438 "%qs", sym
->name
, &sym
->declared_at
,
15439 sym
->ns
->proc_name
->name
))
15441 else if (!gfc_logical_kinds
[i
].c_bool
15442 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15443 "%qs at %L with non-C_Bool kind in "
15444 "BIND(C) procedure %qs", sym
->name
,
15446 sym
->attr
.function
? sym
->name
15447 : sym
->ns
->proc_name
->name
))
15451 switch (sym
->attr
.flavor
)
15454 if (!resolve_fl_variable (sym
, mp_flag
))
15459 if (sym
->formal
&& !sym
->formal_ns
)
15461 /* Check that none of the arguments are a namelist. */
15462 gfc_formal_arglist
*formal
= sym
->formal
;
15464 for (; formal
; formal
= formal
->next
)
15465 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15467 gfc_error ("Namelist %qs cannot be an argument to "
15468 "subroutine or function at %L",
15469 formal
->sym
->name
, &sym
->declared_at
);
15474 if (!resolve_fl_procedure (sym
, mp_flag
))
15479 if (!resolve_fl_namelist (sym
))
15484 if (!resolve_fl_parameter (sym
))
15492 /* Resolve array specifier. Check as well some constraints
15493 on COMMON blocks. */
15495 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15497 /* Set the formal_arg_flag so that check_conflict will not throw
15498 an error for host associated variables in the specification
15499 expression for an array_valued function. */
15500 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
15501 formal_arg_flag
= true;
15503 saved_specification_expr
= specification_expr
;
15504 specification_expr
= true;
15505 gfc_resolve_array_spec (sym
->as
, check_constant
);
15506 specification_expr
= saved_specification_expr
;
15508 formal_arg_flag
= false;
15510 /* Resolve formal namespaces. */
15511 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15512 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15513 gfc_resolve (sym
->formal_ns
);
15515 /* Make sure the formal namespace is present. */
15516 if (sym
->formal
&& !sym
->formal_ns
)
15518 gfc_formal_arglist
*formal
= sym
->formal
;
15519 while (formal
&& !formal
->sym
)
15520 formal
= formal
->next
;
15524 sym
->formal_ns
= formal
->sym
->ns
;
15525 if (sym
->ns
!= formal
->sym
->ns
)
15526 sym
->formal_ns
->refs
++;
15530 /* Check threadprivate restrictions. */
15531 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15532 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15533 && (!sym
->attr
.in_common
15534 && sym
->module
== NULL
15535 && (sym
->ns
->proc_name
== NULL
15536 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15537 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15539 /* Check omp declare target restrictions. */
15540 if (sym
->attr
.omp_declare_target
15541 && sym
->attr
.flavor
== FL_VARIABLE
15543 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15544 && (!sym
->attr
.in_common
15545 && sym
->module
== NULL
15546 && (sym
->ns
->proc_name
== NULL
15547 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15548 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15549 sym
->name
, &sym
->declared_at
);
15551 /* If we have come this far we can apply default-initializers, as
15552 described in 14.7.5, to those variables that have not already
15553 been assigned one. */
15554 if (sym
->ts
.type
== BT_DERIVED
15556 && !sym
->attr
.allocatable
15557 && !sym
->attr
.alloc_comp
)
15559 symbol_attribute
*a
= &sym
->attr
;
15561 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15562 && !a
->in_common
&& !a
->use_assoc
15564 && !((a
->function
|| a
->result
)
15566 || sym
->ts
.u
.derived
->attr
.alloc_comp
15567 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15568 && !(a
->function
&& sym
!= sym
->result
))
15569 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15570 apply_default_init (sym
);
15571 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15572 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15573 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15574 /* Mark the result symbol to be referenced, when it has allocatable
15576 sym
->result
->attr
.referenced
= 1;
15579 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15580 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15581 && !CLASS_DATA (sym
)->attr
.class_pointer
15582 && !CLASS_DATA (sym
)->attr
.allocatable
)
15583 apply_default_init (sym
);
15585 /* If this symbol has a type-spec, check it. */
15586 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15587 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15588 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15591 if (sym
->param_list
)
15596 /************* Resolve DATA statements *************/
15600 gfc_data_value
*vnode
;
15606 /* Advance the values structure to point to the next value in the data list. */
15609 next_data_value (void)
15611 while (mpz_cmp_ui (values
.left
, 0) == 0)
15614 if (values
.vnode
->next
== NULL
)
15617 values
.vnode
= values
.vnode
->next
;
15618 mpz_set (values
.left
, values
.vnode
->repeat
);
15626 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15632 ar_type mark
= AR_UNKNOWN
;
15634 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15640 if (!gfc_resolve_expr (var
->expr
))
15644 mpz_init_set_si (offset
, 0);
15647 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15648 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15649 e
= e
->value
.function
.actual
->expr
;
15651 if (e
->expr_type
!= EXPR_VARIABLE
)
15653 gfc_error ("Expecting definable entity near %L", where
);
15657 sym
= e
->symtree
->n
.sym
;
15659 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15661 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15662 sym
->name
, &sym
->declared_at
);
15666 if (e
->ref
== NULL
&& sym
->as
)
15668 gfc_error ("DATA array %qs at %L must be specified in a previous"
15669 " declaration", sym
->name
, where
);
15673 has_pointer
= sym
->attr
.pointer
;
15675 if (gfc_is_coindexed (e
))
15677 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15682 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15684 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15688 && ref
->type
== REF_ARRAY
15689 && ref
->u
.ar
.type
!= AR_FULL
)
15691 gfc_error ("DATA element %qs at %L is a pointer and so must "
15692 "be a full array", sym
->name
, where
);
15697 if (e
->rank
== 0 || has_pointer
)
15699 mpz_init_set_ui (size
, 1);
15706 /* Find the array section reference. */
15707 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15709 if (ref
->type
!= REF_ARRAY
)
15711 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15717 /* Set marks according to the reference pattern. */
15718 switch (ref
->u
.ar
.type
)
15726 /* Get the start position of array section. */
15727 gfc_get_section_index (ar
, section_index
, &offset
);
15732 gcc_unreachable ();
15735 if (!gfc_array_size (e
, &size
))
15737 gfc_error ("Nonconstant array section at %L in DATA statement",
15739 mpz_clear (offset
);
15746 while (mpz_cmp_ui (size
, 0) > 0)
15748 if (!next_data_value ())
15750 gfc_error ("DATA statement at %L has more variables than values",
15756 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
15760 /* If we have more than one element left in the repeat count,
15761 and we have more than one element left in the target variable,
15762 then create a range assignment. */
15763 /* FIXME: Only done for full arrays for now, since array sections
15765 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
15766 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
15770 if (mpz_cmp (size
, values
.left
) >= 0)
15772 mpz_init_set (range
, values
.left
);
15773 mpz_sub (size
, size
, values
.left
);
15774 mpz_set_ui (values
.left
, 0);
15778 mpz_init_set (range
, size
);
15779 mpz_sub (values
.left
, values
.left
, size
);
15780 mpz_set_ui (size
, 0);
15783 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15786 mpz_add (offset
, offset
, range
);
15793 /* Assign initial value to symbol. */
15796 mpz_sub_ui (values
.left
, values
.left
, 1);
15797 mpz_sub_ui (size
, size
, 1);
15799 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15804 if (mark
== AR_FULL
)
15805 mpz_add_ui (offset
, offset
, 1);
15807 /* Modify the array section indexes and recalculate the offset
15808 for next element. */
15809 else if (mark
== AR_SECTION
)
15810 gfc_advance_section (section_index
, ar
, &offset
);
15814 if (mark
== AR_SECTION
)
15816 for (i
= 0; i
< ar
->dimen
; i
++)
15817 mpz_clear (section_index
[i
]);
15821 mpz_clear (offset
);
15827 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15829 /* Iterate over a list of elements in a DATA statement. */
15832 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15835 iterator_stack frame
;
15836 gfc_expr
*e
, *start
, *end
, *step
;
15837 bool retval
= true;
15839 mpz_init (frame
.value
);
15842 start
= gfc_copy_expr (var
->iter
.start
);
15843 end
= gfc_copy_expr (var
->iter
.end
);
15844 step
= gfc_copy_expr (var
->iter
.step
);
15846 if (!gfc_simplify_expr (start
, 1)
15847 || start
->expr_type
!= EXPR_CONSTANT
)
15849 gfc_error ("start of implied-do loop at %L could not be "
15850 "simplified to a constant value", &start
->where
);
15854 if (!gfc_simplify_expr (end
, 1)
15855 || end
->expr_type
!= EXPR_CONSTANT
)
15857 gfc_error ("end of implied-do loop at %L could not be "
15858 "simplified to a constant value", &start
->where
);
15862 if (!gfc_simplify_expr (step
, 1)
15863 || step
->expr_type
!= EXPR_CONSTANT
)
15865 gfc_error ("step of implied-do loop at %L could not be "
15866 "simplified to a constant value", &start
->where
);
15871 mpz_set (trip
, end
->value
.integer
);
15872 mpz_sub (trip
, trip
, start
->value
.integer
);
15873 mpz_add (trip
, trip
, step
->value
.integer
);
15875 mpz_div (trip
, trip
, step
->value
.integer
);
15877 mpz_set (frame
.value
, start
->value
.integer
);
15879 frame
.prev
= iter_stack
;
15880 frame
.variable
= var
->iter
.var
->symtree
;
15881 iter_stack
= &frame
;
15883 while (mpz_cmp_ui (trip
, 0) > 0)
15885 if (!traverse_data_var (var
->list
, where
))
15891 e
= gfc_copy_expr (var
->expr
);
15892 if (!gfc_simplify_expr (e
, 1))
15899 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15901 mpz_sub_ui (trip
, trip
, 1);
15905 mpz_clear (frame
.value
);
15908 gfc_free_expr (start
);
15909 gfc_free_expr (end
);
15910 gfc_free_expr (step
);
15912 iter_stack
= frame
.prev
;
15917 /* Type resolve variables in the variable list of a DATA statement. */
15920 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15924 for (; var
; var
= var
->next
)
15926 if (var
->expr
== NULL
)
15927 t
= traverse_data_list (var
, where
);
15929 t
= check_data_variable (var
, where
);
15939 /* Resolve the expressions and iterators associated with a data statement.
15940 This is separate from the assignment checking because data lists should
15941 only be resolved once. */
15944 resolve_data_variables (gfc_data_variable
*d
)
15946 for (; d
; d
= d
->next
)
15948 if (d
->list
== NULL
)
15950 if (!gfc_resolve_expr (d
->expr
))
15955 if (!gfc_resolve_iterator (&d
->iter
, false, true))
15958 if (!resolve_data_variables (d
->list
))
15967 /* Resolve a single DATA statement. We implement this by storing a pointer to
15968 the value list into static variables, and then recursively traversing the
15969 variables list, expanding iterators and such. */
15972 resolve_data (gfc_data
*d
)
15975 if (!resolve_data_variables (d
->var
))
15978 values
.vnode
= d
->value
;
15979 if (d
->value
== NULL
)
15980 mpz_set_ui (values
.left
, 0);
15982 mpz_set (values
.left
, d
->value
->repeat
);
15984 if (!traverse_data_var (d
->var
, &d
->where
))
15987 /* At this point, we better not have any values left. */
15989 if (next_data_value ())
15990 gfc_error ("DATA statement at %L has more values than variables",
15995 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15996 accessed by host or use association, is a dummy argument to a pure function,
15997 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15998 is storage associated with any such variable, shall not be used in the
15999 following contexts: (clients of this function). */
16001 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
16002 procedure. Returns zero if assignment is OK, nonzero if there is a
16005 gfc_impure_variable (gfc_symbol
*sym
)
16010 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
16013 /* Check if the symbol's ns is inside the pure procedure. */
16014 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16018 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
16022 proc
= sym
->ns
->proc_name
;
16023 if (sym
->attr
.dummy
16024 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
16025 || proc
->attr
.function
))
16028 /* TODO: Sort out what can be storage associated, if anything, and include
16029 it here. In principle equivalences should be scanned but it does not
16030 seem to be possible to storage associate an impure variable this way. */
16035 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
16036 current namespace is inside a pure procedure. */
16039 gfc_pure (gfc_symbol
*sym
)
16041 symbol_attribute attr
;
16046 /* Check if the current namespace or one of its parents
16047 belongs to a pure procedure. */
16048 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16050 sym
= ns
->proc_name
;
16054 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
16062 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
16066 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16067 checks if the current namespace is implicitly pure. Note that this
16068 function returns false for a PURE procedure. */
16071 gfc_implicit_pure (gfc_symbol
*sym
)
16077 /* Check if the current procedure is implicit_pure. Walk up
16078 the procedure list until we find a procedure. */
16079 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16081 sym
= ns
->proc_name
;
16085 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16090 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
16091 && !sym
->attr
.pure
;
16096 gfc_unset_implicit_pure (gfc_symbol
*sym
)
16102 /* Check if the current procedure is implicit_pure. Walk up
16103 the procedure list until we find a procedure. */
16104 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16106 sym
= ns
->proc_name
;
16110 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16115 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16116 sym
->attr
.implicit_pure
= 0;
16118 sym
->attr
.pure
= 0;
16122 /* Test whether the current procedure is elemental or not. */
16125 gfc_elemental (gfc_symbol
*sym
)
16127 symbol_attribute attr
;
16130 sym
= gfc_current_ns
->proc_name
;
16135 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
16139 /* Warn about unused labels. */
16142 warn_unused_fortran_label (gfc_st_label
*label
)
16147 warn_unused_fortran_label (label
->left
);
16149 if (label
->defined
== ST_LABEL_UNKNOWN
)
16152 switch (label
->referenced
)
16154 case ST_LABEL_UNKNOWN
:
16155 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
16156 label
->value
, &label
->where
);
16159 case ST_LABEL_BAD_TARGET
:
16160 gfc_warning (OPT_Wunused_label
,
16161 "Label %d at %L defined but cannot be used",
16162 label
->value
, &label
->where
);
16169 warn_unused_fortran_label (label
->right
);
16173 /* Returns the sequence type of a symbol or sequence. */
16176 sequence_type (gfc_typespec ts
)
16185 if (ts
.u
.derived
->components
== NULL
)
16186 return SEQ_NONDEFAULT
;
16188 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16189 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16190 if (sequence_type (c
->ts
) != result
)
16196 if (ts
.kind
!= gfc_default_character_kind
)
16197 return SEQ_NONDEFAULT
;
16199 return SEQ_CHARACTER
;
16202 if (ts
.kind
!= gfc_default_integer_kind
)
16203 return SEQ_NONDEFAULT
;
16205 return SEQ_NUMERIC
;
16208 if (!(ts
.kind
== gfc_default_real_kind
16209 || ts
.kind
== gfc_default_double_kind
))
16210 return SEQ_NONDEFAULT
;
16212 return SEQ_NUMERIC
;
16215 if (ts
.kind
!= gfc_default_complex_kind
)
16216 return SEQ_NONDEFAULT
;
16218 return SEQ_NUMERIC
;
16221 if (ts
.kind
!= gfc_default_logical_kind
)
16222 return SEQ_NONDEFAULT
;
16224 return SEQ_NUMERIC
;
16227 return SEQ_NONDEFAULT
;
16232 /* Resolve derived type EQUIVALENCE object. */
16235 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
16237 gfc_component
*c
= derived
->components
;
16242 /* Shall not be an object of nonsequence derived type. */
16243 if (!derived
->attr
.sequence
)
16245 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16246 "attribute to be an EQUIVALENCE object", sym
->name
,
16251 /* Shall not have allocatable components. */
16252 if (derived
->attr
.alloc_comp
)
16254 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16255 "components to be an EQUIVALENCE object",sym
->name
,
16260 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
16262 gfc_error ("Derived type variable %qs at %L with default "
16263 "initialization cannot be in EQUIVALENCE with a variable "
16264 "in COMMON", sym
->name
, &e
->where
);
16268 for (; c
; c
= c
->next
)
16270 if (gfc_bt_struct (c
->ts
.type
)
16271 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
16274 /* Shall not be an object of sequence derived type containing a pointer
16275 in the structure. */
16276 if (c
->attr
.pointer
)
16278 gfc_error ("Derived type variable %qs at %L with pointer "
16279 "component(s) cannot be an EQUIVALENCE object",
16280 sym
->name
, &e
->where
);
16288 /* Resolve equivalence object.
16289 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16290 an allocatable array, an object of nonsequence derived type, an object of
16291 sequence derived type containing a pointer at any level of component
16292 selection, an automatic object, a function name, an entry name, a result
16293 name, a named constant, a structure component, or a subobject of any of
16294 the preceding objects. A substring shall not have length zero. A
16295 derived type shall not have components with default initialization nor
16296 shall two objects of an equivalence group be initialized.
16297 Either all or none of the objects shall have an protected attribute.
16298 The simple constraints are done in symbol.c(check_conflict) and the rest
16299 are implemented here. */
16302 resolve_equivalence (gfc_equiv
*eq
)
16305 gfc_symbol
*first_sym
;
16308 locus
*last_where
= NULL
;
16309 seq_type eq_type
, last_eq_type
;
16310 gfc_typespec
*last_ts
;
16311 int object
, cnt_protected
;
16314 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16316 first_sym
= eq
->expr
->symtree
->n
.sym
;
16320 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16324 e
->ts
= e
->symtree
->n
.sym
->ts
;
16325 /* match_varspec might not know yet if it is seeing
16326 array reference or substring reference, as it doesn't
16328 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16330 gfc_ref
*ref
= e
->ref
;
16331 sym
= e
->symtree
->n
.sym
;
16333 if (sym
->attr
.dimension
)
16335 ref
->u
.ar
.as
= sym
->as
;
16339 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16340 if (e
->ts
.type
== BT_CHARACTER
16342 && ref
->type
== REF_ARRAY
16343 && ref
->u
.ar
.dimen
== 1
16344 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16345 && ref
->u
.ar
.stride
[0] == NULL
)
16347 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16348 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16351 /* Optimize away the (:) reference. */
16352 if (start
== NULL
&& end
== NULL
)
16355 e
->ref
= ref
->next
;
16357 e
->ref
->next
= ref
->next
;
16362 ref
->type
= REF_SUBSTRING
;
16364 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16366 ref
->u
.ss
.start
= start
;
16367 if (end
== NULL
&& e
->ts
.u
.cl
)
16368 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16369 ref
->u
.ss
.end
= end
;
16370 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16377 /* Any further ref is an error. */
16380 gcc_assert (ref
->type
== REF_ARRAY
);
16381 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16387 if (!gfc_resolve_expr (e
))
16390 sym
= e
->symtree
->n
.sym
;
16392 if (sym
->attr
.is_protected
)
16394 if (cnt_protected
> 0 && cnt_protected
!= object
)
16396 gfc_error ("Either all or none of the objects in the "
16397 "EQUIVALENCE set at %L shall have the "
16398 "PROTECTED attribute",
16403 /* Shall not equivalence common block variables in a PURE procedure. */
16404 if (sym
->ns
->proc_name
16405 && sym
->ns
->proc_name
->attr
.pure
16406 && sym
->attr
.in_common
)
16408 /* Need to check for symbols that may have entered the pure
16409 procedure via a USE statement. */
16410 bool saw_sym
= false;
16411 if (sym
->ns
->use_stmts
)
16414 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16415 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16421 gfc_error ("COMMON block member %qs at %L cannot be an "
16422 "EQUIVALENCE object in the pure procedure %qs",
16423 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16427 /* Shall not be a named constant. */
16428 if (e
->expr_type
== EXPR_CONSTANT
)
16430 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16431 "object", sym
->name
, &e
->where
);
16435 if (e
->ts
.type
== BT_DERIVED
16436 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16439 /* Check that the types correspond correctly:
16441 A numeric sequence structure may be equivalenced to another sequence
16442 structure, an object of default integer type, default real type, double
16443 precision real type, default logical type such that components of the
16444 structure ultimately only become associated to objects of the same
16445 kind. A character sequence structure may be equivalenced to an object
16446 of default character kind or another character sequence structure.
16447 Other objects may be equivalenced only to objects of the same type and
16448 kind parameters. */
16450 /* Identical types are unconditionally OK. */
16451 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16452 goto identical_types
;
16454 last_eq_type
= sequence_type (*last_ts
);
16455 eq_type
= sequence_type (sym
->ts
);
16457 /* Since the pair of objects is not of the same type, mixed or
16458 non-default sequences can be rejected. */
16460 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16461 "statement at %L with different type objects";
16463 && last_eq_type
== SEQ_MIXED
16464 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16465 || (eq_type
== SEQ_MIXED
16466 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16469 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16470 "statement at %L with objects of different type";
16472 && last_eq_type
== SEQ_NONDEFAULT
16473 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16474 || (eq_type
== SEQ_NONDEFAULT
16475 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16478 msg
="Non-CHARACTER object %qs in default CHARACTER "
16479 "EQUIVALENCE statement at %L";
16480 if (last_eq_type
== SEQ_CHARACTER
16481 && eq_type
!= SEQ_CHARACTER
16482 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16485 msg
="Non-NUMERIC object %qs in default NUMERIC "
16486 "EQUIVALENCE statement at %L";
16487 if (last_eq_type
== SEQ_NUMERIC
16488 && eq_type
!= SEQ_NUMERIC
16489 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16494 last_where
= &e
->where
;
16499 /* Shall not be an automatic array. */
16500 if (e
->ref
->type
== REF_ARRAY
16501 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16503 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16504 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16511 /* Shall not be a structure component. */
16512 if (r
->type
== REF_COMPONENT
)
16514 gfc_error ("Structure component %qs at %L cannot be an "
16515 "EQUIVALENCE object",
16516 r
->u
.c
.component
->name
, &e
->where
);
16520 /* A substring shall not have length zero. */
16521 if (r
->type
== REF_SUBSTRING
)
16523 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16525 gfc_error ("Substring at %L has length zero",
16526 &r
->u
.ss
.start
->where
);
16536 /* Function called by resolve_fntype to flag other symbol used in the
16537 length type parameter specification of function resuls. */
16540 flag_fn_result_spec (gfc_expr
*expr
,
16542 int *f ATTRIBUTE_UNUSED
)
16547 if (expr
->expr_type
== EXPR_VARIABLE
)
16549 s
= expr
->symtree
->n
.sym
;
16550 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16556 gfc_error ("Self reference in character length expression "
16557 "for %qs at %L", sym
->name
, &expr
->where
);
16561 if (!s
->fn_result_spec
16562 && s
->attr
.flavor
== FL_PARAMETER
)
16564 /* Function contained in a module.... */
16565 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16568 s
->fn_result_spec
= 1;
16569 /* Make sure that this symbol is translated as a module
16571 st
= gfc_get_unique_symtree (ns
);
16575 /* ... which is use associated and called. */
16576 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16578 /* External function matched with an interface. */
16581 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16582 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16583 && s
->ns
->proc_name
->attr
.function
))
16584 s
->fn_result_spec
= 1;
16591 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16594 resolve_fntype (gfc_namespace
*ns
)
16596 gfc_entry_list
*el
;
16599 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16602 /* If there are any entries, ns->proc_name is the entry master
16603 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16605 sym
= ns
->entries
->sym
;
16607 sym
= ns
->proc_name
;
16608 if (sym
->result
== sym
16609 && sym
->ts
.type
== BT_UNKNOWN
16610 && !gfc_set_default_type (sym
, 0, NULL
)
16611 && !sym
->attr
.untyped
)
16613 gfc_error ("Function %qs at %L has no IMPLICIT type",
16614 sym
->name
, &sym
->declared_at
);
16615 sym
->attr
.untyped
= 1;
16618 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16619 && !sym
->attr
.contained
16620 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16621 && gfc_check_symbol_access (sym
))
16623 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16624 "%L of PRIVATE type %qs", sym
->name
,
16625 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16629 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16631 if (el
->sym
->result
== el
->sym
16632 && el
->sym
->ts
.type
== BT_UNKNOWN
16633 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16634 && !el
->sym
->attr
.untyped
)
16636 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16637 el
->sym
->name
, &el
->sym
->declared_at
);
16638 el
->sym
->attr
.untyped
= 1;
16642 if (sym
->ts
.type
== BT_CHARACTER
)
16643 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16647 /* 12.3.2.1.1 Defined operators. */
16650 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16652 gfc_formal_arglist
*formal
;
16654 if (!sym
->attr
.function
)
16656 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16657 sym
->name
, &where
);
16661 if (sym
->ts
.type
== BT_CHARACTER
16662 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16663 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16664 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16666 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16667 "character length", sym
->name
, &where
);
16671 formal
= gfc_sym_get_dummy_args (sym
);
16672 if (!formal
|| !formal
->sym
)
16674 gfc_error ("User operator procedure %qs at %L must have at least "
16675 "one argument", sym
->name
, &where
);
16679 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16681 gfc_error ("First argument of operator interface at %L must be "
16682 "INTENT(IN)", &where
);
16686 if (formal
->sym
->attr
.optional
)
16688 gfc_error ("First argument of operator interface at %L cannot be "
16689 "optional", &where
);
16693 formal
= formal
->next
;
16694 if (!formal
|| !formal
->sym
)
16697 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16699 gfc_error ("Second argument of operator interface at %L must be "
16700 "INTENT(IN)", &where
);
16704 if (formal
->sym
->attr
.optional
)
16706 gfc_error ("Second argument of operator interface at %L cannot be "
16707 "optional", &where
);
16713 gfc_error ("Operator interface at %L must have, at most, two "
16714 "arguments", &where
);
16722 gfc_resolve_uops (gfc_symtree
*symtree
)
16724 gfc_interface
*itr
;
16726 if (symtree
== NULL
)
16729 gfc_resolve_uops (symtree
->left
);
16730 gfc_resolve_uops (symtree
->right
);
16732 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16733 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16737 /* Examine all of the expressions associated with a program unit,
16738 assign types to all intermediate expressions, make sure that all
16739 assignments are to compatible types and figure out which names
16740 refer to which functions or subroutines. It doesn't check code
16741 block, which is handled by gfc_resolve_code. */
16744 resolve_types (gfc_namespace
*ns
)
16750 gfc_namespace
* old_ns
= gfc_current_ns
;
16752 if (ns
->types_resolved
)
16755 /* Check that all IMPLICIT types are ok. */
16756 if (!ns
->seen_implicit_none
)
16759 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
16760 if (ns
->set_flag
[letter
]
16761 && !resolve_typespec_used (&ns
->default_type
[letter
],
16762 &ns
->implicit_loc
[letter
], NULL
))
16766 gfc_current_ns
= ns
;
16768 resolve_entries (ns
);
16770 resolve_common_vars (&ns
->blank_common
, false);
16771 resolve_common_blocks (ns
->common_root
);
16773 resolve_contained_functions (ns
);
16775 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
16776 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16777 resolve_formal_arglist (ns
->proc_name
);
16779 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
16781 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
16782 resolve_charlen (cl
);
16784 gfc_traverse_ns (ns
, resolve_symbol
);
16786 resolve_fntype (ns
);
16788 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16790 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
16791 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16792 "also be PURE", n
->proc_name
->name
,
16793 &n
->proc_name
->declared_at
);
16799 gfc_do_concurrent_flag
= 0;
16800 gfc_check_interfaces (ns
);
16802 gfc_traverse_ns (ns
, resolve_values
);
16804 if (ns
->save_all
|| !flag_automatic
)
16808 for (d
= ns
->data
; d
; d
= d
->next
)
16812 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16814 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16816 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16817 resolve_equivalence (eq
);
16819 /* Warn about unused labels. */
16820 if (warn_unused_label
)
16821 warn_unused_fortran_label (ns
->st_labels
);
16823 gfc_resolve_uops (ns
->uop_root
);
16825 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16827 gfc_resolve_omp_declare_simd (ns
);
16829 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16831 ns
->types_resolved
= 1;
16833 gfc_current_ns
= old_ns
;
16837 /* Call gfc_resolve_code recursively. */
16840 resolve_codes (gfc_namespace
*ns
)
16843 bitmap_obstack old_obstack
;
16845 if (ns
->resolved
== 1)
16848 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16851 gfc_current_ns
= ns
;
16853 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16854 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16857 /* Set to an out of range value. */
16858 current_entry_id
= -1;
16860 old_obstack
= labels_obstack
;
16861 bitmap_obstack_initialize (&labels_obstack
);
16863 gfc_resolve_oacc_declare (ns
);
16864 gfc_resolve_oacc_routines (ns
);
16865 gfc_resolve_omp_local_vars (ns
);
16866 gfc_resolve_code (ns
->code
, ns
);
16868 bitmap_obstack_release (&labels_obstack
);
16869 labels_obstack
= old_obstack
;
16873 /* This function is called after a complete program unit has been compiled.
16874 Its purpose is to examine all of the expressions associated with a program
16875 unit, assign types to all intermediate expressions, make sure that all
16876 assignments are to compatible types and figure out which names refer to
16877 which functions or subroutines. */
16880 gfc_resolve (gfc_namespace
*ns
)
16882 gfc_namespace
*old_ns
;
16883 code_stack
*old_cs_base
;
16884 struct gfc_omp_saved_state old_omp_state
;
16890 old_ns
= gfc_current_ns
;
16891 old_cs_base
= cs_base
;
16893 /* As gfc_resolve can be called during resolution of an OpenMP construct
16894 body, we should clear any state associated to it, so that say NS's
16895 DO loops are not interpreted as OpenMP loops. */
16896 if (!ns
->construct_entities
)
16897 gfc_omp_save_and_clear_state (&old_omp_state
);
16899 resolve_types (ns
);
16900 component_assignment_level
= 0;
16901 resolve_codes (ns
);
16903 gfc_current_ns
= old_ns
;
16904 cs_base
= old_cs_base
;
16907 gfc_run_passes (ns
);
16909 if (!ns
->construct_entities
)
16910 gfc_omp_restore_state (&old_omp_state
);