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 (0, "Interface mismatch for procedure-pointer "
1433 "component %qs in structure constructor at %L:"
1434 " %s", comp
->name
, &cons
->expr
->where
, err
);
1439 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1440 || cons
->expr
->expr_type
== EXPR_NULL
)
1443 a
= gfc_expr_attr (cons
->expr
);
1445 if (!a
.pointer
&& !a
.target
)
1448 gfc_error ("The element in the structure constructor at %L, "
1449 "for pointer component %qs should be a POINTER or "
1450 "a TARGET", &cons
->expr
->where
, comp
->name
);
1455 /* F08:C461. Additional checks for pointer initialization. */
1459 gfc_error ("Pointer initialization target at %L "
1460 "must not be ALLOCATABLE", &cons
->expr
->where
);
1465 gfc_error ("Pointer initialization target at %L "
1466 "must have the SAVE attribute", &cons
->expr
->where
);
1470 /* F2003, C1272 (3). */
1471 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1472 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1473 || gfc_is_coindexed (cons
->expr
));
1474 if (impure
&& gfc_pure (NULL
))
1477 gfc_error ("Invalid expression in the structure constructor for "
1478 "pointer component %qs at %L in PURE procedure",
1479 comp
->name
, &cons
->expr
->where
);
1483 gfc_unset_implicit_pure (NULL
);
1490 /****************** Expression name resolution ******************/
1492 /* Returns 0 if a symbol was not declared with a type or
1493 attribute declaration statement, nonzero otherwise. */
1496 was_declared (gfc_symbol
*sym
)
1502 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1505 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1506 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1507 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1508 || a
.asynchronous
|| a
.codimension
)
1515 /* Determine if a symbol is generic or not. */
1518 generic_sym (gfc_symbol
*sym
)
1522 if (sym
->attr
.generic
||
1523 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1526 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1529 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1536 return generic_sym (s
);
1543 /* Determine if a symbol is specific or not. */
1546 specific_sym (gfc_symbol
*sym
)
1550 if (sym
->attr
.if_source
== IFSRC_IFBODY
1551 || sym
->attr
.proc
== PROC_MODULE
1552 || sym
->attr
.proc
== PROC_INTERNAL
1553 || sym
->attr
.proc
== PROC_ST_FUNCTION
1554 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1555 || sym
->attr
.external
)
1558 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1561 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1563 return (s
== NULL
) ? 0 : specific_sym (s
);
1567 /* Figure out if the procedure is specific, generic or unknown. */
1570 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1573 procedure_kind (gfc_symbol
*sym
)
1575 if (generic_sym (sym
))
1576 return PTYPE_GENERIC
;
1578 if (specific_sym (sym
))
1579 return PTYPE_SPECIFIC
;
1581 return PTYPE_UNKNOWN
;
1584 /* Check references to assumed size arrays. The flag need_full_assumed_size
1585 is nonzero when matching actual arguments. */
1587 static int need_full_assumed_size
= 0;
1590 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1592 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1595 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1596 What should it be? */
1597 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1598 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1599 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1601 gfc_error ("The upper bound in the last dimension must "
1602 "appear in the reference to the assumed size "
1603 "array %qs at %L", sym
->name
, &e
->where
);
1610 /* Look for bad assumed size array references in argument expressions
1611 of elemental and array valued intrinsic procedures. Since this is
1612 called from procedure resolution functions, it only recurses at
1616 resolve_assumed_size_actual (gfc_expr
*e
)
1621 switch (e
->expr_type
)
1624 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1629 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1630 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1641 /* Check a generic procedure, passed as an actual argument, to see if
1642 there is a matching specific name. If none, it is an error, and if
1643 more than one, the reference is ambiguous. */
1645 count_specific_procs (gfc_expr
*e
)
1652 sym
= e
->symtree
->n
.sym
;
1654 for (p
= sym
->generic
; p
; p
= p
->next
)
1655 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1657 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1663 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1667 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1668 "argument at %L", sym
->name
, &e
->where
);
1674 /* See if a call to sym could possibly be a not allowed RECURSION because of
1675 a missing RECURSIVE declaration. This means that either sym is the current
1676 context itself, or sym is the parent of a contained procedure calling its
1677 non-RECURSIVE containing procedure.
1678 This also works if sym is an ENTRY. */
1681 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1683 gfc_symbol
* proc_sym
;
1684 gfc_symbol
* context_proc
;
1685 gfc_namespace
* real_context
;
1687 if (sym
->attr
.flavor
== FL_PROGRAM
1688 || gfc_fl_struct (sym
->attr
.flavor
))
1691 /* If we've got an ENTRY, find real procedure. */
1692 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1693 proc_sym
= sym
->ns
->entries
->sym
;
1697 /* If sym is RECURSIVE, all is well of course. */
1698 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1701 /* Find the context procedure's "real" symbol if it has entries.
1702 We look for a procedure symbol, so recurse on the parents if we don't
1703 find one (like in case of a BLOCK construct). */
1704 for (real_context
= context
; ; real_context
= real_context
->parent
)
1706 /* We should find something, eventually! */
1707 gcc_assert (real_context
);
1709 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1710 : real_context
->proc_name
);
1712 /* In some special cases, there may not be a proc_name, like for this
1714 real(bad_kind()) function foo () ...
1715 when checking the call to bad_kind ().
1716 In these cases, we simply return here and assume that the
1721 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1725 /* A call from sym's body to itself is recursion, of course. */
1726 if (context_proc
== proc_sym
)
1729 /* The same is true if context is a contained procedure and sym the
1731 if (context_proc
->attr
.contained
)
1733 gfc_symbol
* parent_proc
;
1735 gcc_assert (context
->parent
);
1736 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1737 : context
->parent
->proc_name
);
1739 if (parent_proc
== proc_sym
)
1747 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1748 its typespec and formal argument list. */
1751 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1753 gfc_intrinsic_sym
* isym
= NULL
;
1759 /* Already resolved. */
1760 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1763 /* We already know this one is an intrinsic, so we don't call
1764 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1765 gfc_find_subroutine directly to check whether it is a function or
1768 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1770 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1771 isym
= gfc_intrinsic_subroutine_by_id (id
);
1773 else if (sym
->intmod_sym_id
)
1775 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1776 isym
= gfc_intrinsic_function_by_id (id
);
1778 else if (!sym
->attr
.subroutine
)
1779 isym
= gfc_find_function (sym
->name
);
1781 if (isym
&& !sym
->attr
.subroutine
)
1783 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1784 && !sym
->attr
.implicit_type
)
1785 gfc_warning (OPT_Wsurprising
,
1786 "Type specified for intrinsic function %qs at %L is"
1787 " ignored", sym
->name
, &sym
->declared_at
);
1789 if (!sym
->attr
.function
&&
1790 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1795 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1797 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1799 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1800 " specifier", sym
->name
, &sym
->declared_at
);
1804 if (!sym
->attr
.subroutine
&&
1805 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1810 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1815 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1817 sym
->attr
.pure
= isym
->pure
;
1818 sym
->attr
.elemental
= isym
->elemental
;
1820 /* Check it is actually available in the standard settings. */
1821 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1823 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1824 "available in the current standard settings but %s. Use "
1825 "an appropriate %<-std=*%> option or enable "
1826 "%<-fall-intrinsics%> in order to use it.",
1827 sym
->name
, &sym
->declared_at
, symstd
);
1835 /* Resolve a procedure expression, like passing it to a called procedure or as
1836 RHS for a procedure pointer assignment. */
1839 resolve_procedure_expression (gfc_expr
* expr
)
1843 if (expr
->expr_type
!= EXPR_VARIABLE
)
1845 gcc_assert (expr
->symtree
);
1847 sym
= expr
->symtree
->n
.sym
;
1849 if (sym
->attr
.intrinsic
)
1850 gfc_resolve_intrinsic (sym
, &expr
->where
);
1852 if (sym
->attr
.flavor
!= FL_PROCEDURE
1853 || (sym
->attr
.function
&& sym
->result
== sym
))
1856 /* A non-RECURSIVE procedure that is used as procedure expression within its
1857 own body is in danger of being called recursively. */
1858 if (is_illegal_recursion (sym
, gfc_current_ns
))
1859 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1860 " itself recursively. Declare it RECURSIVE or use"
1861 " %<-frecursive%>", sym
->name
, &expr
->where
);
1867 /* Check that name is not a derived type. */
1870 is_dt_name (const char *name
)
1872 gfc_symbol
*dt_list
, *dt_first
;
1874 dt_list
= dt_first
= gfc_derived_types
;
1875 for (; dt_list
; dt_list
= dt_list
->dt_next
)
1877 if (strcmp(dt_list
->name
, name
) == 0)
1879 if (dt_first
== dt_list
->dt_next
)
1886 /* Resolve an actual argument list. Most of the time, this is just
1887 resolving the expressions in the list.
1888 The exception is that we sometimes have to decide whether arguments
1889 that look like procedure arguments are really simple variable
1893 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1894 bool no_formal_args
)
1897 gfc_symtree
*parent_st
;
1899 gfc_component
*comp
;
1900 int save_need_full_assumed_size
;
1901 bool return_value
= false;
1902 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1905 first_actual_arg
= true;
1907 for (; arg
; arg
= arg
->next
)
1912 /* Check the label is a valid branching target. */
1915 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1917 gfc_error ("Label %d referenced at %L is never defined",
1918 arg
->label
->value
, &arg
->label
->where
);
1922 first_actual_arg
= false;
1926 if (e
->expr_type
== EXPR_VARIABLE
1927 && e
->symtree
->n
.sym
->attr
.generic
1929 && count_specific_procs (e
) != 1)
1932 if (e
->ts
.type
!= BT_PROCEDURE
)
1934 save_need_full_assumed_size
= need_full_assumed_size
;
1935 if (e
->expr_type
!= EXPR_VARIABLE
)
1936 need_full_assumed_size
= 0;
1937 if (!gfc_resolve_expr (e
))
1939 need_full_assumed_size
= save_need_full_assumed_size
;
1943 /* See if the expression node should really be a variable reference. */
1945 sym
= e
->symtree
->n
.sym
;
1947 if (sym
->attr
.flavor
== FL_PROCEDURE
&& is_dt_name (sym
->name
))
1949 gfc_error ("Derived type %qs is used as an actual "
1950 "argument at %L", sym
->name
, &e
->where
);
1954 if (sym
->attr
.flavor
== FL_PROCEDURE
1955 || sym
->attr
.intrinsic
1956 || sym
->attr
.external
)
1960 /* If a procedure is not already determined to be something else
1961 check if it is intrinsic. */
1962 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1963 sym
->attr
.intrinsic
= 1;
1965 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1967 gfc_error ("Statement function %qs at %L is not allowed as an "
1968 "actual argument", sym
->name
, &e
->where
);
1971 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1972 sym
->attr
.subroutine
);
1973 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1975 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1976 "actual argument", sym
->name
, &e
->where
);
1979 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1980 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1982 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1983 " used as actual argument at %L",
1984 sym
->name
, &e
->where
))
1988 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1990 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1991 "allowed as an actual argument at %L", sym
->name
,
1995 /* Check if a generic interface has a specific procedure
1996 with the same name before emitting an error. */
1997 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
2000 /* Just in case a specific was found for the expression. */
2001 sym
= e
->symtree
->n
.sym
;
2003 /* If the symbol is the function that names the current (or
2004 parent) scope, then we really have a variable reference. */
2006 if (gfc_is_function_return_value (sym
, sym
->ns
))
2009 /* If all else fails, see if we have a specific intrinsic. */
2010 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
2012 gfc_intrinsic_sym
*isym
;
2014 isym
= gfc_find_function (sym
->name
);
2015 if (isym
== NULL
|| !isym
->specific
)
2017 gfc_error ("Unable to find a specific INTRINSIC procedure "
2018 "for the reference %qs at %L", sym
->name
,
2023 sym
->attr
.intrinsic
= 1;
2024 sym
->attr
.function
= 1;
2027 if (!gfc_resolve_expr (e
))
2032 /* See if the name is a module procedure in a parent unit. */
2034 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2037 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2039 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2043 if (parent_st
== NULL
)
2046 sym
= parent_st
->n
.sym
;
2047 e
->symtree
= parent_st
; /* Point to the right thing. */
2049 if (sym
->attr
.flavor
== FL_PROCEDURE
2050 || sym
->attr
.intrinsic
2051 || sym
->attr
.external
)
2053 if (!gfc_resolve_expr (e
))
2059 e
->expr_type
= EXPR_VARIABLE
;
2061 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2062 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2063 && CLASS_DATA (sym
)->as
))
2065 e
->rank
= sym
->ts
.type
== BT_CLASS
2066 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2067 e
->ref
= gfc_get_ref ();
2068 e
->ref
->type
= REF_ARRAY
;
2069 e
->ref
->u
.ar
.type
= AR_FULL
;
2070 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2071 ? CLASS_DATA (sym
)->as
: sym
->as
;
2074 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2075 primary.c (match_actual_arg). If above code determines that it
2076 is a variable instead, it needs to be resolved as it was not
2077 done at the beginning of this function. */
2078 save_need_full_assumed_size
= need_full_assumed_size
;
2079 if (e
->expr_type
!= EXPR_VARIABLE
)
2080 need_full_assumed_size
= 0;
2081 if (!gfc_resolve_expr (e
))
2083 need_full_assumed_size
= save_need_full_assumed_size
;
2086 /* Check argument list functions %VAL, %LOC and %REF. There is
2087 nothing to do for %REF. */
2088 if (arg
->name
&& arg
->name
[0] == '%')
2090 if (strcmp ("%VAL", arg
->name
) == 0)
2092 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2094 gfc_error ("By-value argument at %L is not of numeric "
2101 gfc_error ("By-value argument at %L cannot be an array or "
2102 "an array section", &e
->where
);
2106 /* Intrinsics are still PROC_UNKNOWN here. However,
2107 since same file external procedures are not resolvable
2108 in gfortran, it is a good deal easier to leave them to
2110 if (ptype
!= PROC_UNKNOWN
2111 && ptype
!= PROC_DUMMY
2112 && ptype
!= PROC_EXTERNAL
2113 && ptype
!= PROC_MODULE
)
2115 gfc_error ("By-value argument at %L is not allowed "
2116 "in this context", &e
->where
);
2121 /* Statement functions have already been excluded above. */
2122 else if (strcmp ("%LOC", arg
->name
) == 0
2123 && e
->ts
.type
== BT_PROCEDURE
)
2125 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2127 gfc_error ("Passing internal procedure at %L by location "
2128 "not allowed", &e
->where
);
2134 comp
= gfc_get_proc_ptr_comp(e
);
2135 if (e
->expr_type
== EXPR_VARIABLE
2136 && comp
&& comp
->attr
.elemental
)
2138 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2139 "allowed as an actual argument at %L", comp
->name
,
2143 /* Fortran 2008, C1237. */
2144 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2145 && gfc_has_ultimate_pointer (e
))
2147 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2148 "component", &e
->where
);
2152 first_actual_arg
= false;
2155 return_value
= true;
2158 actual_arg
= actual_arg_sav
;
2159 first_actual_arg
= first_actual_arg_sav
;
2161 return return_value
;
2165 /* Do the checks of the actual argument list that are specific to elemental
2166 procedures. If called with c == NULL, we have a function, otherwise if
2167 expr == NULL, we have a subroutine. */
2170 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2172 gfc_actual_arglist
*arg0
;
2173 gfc_actual_arglist
*arg
;
2174 gfc_symbol
*esym
= NULL
;
2175 gfc_intrinsic_sym
*isym
= NULL
;
2177 gfc_intrinsic_arg
*iformal
= NULL
;
2178 gfc_formal_arglist
*eformal
= NULL
;
2179 bool formal_optional
= false;
2180 bool set_by_optional
= false;
2184 /* Is this an elemental procedure? */
2185 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2187 if (expr
->value
.function
.esym
!= NULL
2188 && expr
->value
.function
.esym
->attr
.elemental
)
2190 arg0
= expr
->value
.function
.actual
;
2191 esym
= expr
->value
.function
.esym
;
2193 else if (expr
->value
.function
.isym
!= NULL
2194 && expr
->value
.function
.isym
->elemental
)
2196 arg0
= expr
->value
.function
.actual
;
2197 isym
= expr
->value
.function
.isym
;
2202 else if (c
&& c
->ext
.actual
!= NULL
)
2204 arg0
= c
->ext
.actual
;
2206 if (c
->resolved_sym
)
2207 esym
= c
->resolved_sym
;
2209 esym
= c
->symtree
->n
.sym
;
2212 if (!esym
->attr
.elemental
)
2218 /* The rank of an elemental is the rank of its array argument(s). */
2219 for (arg
= arg0
; arg
; arg
= arg
->next
)
2221 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2223 rank
= arg
->expr
->rank
;
2224 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2225 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2226 set_by_optional
= true;
2228 /* Function specific; set the result rank and shape. */
2232 if (!expr
->shape
&& arg
->expr
->shape
)
2234 expr
->shape
= gfc_get_shape (rank
);
2235 for (i
= 0; i
< rank
; i
++)
2236 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2243 /* If it is an array, it shall not be supplied as an actual argument
2244 to an elemental procedure unless an array of the same rank is supplied
2245 as an actual argument corresponding to a nonoptional dummy argument of
2246 that elemental procedure(12.4.1.5). */
2247 formal_optional
= false;
2249 iformal
= isym
->formal
;
2251 eformal
= esym
->formal
;
2253 for (arg
= arg0
; arg
; arg
= arg
->next
)
2257 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2258 formal_optional
= true;
2259 eformal
= eformal
->next
;
2261 else if (isym
&& iformal
)
2263 if (iformal
->optional
)
2264 formal_optional
= true;
2265 iformal
= iformal
->next
;
2268 formal_optional
= true;
2270 if (pedantic
&& arg
->expr
!= NULL
2271 && arg
->expr
->expr_type
== EXPR_VARIABLE
2272 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2275 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2276 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2278 gfc_warning (OPT_Wpedantic
,
2279 "%qs at %L is an array and OPTIONAL; IF IT IS "
2280 "MISSING, it cannot be the actual argument of an "
2281 "ELEMENTAL procedure unless there is a non-optional "
2282 "argument with the same rank (12.4.1.5)",
2283 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2287 for (arg
= arg0
; arg
; arg
= arg
->next
)
2289 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2292 /* Being elemental, the last upper bound of an assumed size array
2293 argument must be present. */
2294 if (resolve_assumed_size_actual (arg
->expr
))
2297 /* Elemental procedure's array actual arguments must conform. */
2300 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2307 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2308 is an array, the intent inout/out variable needs to be also an array. */
2309 if (rank
> 0 && esym
&& expr
== NULL
)
2310 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2311 arg
= arg
->next
, eformal
= eformal
->next
)
2312 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2313 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2314 && arg
->expr
&& arg
->expr
->rank
== 0)
2316 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2317 "ELEMENTAL subroutine %qs is a scalar, but another "
2318 "actual argument is an array", &arg
->expr
->where
,
2319 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2320 : "INOUT", eformal
->sym
->name
, esym
->name
);
2327 /* This function does the checking of references to global procedures
2328 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2329 77 and 95 standards. It checks for a gsymbol for the name, making
2330 one if it does not already exist. If it already exists, then the
2331 reference being resolved must correspond to the type of gsymbol.
2332 Otherwise, the new symbol is equipped with the attributes of the
2333 reference. The corresponding code that is called in creating
2334 global entities is parse.c.
2336 In addition, for all but -std=legacy, the gsymbols are used to
2337 check the interfaces of external procedures from the same file.
2338 The namespace of the gsymbol is resolved and then, once this is
2339 done the interface is checked. */
2343 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2345 if (!gsym_ns
->proc_name
->attr
.recursive
)
2348 if (sym
->ns
== gsym_ns
)
2351 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2358 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2360 if (gsym_ns
->entries
)
2362 gfc_entry_list
*entry
= gsym_ns
->entries
;
2364 for (; entry
; entry
= entry
->next
)
2366 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2368 if (strcmp (gsym_ns
->proc_name
->name
,
2369 sym
->ns
->proc_name
->name
) == 0)
2373 && strcmp (gsym_ns
->proc_name
->name
,
2374 sym
->ns
->parent
->proc_name
->name
) == 0)
2383 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2386 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2388 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2390 for ( ; arg
; arg
= arg
->next
)
2395 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2397 strncpy (errmsg
, _("allocatable argument"), err_len
);
2400 else if (arg
->sym
->attr
.asynchronous
)
2402 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2405 else if (arg
->sym
->attr
.optional
)
2407 strncpy (errmsg
, _("optional argument"), err_len
);
2410 else if (arg
->sym
->attr
.pointer
)
2412 strncpy (errmsg
, _("pointer argument"), err_len
);
2415 else if (arg
->sym
->attr
.target
)
2417 strncpy (errmsg
, _("target argument"), err_len
);
2420 else if (arg
->sym
->attr
.value
)
2422 strncpy (errmsg
, _("value argument"), err_len
);
2425 else if (arg
->sym
->attr
.volatile_
)
2427 strncpy (errmsg
, _("volatile argument"), err_len
);
2430 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2432 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2435 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2437 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2440 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2442 strncpy (errmsg
, _("coarray argument"), err_len
);
2445 else if (false) /* (2d) TODO: parametrized derived type */
2447 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2450 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2452 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2455 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2457 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2460 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2462 /* As assumed-type is unlimited polymorphic (cf. above).
2463 See also TS 29113, Note 6.1. */
2464 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2469 if (sym
->attr
.function
)
2471 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2473 if (res
->attr
.dimension
) /* (3a) */
2475 strncpy (errmsg
, _("array result"), err_len
);
2478 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2480 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2483 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2484 && res
->ts
.u
.cl
->length
2485 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2487 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2492 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2494 strncpy (errmsg
, _("elemental procedure"), err_len
);
2497 else if (sym
->attr
.is_bind_c
) /* (5) */
2499 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2508 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
2512 enum gfc_symbol_type type
;
2515 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2517 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2518 sym
->binding_label
!= NULL
);
2520 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2521 gfc_global_used (gsym
, where
);
2523 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2524 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2525 && gsym
->type
!= GSYM_UNKNOWN
2526 && !gsym
->binding_label
2528 && gsym
->ns
->proc_name
2529 && not_in_recursive (sym
, gsym
->ns
)
2530 && not_entry_self_reference (sym
, gsym
->ns
))
2532 gfc_symbol
*def_sym
;
2533 def_sym
= gsym
->ns
->proc_name
;
2535 if (gsym
->ns
->resolved
!= -1)
2538 /* Resolve the gsymbol namespace if needed. */
2539 if (!gsym
->ns
->resolved
)
2541 gfc_symbol
*old_dt_list
;
2543 /* Stash away derived types so that the backend_decls
2544 do not get mixed up. */
2545 old_dt_list
= gfc_derived_types
;
2546 gfc_derived_types
= NULL
;
2548 gfc_resolve (gsym
->ns
);
2550 /* Store the new derived types with the global namespace. */
2551 if (gfc_derived_types
)
2552 gsym
->ns
->derived_types
= gfc_derived_types
;
2554 /* Restore the derived types of this namespace. */
2555 gfc_derived_types
= old_dt_list
;
2558 /* Make sure that translation for the gsymbol occurs before
2559 the procedure currently being resolved. */
2560 ns
= gfc_global_ns_list
;
2561 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2563 if (ns
->sibling
== gsym
->ns
)
2565 ns
->sibling
= gsym
->ns
->sibling
;
2566 gsym
->ns
->sibling
= gfc_global_ns_list
;
2567 gfc_global_ns_list
= gsym
->ns
;
2572 /* This can happen if a binding name has been specified. */
2573 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2574 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2576 if (def_sym
->attr
.entry_master
|| def_sym
->attr
.entry
)
2578 gfc_entry_list
*entry
;
2579 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2580 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2582 def_sym
= entry
->sym
;
2588 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2590 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2591 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2592 gfc_typename (&def_sym
->ts
));
2596 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2597 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2599 gfc_error ("Explicit interface required for %qs at %L: %s",
2600 sym
->name
, &sym
->declared_at
, reason
);
2604 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2605 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2606 gfc_errors_to_warnings (true);
2608 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2609 reason
, sizeof(reason
), NULL
, NULL
))
2611 gfc_error_opt (0, "Interface mismatch in global procedure %qs at %L:"
2612 " %s", sym
->name
, &sym
->declared_at
, reason
);
2618 gfc_errors_to_warnings (false);
2620 if (gsym
->type
== GSYM_UNKNOWN
)
2623 gsym
->where
= *where
;
2630 /************* Function resolution *************/
2632 /* Resolve a function call known to be generic.
2633 Section 14.1.2.4.1. */
2636 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2640 if (sym
->attr
.generic
)
2642 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2645 expr
->value
.function
.name
= s
->name
;
2646 expr
->value
.function
.esym
= s
;
2648 if (s
->ts
.type
!= BT_UNKNOWN
)
2650 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2651 expr
->ts
= s
->result
->ts
;
2654 expr
->rank
= s
->as
->rank
;
2655 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2656 expr
->rank
= s
->result
->as
->rank
;
2658 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2663 /* TODO: Need to search for elemental references in generic
2667 if (sym
->attr
.intrinsic
)
2668 return gfc_intrinsic_func_interface (expr
, 0);
2675 resolve_generic_f (gfc_expr
*expr
)
2679 gfc_interface
*intr
= NULL
;
2681 sym
= expr
->symtree
->n
.sym
;
2685 m
= resolve_generic_f0 (expr
, sym
);
2688 else if (m
== MATCH_ERROR
)
2693 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2694 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2697 if (sym
->ns
->parent
== NULL
)
2699 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2703 if (!generic_sym (sym
))
2707 /* Last ditch attempt. See if the reference is to an intrinsic
2708 that possesses a matching interface. 14.1.2.4 */
2709 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2711 if (gfc_init_expr_flag
)
2712 gfc_error ("Function %qs in initialization expression at %L "
2713 "must be an intrinsic function",
2714 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2716 gfc_error ("There is no specific function for the generic %qs "
2717 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2723 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2726 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2728 return resolve_structure_cons (expr
, 0);
2731 m
= gfc_intrinsic_func_interface (expr
, 0);
2736 gfc_error ("Generic function %qs at %L is not consistent with a "
2737 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2744 /* Resolve a function call known to be specific. */
2747 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2751 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2753 if (sym
->attr
.dummy
)
2755 sym
->attr
.proc
= PROC_DUMMY
;
2759 sym
->attr
.proc
= PROC_EXTERNAL
;
2763 if (sym
->attr
.proc
== PROC_MODULE
2764 || sym
->attr
.proc
== PROC_ST_FUNCTION
2765 || sym
->attr
.proc
== PROC_INTERNAL
)
2768 if (sym
->attr
.intrinsic
)
2770 m
= gfc_intrinsic_func_interface (expr
, 1);
2774 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2775 "with an intrinsic", sym
->name
, &expr
->where
);
2783 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2786 expr
->ts
= sym
->result
->ts
;
2789 expr
->value
.function
.name
= sym
->name
;
2790 expr
->value
.function
.esym
= sym
;
2791 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2793 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2795 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2796 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2797 else if (sym
->as
!= NULL
)
2798 expr
->rank
= sym
->as
->rank
;
2805 resolve_specific_f (gfc_expr
*expr
)
2810 sym
= expr
->symtree
->n
.sym
;
2814 m
= resolve_specific_f0 (sym
, expr
);
2817 if (m
== MATCH_ERROR
)
2820 if (sym
->ns
->parent
== NULL
)
2823 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2829 gfc_error ("Unable to resolve the specific function %qs at %L",
2830 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2835 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2836 candidates in CANDIDATES_LEN. */
2839 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2841 size_t &candidates_len
)
2847 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2848 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2849 vec_push (candidates
, candidates_len
, sym
->name
);
2853 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2857 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2861 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2864 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2866 char **candidates
= NULL
;
2867 size_t candidates_len
= 0;
2868 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2869 return gfc_closest_fuzzy_match (fn
, candidates
);
2873 /* Resolve a procedure call not known to be generic nor specific. */
2876 resolve_unknown_f (gfc_expr
*expr
)
2881 sym
= expr
->symtree
->n
.sym
;
2883 if (sym
->attr
.dummy
)
2885 sym
->attr
.proc
= PROC_DUMMY
;
2886 expr
->value
.function
.name
= sym
->name
;
2890 /* See if we have an intrinsic function reference. */
2892 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2894 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2899 /* The reference is to an external name. */
2901 sym
->attr
.proc
= PROC_EXTERNAL
;
2902 expr
->value
.function
.name
= sym
->name
;
2903 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2905 if (sym
->as
!= NULL
)
2906 expr
->rank
= sym
->as
->rank
;
2908 /* Type of the expression is either the type of the symbol or the
2909 default type of the symbol. */
2912 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2914 if (sym
->ts
.type
!= BT_UNKNOWN
)
2918 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2920 if (ts
->type
== BT_UNKNOWN
)
2923 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2925 gfc_error ("Function %qs at %L has no IMPLICIT type"
2926 "; did you mean %qs?",
2927 sym
->name
, &expr
->where
, guessed
);
2929 gfc_error ("Function %qs at %L has no IMPLICIT type",
2930 sym
->name
, &expr
->where
);
2941 /* Return true, if the symbol is an external procedure. */
2943 is_external_proc (gfc_symbol
*sym
)
2945 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2946 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2947 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2948 && !sym
->attr
.proc_pointer
2949 && !sym
->attr
.use_assoc
2957 /* Figure out if a function reference is pure or not. Also set the name
2958 of the function for a potential error message. Return nonzero if the
2959 function is PURE, zero if not. */
2961 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2964 gfc_pure_function (gfc_expr
*e
, const char **name
)
2967 gfc_component
*comp
;
2971 if (e
->symtree
!= NULL
2972 && e
->symtree
->n
.sym
!= NULL
2973 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2974 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2976 comp
= gfc_get_proc_ptr_comp (e
);
2979 pure
= gfc_pure (comp
->ts
.interface
);
2982 else if (e
->value
.function
.esym
)
2984 pure
= gfc_pure (e
->value
.function
.esym
);
2985 *name
= e
->value
.function
.esym
->name
;
2987 else if (e
->value
.function
.isym
)
2989 pure
= e
->value
.function
.isym
->pure
2990 || e
->value
.function
.isym
->elemental
;
2991 *name
= e
->value
.function
.isym
->name
;
2995 /* Implicit functions are not pure. */
2997 *name
= e
->value
.function
.name
;
3004 /* Check if the expression is a reference to an implicitly pure function. */
3007 gfc_implicit_pure_function (gfc_expr
*e
)
3009 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
3011 return gfc_implicit_pure (comp
->ts
.interface
);
3012 else if (e
->value
.function
.esym
)
3013 return gfc_implicit_pure (e
->value
.function
.esym
);
3020 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3021 int *f ATTRIBUTE_UNUSED
)
3025 /* Don't bother recursing into other statement functions
3026 since they will be checked individually for purity. */
3027 if (e
->expr_type
!= EXPR_FUNCTION
3029 || e
->symtree
->n
.sym
== sym
3030 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3033 return gfc_pure_function (e
, &name
) ? false : true;
3038 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3040 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3044 /* Check if an impure function is allowed in the current context. */
3046 static bool check_pure_function (gfc_expr
*e
)
3048 const char *name
= NULL
;
3049 if (!gfc_pure_function (e
, &name
) && name
)
3053 gfc_error ("Reference to impure function %qs at %L inside a "
3054 "FORALL %s", name
, &e
->where
,
3055 forall_flag
== 2 ? "mask" : "block");
3058 else if (gfc_do_concurrent_flag
)
3060 gfc_error ("Reference to impure function %qs at %L inside a "
3061 "DO CONCURRENT %s", name
, &e
->where
,
3062 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3065 else if (gfc_pure (NULL
))
3067 gfc_error ("Reference to impure function %qs at %L "
3068 "within a PURE procedure", name
, &e
->where
);
3071 if (!gfc_implicit_pure_function (e
))
3072 gfc_unset_implicit_pure (NULL
);
3078 /* Update current procedure's array_outer_dependency flag, considering
3079 a call to procedure SYM. */
3082 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3084 /* Check to see if this is a sibling function that has not yet
3086 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3087 for (; sibling
; sibling
= sibling
->sibling
)
3089 if (sibling
->proc_name
== sym
)
3091 gfc_resolve (sibling
);
3096 /* If SYM has references to outer arrays, so has the procedure calling
3097 SYM. If SYM is a procedure pointer, we can assume the worst. */
3098 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3099 && gfc_current_ns
->proc_name
)
3100 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3104 /* Resolve a function call, which means resolving the arguments, then figuring
3105 out which entity the name refers to. */
3108 resolve_function (gfc_expr
*expr
)
3110 gfc_actual_arglist
*arg
;
3114 procedure_type p
= PROC_INTRINSIC
;
3115 bool no_formal_args
;
3119 sym
= expr
->symtree
->n
.sym
;
3121 /* If this is a procedure pointer component, it has already been resolved. */
3122 if (gfc_is_proc_ptr_comp (expr
))
3125 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3127 if (sym
&& sym
->attr
.intrinsic
3128 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3129 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3132 if (sym
&& sym
->attr
.intrinsic
3133 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3136 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3138 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3142 /* If this is a deferred TBP with an abstract interface (which may
3143 of course be referenced), expr->value.function.esym will be set. */
3144 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3146 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3147 sym
->name
, &expr
->where
);
3151 /* If this is a deferred TBP with an abstract interface, its result
3152 cannot be an assumed length character (F2003: C418). */
3153 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3154 && sym
->result
->ts
.u
.cl
3155 && sym
->result
->ts
.u
.cl
->length
== NULL
3156 && !sym
->result
->ts
.deferred
)
3158 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3159 "character length result (F2008: C418)", sym
->name
,
3164 /* Switch off assumed size checking and do this again for certain kinds
3165 of procedure, once the procedure itself is resolved. */
3166 need_full_assumed_size
++;
3168 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3169 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3171 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3172 inquiry_argument
= true;
3173 no_formal_args
= sym
&& is_external_proc (sym
)
3174 && gfc_sym_get_dummy_args (sym
) == NULL
;
3176 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3179 inquiry_argument
= false;
3183 inquiry_argument
= false;
3185 /* Resume assumed_size checking. */
3186 need_full_assumed_size
--;
3188 /* If the procedure is external, check for usage. */
3189 if (sym
&& is_external_proc (sym
))
3190 resolve_global_procedure (sym
, &expr
->where
, 0);
3192 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3194 && sym
->ts
.u
.cl
->length
== NULL
3196 && !sym
->ts
.deferred
3197 && expr
->value
.function
.esym
== NULL
3198 && !sym
->attr
.contained
)
3200 /* Internal procedures are taken care of in resolve_contained_fntype. */
3201 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3202 "be used at %L since it is not a dummy argument",
3203 sym
->name
, &expr
->where
);
3207 /* See if function is already resolved. */
3209 if (expr
->value
.function
.name
!= NULL
3210 || expr
->value
.function
.isym
!= NULL
)
3212 if (expr
->ts
.type
== BT_UNKNOWN
)
3218 /* Apply the rules of section 14.1.2. */
3220 switch (procedure_kind (sym
))
3223 t
= resolve_generic_f (expr
);
3226 case PTYPE_SPECIFIC
:
3227 t
= resolve_specific_f (expr
);
3231 t
= resolve_unknown_f (expr
);
3235 gfc_internal_error ("resolve_function(): bad function type");
3239 /* If the expression is still a function (it might have simplified),
3240 then we check to see if we are calling an elemental function. */
3242 if (expr
->expr_type
!= EXPR_FUNCTION
)
3245 /* Walk the argument list looking for invalid BOZ. */
3246 if (expr
->value
.function
.esym
)
3248 gfc_actual_arglist
*a
;
3250 for (a
= expr
->value
.function
.actual
; a
; a
= a
->next
)
3251 if (a
->expr
&& a
->expr
->ts
.type
== BT_BOZ
)
3253 gfc_error ("A BOZ literal constant at %L cannot appear as an "
3254 "actual argument in a function reference",
3260 temp
= need_full_assumed_size
;
3261 need_full_assumed_size
= 0;
3263 if (!resolve_elemental_actual (expr
, NULL
))
3266 if (omp_workshare_flag
3267 && expr
->value
.function
.esym
3268 && ! gfc_elemental (expr
->value
.function
.esym
))
3270 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3271 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3276 #define GENERIC_ID expr->value.function.isym->id
3277 else if (expr
->value
.function
.actual
!= NULL
3278 && expr
->value
.function
.isym
!= NULL
3279 && GENERIC_ID
!= GFC_ISYM_LBOUND
3280 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3281 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3282 && GENERIC_ID
!= GFC_ISYM_LEN
3283 && GENERIC_ID
!= GFC_ISYM_LOC
3284 && GENERIC_ID
!= GFC_ISYM_C_LOC
3285 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3287 /* Array intrinsics must also have the last upper bound of an
3288 assumed size array argument. UBOUND and SIZE have to be
3289 excluded from the check if the second argument is anything
3292 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3294 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3295 && arg
== expr
->value
.function
.actual
3296 && arg
->next
!= NULL
&& arg
->next
->expr
)
3298 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3301 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3304 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3309 if (arg
->expr
!= NULL
3310 && arg
->expr
->rank
> 0
3311 && resolve_assumed_size_actual (arg
->expr
))
3317 need_full_assumed_size
= temp
;
3319 if (!check_pure_function(expr
))
3322 /* Functions without the RECURSIVE attribution are not allowed to
3323 * call themselves. */
3324 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3327 esym
= expr
->value
.function
.esym
;
3329 if (is_illegal_recursion (esym
, gfc_current_ns
))
3331 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3332 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3333 " function %qs is not RECURSIVE",
3334 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3336 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3337 " is not RECURSIVE", esym
->name
, &expr
->where
);
3343 /* Character lengths of use associated functions may contains references to
3344 symbols not referenced from the current program unit otherwise. Make sure
3345 those symbols are marked as referenced. */
3347 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3348 && expr
->value
.function
.esym
->attr
.use_assoc
)
3350 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3353 /* Make sure that the expression has a typespec that works. */
3354 if (expr
->ts
.type
== BT_UNKNOWN
)
3356 if (expr
->symtree
->n
.sym
->result
3357 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3358 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3359 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3362 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3364 if (expr
->value
.function
.esym
)
3365 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3367 update_current_proc_array_outer_dependency (sym
);
3370 /* typebound procedure: Assume the worst. */
3371 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3377 /************* Subroutine resolution *************/
3380 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3387 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3391 else if (gfc_do_concurrent_flag
)
3393 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3397 else if (gfc_pure (NULL
))
3399 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3403 gfc_unset_implicit_pure (NULL
);
3409 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3413 if (sym
->attr
.generic
)
3415 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3418 c
->resolved_sym
= s
;
3419 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3424 /* TODO: Need to search for elemental references in generic interface. */
3427 if (sym
->attr
.intrinsic
)
3428 return gfc_intrinsic_sub_interface (c
, 0);
3435 resolve_generic_s (gfc_code
*c
)
3440 sym
= c
->symtree
->n
.sym
;
3444 m
= resolve_generic_s0 (c
, sym
);
3447 else if (m
== MATCH_ERROR
)
3451 if (sym
->ns
->parent
== NULL
)
3453 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3457 if (!generic_sym (sym
))
3461 /* Last ditch attempt. See if the reference is to an intrinsic
3462 that possesses a matching interface. 14.1.2.4 */
3463 sym
= c
->symtree
->n
.sym
;
3465 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3467 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3468 sym
->name
, &c
->loc
);
3472 m
= gfc_intrinsic_sub_interface (c
, 0);
3476 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3477 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3483 /* Resolve a subroutine call known to be specific. */
3486 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3490 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3492 if (sym
->attr
.dummy
)
3494 sym
->attr
.proc
= PROC_DUMMY
;
3498 sym
->attr
.proc
= PROC_EXTERNAL
;
3502 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3505 if (sym
->attr
.intrinsic
)
3507 m
= gfc_intrinsic_sub_interface (c
, 1);
3511 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3512 "with an intrinsic", sym
->name
, &c
->loc
);
3520 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3522 c
->resolved_sym
= sym
;
3523 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3531 resolve_specific_s (gfc_code
*c
)
3536 sym
= c
->symtree
->n
.sym
;
3540 m
= resolve_specific_s0 (c
, sym
);
3543 if (m
== MATCH_ERROR
)
3546 if (sym
->ns
->parent
== NULL
)
3549 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3555 sym
= c
->symtree
->n
.sym
;
3556 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3557 sym
->name
, &c
->loc
);
3563 /* Resolve a subroutine call not known to be generic nor specific. */
3566 resolve_unknown_s (gfc_code
*c
)
3570 sym
= c
->symtree
->n
.sym
;
3572 if (sym
->attr
.dummy
)
3574 sym
->attr
.proc
= PROC_DUMMY
;
3578 /* See if we have an intrinsic function reference. */
3580 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3582 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3587 /* The reference is to an external name. */
3590 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3592 c
->resolved_sym
= sym
;
3594 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3598 /* Resolve a subroutine call. Although it was tempting to use the same code
3599 for functions, subroutines and functions are stored differently and this
3600 makes things awkward. */
3603 resolve_call (gfc_code
*c
)
3606 procedure_type ptype
= PROC_INTRINSIC
;
3607 gfc_symbol
*csym
, *sym
;
3608 bool no_formal_args
;
3610 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3612 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3614 gfc_error ("%qs at %L has a type, which is not consistent with "
3615 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3619 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3622 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3623 sym
= st
? st
->n
.sym
: NULL
;
3624 if (sym
&& csym
!= sym
3625 && sym
->ns
== gfc_current_ns
3626 && sym
->attr
.flavor
== FL_PROCEDURE
3627 && sym
->attr
.contained
)
3630 if (csym
->attr
.generic
)
3631 c
->symtree
->n
.sym
= sym
;
3634 csym
= c
->symtree
->n
.sym
;
3638 /* If this ia a deferred TBP, c->expr1 will be set. */
3639 if (!c
->expr1
&& csym
)
3641 if (csym
->attr
.abstract
)
3643 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3644 csym
->name
, &c
->loc
);
3648 /* Subroutines without the RECURSIVE attribution are not allowed to
3650 if (is_illegal_recursion (csym
, gfc_current_ns
))
3652 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3653 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3654 "as subroutine %qs is not RECURSIVE",
3655 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3657 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3658 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3664 /* Switch off assumed size checking and do this again for certain kinds
3665 of procedure, once the procedure itself is resolved. */
3666 need_full_assumed_size
++;
3669 ptype
= csym
->attr
.proc
;
3671 no_formal_args
= csym
&& is_external_proc (csym
)
3672 && gfc_sym_get_dummy_args (csym
) == NULL
;
3673 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3676 /* Resume assumed_size checking. */
3677 need_full_assumed_size
--;
3679 /* If external, check for usage. */
3680 if (csym
&& is_external_proc (csym
))
3681 resolve_global_procedure (csym
, &c
->loc
, 1);
3684 if (c
->resolved_sym
== NULL
)
3686 c
->resolved_isym
= NULL
;
3687 switch (procedure_kind (csym
))
3690 t
= resolve_generic_s (c
);
3693 case PTYPE_SPECIFIC
:
3694 t
= resolve_specific_s (c
);
3698 t
= resolve_unknown_s (c
);
3702 gfc_internal_error ("resolve_subroutine(): bad function type");
3706 /* Some checks of elemental subroutine actual arguments. */
3707 if (!resolve_elemental_actual (NULL
, c
))
3711 update_current_proc_array_outer_dependency (csym
);
3713 /* Typebound procedure: Assume the worst. */
3714 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3720 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3721 op1->shape and op2->shape are non-NULL return true if their shapes
3722 match. If both op1->shape and op2->shape are non-NULL return false
3723 if their shapes do not match. If either op1->shape or op2->shape is
3724 NULL, return true. */
3727 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3734 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3736 for (i
= 0; i
< op1
->rank
; i
++)
3738 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3740 gfc_error ("Shapes for operands at %L and %L are not conformable",
3741 &op1
->where
, &op2
->where
);
3751 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3752 For example A .AND. B becomes IAND(A, B). */
3754 logical_to_bitwise (gfc_expr
*e
)
3756 gfc_expr
*tmp
, *op1
, *op2
;
3758 gfc_actual_arglist
*args
= NULL
;
3760 gcc_assert (e
->expr_type
== EXPR_OP
);
3762 isym
= GFC_ISYM_NONE
;
3763 op1
= e
->value
.op
.op1
;
3764 op2
= e
->value
.op
.op2
;
3766 switch (e
->value
.op
.op
)
3769 isym
= GFC_ISYM_NOT
;
3772 isym
= GFC_ISYM_IAND
;
3775 isym
= GFC_ISYM_IOR
;
3777 case INTRINSIC_NEQV
:
3778 isym
= GFC_ISYM_IEOR
;
3781 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3782 Change the old expression to NEQV, which will get replaced by IEOR,
3783 and wrap it in NOT. */
3784 tmp
= gfc_copy_expr (e
);
3785 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3786 tmp
= logical_to_bitwise (tmp
);
3787 isym
= GFC_ISYM_NOT
;
3792 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3795 /* Inherit the original operation's operands as arguments. */
3796 args
= gfc_get_actual_arglist ();
3800 args
->next
= gfc_get_actual_arglist ();
3801 args
->next
->expr
= op2
;
3804 /* Convert the expression to a function call. */
3805 e
->expr_type
= EXPR_FUNCTION
;
3806 e
->value
.function
.actual
= args
;
3807 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3808 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3809 e
->value
.function
.esym
= NULL
;
3811 /* Make up a pre-resolved function call symtree if we need to. */
3812 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3815 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3816 sym
= e
->symtree
->n
.sym
;
3818 sym
->attr
.flavor
= FL_PROCEDURE
;
3819 sym
->attr
.function
= 1;
3820 sym
->attr
.elemental
= 1;
3822 sym
->attr
.referenced
= 1;
3823 gfc_intrinsic_symbol (sym
);
3824 gfc_commit_symbol (sym
);
3827 args
->name
= e
->value
.function
.isym
->formal
->name
;
3828 if (e
->value
.function
.isym
->formal
->next
)
3829 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3834 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3835 candidates in CANDIDATES_LEN. */
3837 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3839 size_t &candidates_len
)
3846 /* Not sure how to properly filter here. Use all for a start.
3847 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3848 these as i suppose they don't make terribly sense. */
3850 if (uop
->n
.uop
->op
!= NULL
)
3851 vec_push (candidates
, candidates_len
, uop
->name
);
3855 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3859 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3862 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3865 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3867 char **candidates
= NULL
;
3868 size_t candidates_len
= 0;
3869 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3870 return gfc_closest_fuzzy_match (op
, candidates
);
3874 /* Callback finding an impure function as an operand to an .and. or
3875 .or. expression. Remember the last function warned about to
3876 avoid double warnings when recursing. */
3879 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3884 static gfc_expr
*last
= NULL
;
3885 bool *found
= (bool *) data
;
3887 if (f
->expr_type
== EXPR_FUNCTION
)
3890 if (f
!= last
&& !gfc_pure_function (f
, &name
)
3891 && !gfc_implicit_pure_function (f
))
3894 gfc_warning (OPT_Wfunction_elimination
,
3895 "Impure function %qs at %L might not be evaluated",
3898 gfc_warning (OPT_Wfunction_elimination
,
3899 "Impure function at %L might not be evaluated",
3909 /* Resolve an operator expression node. This can involve replacing the
3910 operation with a user defined function call. */
3913 resolve_operator (gfc_expr
*e
)
3915 gfc_expr
*op1
, *op2
;
3917 bool dual_locus_error
;
3920 /* Resolve all subnodes-- give them types. */
3922 switch (e
->value
.op
.op
)
3925 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3931 case INTRINSIC_UPLUS
:
3932 case INTRINSIC_UMINUS
:
3933 case INTRINSIC_PARENTHESES
:
3934 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3937 && e
->value
.op
.op1
->ts
.type
== BT_BOZ
&& !e
->value
.op
.op2
)
3939 gfc_error ("BOZ literal constant at %L cannot be an operand of "
3940 "unary operator %qs", &e
->value
.op
.op1
->where
,
3941 gfc_op2string (e
->value
.op
.op
));
3947 /* Typecheck the new node. */
3949 op1
= e
->value
.op
.op1
;
3950 op2
= e
->value
.op
.op2
;
3951 dual_locus_error
= false;
3953 /* op1 and op2 cannot both be BOZ. */
3954 if (op1
&& op1
->ts
.type
== BT_BOZ
3955 && op2
&& op2
->ts
.type
== BT_BOZ
)
3957 gfc_error ("Operands at %L and %L cannot appear as operands of "
3958 "binary operator %qs", &op1
->where
, &op2
->where
,
3959 gfc_op2string (e
->value
.op
.op
));
3963 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3964 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3966 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3970 switch (e
->value
.op
.op
)
3972 case INTRINSIC_UPLUS
:
3973 case INTRINSIC_UMINUS
:
3974 if (op1
->ts
.type
== BT_INTEGER
3975 || op1
->ts
.type
== BT_REAL
3976 || op1
->ts
.type
== BT_COMPLEX
)
3982 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3983 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3986 case INTRINSIC_PLUS
:
3987 case INTRINSIC_MINUS
:
3988 case INTRINSIC_TIMES
:
3989 case INTRINSIC_DIVIDE
:
3990 case INTRINSIC_POWER
:
3991 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3993 gfc_type_convert_binary (e
, 1);
3997 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
3999 _("Unexpected derived-type entities in binary intrinsic "
4000 "numeric operator %%<%s%%> at %%L"),
4001 gfc_op2string (e
->value
.op
.op
));
4004 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
4005 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4006 gfc_typename (&op2
->ts
));
4009 case INTRINSIC_CONCAT
:
4010 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4011 && op1
->ts
.kind
== op2
->ts
.kind
)
4013 e
->ts
.type
= BT_CHARACTER
;
4014 e
->ts
.kind
= op1
->ts
.kind
;
4019 _("Operands of string concatenation operator at %%L are %s/%s"),
4020 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
4026 case INTRINSIC_NEQV
:
4027 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4029 e
->ts
.type
= BT_LOGICAL
;
4030 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4031 if (op1
->ts
.kind
< e
->ts
.kind
)
4032 gfc_convert_type (op1
, &e
->ts
, 2);
4033 else if (op2
->ts
.kind
< e
->ts
.kind
)
4034 gfc_convert_type (op2
, &e
->ts
, 2);
4036 if (flag_frontend_optimize
&&
4037 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4039 /* Warn about short-circuiting
4040 with impure function as second operand. */
4042 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4047 /* Logical ops on integers become bitwise ops with -fdec. */
4049 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4051 e
->ts
.type
= BT_INTEGER
;
4052 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4053 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4054 gfc_convert_type (op1
, &e
->ts
, 1);
4055 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4056 gfc_convert_type (op2
, &e
->ts
, 1);
4057 e
= logical_to_bitwise (e
);
4061 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4062 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4063 gfc_typename (&op2
->ts
));
4068 /* Logical ops on integers become bitwise ops with -fdec. */
4069 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4071 e
->ts
.type
= BT_INTEGER
;
4072 e
->ts
.kind
= op1
->ts
.kind
;
4073 e
= logical_to_bitwise (e
);
4077 if (op1
->ts
.type
== BT_LOGICAL
)
4079 e
->ts
.type
= BT_LOGICAL
;
4080 e
->ts
.kind
= op1
->ts
.kind
;
4084 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4085 gfc_typename (&op1
->ts
));
4089 case INTRINSIC_GT_OS
:
4091 case INTRINSIC_GE_OS
:
4093 case INTRINSIC_LT_OS
:
4095 case INTRINSIC_LE_OS
:
4096 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4098 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4105 case INTRINSIC_EQ_OS
:
4107 case INTRINSIC_NE_OS
:
4108 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4109 && op1
->ts
.kind
== op2
->ts
.kind
)
4111 e
->ts
.type
= BT_LOGICAL
;
4112 e
->ts
.kind
= gfc_default_logical_kind
;
4116 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4117 if (op1
->ts
.type
== BT_BOZ
)
4119 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4120 "an operand of a relational operator",
4124 if (op2
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op1
, op2
->ts
.kind
))
4127 if (op2
->ts
.type
== BT_REAL
&& !gfc_boz2real (op1
, op2
->ts
.kind
))
4131 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4132 if (op2
->ts
.type
== BT_BOZ
)
4134 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4135 "an operand of a relational operator",
4139 if (op1
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op2
, op1
->ts
.kind
))
4142 if (op1
->ts
.type
== BT_REAL
&& !gfc_boz2real (op2
, op1
->ts
.kind
))
4146 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4148 gfc_type_convert_binary (e
, 1);
4150 e
->ts
.type
= BT_LOGICAL
;
4151 e
->ts
.kind
= gfc_default_logical_kind
;
4153 if (warn_compare_reals
)
4155 gfc_intrinsic_op op
= e
->value
.op
.op
;
4157 /* Type conversion has made sure that the types of op1 and op2
4158 agree, so it is only necessary to check the first one. */
4159 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4160 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4161 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4165 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4166 msg
= "Equality comparison for %s at %L";
4168 msg
= "Inequality comparison for %s at %L";
4170 gfc_warning (OPT_Wcompare_reals
, msg
,
4171 gfc_typename (&op1
->ts
), &op1
->where
);
4178 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4180 _("Logicals at %%L must be compared with %s instead of %s"),
4181 (e
->value
.op
.op
== INTRINSIC_EQ
4182 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4183 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4186 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4187 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4188 gfc_typename (&op2
->ts
));
4192 case INTRINSIC_USER
:
4193 if (e
->value
.op
.uop
->op
== NULL
)
4195 const char *name
= e
->value
.op
.uop
->name
;
4196 const char *guessed
;
4197 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4199 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4202 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4204 else if (op2
== NULL
)
4205 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4206 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4209 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4210 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4211 gfc_typename (&op2
->ts
));
4212 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4217 case INTRINSIC_PARENTHESES
:
4219 if (e
->ts
.type
== BT_CHARACTER
)
4220 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4224 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4227 /* Deal with arrayness of an operand through an operator. */
4229 switch (e
->value
.op
.op
)
4231 case INTRINSIC_PLUS
:
4232 case INTRINSIC_MINUS
:
4233 case INTRINSIC_TIMES
:
4234 case INTRINSIC_DIVIDE
:
4235 case INTRINSIC_POWER
:
4236 case INTRINSIC_CONCAT
:
4240 case INTRINSIC_NEQV
:
4242 case INTRINSIC_EQ_OS
:
4244 case INTRINSIC_NE_OS
:
4246 case INTRINSIC_GT_OS
:
4248 case INTRINSIC_GE_OS
:
4250 case INTRINSIC_LT_OS
:
4252 case INTRINSIC_LE_OS
:
4254 if (op1
->rank
== 0 && op2
->rank
== 0)
4257 if (op1
->rank
== 0 && op2
->rank
!= 0)
4259 e
->rank
= op2
->rank
;
4261 if (e
->shape
== NULL
)
4262 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4265 if (op1
->rank
!= 0 && op2
->rank
== 0)
4267 e
->rank
= op1
->rank
;
4269 if (e
->shape
== NULL
)
4270 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4273 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4275 if (op1
->rank
== op2
->rank
)
4277 e
->rank
= op1
->rank
;
4278 if (e
->shape
== NULL
)
4280 t
= compare_shapes (op1
, op2
);
4284 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4289 /* Allow higher level expressions to work. */
4292 /* Try user-defined operators, and otherwise throw an error. */
4293 dual_locus_error
= true;
4295 _("Inconsistent ranks for operator at %%L and %%L"));
4302 case INTRINSIC_PARENTHESES
:
4304 case INTRINSIC_UPLUS
:
4305 case INTRINSIC_UMINUS
:
4306 /* Simply copy arrayness attribute */
4307 e
->rank
= op1
->rank
;
4309 if (e
->shape
== NULL
)
4310 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4320 /* Attempt to simplify the expression. */
4323 t
= gfc_simplify_expr (e
, 0);
4324 /* Some calls do not succeed in simplification and return false
4325 even though there is no error; e.g. variable references to
4326 PARAMETER arrays. */
4327 if (!gfc_is_constant_expr (e
))
4335 match m
= gfc_extend_expr (e
);
4338 if (m
== MATCH_ERROR
)
4342 if (dual_locus_error
)
4343 gfc_error (msg
, &op1
->where
, &op2
->where
);
4345 gfc_error (msg
, &e
->where
);
4351 /************** Array resolution subroutines **************/
4354 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4356 /* Compare two integer expressions. */
4358 static compare_result
4359 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4363 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4364 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4367 /* If either of the types isn't INTEGER, we must have
4368 raised an error earlier. */
4370 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4373 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4383 /* Compare an integer expression with an integer. */
4385 static compare_result
4386 compare_bound_int (gfc_expr
*a
, int b
)
4390 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4393 if (a
->ts
.type
!= BT_INTEGER
)
4394 gfc_internal_error ("compare_bound_int(): Bad expression");
4396 i
= mpz_cmp_si (a
->value
.integer
, b
);
4406 /* Compare an integer expression with a mpz_t. */
4408 static compare_result
4409 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4413 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4416 if (a
->ts
.type
!= BT_INTEGER
)
4417 gfc_internal_error ("compare_bound_int(): Bad expression");
4419 i
= mpz_cmp (a
->value
.integer
, b
);
4429 /* Compute the last value of a sequence given by a triplet.
4430 Return 0 if it wasn't able to compute the last value, or if the
4431 sequence if empty, and 1 otherwise. */
4434 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4435 gfc_expr
*stride
, mpz_t last
)
4439 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4440 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4441 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4444 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4445 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4448 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4450 if (compare_bound (start
, end
) == CMP_GT
)
4452 mpz_set (last
, end
->value
.integer
);
4456 if (compare_bound_int (stride
, 0) == CMP_GT
)
4458 /* Stride is positive */
4459 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4464 /* Stride is negative */
4465 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4470 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4471 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4472 mpz_sub (last
, end
->value
.integer
, rem
);
4479 /* Compare a single dimension of an array reference to the array
4483 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4487 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4489 gcc_assert (ar
->stride
[i
] == NULL
);
4490 /* This implies [*] as [*:] and [*:3] are not possible. */
4491 if (ar
->start
[i
] == NULL
)
4493 gcc_assert (ar
->end
[i
] == NULL
);
4498 /* Given start, end and stride values, calculate the minimum and
4499 maximum referenced indexes. */
4501 switch (ar
->dimen_type
[i
])
4504 case DIMEN_THIS_IMAGE
:
4509 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4512 gfc_warning (0, "Array reference at %L is out of bounds "
4513 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4514 mpz_get_si (ar
->start
[i
]->value
.integer
),
4515 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4517 gfc_warning (0, "Array reference at %L is out of bounds "
4518 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4519 mpz_get_si (ar
->start
[i
]->value
.integer
),
4520 mpz_get_si (as
->lower
[i
]->value
.integer
),
4524 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4527 gfc_warning (0, "Array reference at %L is out of bounds "
4528 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4529 mpz_get_si (ar
->start
[i
]->value
.integer
),
4530 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4532 gfc_warning (0, "Array reference at %L is out of bounds "
4533 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4534 mpz_get_si (ar
->start
[i
]->value
.integer
),
4535 mpz_get_si (as
->upper
[i
]->value
.integer
),
4544 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4545 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4547 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4549 /* Check for zero stride, which is not allowed. */
4550 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4552 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4556 /* if start == len || (stride > 0 && start < len)
4557 || (stride < 0 && start > len),
4558 then the array section contains at least one element. In this
4559 case, there is an out-of-bounds access if
4560 (start < lower || start > upper). */
4561 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4562 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4563 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4564 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4565 && comp_start_end
== CMP_GT
))
4567 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4569 gfc_warning (0, "Lower array reference at %L is out of bounds "
4570 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4571 mpz_get_si (AR_START
->value
.integer
),
4572 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4575 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4577 gfc_warning (0, "Lower array reference at %L is out of bounds "
4578 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4579 mpz_get_si (AR_START
->value
.integer
),
4580 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4585 /* If we can compute the highest index of the array section,
4586 then it also has to be between lower and upper. */
4587 mpz_init (last_value
);
4588 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4591 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4593 gfc_warning (0, "Upper array reference at %L is out of bounds "
4594 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4595 mpz_get_si (last_value
),
4596 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4597 mpz_clear (last_value
);
4600 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4602 gfc_warning (0, "Upper array reference at %L is out of bounds "
4603 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4604 mpz_get_si (last_value
),
4605 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4606 mpz_clear (last_value
);
4610 mpz_clear (last_value
);
4618 gfc_internal_error ("check_dimension(): Bad array reference");
4625 /* Compare an array reference with an array specification. */
4628 compare_spec_to_ref (gfc_array_ref
*ar
)
4635 /* TODO: Full array sections are only allowed as actual parameters. */
4636 if (as
->type
== AS_ASSUMED_SIZE
4637 && (/*ar->type == AR_FULL
4638 ||*/ (ar
->type
== AR_SECTION
4639 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4641 gfc_error ("Rightmost upper bound of assumed size array section "
4642 "not specified at %L", &ar
->where
);
4646 if (ar
->type
== AR_FULL
)
4649 if (as
->rank
!= ar
->dimen
)
4651 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4652 &ar
->where
, ar
->dimen
, as
->rank
);
4656 /* ar->codimen == 0 is a local array. */
4657 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4659 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4660 &ar
->where
, ar
->codimen
, as
->corank
);
4664 for (i
= 0; i
< as
->rank
; i
++)
4665 if (!check_dimension (i
, ar
, as
))
4668 /* Local access has no coarray spec. */
4669 if (ar
->codimen
!= 0)
4670 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4672 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4673 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4675 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4676 i
+ 1 - as
->rank
, &ar
->where
);
4679 if (!check_dimension (i
, ar
, as
))
4687 /* Resolve one part of an array index. */
4690 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4691 int force_index_integer_kind
)
4698 if (!gfc_resolve_expr (index
))
4701 if (check_scalar
&& index
->rank
!= 0)
4703 gfc_error ("Array index at %L must be scalar", &index
->where
);
4707 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4709 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4710 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4714 if (index
->ts
.type
== BT_REAL
)
4715 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4719 if ((index
->ts
.kind
!= gfc_index_integer_kind
4720 && force_index_integer_kind
)
4721 || index
->ts
.type
!= BT_INTEGER
)
4724 ts
.type
= BT_INTEGER
;
4725 ts
.kind
= gfc_index_integer_kind
;
4727 gfc_convert_type_warn (index
, &ts
, 2, 0);
4733 /* Resolve one part of an array index. */
4736 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4738 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4741 /* Resolve a dim argument to an intrinsic function. */
4744 gfc_resolve_dim_arg (gfc_expr
*dim
)
4749 if (!gfc_resolve_expr (dim
))
4754 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4759 if (dim
->ts
.type
!= BT_INTEGER
)
4761 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4765 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4770 ts
.type
= BT_INTEGER
;
4771 ts
.kind
= gfc_index_integer_kind
;
4773 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4779 /* Given an expression that contains array references, update those array
4780 references to point to the right array specifications. While this is
4781 filled in during matching, this information is difficult to save and load
4782 in a module, so we take care of it here.
4784 The idea here is that the original array reference comes from the
4785 base symbol. We traverse the list of reference structures, setting
4786 the stored reference to references. Component references can
4787 provide an additional array specification. */
4790 find_array_spec (gfc_expr
*e
)
4795 bool class_as
= false;
4797 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4799 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4803 as
= e
->symtree
->n
.sym
->as
;
4805 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4810 gfc_internal_error ("find_array_spec(): Missing spec");
4817 c
= ref
->u
.c
.component
;
4818 if (c
->attr
.dimension
)
4820 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
4821 gfc_internal_error ("find_array_spec(): unused as(1)");
4833 gfc_internal_error ("find_array_spec(): unused as(2)");
4837 /* Resolve an array reference. */
4840 resolve_array_ref (gfc_array_ref
*ar
)
4842 int i
, check_scalar
;
4845 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4847 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4849 /* Do not force gfc_index_integer_kind for the start. We can
4850 do fine with any integer kind. This avoids temporary arrays
4851 created for indexing with a vector. */
4852 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4854 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4856 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4861 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4865 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4869 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4870 if (e
->expr_type
== EXPR_VARIABLE
4871 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4872 ar
->start
[i
] = gfc_get_parentheses (e
);
4876 gfc_error ("Array index at %L is an array of rank %d",
4877 &ar
->c_where
[i
], e
->rank
);
4881 /* Fill in the upper bound, which may be lower than the
4882 specified one for something like a(2:10:5), which is
4883 identical to a(2:7:5). Only relevant for strides not equal
4884 to one. Don't try a division by zero. */
4885 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4886 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4887 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4888 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4892 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4894 if (ar
->end
[i
] == NULL
)
4897 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4899 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4901 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4902 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4904 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4915 if (ar
->type
== AR_FULL
)
4917 if (ar
->as
->rank
== 0)
4918 ar
->type
= AR_ELEMENT
;
4920 /* Make sure array is the same as array(:,:), this way
4921 we don't need to special case all the time. */
4922 ar
->dimen
= ar
->as
->rank
;
4923 for (i
= 0; i
< ar
->dimen
; i
++)
4925 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4927 gcc_assert (ar
->start
[i
] == NULL
);
4928 gcc_assert (ar
->end
[i
] == NULL
);
4929 gcc_assert (ar
->stride
[i
] == NULL
);
4933 /* If the reference type is unknown, figure out what kind it is. */
4935 if (ar
->type
== AR_UNKNOWN
)
4937 ar
->type
= AR_ELEMENT
;
4938 for (i
= 0; i
< ar
->dimen
; i
++)
4939 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4940 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4942 ar
->type
= AR_SECTION
;
4947 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4950 if (ar
->as
->corank
&& ar
->codimen
== 0)
4953 ar
->codimen
= ar
->as
->corank
;
4954 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4955 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4963 resolve_substring (gfc_ref
*ref
, bool *equal_length
)
4965 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4967 if (ref
->u
.ss
.start
!= NULL
)
4969 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4972 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4974 gfc_error ("Substring start index at %L must be of type INTEGER",
4975 &ref
->u
.ss
.start
->where
);
4979 if (ref
->u
.ss
.start
->rank
!= 0)
4981 gfc_error ("Substring start index at %L must be scalar",
4982 &ref
->u
.ss
.start
->where
);
4986 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4987 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4988 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4990 gfc_error ("Substring start index at %L is less than one",
4991 &ref
->u
.ss
.start
->where
);
4996 if (ref
->u
.ss
.end
!= NULL
)
4998 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
5001 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
5003 gfc_error ("Substring end index at %L must be of type INTEGER",
5004 &ref
->u
.ss
.end
->where
);
5008 if (ref
->u
.ss
.end
->rank
!= 0)
5010 gfc_error ("Substring end index at %L must be scalar",
5011 &ref
->u
.ss
.end
->where
);
5015 if (ref
->u
.ss
.length
!= NULL
5016 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
5017 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5018 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5020 gfc_error ("Substring end index at %L exceeds the string length",
5021 &ref
->u
.ss
.start
->where
);
5025 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
5026 gfc_integer_kinds
[k
].huge
) == CMP_GT
5027 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5028 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5030 gfc_error ("Substring end index at %L is too large",
5031 &ref
->u
.ss
.end
->where
);
5034 /* If the substring has the same length as the original
5035 variable, the reference itself can be deleted. */
5037 if (ref
->u
.ss
.length
!= NULL
5038 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
5039 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
5040 *equal_length
= true;
5047 /* This function supplies missing substring charlens. */
5050 gfc_resolve_substring_charlen (gfc_expr
*e
)
5053 gfc_expr
*start
, *end
;
5054 gfc_typespec
*ts
= NULL
;
5057 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5059 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5061 if (char_ref
->type
== REF_COMPONENT
)
5062 ts
= &char_ref
->u
.c
.component
->ts
;
5065 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5068 gcc_assert (char_ref
->next
== NULL
);
5072 if (e
->ts
.u
.cl
->length
)
5073 gfc_free_expr (e
->ts
.u
.cl
->length
);
5074 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5078 e
->ts
.type
= BT_CHARACTER
;
5079 e
->ts
.kind
= gfc_default_character_kind
;
5082 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5084 if (char_ref
->u
.ss
.start
)
5085 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5087 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5089 if (char_ref
->u
.ss
.end
)
5090 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5091 else if (e
->expr_type
== EXPR_VARIABLE
)
5094 ts
= &e
->symtree
->n
.sym
->ts
;
5095 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5102 gfc_free_expr (start
);
5103 gfc_free_expr (end
);
5107 /* Length = (end - start + 1).
5108 Check first whether it has a constant length. */
5109 if (gfc_dep_difference (end
, start
, &diff
))
5111 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5114 mpz_add_ui (len
->value
.integer
, diff
, 1);
5116 e
->ts
.u
.cl
->length
= len
;
5117 /* The check for length < 0 is handled below */
5121 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5122 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5123 gfc_get_int_expr (gfc_charlen_int_kind
,
5127 /* F2008, 6.4.1: Both the starting point and the ending point shall
5128 be within the range 1, 2, ..., n unless the starting point exceeds
5129 the ending point, in which case the substring has length zero. */
5131 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5132 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5134 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5135 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5137 /* Make sure that the length is simplified. */
5138 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5139 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5143 /* Resolve subtype references. */
5146 resolve_ref (gfc_expr
*expr
)
5148 int current_part_dimension
, n_components
, seen_part_dimension
;
5149 gfc_ref
*ref
, **prev
;
5152 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5153 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5155 find_array_spec (expr
);
5159 for (prev
= &expr
->ref
; *prev
!= NULL
;
5160 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5161 switch ((*prev
)->type
)
5164 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5173 equal_length
= false;
5174 if (!resolve_substring (*prev
, &equal_length
))
5177 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5179 /* Remove the reference and move the charlen, if any. */
5183 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5184 ref
->u
.ss
.length
= NULL
;
5185 gfc_free_ref_list (ref
);
5190 /* Check constraints on part references. */
5192 current_part_dimension
= 0;
5193 seen_part_dimension
= 0;
5196 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5201 switch (ref
->u
.ar
.type
)
5204 /* Coarray scalar. */
5205 if (ref
->u
.ar
.as
->rank
== 0)
5207 current_part_dimension
= 0;
5212 current_part_dimension
= 1;
5216 current_part_dimension
= 0;
5220 gfc_internal_error ("resolve_ref(): Bad array reference");
5226 if (current_part_dimension
|| seen_part_dimension
)
5229 if (ref
->u
.c
.component
->attr
.pointer
5230 || ref
->u
.c
.component
->attr
.proc_pointer
5231 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5232 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5234 gfc_error ("Component to the right of a part reference "
5235 "with nonzero rank must not have the POINTER "
5236 "attribute at %L", &expr
->where
);
5239 else if (ref
->u
.c
.component
->attr
.allocatable
5240 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5241 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5244 gfc_error ("Component to the right of a part reference "
5245 "with nonzero rank must not have the ALLOCATABLE "
5246 "attribute at %L", &expr
->where
);
5259 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5260 || ref
->next
== NULL
)
5261 && current_part_dimension
5262 && seen_part_dimension
)
5264 gfc_error ("Two or more part references with nonzero rank must "
5265 "not be specified at %L", &expr
->where
);
5269 if (ref
->type
== REF_COMPONENT
)
5271 if (current_part_dimension
)
5272 seen_part_dimension
= 1;
5274 /* reset to make sure */
5275 current_part_dimension
= 0;
5283 /* Given an expression, determine its shape. This is easier than it sounds.
5284 Leaves the shape array NULL if it is not possible to determine the shape. */
5287 expression_shape (gfc_expr
*e
)
5289 mpz_t array
[GFC_MAX_DIMENSIONS
];
5292 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5295 for (i
= 0; i
< e
->rank
; i
++)
5296 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5299 e
->shape
= gfc_get_shape (e
->rank
);
5301 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5306 for (i
--; i
>= 0; i
--)
5307 mpz_clear (array
[i
]);
5311 /* Given a variable expression node, compute the rank of the expression by
5312 examining the base symbol and any reference structures it may have. */
5315 expression_rank (gfc_expr
*e
)
5320 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5321 could lead to serious confusion... */
5322 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5326 if (e
->expr_type
== EXPR_ARRAY
)
5328 /* Constructors can have a rank different from one via RESHAPE(). */
5330 if (e
->symtree
== NULL
)
5336 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5337 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5343 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5345 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5346 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5347 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5349 if (ref
->type
!= REF_ARRAY
)
5352 if (ref
->u
.ar
.type
== AR_FULL
)
5354 rank
= ref
->u
.ar
.as
->rank
;
5358 if (ref
->u
.ar
.type
== AR_SECTION
)
5360 /* Figure out the rank of the section. */
5362 gfc_internal_error ("expression_rank(): Two array specs");
5364 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5365 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5366 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5376 expression_shape (e
);
5381 add_caf_get_intrinsic (gfc_expr
*e
)
5383 gfc_expr
*wrapper
, *tmp_expr
;
5387 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5388 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5393 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5394 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5397 tmp_expr
= XCNEW (gfc_expr
);
5399 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5400 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5401 wrapper
->ts
= e
->ts
;
5402 wrapper
->rank
= e
->rank
;
5404 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5411 remove_caf_get_intrinsic (gfc_expr
*e
)
5413 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5414 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5415 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5416 e
->value
.function
.actual
->expr
= NULL
;
5417 gfc_free_actual_arglist (e
->value
.function
.actual
);
5418 gfc_free_shape (&e
->shape
, e
->rank
);
5424 /* Resolve a variable expression. */
5427 resolve_variable (gfc_expr
*e
)
5434 if (e
->symtree
== NULL
)
5436 sym
= e
->symtree
->n
.sym
;
5438 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5439 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5440 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5442 if (!actual_arg
|| inquiry_argument
)
5444 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5445 "be used as actual argument", sym
->name
, &e
->where
);
5449 /* TS 29113, 407b. */
5450 else if (e
->ts
.type
== BT_ASSUMED
)
5454 gfc_error ("Assumed-type variable %s at %L may only be used "
5455 "as actual argument", sym
->name
, &e
->where
);
5458 else if (inquiry_argument
&& !first_actual_arg
)
5460 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5461 for all inquiry functions in resolve_function; the reason is
5462 that the function-name resolution happens too late in that
5464 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5465 "an inquiry function shall be the first argument",
5466 sym
->name
, &e
->where
);
5470 /* TS 29113, C535b. */
5471 else if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5472 && CLASS_DATA (sym
)->as
5473 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5474 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5475 && sym
->as
->type
== AS_ASSUMED_RANK
))
5476 && !sym
->attr
.select_rank_temporary
)
5479 && !(cs_base
&& cs_base
->current
5480 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
5482 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5483 "actual argument", sym
->name
, &e
->where
);
5486 else if (inquiry_argument
&& !first_actual_arg
)
5488 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5489 for all inquiry functions in resolve_function; the reason is
5490 that the function-name resolution happens too late in that
5492 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5493 "to an inquiry function shall be the first argument",
5494 sym
->name
, &e
->where
);
5499 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5500 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5501 && e
->ref
->next
== NULL
))
5503 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5504 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5507 /* TS 29113, 407b. */
5508 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5509 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5510 && e
->ref
->next
== NULL
))
5512 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5513 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5517 /* TS 29113, C535b. */
5518 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5519 && CLASS_DATA (sym
)->as
5520 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5521 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5522 && sym
->as
->type
== AS_ASSUMED_RANK
))
5524 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5525 && e
->ref
->next
== NULL
))
5527 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5528 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5532 /* For variables that are used in an associate (target => object) where
5533 the object's basetype is array valued while the target is scalar,
5534 the ts' type of the component refs is still array valued, which
5535 can't be translated that way. */
5536 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5537 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5538 && CLASS_DATA (sym
->assoc
->target
)->as
)
5540 gfc_ref
*ref
= e
->ref
;
5546 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5547 /* Stop the loop. */
5557 /* If this is an associate-name, it may be parsed with an array reference
5558 in error even though the target is scalar. Fail directly in this case.
5559 TODO Understand why class scalar expressions must be excluded. */
5560 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5562 if (sym
->ts
.type
== BT_CLASS
)
5563 gfc_fix_class_refs (e
);
5564 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5566 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5568 /* This can happen because the parser did not detect that the
5569 associate name is an array and the expression had no array
5571 gfc_ref
*ref
= gfc_get_ref ();
5572 ref
->type
= REF_ARRAY
;
5573 ref
->u
.ar
= *gfc_get_array_ref();
5574 ref
->u
.ar
.type
= AR_FULL
;
5577 ref
->u
.ar
.as
= sym
->as
;
5578 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5586 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5587 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5589 /* On the other hand, the parser may not have known this is an array;
5590 in this case, we have to add a FULL reference. */
5591 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5593 e
->ref
= gfc_get_ref ();
5594 e
->ref
->type
= REF_ARRAY
;
5595 e
->ref
->u
.ar
.type
= AR_FULL
;
5596 e
->ref
->u
.ar
.dimen
= 0;
5599 /* Like above, but for class types, where the checking whether an array
5600 ref is present is more complicated. Furthermore make sure not to add
5601 the full array ref to _vptr or _len refs. */
5602 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5603 && CLASS_DATA (sym
)->attr
.dimension
5604 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5606 gfc_ref
*ref
, *newref
;
5608 newref
= gfc_get_ref ();
5609 newref
->type
= REF_ARRAY
;
5610 newref
->u
.ar
.type
= AR_FULL
;
5611 newref
->u
.ar
.dimen
= 0;
5612 /* Because this is an associate var and the first ref either is a ref to
5613 the _data component or not, no traversal of the ref chain is
5614 needed. The array ref needs to be inserted after the _data ref,
5615 or when that is not present, which may happend for polymorphic
5616 types, then at the first position. */
5620 else if (ref
->type
== REF_COMPONENT
5621 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5623 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5625 newref
->next
= ref
->next
;
5629 /* Array ref present already. */
5630 gfc_free_ref_list (newref
);
5632 else if (ref
->type
== REF_ARRAY
)
5633 /* Array ref present already. */
5634 gfc_free_ref_list (newref
);
5642 if (e
->ref
&& !resolve_ref (e
))
5645 if (sym
->attr
.flavor
== FL_PROCEDURE
5646 && (!sym
->attr
.function
5647 || (sym
->attr
.function
&& sym
->result
5648 && sym
->result
->attr
.proc_pointer
5649 && !sym
->result
->attr
.function
)))
5651 e
->ts
.type
= BT_PROCEDURE
;
5652 goto resolve_procedure
;
5655 if (sym
->ts
.type
!= BT_UNKNOWN
)
5656 gfc_variable_attr (e
, &e
->ts
);
5657 else if (sym
->attr
.flavor
== FL_PROCEDURE
5658 && sym
->attr
.function
&& sym
->result
5659 && sym
->result
->ts
.type
!= BT_UNKNOWN
5660 && sym
->result
->attr
.proc_pointer
)
5661 e
->ts
= sym
->result
->ts
;
5664 /* Must be a simple variable reference. */
5665 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5670 if (check_assumed_size_reference (sym
, e
))
5673 /* Deal with forward references to entries during gfc_resolve_code, to
5674 satisfy, at least partially, 12.5.2.5. */
5675 if (gfc_current_ns
->entries
5676 && current_entry_id
== sym
->entry_id
5679 && cs_base
->current
->op
!= EXEC_ENTRY
)
5681 gfc_entry_list
*entry
;
5682 gfc_formal_arglist
*formal
;
5684 bool seen
, saved_specification_expr
;
5686 /* If the symbol is a dummy... */
5687 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5689 entry
= gfc_current_ns
->entries
;
5692 /* ...test if the symbol is a parameter of previous entries. */
5693 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5694 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5696 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5703 /* If it has not been seen as a dummy, this is an error. */
5706 if (specification_expr
)
5707 gfc_error ("Variable %qs, used in a specification expression"
5708 ", is referenced at %L before the ENTRY statement "
5709 "in which it is a parameter",
5710 sym
->name
, &cs_base
->current
->loc
);
5712 gfc_error ("Variable %qs is used at %L before the ENTRY "
5713 "statement in which it is a parameter",
5714 sym
->name
, &cs_base
->current
->loc
);
5719 /* Now do the same check on the specification expressions. */
5720 saved_specification_expr
= specification_expr
;
5721 specification_expr
= true;
5722 if (sym
->ts
.type
== BT_CHARACTER
5723 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5727 for (n
= 0; n
< sym
->as
->rank
; n
++)
5729 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5731 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5734 specification_expr
= saved_specification_expr
;
5737 /* Update the symbol's entry level. */
5738 sym
->entry_id
= current_entry_id
+ 1;
5741 /* If a symbol has been host_associated mark it. This is used latter,
5742 to identify if aliasing is possible via host association. */
5743 if (sym
->attr
.flavor
== FL_VARIABLE
5744 && gfc_current_ns
->parent
5745 && (gfc_current_ns
->parent
== sym
->ns
5746 || (gfc_current_ns
->parent
->parent
5747 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5748 sym
->attr
.host_assoc
= 1;
5750 if (gfc_current_ns
->proc_name
5751 && sym
->attr
.dimension
5752 && (sym
->ns
!= gfc_current_ns
5753 || sym
->attr
.use_assoc
5754 || sym
->attr
.in_common
))
5755 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5758 if (t
&& !resolve_procedure_expression (e
))
5761 /* F2008, C617 and C1229. */
5762 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5763 && gfc_is_coindexed (e
))
5765 gfc_ref
*ref
, *ref2
= NULL
;
5767 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5769 if (ref
->type
== REF_COMPONENT
)
5771 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5775 for ( ; ref
; ref
= ref
->next
)
5776 if (ref
->type
== REF_COMPONENT
)
5779 /* Expression itself is not coindexed object. */
5780 if (ref
&& e
->ts
.type
== BT_CLASS
)
5782 gfc_error ("Polymorphic subobject of coindexed object at %L",
5787 /* Expression itself is coindexed object. */
5791 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5792 for ( ; c
; c
= c
->next
)
5793 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5795 gfc_error ("Coindexed object with polymorphic allocatable "
5796 "subcomponent at %L", &e
->where
);
5804 expression_rank (e
);
5806 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5807 add_caf_get_intrinsic (e
);
5809 /* Simplify cases where access to a parameter array results in a
5810 single constant. Suppress errors since those will have been
5811 issued before, as warnings. */
5812 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5814 gfc_push_suppress_errors ();
5815 gfc_simplify_expr (e
, 1);
5816 gfc_pop_suppress_errors ();
5823 /* Checks to see that the correct symbol has been host associated.
5824 The only situation where this arises is that in which a twice
5825 contained function is parsed after the host association is made.
5826 Therefore, on detecting this, change the symbol in the expression
5827 and convert the array reference into an actual arglist if the old
5828 symbol is a variable. */
5830 check_host_association (gfc_expr
*e
)
5832 gfc_symbol
*sym
, *old_sym
;
5836 gfc_actual_arglist
*arg
, *tail
= NULL
;
5837 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5839 /* If the expression is the result of substitution in
5840 interface.c(gfc_extend_expr) because there is no way in
5841 which the host association can be wrong. */
5842 if (e
->symtree
== NULL
5843 || e
->symtree
->n
.sym
== NULL
5844 || e
->user_operator
)
5847 old_sym
= e
->symtree
->n
.sym
;
5849 if (gfc_current_ns
->parent
5850 && old_sym
->ns
!= gfc_current_ns
)
5852 /* Use the 'USE' name so that renamed module symbols are
5853 correctly handled. */
5854 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5856 if (sym
&& old_sym
!= sym
5857 && sym
->ts
.type
== old_sym
->ts
.type
5858 && sym
->attr
.flavor
== FL_PROCEDURE
5859 && sym
->attr
.contained
)
5861 /* Clear the shape, since it might not be valid. */
5862 gfc_free_shape (&e
->shape
, e
->rank
);
5864 /* Give the expression the right symtree! */
5865 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5866 gcc_assert (st
!= NULL
);
5868 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5869 || e
->expr_type
== EXPR_FUNCTION
)
5871 /* Original was function so point to the new symbol, since
5872 the actual argument list is already attached to the
5874 e
->value
.function
.esym
= NULL
;
5879 /* Original was variable so convert array references into
5880 an actual arglist. This does not need any checking now
5881 since resolve_function will take care of it. */
5882 e
->value
.function
.actual
= NULL
;
5883 e
->expr_type
= EXPR_FUNCTION
;
5886 /* Ambiguity will not arise if the array reference is not
5887 the last reference. */
5888 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5889 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5892 gcc_assert (ref
->type
== REF_ARRAY
);
5894 /* Grab the start expressions from the array ref and
5895 copy them into actual arguments. */
5896 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5898 arg
= gfc_get_actual_arglist ();
5899 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5900 if (e
->value
.function
.actual
== NULL
)
5901 tail
= e
->value
.function
.actual
= arg
;
5909 /* Dump the reference list and set the rank. */
5910 gfc_free_ref_list (e
->ref
);
5912 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5915 gfc_resolve_expr (e
);
5919 /* This might have changed! */
5920 return e
->expr_type
== EXPR_FUNCTION
;
5925 gfc_resolve_character_operator (gfc_expr
*e
)
5927 gfc_expr
*op1
= e
->value
.op
.op1
;
5928 gfc_expr
*op2
= e
->value
.op
.op2
;
5929 gfc_expr
*e1
= NULL
;
5930 gfc_expr
*e2
= NULL
;
5932 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5934 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5935 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5936 else if (op1
->expr_type
== EXPR_CONSTANT
)
5937 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5938 op1
->value
.character
.length
);
5940 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5941 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5942 else if (op2
->expr_type
== EXPR_CONSTANT
)
5943 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5944 op2
->value
.character
.length
);
5946 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5956 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5957 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5958 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5959 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5960 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5966 /* Ensure that an character expression has a charlen and, if possible, a
5967 length expression. */
5970 fixup_charlen (gfc_expr
*e
)
5972 /* The cases fall through so that changes in expression type and the need
5973 for multiple fixes are picked up. In all circumstances, a charlen should
5974 be available for the middle end to hang a backend_decl on. */
5975 switch (e
->expr_type
)
5978 gfc_resolve_character_operator (e
);
5982 if (e
->expr_type
== EXPR_ARRAY
)
5983 gfc_resolve_character_array_constructor (e
);
5986 case EXPR_SUBSTRING
:
5987 if (!e
->ts
.u
.cl
&& e
->ref
)
5988 gfc_resolve_substring_charlen (e
);
5993 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6000 /* Update an actual argument to include the passed-object for type-bound
6001 procedures at the right position. */
6003 static gfc_actual_arglist
*
6004 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
6007 gcc_assert (argpos
> 0);
6011 gfc_actual_arglist
* result
;
6013 result
= gfc_get_actual_arglist ();
6017 result
->name
= name
;
6023 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
6025 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
6030 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6033 extract_compcall_passed_object (gfc_expr
* e
)
6037 if (e
->expr_type
== EXPR_UNKNOWN
)
6039 gfc_error ("Error in typebound call at %L",
6044 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6046 if (e
->value
.compcall
.base_object
)
6047 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
6050 po
= gfc_get_expr ();
6051 po
->expr_type
= EXPR_VARIABLE
;
6052 po
->symtree
= e
->symtree
;
6053 po
->ref
= gfc_copy_ref (e
->ref
);
6054 po
->where
= e
->where
;
6057 if (!gfc_resolve_expr (po
))
6064 /* Update the arglist of an EXPR_COMPCALL expression to include the
6068 update_compcall_arglist (gfc_expr
* e
)
6071 gfc_typebound_proc
* tbp
;
6073 tbp
= e
->value
.compcall
.tbp
;
6078 po
= extract_compcall_passed_object (e
);
6082 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6088 if (tbp
->pass_arg_num
<= 0)
6091 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6099 /* Extract the passed object from a PPC call (a copy of it). */
6102 extract_ppc_passed_object (gfc_expr
*e
)
6107 po
= gfc_get_expr ();
6108 po
->expr_type
= EXPR_VARIABLE
;
6109 po
->symtree
= e
->symtree
;
6110 po
->ref
= gfc_copy_ref (e
->ref
);
6111 po
->where
= e
->where
;
6113 /* Remove PPC reference. */
6115 while ((*ref
)->next
)
6116 ref
= &(*ref
)->next
;
6117 gfc_free_ref_list (*ref
);
6120 if (!gfc_resolve_expr (po
))
6127 /* Update the actual arglist of a procedure pointer component to include the
6131 update_ppc_arglist (gfc_expr
* e
)
6135 gfc_typebound_proc
* tb
;
6137 ppc
= gfc_get_proc_ptr_comp (e
);
6145 else if (tb
->nopass
)
6148 po
= extract_ppc_passed_object (e
);
6155 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6160 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6162 gfc_error ("Base object for procedure-pointer component call at %L is of"
6163 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6167 gcc_assert (tb
->pass_arg_num
> 0);
6168 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6176 /* Check that the object a TBP is called on is valid, i.e. it must not be
6177 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6180 check_typebound_baseobject (gfc_expr
* e
)
6183 bool return_value
= false;
6185 base
= extract_compcall_passed_object (e
);
6189 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6191 gfc_error ("Error in typebound call at %L", &e
->where
);
6195 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6199 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6201 gfc_error ("Base object for type-bound procedure call at %L is of"
6202 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6206 /* F08:C1230. If the procedure called is NOPASS,
6207 the base object must be scalar. */
6208 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6210 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6211 " be scalar", &e
->where
);
6215 return_value
= true;
6218 gfc_free_expr (base
);
6219 return return_value
;
6223 /* Resolve a call to a type-bound procedure, either function or subroutine,
6224 statically from the data in an EXPR_COMPCALL expression. The adapted
6225 arglist and the target-procedure symtree are returned. */
6228 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6229 gfc_actual_arglist
** actual
)
6231 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6232 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6234 /* Update the actual arglist for PASS. */
6235 if (!update_compcall_arglist (e
))
6238 *actual
= e
->value
.compcall
.actual
;
6239 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6241 gfc_free_ref_list (e
->ref
);
6243 e
->value
.compcall
.actual
= NULL
;
6245 /* If we find a deferred typebound procedure, check for derived types
6246 that an overriding typebound procedure has not been missed. */
6247 if (e
->value
.compcall
.name
6248 && !e
->value
.compcall
.tbp
->non_overridable
6249 && e
->value
.compcall
.base_object
6250 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6253 gfc_symbol
*derived
;
6255 /* Use the derived type of the base_object. */
6256 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6259 /* If necessary, go through the inheritance chain. */
6260 while (!st
&& derived
)
6262 /* Look for the typebound procedure 'name'. */
6263 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6264 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6265 e
->value
.compcall
.name
);
6267 derived
= gfc_get_derived_super_type (derived
);
6270 /* Now find the specific name in the derived type namespace. */
6271 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6272 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6273 derived
->ns
, 1, &st
);
6281 /* Get the ultimate declared type from an expression. In addition,
6282 return the last class/derived type reference and the copy of the
6283 reference list. If check_types is set true, derived types are
6284 identified as well as class references. */
6286 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6287 gfc_expr
*e
, bool check_types
)
6289 gfc_symbol
*declared
;
6296 *new_ref
= gfc_copy_ref (e
->ref
);
6298 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6300 if (ref
->type
!= REF_COMPONENT
)
6303 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6304 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6305 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6307 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6313 if (declared
== NULL
)
6314 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6320 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6321 which of the specific bindings (if any) matches the arglist and transform
6322 the expression into a call of that binding. */
6325 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6327 gfc_typebound_proc
* genproc
;
6328 const char* genname
;
6330 gfc_symbol
*derived
;
6332 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6333 genname
= e
->value
.compcall
.name
;
6334 genproc
= e
->value
.compcall
.tbp
;
6336 if (!genproc
->is_generic
)
6339 /* Try the bindings on this type and in the inheritance hierarchy. */
6340 for (; genproc
; genproc
= genproc
->overridden
)
6344 gcc_assert (genproc
->is_generic
);
6345 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6348 gfc_actual_arglist
* args
;
6351 gcc_assert (g
->specific
);
6353 if (g
->specific
->error
)
6356 target
= g
->specific
->u
.specific
->n
.sym
;
6358 /* Get the right arglist by handling PASS/NOPASS. */
6359 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6360 if (!g
->specific
->nopass
)
6363 po
= extract_compcall_passed_object (e
);
6366 gfc_free_actual_arglist (args
);
6370 gcc_assert (g
->specific
->pass_arg_num
> 0);
6371 gcc_assert (!g
->specific
->error
);
6372 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6373 g
->specific
->pass_arg
);
6375 resolve_actual_arglist (args
, target
->attr
.proc
,
6376 is_external_proc (target
)
6377 && gfc_sym_get_dummy_args (target
) == NULL
);
6379 /* Check if this arglist matches the formal. */
6380 matches
= gfc_arglist_matches_symbol (&args
, target
);
6382 /* Clean up and break out of the loop if we've found it. */
6383 gfc_free_actual_arglist (args
);
6386 e
->value
.compcall
.tbp
= g
->specific
;
6387 genname
= g
->specific_st
->name
;
6388 /* Pass along the name for CLASS methods, where the vtab
6389 procedure pointer component has to be referenced. */
6397 /* Nothing matching found! */
6398 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6399 " %qs at %L", genname
, &e
->where
);
6403 /* Make sure that we have the right specific instance for the name. */
6404 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6406 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6408 e
->value
.compcall
.tbp
= st
->n
.tb
;
6414 /* Resolve a call to a type-bound subroutine. */
6417 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6419 gfc_actual_arglist
* newactual
;
6420 gfc_symtree
* target
;
6422 /* Check that's really a SUBROUTINE. */
6423 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6425 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6426 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6427 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6428 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6429 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6432 gfc_error ("%qs at %L should be a SUBROUTINE",
6433 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6438 if (!check_typebound_baseobject (c
->expr1
))
6441 /* Pass along the name for CLASS methods, where the vtab
6442 procedure pointer component has to be referenced. */
6444 *name
= c
->expr1
->value
.compcall
.name
;
6446 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6449 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6451 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6453 /* Transform into an ordinary EXEC_CALL for now. */
6455 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6458 c
->ext
.actual
= newactual
;
6459 c
->symtree
= target
;
6460 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6462 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6464 gfc_free_expr (c
->expr1
);
6465 c
->expr1
= gfc_get_expr ();
6466 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6467 c
->expr1
->symtree
= target
;
6468 c
->expr1
->where
= c
->loc
;
6470 return resolve_call (c
);
6474 /* Resolve a component-call expression. */
6476 resolve_compcall (gfc_expr
* e
, const char **name
)
6478 gfc_actual_arglist
* newactual
;
6479 gfc_symtree
* target
;
6481 /* Check that's really a FUNCTION. */
6482 if (!e
->value
.compcall
.tbp
->function
)
6484 gfc_error ("%qs at %L should be a FUNCTION",
6485 e
->value
.compcall
.name
, &e
->where
);
6490 /* These must not be assign-calls! */
6491 gcc_assert (!e
->value
.compcall
.assign
);
6493 if (!check_typebound_baseobject (e
))
6496 /* Pass along the name for CLASS methods, where the vtab
6497 procedure pointer component has to be referenced. */
6499 *name
= e
->value
.compcall
.name
;
6501 if (!resolve_typebound_generic_call (e
, name
))
6503 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6505 /* Take the rank from the function's symbol. */
6506 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6507 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6509 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6510 arglist to the TBP's binding target. */
6512 if (!resolve_typebound_static (e
, &target
, &newactual
))
6515 e
->value
.function
.actual
= newactual
;
6516 e
->value
.function
.name
= NULL
;
6517 e
->value
.function
.esym
= target
->n
.sym
;
6518 e
->value
.function
.isym
= NULL
;
6519 e
->symtree
= target
;
6520 e
->ts
= target
->n
.sym
->ts
;
6521 e
->expr_type
= EXPR_FUNCTION
;
6523 /* Resolution is not necessary if this is a class subroutine; this
6524 function only has to identify the specific proc. Resolution of
6525 the call will be done next in resolve_typebound_call. */
6526 return gfc_resolve_expr (e
);
6530 static bool resolve_fl_derived (gfc_symbol
*sym
);
6533 /* Resolve a typebound function, or 'method'. First separate all
6534 the non-CLASS references by calling resolve_compcall directly. */
6537 resolve_typebound_function (gfc_expr
* e
)
6539 gfc_symbol
*declared
;
6551 /* Deal with typebound operators for CLASS objects. */
6552 expr
= e
->value
.compcall
.base_object
;
6553 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6554 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6556 /* If the base_object is not a variable, the corresponding actual
6557 argument expression must be stored in e->base_expression so
6558 that the corresponding tree temporary can be used as the base
6559 object in gfc_conv_procedure_call. */
6560 if (expr
->expr_type
!= EXPR_VARIABLE
)
6562 gfc_actual_arglist
*args
;
6564 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6566 if (expr
== args
->expr
)
6571 /* Since the typebound operators are generic, we have to ensure
6572 that any delays in resolution are corrected and that the vtab
6575 declared
= ts
.u
.derived
;
6576 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6577 if (c
->ts
.u
.derived
== NULL
)
6578 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6580 if (!resolve_compcall (e
, &name
))
6583 /* Use the generic name if it is there. */
6584 name
= name
? name
: e
->value
.function
.esym
->name
;
6585 e
->symtree
= expr
->symtree
;
6586 e
->ref
= gfc_copy_ref (expr
->ref
);
6587 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6589 /* Trim away the extraneous references that emerge from nested
6590 use of interface.c (extend_expr). */
6591 if (class_ref
&& class_ref
->next
)
6593 gfc_free_ref_list (class_ref
->next
);
6594 class_ref
->next
= NULL
;
6596 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6598 gfc_free_ref_list (e
->ref
);
6602 gfc_add_vptr_component (e
);
6603 gfc_add_component_ref (e
, name
);
6604 e
->value
.function
.esym
= NULL
;
6605 if (expr
->expr_type
!= EXPR_VARIABLE
)
6606 e
->base_expr
= expr
;
6611 return resolve_compcall (e
, NULL
);
6613 if (!resolve_ref (e
))
6616 /* Get the CLASS declared type. */
6617 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6619 if (!resolve_fl_derived (declared
))
6622 /* Weed out cases of the ultimate component being a derived type. */
6623 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6624 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6626 gfc_free_ref_list (new_ref
);
6627 return resolve_compcall (e
, NULL
);
6630 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6632 /* Treat the call as if it is a typebound procedure, in order to roll
6633 out the correct name for the specific function. */
6634 if (!resolve_compcall (e
, &name
))
6636 gfc_free_ref_list (new_ref
);
6643 /* Convert the expression to a procedure pointer component call. */
6644 e
->value
.function
.esym
= NULL
;
6650 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6651 gfc_add_vptr_component (e
);
6652 gfc_add_component_ref (e
, name
);
6654 /* Recover the typespec for the expression. This is really only
6655 necessary for generic procedures, where the additional call
6656 to gfc_add_component_ref seems to throw the collection of the
6657 correct typespec. */
6661 gfc_free_ref_list (new_ref
);
6666 /* Resolve a typebound subroutine, or 'method'. First separate all
6667 the non-CLASS references by calling resolve_typebound_call
6671 resolve_typebound_subroutine (gfc_code
*code
)
6673 gfc_symbol
*declared
;
6683 st
= code
->expr1
->symtree
;
6685 /* Deal with typebound operators for CLASS objects. */
6686 expr
= code
->expr1
->value
.compcall
.base_object
;
6687 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6688 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6690 /* If the base_object is not a variable, the corresponding actual
6691 argument expression must be stored in e->base_expression so
6692 that the corresponding tree temporary can be used as the base
6693 object in gfc_conv_procedure_call. */
6694 if (expr
->expr_type
!= EXPR_VARIABLE
)
6696 gfc_actual_arglist
*args
;
6698 args
= code
->expr1
->value
.function
.actual
;
6699 for (; args
; args
= args
->next
)
6700 if (expr
== args
->expr
)
6704 /* Since the typebound operators are generic, we have to ensure
6705 that any delays in resolution are corrected and that the vtab
6707 declared
= expr
->ts
.u
.derived
;
6708 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6709 if (c
->ts
.u
.derived
== NULL
)
6710 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6712 if (!resolve_typebound_call (code
, &name
, NULL
))
6715 /* Use the generic name if it is there. */
6716 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6717 code
->expr1
->symtree
= expr
->symtree
;
6718 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6720 /* Trim away the extraneous references that emerge from nested
6721 use of interface.c (extend_expr). */
6722 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6723 if (class_ref
&& class_ref
->next
)
6725 gfc_free_ref_list (class_ref
->next
);
6726 class_ref
->next
= NULL
;
6728 else if (code
->expr1
->ref
&& !class_ref
)
6730 gfc_free_ref_list (code
->expr1
->ref
);
6731 code
->expr1
->ref
= NULL
;
6734 /* Now use the procedure in the vtable. */
6735 gfc_add_vptr_component (code
->expr1
);
6736 gfc_add_component_ref (code
->expr1
, name
);
6737 code
->expr1
->value
.function
.esym
= NULL
;
6738 if (expr
->expr_type
!= EXPR_VARIABLE
)
6739 code
->expr1
->base_expr
= expr
;
6744 return resolve_typebound_call (code
, NULL
, NULL
);
6746 if (!resolve_ref (code
->expr1
))
6749 /* Get the CLASS declared type. */
6750 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6752 /* Weed out cases of the ultimate component being a derived type. */
6753 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6754 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6756 gfc_free_ref_list (new_ref
);
6757 return resolve_typebound_call (code
, NULL
, NULL
);
6760 if (!resolve_typebound_call (code
, &name
, &overridable
))
6762 gfc_free_ref_list (new_ref
);
6765 ts
= code
->expr1
->ts
;
6769 /* Convert the expression to a procedure pointer component call. */
6770 code
->expr1
->value
.function
.esym
= NULL
;
6771 code
->expr1
->symtree
= st
;
6774 code
->expr1
->ref
= new_ref
;
6776 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6777 gfc_add_vptr_component (code
->expr1
);
6778 gfc_add_component_ref (code
->expr1
, name
);
6780 /* Recover the typespec for the expression. This is really only
6781 necessary for generic procedures, where the additional call
6782 to gfc_add_component_ref seems to throw the collection of the
6783 correct typespec. */
6784 code
->expr1
->ts
= ts
;
6787 gfc_free_ref_list (new_ref
);
6793 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6796 resolve_ppc_call (gfc_code
* c
)
6798 gfc_component
*comp
;
6800 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6801 gcc_assert (comp
!= NULL
);
6803 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6804 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6806 if (!comp
->attr
.subroutine
)
6807 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6809 if (!resolve_ref (c
->expr1
))
6812 if (!update_ppc_arglist (c
->expr1
))
6815 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6817 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6818 !(comp
->ts
.interface
6819 && comp
->ts
.interface
->formal
)))
6822 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6825 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6831 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6834 resolve_expr_ppc (gfc_expr
* e
)
6836 gfc_component
*comp
;
6838 comp
= gfc_get_proc_ptr_comp (e
);
6839 gcc_assert (comp
!= NULL
);
6841 /* Convert to EXPR_FUNCTION. */
6842 e
->expr_type
= EXPR_FUNCTION
;
6843 e
->value
.function
.isym
= NULL
;
6844 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6846 if (comp
->as
!= NULL
)
6847 e
->rank
= comp
->as
->rank
;
6849 if (!comp
->attr
.function
)
6850 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6852 if (!resolve_ref (e
))
6855 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6856 !(comp
->ts
.interface
6857 && comp
->ts
.interface
->formal
)))
6860 if (!update_ppc_arglist (e
))
6863 if (!check_pure_function(e
))
6866 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6873 gfc_is_expandable_expr (gfc_expr
*e
)
6875 gfc_constructor
*con
;
6877 if (e
->expr_type
== EXPR_ARRAY
)
6879 /* Traverse the constructor looking for variables that are flavor
6880 parameter. Parameters must be expanded since they are fully used at
6882 con
= gfc_constructor_first (e
->value
.constructor
);
6883 for (; con
; con
= gfc_constructor_next (con
))
6885 if (con
->expr
->expr_type
== EXPR_VARIABLE
6886 && con
->expr
->symtree
6887 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6888 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6890 if (con
->expr
->expr_type
== EXPR_ARRAY
6891 && gfc_is_expandable_expr (con
->expr
))
6900 /* Sometimes variables in specification expressions of the result
6901 of module procedures in submodules wind up not being the 'real'
6902 dummy. Find this, if possible, in the namespace of the first
6906 fixup_unique_dummy (gfc_expr
*e
)
6908 gfc_symtree
*st
= NULL
;
6909 gfc_symbol
*s
= NULL
;
6911 if (e
->symtree
->n
.sym
->ns
->proc_name
6912 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6913 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6916 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6919 && st
->n
.sym
!= NULL
6920 && st
->n
.sym
->attr
.dummy
)
6924 /* Resolve an expression. That is, make sure that types of operands agree
6925 with their operators, intrinsic operators are converted to function calls
6926 for overloaded types and unresolved function references are resolved. */
6929 gfc_resolve_expr (gfc_expr
*e
)
6932 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6934 if (e
== NULL
|| e
->do_not_resolve_again
)
6937 /* inquiry_argument only applies to variables. */
6938 inquiry_save
= inquiry_argument
;
6939 actual_arg_save
= actual_arg
;
6940 first_actual_arg_save
= first_actual_arg
;
6942 if (e
->expr_type
!= EXPR_VARIABLE
)
6944 inquiry_argument
= false;
6946 first_actual_arg
= false;
6948 else if (e
->symtree
!= NULL
6949 && *e
->symtree
->name
== '@'
6950 && e
->symtree
->n
.sym
->attr
.dummy
)
6952 /* Deal with submodule specification expressions that are not
6953 found to be referenced in module.c(read_cleanup). */
6954 fixup_unique_dummy (e
);
6957 switch (e
->expr_type
)
6960 t
= resolve_operator (e
);
6966 if (check_host_association (e
))
6967 t
= resolve_function (e
);
6969 t
= resolve_variable (e
);
6971 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6972 && e
->ref
->type
!= REF_SUBSTRING
)
6973 gfc_resolve_substring_charlen (e
);
6978 t
= resolve_typebound_function (e
);
6981 case EXPR_SUBSTRING
:
6982 t
= resolve_ref (e
);
6991 t
= resolve_expr_ppc (e
);
6996 if (!resolve_ref (e
))
6999 t
= gfc_resolve_array_constructor (e
);
7000 /* Also try to expand a constructor. */
7003 expression_rank (e
);
7004 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
7005 gfc_expand_constructor (e
, false);
7008 /* This provides the opportunity for the length of constructors with
7009 character valued function elements to propagate the string length
7010 to the expression. */
7011 if (t
&& e
->ts
.type
== BT_CHARACTER
)
7013 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
7014 here rather then add a duplicate test for it above. */
7015 gfc_expand_constructor (e
, false);
7016 t
= gfc_resolve_character_array_constructor (e
);
7021 case EXPR_STRUCTURE
:
7022 t
= resolve_ref (e
);
7026 t
= resolve_structure_cons (e
, 0);
7030 t
= gfc_simplify_expr (e
, 0);
7034 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7037 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
7040 inquiry_argument
= inquiry_save
;
7041 actual_arg
= actual_arg_save
;
7042 first_actual_arg
= first_actual_arg_save
;
7044 /* For some reason, resolving these expressions a second time mangles
7045 the typespec of the expression itself. */
7046 if (t
&& e
->expr_type
== EXPR_VARIABLE
7047 && e
->symtree
->n
.sym
->attr
.select_rank_temporary
7048 && UNLIMITED_POLY (e
->symtree
->n
.sym
))
7049 e
->do_not_resolve_again
= 1;
7055 /* Resolve an expression from an iterator. They must be scalar and have
7056 INTEGER or (optionally) REAL type. */
7059 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
7060 const char *name_msgid
)
7062 if (!gfc_resolve_expr (expr
))
7065 if (expr
->rank
!= 0)
7067 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7071 if (expr
->ts
.type
!= BT_INTEGER
)
7073 if (expr
->ts
.type
== BT_REAL
)
7076 return gfc_notify_std (GFC_STD_F95_DEL
,
7077 "%s at %L must be integer",
7078 _(name_msgid
), &expr
->where
);
7081 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7088 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7096 /* Resolve the expressions in an iterator structure. If REAL_OK is
7097 false allow only INTEGER type iterators, otherwise allow REAL types.
7098 Set own_scope to true for ac-implied-do and data-implied-do as those
7099 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7102 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7104 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7107 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7108 _("iterator variable")))
7111 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7112 "Start expression in DO loop"))
7115 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7116 "End expression in DO loop"))
7119 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7120 "Step expression in DO loop"))
7123 /* Convert start, end, and step to the same type as var. */
7124 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7125 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7126 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7128 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7129 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7130 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7132 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7133 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7134 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7136 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7138 if ((iter
->step
->ts
.type
== BT_INTEGER
7139 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7140 || (iter
->step
->ts
.type
== BT_REAL
7141 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7143 gfc_error ("Step expression in DO loop at %L cannot be zero",
7144 &iter
->step
->where
);
7149 if (iter
->start
->expr_type
== EXPR_CONSTANT
7150 && iter
->end
->expr_type
== EXPR_CONSTANT
7151 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7154 if (iter
->start
->ts
.type
== BT_INTEGER
)
7156 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7157 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7161 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7162 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7164 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7165 gfc_warning (OPT_Wzerotrip
,
7166 "DO loop at %L will be executed zero times",
7167 &iter
->step
->where
);
7170 if (iter
->end
->expr_type
== EXPR_CONSTANT
7171 && iter
->end
->ts
.type
== BT_INTEGER
7172 && iter
->step
->expr_type
== EXPR_CONSTANT
7173 && iter
->step
->ts
.type
== BT_INTEGER
7174 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7175 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7177 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7178 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7180 if (is_step_positive
7181 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7182 gfc_warning (OPT_Wundefined_do_loop
,
7183 "DO loop at %L is undefined as it overflows",
7184 &iter
->step
->where
);
7185 else if (!is_step_positive
7186 && mpz_cmp (iter
->end
->value
.integer
,
7187 gfc_integer_kinds
[k
].min_int
) == 0)
7188 gfc_warning (OPT_Wundefined_do_loop
,
7189 "DO loop at %L is undefined as it underflows",
7190 &iter
->step
->where
);
7197 /* Traversal function for find_forall_index. f == 2 signals that
7198 that variable itself is not to be checked - only the references. */
7201 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7203 if (expr
->expr_type
!= EXPR_VARIABLE
)
7206 /* A scalar assignment */
7207 if (!expr
->ref
|| *f
== 1)
7209 if (expr
->symtree
->n
.sym
== sym
)
7221 /* Check whether the FORALL index appears in the expression or not.
7222 Returns true if SYM is found in EXPR. */
7225 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7227 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7234 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7235 to be a scalar INTEGER variable. The subscripts and stride are scalar
7236 INTEGERs, and if stride is a constant it must be nonzero.
7237 Furthermore "A subscript or stride in a forall-triplet-spec shall
7238 not contain a reference to any index-name in the
7239 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7242 resolve_forall_iterators (gfc_forall_iterator
*it
)
7244 gfc_forall_iterator
*iter
, *iter2
;
7246 for (iter
= it
; iter
; iter
= iter
->next
)
7248 if (gfc_resolve_expr (iter
->var
)
7249 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7250 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7253 if (gfc_resolve_expr (iter
->start
)
7254 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7255 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7256 &iter
->start
->where
);
7257 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7258 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7260 if (gfc_resolve_expr (iter
->end
)
7261 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7262 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7264 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7265 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7267 if (gfc_resolve_expr (iter
->stride
))
7269 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7270 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7271 &iter
->stride
->where
, "INTEGER");
7273 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7274 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7275 gfc_error ("FORALL stride expression at %L cannot be zero",
7276 &iter
->stride
->where
);
7278 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7279 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7282 for (iter
= it
; iter
; iter
= iter
->next
)
7283 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7285 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7286 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7287 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7288 gfc_error ("FORALL index %qs may not appear in triplet "
7289 "specification at %L", iter
->var
->symtree
->name
,
7290 &iter2
->start
->where
);
7295 /* Given a pointer to a symbol that is a derived type, see if it's
7296 inaccessible, i.e. if it's defined in another module and the components are
7297 PRIVATE. The search is recursive if necessary. Returns zero if no
7298 inaccessible components are found, nonzero otherwise. */
7301 derived_inaccessible (gfc_symbol
*sym
)
7305 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7308 for (c
= sym
->components
; c
; c
= c
->next
)
7310 /* Prevent an infinite loop through this function. */
7311 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7312 && sym
== c
->ts
.u
.derived
)
7315 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7323 /* Resolve the argument of a deallocate expression. The expression must be
7324 a pointer or a full array. */
7327 resolve_deallocate_expr (gfc_expr
*e
)
7329 symbol_attribute attr
;
7330 int allocatable
, pointer
;
7336 if (!gfc_resolve_expr (e
))
7339 if (e
->expr_type
!= EXPR_VARIABLE
)
7342 sym
= e
->symtree
->n
.sym
;
7343 unlimited
= UNLIMITED_POLY(sym
);
7345 if (sym
->ts
.type
== BT_CLASS
)
7347 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7348 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7352 allocatable
= sym
->attr
.allocatable
;
7353 pointer
= sym
->attr
.pointer
;
7355 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7360 if (ref
->u
.ar
.type
!= AR_FULL
7361 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7362 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7367 c
= ref
->u
.c
.component
;
7368 if (c
->ts
.type
== BT_CLASS
)
7370 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7371 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7375 allocatable
= c
->attr
.allocatable
;
7376 pointer
= c
->attr
.pointer
;
7387 attr
= gfc_expr_attr (e
);
7389 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7392 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7398 if (gfc_is_coindexed (e
))
7400 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7405 && !gfc_check_vardef_context (e
, true, true, false,
7406 _("DEALLOCATE object")))
7408 if (!gfc_check_vardef_context (e
, false, true, false,
7409 _("DEALLOCATE object")))
7416 /* Returns true if the expression e contains a reference to the symbol sym. */
7418 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7420 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7427 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7429 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7433 /* Given the expression node e for an allocatable/pointer of derived type to be
7434 allocated, get the expression node to be initialized afterwards (needed for
7435 derived types with default initializers, and derived types with allocatable
7436 components that need nullification.) */
7439 gfc_expr_to_initialize (gfc_expr
*e
)
7445 result
= gfc_copy_expr (e
);
7447 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7448 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7449 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7451 if (ref
->u
.ar
.dimen
== 0
7452 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->corank
)
7455 ref
->u
.ar
.type
= AR_FULL
;
7457 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7458 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7463 gfc_free_shape (&result
->shape
, result
->rank
);
7465 /* Recalculate rank, shape, etc. */
7466 gfc_resolve_expr (result
);
7471 /* If the last ref of an expression is an array ref, return a copy of the
7472 expression with that one removed. Otherwise, a copy of the original
7473 expression. This is used for allocate-expressions and pointer assignment
7474 LHS, where there may be an array specification that needs to be stripped
7475 off when using gfc_check_vardef_context. */
7478 remove_last_array_ref (gfc_expr
* e
)
7483 e2
= gfc_copy_expr (e
);
7484 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7485 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7487 gfc_free_ref_list (*r
);
7496 /* Used in resolve_allocate_expr to check that a allocation-object and
7497 a source-expr are conformable. This does not catch all possible
7498 cases; in particular a runtime checking is needed. */
7501 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7504 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7506 /* First compare rank. */
7507 if ((tail
&& (!tail
->u
.ar
.as
|| e1
->rank
!= tail
->u
.ar
.as
->rank
))
7508 || (!tail
&& e1
->rank
!= e2
->rank
))
7510 gfc_error ("Source-expr at %L must be scalar or have the "
7511 "same rank as the allocate-object at %L",
7512 &e1
->where
, &e2
->where
);
7523 for (i
= 0; i
< e1
->rank
; i
++)
7525 if (tail
->u
.ar
.start
[i
] == NULL
)
7528 if (tail
->u
.ar
.end
[i
])
7530 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7531 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7532 mpz_add_ui (s
, s
, 1);
7536 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7539 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7541 gfc_error ("Source-expr at %L and allocate-object at %L must "
7542 "have the same shape", &e1
->where
, &e2
->where
);
7555 /* Resolve the expression in an ALLOCATE statement, doing the additional
7556 checks to see whether the expression is OK or not. The expression must
7557 have a trailing array reference that gives the size of the array. */
7560 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7562 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7566 symbol_attribute attr
;
7567 gfc_ref
*ref
, *ref2
;
7570 gfc_symbol
*sym
= NULL
;
7575 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7576 checking of coarrays. */
7577 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7578 if (ref
->next
== NULL
)
7581 if (ref
&& ref
->type
== REF_ARRAY
)
7582 ref
->u
.ar
.in_allocate
= true;
7584 if (!gfc_resolve_expr (e
))
7587 /* Make sure the expression is allocatable or a pointer. If it is
7588 pointer, the next-to-last reference must be a pointer. */
7592 sym
= e
->symtree
->n
.sym
;
7594 /* Check whether ultimate component is abstract and CLASS. */
7597 /* Is the allocate-object unlimited polymorphic? */
7598 unlimited
= UNLIMITED_POLY(e
);
7600 if (e
->expr_type
!= EXPR_VARIABLE
)
7603 attr
= gfc_expr_attr (e
);
7604 pointer
= attr
.pointer
;
7605 dimension
= attr
.dimension
;
7606 codimension
= attr
.codimension
;
7610 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7612 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7613 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7614 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7615 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7616 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7620 allocatable
= sym
->attr
.allocatable
;
7621 pointer
= sym
->attr
.pointer
;
7622 dimension
= sym
->attr
.dimension
;
7623 codimension
= sym
->attr
.codimension
;
7628 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7633 if (ref
->u
.ar
.codimen
> 0)
7636 for (n
= ref
->u
.ar
.dimen
;
7637 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7638 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7645 if (ref
->next
!= NULL
)
7653 gfc_error ("Coindexed allocatable object at %L",
7658 c
= ref
->u
.c
.component
;
7659 if (c
->ts
.type
== BT_CLASS
)
7661 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7662 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7663 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7664 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7665 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7669 allocatable
= c
->attr
.allocatable
;
7670 pointer
= c
->attr
.pointer
;
7671 dimension
= c
->attr
.dimension
;
7672 codimension
= c
->attr
.codimension
;
7673 is_abstract
= c
->attr
.abstract
;
7686 /* Check for F08:C628. */
7687 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7689 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7694 /* Some checks for the SOURCE tag. */
7697 /* Check F03:C631. */
7698 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7700 gfc_error ("Type of entity at %L is type incompatible with "
7701 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7705 /* Check F03:C632 and restriction following Note 6.18. */
7706 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7709 /* Check F03:C633. */
7710 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7712 gfc_error ("The allocate-object at %L and the source-expr at %L "
7713 "shall have the same kind type parameter",
7714 &e
->where
, &code
->expr3
->where
);
7718 /* Check F2008, C642. */
7719 if (code
->expr3
->ts
.type
== BT_DERIVED
7720 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7721 || (code
->expr3
->ts
.u
.derived
->from_intmod
7722 == INTMOD_ISO_FORTRAN_ENV
7723 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7724 == ISOFORTRAN_LOCK_TYPE
)))
7726 gfc_error ("The source-expr at %L shall neither be of type "
7727 "LOCK_TYPE nor have a LOCK_TYPE component if "
7728 "allocate-object at %L is a coarray",
7729 &code
->expr3
->where
, &e
->where
);
7733 /* Check TS18508, C702/C703. */
7734 if (code
->expr3
->ts
.type
== BT_DERIVED
7735 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7736 || (code
->expr3
->ts
.u
.derived
->from_intmod
7737 == INTMOD_ISO_FORTRAN_ENV
7738 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7739 == ISOFORTRAN_EVENT_TYPE
)))
7741 gfc_error ("The source-expr at %L shall neither be of type "
7742 "EVENT_TYPE nor have a EVENT_TYPE component if "
7743 "allocate-object at %L is a coarray",
7744 &code
->expr3
->where
, &e
->where
);
7749 /* Check F08:C629. */
7750 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7753 gcc_assert (e
->ts
.type
== BT_CLASS
);
7754 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7755 "type-spec or source-expr", sym
->name
, &e
->where
);
7759 /* Check F08:C632. */
7760 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7761 && !UNLIMITED_POLY (e
))
7765 if (!e
->ts
.u
.cl
->length
)
7768 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7769 code
->ext
.alloc
.ts
.u
.cl
->length
);
7770 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7772 gfc_error ("Allocating %s at %L with type-spec requires the same "
7773 "character-length parameter as in the declaration",
7774 sym
->name
, &e
->where
);
7779 /* In the variable definition context checks, gfc_expr_attr is used
7780 on the expression. This is fooled by the array specification
7781 present in e, thus we have to eliminate that one temporarily. */
7782 e2
= remove_last_array_ref (e
);
7785 t
= gfc_check_vardef_context (e2
, true, true, false,
7786 _("ALLOCATE object"));
7788 t
= gfc_check_vardef_context (e2
, false, true, false,
7789 _("ALLOCATE object"));
7794 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7795 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7797 /* For class arrays, the initialization with SOURCE is done
7798 using _copy and trans_call. It is convenient to exploit that
7799 when the allocated type is different from the declared type but
7800 no SOURCE exists by setting expr3. */
7801 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7803 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7804 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7805 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7807 /* We have to zero initialize the integer variable. */
7808 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7811 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7813 /* Make sure the vtab symbol is present when
7814 the module variables are generated. */
7815 gfc_typespec ts
= e
->ts
;
7817 ts
= code
->expr3
->ts
;
7818 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7819 ts
= code
->ext
.alloc
.ts
;
7821 /* Finding the vtab also publishes the type's symbol. Therefore this
7822 statement is necessary. */
7823 gfc_find_derived_vtab (ts
.u
.derived
);
7825 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7827 /* Again, make sure the vtab symbol is present when
7828 the module variables are generated. */
7829 gfc_typespec
*ts
= NULL
;
7831 ts
= &code
->expr3
->ts
;
7833 ts
= &code
->ext
.alloc
.ts
;
7837 /* Finding the vtab also publishes the type's symbol. Therefore this
7838 statement is necessary. */
7842 if (dimension
== 0 && codimension
== 0)
7845 /* Make sure the last reference node is an array specification. */
7847 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7848 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7853 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7854 "in ALLOCATE statement at %L", &e
->where
))
7856 if (code
->expr3
->rank
!= 0)
7857 *array_alloc_wo_spec
= true;
7860 gfc_error ("Array specification or array-valued SOURCE= "
7861 "expression required in ALLOCATE statement at %L",
7868 gfc_error ("Array specification required in ALLOCATE statement "
7869 "at %L", &e
->where
);
7874 /* Make sure that the array section reference makes sense in the
7875 context of an ALLOCATE specification. */
7880 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7882 switch (ar
->dimen_type
[i
])
7884 case DIMEN_THIS_IMAGE
:
7885 gfc_error ("Coarray specification required in ALLOCATE statement "
7886 "at %L", &e
->where
);
7890 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0)
7892 /* If ar->stride[i] is NULL, we issued a previous error. */
7893 if (ar
->stride
[i
] == NULL
)
7894 gfc_error ("Bad array specification in ALLOCATE statement "
7895 "at %L", &e
->where
);
7898 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
7900 gfc_error ("Upper cobound is less than lower cobound at %L",
7901 &ar
->start
[i
]->where
);
7907 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
7909 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
7910 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
7912 gfc_error ("Upper cobound is less than lower cobound "
7913 "of 1 at %L", &ar
->start
[i
]->where
);
7923 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7929 for (i
= 0; i
< ar
->dimen
; i
++)
7931 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7934 switch (ar
->dimen_type
[i
])
7940 if (ar
->start
[i
] != NULL
7941 && ar
->end
[i
] != NULL
7942 && ar
->stride
[i
] == NULL
)
7950 case DIMEN_THIS_IMAGE
:
7951 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7957 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7959 sym
= a
->expr
->symtree
->n
.sym
;
7961 /* TODO - check derived type components. */
7962 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7965 if ((ar
->start
[i
] != NULL
7966 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7967 || (ar
->end
[i
] != NULL
7968 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7970 gfc_error ("%qs must not appear in the array specification at "
7971 "%L in the same ALLOCATE statement where it is "
7972 "itself allocated", sym
->name
, &ar
->where
);
7978 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7980 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7981 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7983 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7985 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7986 "statement at %L", &e
->where
);
7992 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7993 && ar
->stride
[i
] == NULL
)
7996 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
8010 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
8012 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
8013 gfc_alloc
*a
, *p
, *q
;
8016 errmsg
= code
->expr2
;
8018 /* Check the stat variable. */
8021 gfc_check_vardef_context (stat
, false, false, false,
8022 _("STAT variable"));
8024 if ((stat
->ts
.type
!= BT_INTEGER
8025 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
8026 || stat
->ref
->type
== REF_COMPONENT
)))
8028 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8029 "variable", &stat
->where
);
8031 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8032 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
8034 gfc_ref
*ref1
, *ref2
;
8037 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
8038 ref1
= ref1
->next
, ref2
= ref2
->next
)
8040 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8042 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8051 gfc_error ("Stat-variable at %L shall not be %sd within "
8052 "the same %s statement", &stat
->where
, fcn
, fcn
);
8058 /* Check the errmsg variable. */
8062 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8065 gfc_check_vardef_context (errmsg
, false, false, false,
8066 _("ERRMSG variable"));
8068 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8069 F18:R930 errmsg-variable is scalar-default-char-variable
8070 F18:R906 default-char-variable is variable
8071 F18:C906 default-char-variable shall be default character. */
8072 if ((errmsg
->ts
.type
!= BT_CHARACTER
8074 && (errmsg
->ref
->type
== REF_ARRAY
8075 || errmsg
->ref
->type
== REF_COMPONENT
)))
8077 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8078 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8079 "variable", &errmsg
->where
);
8081 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8082 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8084 gfc_ref
*ref1
, *ref2
;
8087 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
8088 ref1
= ref1
->next
, ref2
= ref2
->next
)
8090 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8092 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8101 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8102 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8108 /* Check that an allocate-object appears only once in the statement. */
8110 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8113 for (q
= p
->next
; q
; q
= q
->next
)
8116 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8118 /* This is a potential collision. */
8119 gfc_ref
*pr
= pe
->ref
;
8120 gfc_ref
*qr
= qe
->ref
;
8122 /* Follow the references until
8123 a) They start to differ, in which case there is no error;
8124 you can deallocate a%b and a%c in a single statement
8125 b) Both of them stop, which is an error
8126 c) One of them stops, which is also an error. */
8129 if (pr
== NULL
&& qr
== NULL
)
8131 gfc_error ("Allocate-object at %L also appears at %L",
8132 &pe
->where
, &qe
->where
);
8135 else if (pr
!= NULL
&& qr
== NULL
)
8137 gfc_error ("Allocate-object at %L is subobject of"
8138 " object at %L", &pe
->where
, &qe
->where
);
8141 else if (pr
== NULL
&& qr
!= NULL
)
8143 gfc_error ("Allocate-object at %L is subobject of"
8144 " object at %L", &qe
->where
, &pe
->where
);
8147 /* Here, pr != NULL && qr != NULL */
8148 gcc_assert(pr
->type
== qr
->type
);
8149 if (pr
->type
== REF_ARRAY
)
8151 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8153 gcc_assert (qr
->type
== REF_ARRAY
);
8155 if (pr
->next
&& qr
->next
)
8158 gfc_array_ref
*par
= &(pr
->u
.ar
);
8159 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8161 for (i
=0; i
<par
->dimen
; i
++)
8163 if ((par
->start
[i
] != NULL
8164 || qar
->start
[i
] != NULL
)
8165 && gfc_dep_compare_expr (par
->start
[i
],
8166 qar
->start
[i
]) != 0)
8173 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8186 if (strcmp (fcn
, "ALLOCATE") == 0)
8188 bool arr_alloc_wo_spec
= false;
8190 /* Resolving the expr3 in the loop over all objects to allocate would
8191 execute loop invariant code for each loop item. Therefore do it just
8193 if (code
->expr3
&& code
->expr3
->mold
8194 && code
->expr3
->ts
.type
== BT_DERIVED
)
8196 /* Default initialization via MOLD (non-polymorphic). */
8197 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8200 gfc_resolve_expr (rhs
);
8201 gfc_free_expr (code
->expr3
);
8205 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8206 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8208 if (arr_alloc_wo_spec
&& code
->expr3
)
8210 /* Mark the allocate to have to take the array specification
8212 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8217 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8218 resolve_deallocate_expr (a
->expr
);
8223 /************ SELECT CASE resolution subroutines ************/
8225 /* Callback function for our mergesort variant. Determines interval
8226 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8227 op1 > op2. Assumes we're not dealing with the default case.
8228 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8229 There are nine situations to check. */
8232 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8236 if (op1
->low
== NULL
) /* op1 = (:L) */
8238 /* op2 = (:N), so overlap. */
8240 /* op2 = (M:) or (M:N), L < M */
8241 if (op2
->low
!= NULL
8242 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8245 else if (op1
->high
== NULL
) /* op1 = (K:) */
8247 /* op2 = (M:), so overlap. */
8249 /* op2 = (:N) or (M:N), K > N */
8250 if (op2
->high
!= NULL
8251 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8254 else /* op1 = (K:L) */
8256 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8257 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8259 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8260 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8262 else /* op2 = (M:N) */
8266 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8269 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8278 /* Merge-sort a double linked case list, detecting overlap in the
8279 process. LIST is the head of the double linked case list before it
8280 is sorted. Returns the head of the sorted list if we don't see any
8281 overlap, or NULL otherwise. */
8284 check_case_overlap (gfc_case
*list
)
8286 gfc_case
*p
, *q
, *e
, *tail
;
8287 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8289 /* If the passed list was empty, return immediately. */
8296 /* Loop unconditionally. The only exit from this loop is a return
8297 statement, when we've finished sorting the case list. */
8304 /* Count the number of merges we do in this pass. */
8307 /* Loop while there exists a merge to be done. */
8312 /* Count this merge. */
8315 /* Cut the list in two pieces by stepping INSIZE places
8316 forward in the list, starting from P. */
8319 for (i
= 0; i
< insize
; i
++)
8328 /* Now we have two lists. Merge them! */
8329 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8331 /* See from which the next case to merge comes from. */
8334 /* P is empty so the next case must come from Q. */
8339 else if (qsize
== 0 || q
== NULL
)
8348 cmp
= compare_cases (p
, q
);
8351 /* The whole case range for P is less than the
8359 /* The whole case range for Q is greater than
8360 the case range for P. */
8367 /* The cases overlap, or they are the same
8368 element in the list. Either way, we must
8369 issue an error and get the next case from P. */
8370 /* FIXME: Sort P and Q by line number. */
8371 gfc_error ("CASE label at %L overlaps with CASE "
8372 "label at %L", &p
->where
, &q
->where
);
8380 /* Add the next element to the merged list. */
8389 /* P has now stepped INSIZE places along, and so has Q. So
8390 they're the same. */
8395 /* If we have done only one merge or none at all, we've
8396 finished sorting the cases. */
8405 /* Otherwise repeat, merging lists twice the size. */
8411 /* Check to see if an expression is suitable for use in a CASE statement.
8412 Makes sure that all case expressions are scalar constants of the same
8413 type. Return false if anything is wrong. */
8416 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8418 if (e
== NULL
) return true;
8420 if (e
->ts
.type
!= case_expr
->ts
.type
)
8422 gfc_error ("Expression in CASE statement at %L must be of type %s",
8423 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8427 /* C805 (R808) For a given case-construct, each case-value shall be of
8428 the same type as case-expr. For character type, length differences
8429 are allowed, but the kind type parameters shall be the same. */
8431 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8433 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8434 &e
->where
, case_expr
->ts
.kind
);
8438 /* Convert the case value kind to that of case expression kind,
8441 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8442 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8446 gfc_error ("Expression in CASE statement at %L must be scalar",
8455 /* Given a completely parsed select statement, we:
8457 - Validate all expressions and code within the SELECT.
8458 - Make sure that the selection expression is not of the wrong type.
8459 - Make sure that no case ranges overlap.
8460 - Eliminate unreachable cases and unreachable code resulting from
8461 removing case labels.
8463 The standard does allow unreachable cases, e.g. CASE (5:3). But
8464 they are a hassle for code generation, and to prevent that, we just
8465 cut them out here. This is not necessary for overlapping cases
8466 because they are illegal and we never even try to generate code.
8468 We have the additional caveat that a SELECT construct could have
8469 been a computed GOTO in the source code. Fortunately we can fairly
8470 easily work around that here: The case_expr for a "real" SELECT CASE
8471 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8472 we have to do is make sure that the case_expr is a scalar integer
8476 resolve_select (gfc_code
*code
, bool select_type
)
8479 gfc_expr
*case_expr
;
8480 gfc_case
*cp
, *default_case
, *tail
, *head
;
8481 int seen_unreachable
;
8487 if (code
->expr1
== NULL
)
8489 /* This was actually a computed GOTO statement. */
8490 case_expr
= code
->expr2
;
8491 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8492 gfc_error ("Selection expression in computed GOTO statement "
8493 "at %L must be a scalar integer expression",
8496 /* Further checking is not necessary because this SELECT was built
8497 by the compiler, so it should always be OK. Just move the
8498 case_expr from expr2 to expr so that we can handle computed
8499 GOTOs as normal SELECTs from here on. */
8500 code
->expr1
= code
->expr2
;
8505 case_expr
= code
->expr1
;
8506 type
= case_expr
->ts
.type
;
8509 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8511 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8512 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8514 /* Punt. Going on here just produce more garbage error messages. */
8519 if (!select_type
&& case_expr
->rank
!= 0)
8521 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8522 "expression", &case_expr
->where
);
8528 /* Raise a warning if an INTEGER case value exceeds the range of
8529 the case-expr. Later, all expressions will be promoted to the
8530 largest kind of all case-labels. */
8532 if (type
== BT_INTEGER
)
8533 for (body
= code
->block
; body
; body
= body
->block
)
8534 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8537 && gfc_check_integer_range (cp
->low
->value
.integer
,
8538 case_expr
->ts
.kind
) != ARITH_OK
)
8539 gfc_warning (0, "Expression in CASE statement at %L is "
8540 "not in the range of %s", &cp
->low
->where
,
8541 gfc_typename (&case_expr
->ts
));
8544 && cp
->low
!= cp
->high
8545 && gfc_check_integer_range (cp
->high
->value
.integer
,
8546 case_expr
->ts
.kind
) != ARITH_OK
)
8547 gfc_warning (0, "Expression in CASE statement at %L is "
8548 "not in the range of %s", &cp
->high
->where
,
8549 gfc_typename (&case_expr
->ts
));
8552 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8553 of the SELECT CASE expression and its CASE values. Walk the lists
8554 of case values, and if we find a mismatch, promote case_expr to
8555 the appropriate kind. */
8557 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8559 for (body
= code
->block
; body
; body
= body
->block
)
8561 /* Walk the case label list. */
8562 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8564 /* Intercept the DEFAULT case. It does not have a kind. */
8565 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8568 /* Unreachable case ranges are discarded, so ignore. */
8569 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8570 && cp
->low
!= cp
->high
8571 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8575 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8576 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8578 if (cp
->high
!= NULL
8579 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8580 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8585 /* Assume there is no DEFAULT case. */
8586 default_case
= NULL
;
8591 for (body
= code
->block
; body
; body
= body
->block
)
8593 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8595 seen_unreachable
= 0;
8597 /* Walk the case label list, making sure that all case labels
8599 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8601 /* Count the number of cases in the whole construct. */
8604 /* Intercept the DEFAULT case. */
8605 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8607 if (default_case
!= NULL
)
8609 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8610 "by a second DEFAULT CASE at %L",
8611 &default_case
->where
, &cp
->where
);
8622 /* Deal with single value cases and case ranges. Errors are
8623 issued from the validation function. */
8624 if (!validate_case_label_expr (cp
->low
, case_expr
)
8625 || !validate_case_label_expr (cp
->high
, case_expr
))
8631 if (type
== BT_LOGICAL
8632 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8633 || cp
->low
!= cp
->high
))
8635 gfc_error ("Logical range in CASE statement at %L is not "
8636 "allowed", &cp
->low
->where
);
8641 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8644 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8645 if (value
& seen_logical
)
8647 gfc_error ("Constant logical value in CASE statement "
8648 "is repeated at %L",
8653 seen_logical
|= value
;
8656 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8657 && cp
->low
!= cp
->high
8658 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8660 if (warn_surprising
)
8661 gfc_warning (OPT_Wsurprising
,
8662 "Range specification at %L can never be matched",
8665 cp
->unreachable
= 1;
8666 seen_unreachable
= 1;
8670 /* If the case range can be matched, it can also overlap with
8671 other cases. To make sure it does not, we put it in a
8672 double linked list here. We sort that with a merge sort
8673 later on to detect any overlapping cases. */
8677 head
->right
= head
->left
= NULL
;
8682 tail
->right
->left
= tail
;
8689 /* It there was a failure in the previous case label, give up
8690 for this case label list. Continue with the next block. */
8694 /* See if any case labels that are unreachable have been seen.
8695 If so, we eliminate them. This is a bit of a kludge because
8696 the case lists for a single case statement (label) is a
8697 single forward linked lists. */
8698 if (seen_unreachable
)
8700 /* Advance until the first case in the list is reachable. */
8701 while (body
->ext
.block
.case_list
!= NULL
8702 && body
->ext
.block
.case_list
->unreachable
)
8704 gfc_case
*n
= body
->ext
.block
.case_list
;
8705 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8707 gfc_free_case_list (n
);
8710 /* Strip all other unreachable cases. */
8711 if (body
->ext
.block
.case_list
)
8713 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8715 if (cp
->next
->unreachable
)
8717 gfc_case
*n
= cp
->next
;
8718 cp
->next
= cp
->next
->next
;
8720 gfc_free_case_list (n
);
8727 /* See if there were overlapping cases. If the check returns NULL,
8728 there was overlap. In that case we don't do anything. If head
8729 is non-NULL, we prepend the DEFAULT case. The sorted list can
8730 then used during code generation for SELECT CASE constructs with
8731 a case expression of a CHARACTER type. */
8734 head
= check_case_overlap (head
);
8736 /* Prepend the default_case if it is there. */
8737 if (head
!= NULL
&& default_case
)
8739 default_case
->left
= NULL
;
8740 default_case
->right
= head
;
8741 head
->left
= default_case
;
8745 /* Eliminate dead blocks that may be the result if we've seen
8746 unreachable case labels for a block. */
8747 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8749 if (body
->block
->ext
.block
.case_list
== NULL
)
8751 /* Cut the unreachable block from the code chain. */
8752 gfc_code
*c
= body
->block
;
8753 body
->block
= c
->block
;
8755 /* Kill the dead block, but not the blocks below it. */
8757 gfc_free_statements (c
);
8761 /* More than two cases is legal but insane for logical selects.
8762 Issue a warning for it. */
8763 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8764 gfc_warning (OPT_Wsurprising
,
8765 "Logical SELECT CASE block at %L has more that two cases",
8770 /* Check if a derived type is extensible. */
8773 gfc_type_is_extensible (gfc_symbol
*sym
)
8775 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8776 || (sym
->attr
.is_class
8777 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8782 resolve_types (gfc_namespace
*ns
);
8784 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8785 correct as well as possibly the array-spec. */
8788 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8792 gcc_assert (sym
->assoc
);
8793 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8795 /* If this is for SELECT TYPE, the target may not yet be set. In that
8796 case, return. Resolution will be called later manually again when
8798 target
= sym
->assoc
->target
;
8801 gcc_assert (!sym
->assoc
->dangling
);
8803 if (resolve_target
&& !gfc_resolve_expr (target
))
8806 /* For variable targets, we get some attributes from the target. */
8807 if (target
->expr_type
== EXPR_VARIABLE
)
8811 gcc_assert (target
->symtree
);
8812 tsym
= target
->symtree
->n
.sym
;
8814 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8815 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8817 sym
->attr
.target
= tsym
->attr
.target
8818 || gfc_expr_attr (target
).pointer
;
8819 if (is_subref_array (target
))
8820 sym
->attr
.subref_array_pointer
= 1;
8823 if (target
->expr_type
== EXPR_NULL
)
8825 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8828 else if (target
->ts
.type
== BT_UNKNOWN
)
8830 gfc_error ("Selector at %L has no type", &target
->where
);
8834 /* Get type if this was not already set. Note that it can be
8835 some other type than the target in case this is a SELECT TYPE
8836 selector! So we must not update when the type is already there. */
8837 if (sym
->ts
.type
== BT_UNKNOWN
)
8838 sym
->ts
= target
->ts
;
8840 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8842 /* See if this is a valid association-to-variable. */
8843 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8844 && !gfc_has_vector_subscript (target
));
8846 /* Finally resolve if this is an array or not. */
8847 if (sym
->attr
.dimension
&& target
->rank
== 0)
8849 /* primary.c makes the assumption that a reference to an associate
8850 name followed by a left parenthesis is an array reference. */
8851 if (sym
->ts
.type
!= BT_CHARACTER
)
8852 gfc_error ("Associate-name %qs at %L is used as array",
8853 sym
->name
, &sym
->declared_at
);
8854 sym
->attr
.dimension
= 0;
8859 /* We cannot deal with class selectors that need temporaries. */
8860 if (target
->ts
.type
== BT_CLASS
8861 && gfc_ref_needs_temporary_p (target
->ref
))
8863 gfc_error ("CLASS selector at %L needs a temporary which is not "
8864 "yet implemented", &target
->where
);
8868 if (target
->ts
.type
== BT_CLASS
)
8869 gfc_fix_class_refs (target
);
8871 if (target
->rank
!= 0 && !sym
->attr
.select_rank_temporary
)
8874 /* The rank may be incorrectly guessed at parsing, therefore make sure
8875 it is corrected now. */
8876 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8879 sym
->as
= gfc_get_array_spec ();
8881 as
->rank
= target
->rank
;
8882 as
->type
= AS_DEFERRED
;
8883 as
->corank
= gfc_get_corank (target
);
8884 sym
->attr
.dimension
= 1;
8885 if (as
->corank
!= 0)
8886 sym
->attr
.codimension
= 1;
8888 else if (sym
->ts
.type
== BT_CLASS
&& (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
8890 if (!CLASS_DATA (sym
)->as
)
8891 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
8892 as
= CLASS_DATA (sym
)->as
;
8893 as
->rank
= target
->rank
;
8894 as
->type
= AS_DEFERRED
;
8895 as
->corank
= gfc_get_corank (target
);
8896 CLASS_DATA (sym
)->attr
.dimension
= 1;
8897 if (as
->corank
!= 0)
8898 CLASS_DATA (sym
)->attr
.codimension
= 1;
8901 else if (!sym
->attr
.select_rank_temporary
)
8903 /* target's rank is 0, but the type of the sym is still array valued,
8904 which has to be corrected. */
8905 if (sym
->ts
.type
== BT_CLASS
8906 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
8909 symbol_attribute attr
;
8910 /* The associated variable's type is still the array type
8911 correct this now. */
8912 gfc_typespec
*ts
= &target
->ts
;
8915 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8920 ts
= &ref
->u
.c
.component
->ts
;
8923 if (ts
->type
== BT_CLASS
)
8924 ts
= &ts
->u
.derived
->components
->ts
;
8930 /* Create a scalar instance of the current class type. Because the
8931 rank of a class array goes into its name, the type has to be
8932 rebuild. The alternative of (re-)setting just the attributes
8933 and as in the current type, destroys the type also in other
8937 sym
->ts
.type
= BT_CLASS
;
8938 attr
= CLASS_DATA (sym
)->attr
;
8940 attr
.associate_var
= 1;
8941 attr
.dimension
= attr
.codimension
= 0;
8942 attr
.class_pointer
= 1;
8943 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8945 /* Make sure the _vptr is set. */
8946 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8947 if (c
->ts
.u
.derived
== NULL
)
8948 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8949 CLASS_DATA (sym
)->attr
.pointer
= 1;
8950 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8951 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8952 gfc_commit_symbol (sym
->ts
.u
.derived
);
8953 /* _vptr now has the _vtab in it, change it to the _vtype. */
8954 if (c
->ts
.u
.derived
->attr
.vtab
)
8955 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8956 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8957 resolve_types (c
->ts
.u
.derived
->ns
);
8961 /* Mark this as an associate variable. */
8962 sym
->attr
.associate_var
= 1;
8964 /* Fix up the type-spec for CHARACTER types. */
8965 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8968 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8970 if (sym
->ts
.deferred
&& target
->expr_type
== EXPR_VARIABLE
8971 && target
->symtree
->n
.sym
->attr
.dummy
8972 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
8974 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8975 sym
->ts
.deferred
= 1;
8978 if (!sym
->ts
.u
.cl
->length
8979 && !sym
->ts
.deferred
8980 && target
->expr_type
== EXPR_CONSTANT
)
8982 sym
->ts
.u
.cl
->length
=
8983 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8984 target
->value
.character
.length
);
8986 else if ((!sym
->ts
.u
.cl
->length
8987 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8988 && target
->expr_type
!= EXPR_VARIABLE
)
8990 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8991 sym
->ts
.deferred
= 1;
8993 /* This is reset in trans-stmt.c after the assignment
8994 of the target expression to the associate name. */
8995 sym
->attr
.allocatable
= 1;
8999 /* If the target is a good class object, so is the associate variable. */
9000 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
9001 sym
->attr
.class_ok
= 1;
9005 /* Ensure that SELECT TYPE expressions have the correct rank and a full
9006 array reference, where necessary. The symbols are artificial and so
9007 the dimension attribute and arrayspec can also be set. In addition,
9008 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
9009 This is corrected here as well.*/
9012 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
9013 int rank
, gfc_ref
*ref
)
9015 gfc_ref
*nref
= (*expr1
)->ref
;
9016 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
9017 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
9018 (*expr1
)->rank
= rank
;
9019 if (sym1
->ts
.type
== BT_CLASS
)
9021 if ((*expr1
)->ts
.type
!= BT_CLASS
)
9022 (*expr1
)->ts
= sym1
->ts
;
9024 CLASS_DATA (sym1
)->attr
.dimension
= 1;
9025 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
9026 CLASS_DATA (sym1
)->as
9027 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
9031 sym1
->attr
.dimension
= 1;
9032 if (sym1
->as
== NULL
&& sym2
)
9033 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
9036 for (; nref
; nref
= nref
->next
)
9037 if (nref
->next
== NULL
)
9040 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
9041 nref
->next
= gfc_copy_ref (ref
);
9042 else if (ref
&& !nref
)
9043 (*expr1
)->ref
= gfc_copy_ref (ref
);
9048 build_loc_call (gfc_expr
*sym_expr
)
9051 loc_call
= gfc_get_expr ();
9052 loc_call
->expr_type
= EXPR_FUNCTION
;
9053 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
9054 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
9055 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
9056 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
9057 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
9058 loc_call
->ts
.type
= BT_INTEGER
;
9059 loc_call
->ts
.kind
= gfc_index_integer_kind
;
9060 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
9061 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
9062 loc_call
->value
.function
.actual
->expr
= sym_expr
;
9063 loc_call
->where
= sym_expr
->where
;
9067 /* Resolve a SELECT TYPE statement. */
9070 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9072 gfc_symbol
*selector_type
;
9073 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9074 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9077 char name
[GFC_MAX_SYMBOL_LEN
];
9081 gfc_ref
* ref
= NULL
;
9082 gfc_expr
*selector_expr
= NULL
;
9084 ns
= code
->ext
.block
.ns
;
9087 /* Check for F03:C813. */
9088 if (code
->expr1
->ts
.type
!= BT_CLASS
9089 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9091 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9092 "at %L", &code
->loc
);
9096 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9101 gfc_ref
*ref2
= NULL
;
9102 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9103 if (ref
->type
== REF_COMPONENT
9104 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9109 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9110 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9111 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9115 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9116 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9117 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
9120 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
9121 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9123 /* F2008: C803 The selector expression must not be coindexed. */
9124 if (gfc_is_coindexed (code
->expr2
))
9126 gfc_error ("Selector at %L must not be coindexed",
9127 &code
->expr2
->where
);
9134 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9136 if (gfc_is_coindexed (code
->expr1
))
9138 gfc_error ("Selector at %L must not be coindexed",
9139 &code
->expr1
->where
);
9144 /* Loop over TYPE IS / CLASS IS cases. */
9145 for (body
= code
->block
; body
; body
= body
->block
)
9147 c
= body
->ext
.block
.case_list
;
9151 /* Check for repeated cases. */
9152 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9154 gfc_case
*d
= tail
->ext
.block
.case_list
;
9158 if (c
->ts
.type
== d
->ts
.type
9159 && ((c
->ts
.type
== BT_DERIVED
9160 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9161 && !strcmp (c
->ts
.u
.derived
->name
,
9162 d
->ts
.u
.derived
->name
))
9163 || c
->ts
.type
== BT_UNKNOWN
9164 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9165 && c
->ts
.kind
== d
->ts
.kind
)))
9167 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9168 &c
->where
, &d
->where
);
9174 /* Check F03:C815. */
9175 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9176 && !selector_type
->attr
.unlimited_polymorphic
9177 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9179 gfc_error ("Derived type %qs at %L must be extensible",
9180 c
->ts
.u
.derived
->name
, &c
->where
);
9185 /* Check F03:C816. */
9186 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
9187 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9188 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9190 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9191 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9192 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9194 gfc_error ("Unexpected intrinsic type %qs at %L",
9195 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9200 /* Check F03:C814. */
9201 if (c
->ts
.type
== BT_CHARACTER
9202 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9204 gfc_error ("The type-spec at %L shall specify that each length "
9205 "type parameter is assumed", &c
->where
);
9210 /* Intercept the DEFAULT case. */
9211 if (c
->ts
.type
== BT_UNKNOWN
)
9213 /* Check F03:C818. */
9216 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9217 "by a second DEFAULT CASE at %L",
9218 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9223 default_case
= body
;
9230 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9231 target if present. If there are any EXIT statements referring to the
9232 SELECT TYPE construct, this is no problem because the gfc_code
9233 reference stays the same and EXIT is equally possible from the BLOCK
9234 it is changed to. */
9235 code
->op
= EXEC_BLOCK
;
9238 gfc_association_list
* assoc
;
9240 assoc
= gfc_get_association_list ();
9241 assoc
->st
= code
->expr1
->symtree
;
9242 assoc
->target
= gfc_copy_expr (code
->expr2
);
9243 assoc
->target
->where
= code
->expr2
->where
;
9244 /* assoc->variable will be set by resolve_assoc_var. */
9246 code
->ext
.block
.assoc
= assoc
;
9247 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9249 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9252 code
->ext
.block
.assoc
= NULL
;
9254 /* Ensure that the selector rank and arrayspec are available to
9255 correct expressions in which they might be missing. */
9256 if (code
->expr2
&& code
->expr2
->rank
)
9258 rank
= code
->expr2
->rank
;
9259 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9260 if (ref
->next
== NULL
)
9262 if (ref
&& ref
->type
== REF_ARRAY
)
9263 ref
= gfc_copy_ref (ref
);
9265 /* Fixup expr1 if necessary. */
9267 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9269 else if (code
->expr1
->rank
)
9271 rank
= code
->expr1
->rank
;
9272 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9273 if (ref
->next
== NULL
)
9275 if (ref
&& ref
->type
== REF_ARRAY
)
9276 ref
= gfc_copy_ref (ref
);
9279 /* Add EXEC_SELECT to switch on type. */
9280 new_st
= gfc_get_code (code
->op
);
9281 new_st
->expr1
= code
->expr1
;
9282 new_st
->expr2
= code
->expr2
;
9283 new_st
->block
= code
->block
;
9284 code
->expr1
= code
->expr2
= NULL
;
9289 ns
->code
->next
= new_st
;
9291 code
->op
= EXEC_SELECT_TYPE
;
9293 /* Use the intrinsic LOC function to generate an integer expression
9294 for the vtable of the selector. Note that the rank of the selector
9295 expression has to be set to zero. */
9296 gfc_add_vptr_component (code
->expr1
);
9297 code
->expr1
->rank
= 0;
9298 code
->expr1
= build_loc_call (code
->expr1
);
9299 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9301 /* Loop over TYPE IS / CLASS IS cases. */
9302 for (body
= code
->block
; body
; body
= body
->block
)
9306 c
= body
->ext
.block
.case_list
;
9308 /* Generate an index integer expression for address of the
9309 TYPE/CLASS vtable and store it in c->low. The hash expression
9310 is stored in c->high and is used to resolve intrinsic cases. */
9311 if (c
->ts
.type
!= BT_UNKNOWN
)
9313 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9315 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9317 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9318 c
->ts
.u
.derived
->hash_value
);
9322 vtab
= gfc_find_vtab (&c
->ts
);
9323 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9324 e
= CLASS_DATA (vtab
)->initializer
;
9325 c
->high
= gfc_copy_expr (e
);
9326 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9329 ts
.kind
= gfc_integer_4_kind
;
9330 ts
.type
= BT_INTEGER
;
9331 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9335 e
= gfc_lval_expr_from_sym (vtab
);
9336 c
->low
= build_loc_call (e
);
9341 /* Associate temporary to selector. This should only be done
9342 when this case is actually true, so build a new ASSOCIATE
9343 that does precisely this here (instead of using the
9346 if (c
->ts
.type
== BT_CLASS
)
9347 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9348 else if (c
->ts
.type
== BT_DERIVED
)
9349 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9350 else if (c
->ts
.type
== BT_CHARACTER
)
9352 HOST_WIDE_INT charlen
= 0;
9353 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9354 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9355 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9356 snprintf (name
, sizeof (name
),
9357 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9358 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9361 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9364 st
= gfc_find_symtree (ns
->sym_root
, name
);
9365 gcc_assert (st
->n
.sym
->assoc
);
9366 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9367 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9368 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9370 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9371 /* Fixup the target expression if necessary. */
9373 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9376 new_st
= gfc_get_code (EXEC_BLOCK
);
9377 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9378 new_st
->ext
.block
.ns
->code
= body
->next
;
9379 body
->next
= new_st
;
9381 /* Chain in the new list only if it is marked as dangling. Otherwise
9382 there is a CASE label overlap and this is already used. Just ignore,
9383 the error is diagnosed elsewhere. */
9384 if (st
->n
.sym
->assoc
->dangling
)
9386 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9387 st
->n
.sym
->assoc
->dangling
= 0;
9390 resolve_assoc_var (st
->n
.sym
, false);
9393 /* Take out CLASS IS cases for separate treatment. */
9395 while (body
&& body
->block
)
9397 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9399 /* Add to class_is list. */
9400 if (class_is
== NULL
)
9402 class_is
= body
->block
;
9407 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9408 tail
->block
= body
->block
;
9411 /* Remove from EXEC_SELECT list. */
9412 body
->block
= body
->block
->block
;
9425 /* Add a default case to hold the CLASS IS cases. */
9426 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9427 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9429 tail
->ext
.block
.case_list
= gfc_get_case ();
9430 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9432 default_case
= tail
;
9435 /* More than one CLASS IS block? */
9436 if (class_is
->block
)
9440 /* Sort CLASS IS blocks by extension level. */
9444 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9447 /* F03:C817 (check for doubles). */
9448 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9449 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9451 gfc_error ("Double CLASS IS block in SELECT TYPE "
9453 &c2
->ext
.block
.case_list
->where
);
9456 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9457 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9460 (*c1
)->block
= c2
->block
;
9470 /* Generate IF chain. */
9471 if_st
= gfc_get_code (EXEC_IF
);
9473 for (body
= class_is
; body
; body
= body
->block
)
9475 new_st
->block
= gfc_get_code (EXEC_IF
);
9476 new_st
= new_st
->block
;
9477 /* Set up IF condition: Call _gfortran_is_extension_of. */
9478 new_st
->expr1
= gfc_get_expr ();
9479 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9480 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9481 new_st
->expr1
->ts
.kind
= 4;
9482 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9483 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9484 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9485 /* Set up arguments. */
9486 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9487 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9488 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9489 new_st
->expr1
->where
= code
->loc
;
9490 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9491 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9492 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9493 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9494 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9495 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9496 new_st
->next
= body
->next
;
9498 if (default_case
->next
)
9500 new_st
->block
= gfc_get_code (EXEC_IF
);
9501 new_st
= new_st
->block
;
9502 new_st
->next
= default_case
->next
;
9505 /* Replace CLASS DEFAULT code by the IF chain. */
9506 default_case
->next
= if_st
;
9509 /* Resolve the internal code. This cannot be done earlier because
9510 it requires that the sym->assoc of selectors is set already. */
9511 gfc_current_ns
= ns
;
9512 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9513 gfc_current_ns
= old_ns
;
9520 /* Resolve a SELECT RANK statement. */
9523 resolve_select_rank (gfc_code
*code
, gfc_namespace
*old_ns
)
9526 gfc_code
*body
, *new_st
, *tail
;
9528 char tname
[GFC_MAX_SYMBOL_LEN
];
9529 char name
[2 * GFC_MAX_SYMBOL_LEN
];
9531 gfc_expr
*selector_expr
= NULL
;
9533 HOST_WIDE_INT charlen
= 0;
9535 ns
= code
->ext
.block
.ns
;
9538 code
->op
= EXEC_BLOCK
;
9541 gfc_association_list
* assoc
;
9543 assoc
= gfc_get_association_list ();
9544 assoc
->st
= code
->expr1
->symtree
;
9545 assoc
->target
= gfc_copy_expr (code
->expr2
);
9546 assoc
->target
->where
= code
->expr2
->where
;
9547 /* assoc->variable will be set by resolve_assoc_var. */
9549 code
->ext
.block
.assoc
= assoc
;
9550 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9552 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9555 code
->ext
.block
.assoc
= NULL
;
9557 /* Loop over RANK cases. Note that returning on the errors causes a
9558 cascade of further errors because the case blocks do not compile
9560 for (body
= code
->block
; body
; body
= body
->block
)
9562 c
= body
->ext
.block
.case_list
;
9564 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9568 /* Check for repeated cases. */
9569 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9571 gfc_case
*d
= tail
->ext
.block
.case_list
;
9577 /* Check F2018: C1153. */
9578 if (!c
->low
&& !d
->low
)
9579 gfc_error ("RANK DEFAULT at %L is repeated at %L",
9580 &c
->where
, &d
->where
);
9582 if (!c
->low
|| !d
->low
)
9585 /* Check F2018: C1153. */
9586 case_value2
= (int) mpz_get_si (d
->low
->value
.integer
);
9587 if ((case_value
== case_value2
) && case_value
== -1)
9588 gfc_error ("RANK (*) at %L is repeated at %L",
9589 &c
->where
, &d
->where
);
9590 else if (case_value
== case_value2
)
9591 gfc_error ("RANK (%i) at %L is repeated at %L",
9592 case_value
, &c
->where
, &d
->where
);
9598 /* Check F2018: C1155. */
9599 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9600 || gfc_expr_attr (code
->expr1
).pointer
))
9601 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9602 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9604 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9605 || gfc_expr_attr (code
->expr1
).pointer
))
9606 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9607 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9610 /* Add EXEC_SELECT to switch on rank. */
9611 new_st
= gfc_get_code (code
->op
);
9612 new_st
->expr1
= code
->expr1
;
9613 new_st
->expr2
= code
->expr2
;
9614 new_st
->block
= code
->block
;
9615 code
->expr1
= code
->expr2
= NULL
;
9620 ns
->code
->next
= new_st
;
9622 code
->op
= EXEC_SELECT_RANK
;
9624 selector_expr
= code
->expr1
;
9626 /* Loop over SELECT RANK cases. */
9627 for (body
= code
->block
; body
; body
= body
->block
)
9629 c
= body
->ext
.block
.case_list
;
9632 /* Pass on the default case. */
9636 /* Associate temporary to selector. This should only be done
9637 when this case is actually true, so build a new ASSOCIATE
9638 that does precisely this here (instead of using the
9640 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9641 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9642 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9644 if (c
->ts
.type
== BT_CLASS
)
9645 sprintf (tname
, "class_%s", c
->ts
.u
.derived
->name
);
9646 else if (c
->ts
.type
== BT_DERIVED
)
9647 sprintf (tname
, "type_%s", c
->ts
.u
.derived
->name
);
9648 else if (c
->ts
.type
!= BT_CHARACTER
)
9649 sprintf (tname
, "%s_%d", gfc_basic_typename (c
->ts
.type
), c
->ts
.kind
);
9651 sprintf (tname
, "%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9652 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9654 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9655 if (case_value
>= 0)
9656 sprintf (name
, "__tmp_%s_rank_%d", tname
, case_value
);
9658 sprintf (name
, "__tmp_%s_rank_m%d", tname
, -case_value
);
9660 st
= gfc_find_symtree (ns
->sym_root
, name
);
9661 gcc_assert (st
->n
.sym
->assoc
);
9663 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9664 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9666 new_st
= gfc_get_code (EXEC_BLOCK
);
9667 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9668 new_st
->ext
.block
.ns
->code
= body
->next
;
9669 body
->next
= new_st
;
9671 /* Chain in the new list only if it is marked as dangling. Otherwise
9672 there is a CASE label overlap and this is already used. Just ignore,
9673 the error is diagnosed elsewhere. */
9674 if (st
->n
.sym
->assoc
->dangling
)
9676 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9677 st
->n
.sym
->assoc
->dangling
= 0;
9680 resolve_assoc_var (st
->n
.sym
, false);
9683 gfc_current_ns
= ns
;
9684 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9685 gfc_current_ns
= old_ns
;
9689 /* Resolve a transfer statement. This is making sure that:
9690 -- a derived type being transferred has only non-pointer components
9691 -- a derived type being transferred doesn't have private components, unless
9692 it's being transferred from the module where the type was defined
9693 -- we're not trying to transfer a whole assumed size array. */
9696 resolve_transfer (gfc_code
*code
)
9698 gfc_symbol
*sym
, *derived
;
9702 bool formatted
= false;
9703 gfc_dt
*dt
= code
->ext
.dt
;
9704 gfc_symbol
*dtio_sub
= NULL
;
9708 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9709 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9710 exp
= exp
->value
.op
.op1
;
9712 if (exp
&& exp
->expr_type
== EXPR_NULL
9715 gfc_error ("Invalid context for NULL () intrinsic at %L",
9720 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9721 && exp
->expr_type
!= EXPR_FUNCTION
9722 && exp
->expr_type
!= EXPR_STRUCTURE
))
9725 /* If we are reading, the variable will be changed. Note that
9726 code->ext.dt may be NULL if the TRANSFER is related to
9727 an INQUIRE statement -- but in this case, we are not reading, either. */
9728 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9729 && !gfc_check_vardef_context (exp
, false, false, false,
9733 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
9734 || exp
->expr_type
== EXPR_FUNCTION
9735 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9737 /* Go to actual component transferred. */
9738 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9739 if (ref
->type
== REF_COMPONENT
)
9740 ts
= &ref
->u
.c
.component
->ts
;
9742 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9743 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9745 derived
= ts
->u
.derived
;
9747 /* Determine when to use the formatted DTIO procedure. */
9748 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9751 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9752 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9753 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9755 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9758 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9759 /* Check to see if this is a nested DTIO call, with the
9760 dummy as the io-list object. */
9761 if (sym
&& sym
== dtio_sub
&& sym
->formal
9762 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9763 && exp
->ref
== NULL
)
9765 if (!sym
->attr
.recursive
)
9767 gfc_error ("DTIO %s procedure at %L must be recursive",
9768 sym
->name
, &sym
->declared_at
);
9775 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9777 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9778 "it is processed by a defined input/output procedure",
9783 if (ts
->type
== BT_DERIVED
)
9785 /* Check that transferred derived type doesn't contain POINTER
9786 components unless it is processed by a defined input/output
9788 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9790 gfc_error ("Data transfer element at %L cannot have POINTER "
9791 "components unless it is processed by a defined "
9792 "input/output procedure", &code
->loc
);
9797 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9799 gfc_error ("Data transfer element at %L cannot have "
9800 "procedure pointer components", &code
->loc
);
9804 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9806 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9807 "components unless it is processed by a defined "
9808 "input/output procedure", &code
->loc
);
9812 /* C_PTR and C_FUNPTR have private components which means they cannot
9813 be printed. However, if -std=gnu and not -pedantic, allow
9814 the component to be printed to help debugging. */
9815 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9817 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9818 "cannot have PRIVATE components", &code
->loc
))
9821 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9823 gfc_error ("Data transfer element at %L cannot have "
9824 "PRIVATE components unless it is processed by "
9825 "a defined input/output procedure", &code
->loc
);
9830 if (exp
->expr_type
== EXPR_STRUCTURE
)
9833 sym
= exp
->symtree
->n
.sym
;
9835 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9836 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9838 gfc_error ("Data transfer element at %L cannot be a full reference to "
9839 "an assumed-size array", &code
->loc
);
9843 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9844 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9848 /*********** Toplevel code resolution subroutines ***********/
9850 /* Find the set of labels that are reachable from this block. We also
9851 record the last statement in each block. */
9854 find_reachable_labels (gfc_code
*block
)
9861 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9863 /* Collect labels in this block. We don't keep those corresponding
9864 to END {IF|SELECT}, these are checked in resolve_branch by going
9865 up through the code_stack. */
9866 for (c
= block
; c
; c
= c
->next
)
9868 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9869 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9872 /* Merge with labels from parent block. */
9875 gcc_assert (cs_base
->prev
->reachable_labels
);
9876 bitmap_ior_into (cs_base
->reachable_labels
,
9877 cs_base
->prev
->reachable_labels
);
9883 resolve_lock_unlock_event (gfc_code
*code
)
9885 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9886 && code
->expr1
->value
.function
.isym
9887 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9888 remove_caf_get_intrinsic (code
->expr1
);
9890 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9891 && (code
->expr1
->ts
.type
!= BT_DERIVED
9892 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9893 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9894 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9895 || code
->expr1
->rank
!= 0
9896 || (!gfc_is_coarray (code
->expr1
) &&
9897 !gfc_is_coindexed (code
->expr1
))))
9898 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9899 &code
->expr1
->where
);
9900 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9901 && (code
->expr1
->ts
.type
!= BT_DERIVED
9902 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9903 || code
->expr1
->ts
.u
.derived
->from_intmod
9904 != INTMOD_ISO_FORTRAN_ENV
9905 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9906 != ISOFORTRAN_EVENT_TYPE
9907 || code
->expr1
->rank
!= 0))
9908 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9909 &code
->expr1
->where
);
9910 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9911 && !gfc_is_coindexed (code
->expr1
))
9912 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9913 &code
->expr1
->where
);
9914 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9915 gfc_error ("Event variable argument at %L must be a coarray but not "
9916 "coindexed", &code
->expr1
->where
);
9920 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9921 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9922 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9923 &code
->expr2
->where
);
9926 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9927 _("STAT variable")))
9932 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9933 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9934 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9935 &code
->expr3
->where
);
9938 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9939 _("ERRMSG variable")))
9942 /* Check for LOCK the ACQUIRED_LOCK. */
9943 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9944 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9945 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9946 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9947 "variable", &code
->expr4
->where
);
9949 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9950 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9951 _("ACQUIRED_LOCK variable")))
9954 /* Check for EVENT WAIT the UNTIL_COUNT. */
9955 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9957 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9958 || code
->expr4
->rank
!= 0)
9959 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9960 "expression", &code
->expr4
->where
);
9966 resolve_critical (gfc_code
*code
)
9968 gfc_symtree
*symtree
;
9969 gfc_symbol
*lock_type
;
9970 char name
[GFC_MAX_SYMBOL_LEN
];
9971 static int serial
= 0;
9973 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9976 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9977 GFC_PREFIX ("lock_type"));
9979 lock_type
= symtree
->n
.sym
;
9982 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9985 lock_type
= symtree
->n
.sym
;
9986 lock_type
->attr
.flavor
= FL_DERIVED
;
9987 lock_type
->attr
.zero_comp
= 1;
9988 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9989 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9992 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9993 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9996 code
->resolved_sym
= symtree
->n
.sym
;
9997 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9998 symtree
->n
.sym
->attr
.referenced
= 1;
9999 symtree
->n
.sym
->attr
.artificial
= 1;
10000 symtree
->n
.sym
->attr
.codimension
= 1;
10001 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
10002 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
10003 symtree
->n
.sym
->as
= gfc_get_array_spec ();
10004 symtree
->n
.sym
->as
->corank
= 1;
10005 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
10006 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
10007 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
10009 gfc_commit_symbols();
10014 resolve_sync (gfc_code
*code
)
10016 /* Check imageset. The * case matches expr1 == NULL. */
10019 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
10020 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
10021 "INTEGER expression", &code
->expr1
->where
);
10022 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
10023 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
10024 gfc_error ("Imageset argument at %L must between 1 and num_images()",
10025 &code
->expr1
->where
);
10026 else if (code
->expr1
->expr_type
== EXPR_ARRAY
10027 && gfc_simplify_expr (code
->expr1
, 0))
10029 gfc_constructor
*cons
;
10030 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
10031 for (; cons
; cons
= gfc_constructor_next (cons
))
10032 if (cons
->expr
->expr_type
== EXPR_CONSTANT
10033 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
10034 gfc_error ("Imageset argument at %L must between 1 and "
10035 "num_images()", &cons
->expr
->where
);
10040 gfc_resolve_expr (code
->expr2
);
10042 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
10043 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
10044 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10045 &code
->expr2
->where
);
10047 /* Check ERRMSG. */
10048 gfc_resolve_expr (code
->expr3
);
10050 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
10051 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
10052 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10053 &code
->expr3
->where
);
10057 /* Given a branch to a label, see if the branch is conforming.
10058 The code node describes where the branch is located. */
10061 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
10068 /* Step one: is this a valid branching target? */
10070 if (label
->defined
== ST_LABEL_UNKNOWN
)
10072 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
10077 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
10079 gfc_error ("Statement at %L is not a valid branch target statement "
10080 "for the branch statement at %L", &label
->where
, &code
->loc
);
10084 /* Step two: make sure this branch is not a branch to itself ;-) */
10086 if (code
->here
== label
)
10089 "Branch at %L may result in an infinite loop", &code
->loc
);
10093 /* Step three: See if the label is in the same block as the
10094 branching statement. The hard work has been done by setting up
10095 the bitmap reachable_labels. */
10097 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
10099 /* Check now whether there is a CRITICAL construct; if so, check
10100 whether the label is still visible outside of the CRITICAL block,
10101 which is invalid. */
10102 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10104 if (stack
->current
->op
== EXEC_CRITICAL
10105 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10106 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
10107 "label at %L", &code
->loc
, &label
->where
);
10108 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
10109 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10110 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
10111 "for label at %L", &code
->loc
, &label
->where
);
10117 /* Step four: If we haven't found the label in the bitmap, it may
10118 still be the label of the END of the enclosing block, in which
10119 case we find it by going up the code_stack. */
10121 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10123 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
10125 if (stack
->current
->op
== EXEC_CRITICAL
)
10127 /* Note: A label at END CRITICAL does not leave the CRITICAL
10128 construct as END CRITICAL is still part of it. */
10129 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
10130 " at %L", &code
->loc
, &label
->where
);
10133 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
10135 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
10136 "label at %L", &code
->loc
, &label
->where
);
10143 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
10147 /* The label is not in an enclosing block, so illegal. This was
10148 allowed in Fortran 66, so we allow it as extension. No
10149 further checks are necessary in this case. */
10150 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
10151 "as the GOTO statement at %L", &label
->where
,
10157 /* Check whether EXPR1 has the same shape as EXPR2. */
10160 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
10162 mpz_t shape
[GFC_MAX_DIMENSIONS
];
10163 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
10164 bool result
= false;
10167 /* Compare the rank. */
10168 if (expr1
->rank
!= expr2
->rank
)
10171 /* Compare the size of each dimension. */
10172 for (i
=0; i
<expr1
->rank
; i
++)
10174 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
10177 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
10180 if (mpz_cmp (shape
[i
], shape2
[i
]))
10184 /* When either of the two expression is an assumed size array, we
10185 ignore the comparison of dimension sizes. */
10190 gfc_clear_shape (shape
, i
);
10191 gfc_clear_shape (shape2
, i
);
10196 /* Check whether a WHERE assignment target or a WHERE mask expression
10197 has the same shape as the outmost WHERE mask expression. */
10200 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
10204 gfc_expr
*e
= NULL
;
10206 cblock
= code
->block
;
10208 /* Store the first WHERE mask-expr of the WHERE statement or construct.
10209 In case of nested WHERE, only the outmost one is stored. */
10210 if (mask
== NULL
) /* outmost WHERE */
10212 else /* inner WHERE */
10219 /* Check if the mask-expr has a consistent shape with the
10220 outmost WHERE mask-expr. */
10221 if (!resolve_where_shape (cblock
->expr1
, e
))
10222 gfc_error ("WHERE mask at %L has inconsistent shape",
10223 &cblock
->expr1
->where
);
10226 /* the assignment statement of a WHERE statement, or the first
10227 statement in where-body-construct of a WHERE construct */
10228 cnext
= cblock
->next
;
10233 /* WHERE assignment statement */
10236 /* Check shape consistent for WHERE assignment target. */
10237 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10238 gfc_error ("WHERE assignment target at %L has "
10239 "inconsistent shape", &cnext
->expr1
->where
);
10243 case EXEC_ASSIGN_CALL
:
10244 resolve_call (cnext
);
10245 if (!cnext
->resolved_sym
->attr
.elemental
)
10246 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10247 &cnext
->ext
.actual
->expr
->where
);
10250 /* WHERE or WHERE construct is part of a where-body-construct */
10252 resolve_where (cnext
, e
);
10256 gfc_error ("Unsupported statement inside WHERE at %L",
10259 /* the next statement within the same where-body-construct */
10260 cnext
= cnext
->next
;
10262 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10263 cblock
= cblock
->block
;
10268 /* Resolve assignment in FORALL construct.
10269 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10270 FORALL index variables. */
10273 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10277 for (n
= 0; n
< nvar
; n
++)
10279 gfc_symbol
*forall_index
;
10281 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10283 /* Check whether the assignment target is one of the FORALL index
10285 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10286 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10287 gfc_error ("Assignment to a FORALL index variable at %L",
10288 &code
->expr1
->where
);
10291 /* If one of the FORALL index variables doesn't appear in the
10292 assignment variable, then there could be a many-to-one
10293 assignment. Emit a warning rather than an error because the
10294 mask could be resolving this problem. */
10295 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10296 gfc_warning (0, "The FORALL with index %qs is not used on the "
10297 "left side of the assignment at %L and so might "
10298 "cause multiple assignment to this object",
10299 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10305 /* Resolve WHERE statement in FORALL construct. */
10308 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10309 gfc_expr
**var_expr
)
10314 cblock
= code
->block
;
10317 /* the assignment statement of a WHERE statement, or the first
10318 statement in where-body-construct of a WHERE construct */
10319 cnext
= cblock
->next
;
10324 /* WHERE assignment statement */
10326 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10329 /* WHERE operator assignment statement */
10330 case EXEC_ASSIGN_CALL
:
10331 resolve_call (cnext
);
10332 if (!cnext
->resolved_sym
->attr
.elemental
)
10333 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10334 &cnext
->ext
.actual
->expr
->where
);
10337 /* WHERE or WHERE construct is part of a where-body-construct */
10339 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10343 gfc_error ("Unsupported statement inside WHERE at %L",
10346 /* the next statement within the same where-body-construct */
10347 cnext
= cnext
->next
;
10349 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10350 cblock
= cblock
->block
;
10355 /* Traverse the FORALL body to check whether the following errors exist:
10356 1. For assignment, check if a many-to-one assignment happens.
10357 2. For WHERE statement, check the WHERE body to see if there is any
10358 many-to-one assignment. */
10361 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10365 c
= code
->block
->next
;
10371 case EXEC_POINTER_ASSIGN
:
10372 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10375 case EXEC_ASSIGN_CALL
:
10379 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10380 there is no need to handle it here. */
10384 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10389 /* The next statement in the FORALL body. */
10395 /* Counts the number of iterators needed inside a forall construct, including
10396 nested forall constructs. This is used to allocate the needed memory
10397 in gfc_resolve_forall. */
10400 gfc_count_forall_iterators (gfc_code
*code
)
10402 int max_iters
, sub_iters
, current_iters
;
10403 gfc_forall_iterator
*fa
;
10405 gcc_assert(code
->op
== EXEC_FORALL
);
10409 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10412 code
= code
->block
->next
;
10416 if (code
->op
== EXEC_FORALL
)
10418 sub_iters
= gfc_count_forall_iterators (code
);
10419 if (sub_iters
> max_iters
)
10420 max_iters
= sub_iters
;
10425 return current_iters
+ max_iters
;
10429 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10430 gfc_resolve_forall_body to resolve the FORALL body. */
10433 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10435 static gfc_expr
**var_expr
;
10436 static int total_var
= 0;
10437 static int nvar
= 0;
10438 int i
, old_nvar
, tmp
;
10439 gfc_forall_iterator
*fa
;
10443 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10446 /* Start to resolve a FORALL construct */
10447 if (forall_save
== 0)
10449 /* Count the total number of FORALL indices in the nested FORALL
10450 construct in order to allocate the VAR_EXPR with proper size. */
10451 total_var
= gfc_count_forall_iterators (code
);
10453 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10454 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10457 /* The information about FORALL iterator, including FORALL indices start, end
10458 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10459 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10461 /* Fortran 20008: C738 (R753). */
10462 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10464 gfc_error ("FORALL index-name at %L must be a scalar variable "
10465 "of type integer", &fa
->var
->where
);
10469 /* Check if any outer FORALL index name is the same as the current
10471 for (i
= 0; i
< nvar
; i
++)
10473 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10474 gfc_error ("An outer FORALL construct already has an index "
10475 "with this name %L", &fa
->var
->where
);
10478 /* Record the current FORALL index. */
10479 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10483 /* No memory leak. */
10484 gcc_assert (nvar
<= total_var
);
10487 /* Resolve the FORALL body. */
10488 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10490 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10491 gfc_resolve_blocks (code
->block
, ns
);
10495 /* Free only the VAR_EXPRs allocated in this frame. */
10496 for (i
= nvar
; i
< tmp
; i
++)
10497 gfc_free_expr (var_expr
[i
]);
10501 /* We are in the outermost FORALL construct. */
10502 gcc_assert (forall_save
== 0);
10504 /* VAR_EXPR is not needed any more. */
10511 /* Resolve a BLOCK construct statement. */
10514 resolve_block_construct (gfc_code
* code
)
10516 /* Resolve the BLOCK's namespace. */
10517 gfc_resolve (code
->ext
.block
.ns
);
10519 /* For an ASSOCIATE block, the associations (and their targets) are already
10520 resolved during resolve_symbol. */
10524 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10528 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10532 for (; b
; b
= b
->block
)
10534 t
= gfc_resolve_expr (b
->expr1
);
10535 if (!gfc_resolve_expr (b
->expr2
))
10541 if (t
&& b
->expr1
!= NULL
10542 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10543 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10549 && b
->expr1
!= NULL
10550 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10551 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10556 resolve_branch (b
->label1
, b
);
10560 resolve_block_construct (b
);
10564 case EXEC_SELECT_TYPE
:
10565 case EXEC_SELECT_RANK
:
10568 case EXEC_DO_WHILE
:
10569 case EXEC_DO_CONCURRENT
:
10570 case EXEC_CRITICAL
:
10573 case EXEC_IOLENGTH
:
10577 case EXEC_OMP_ATOMIC
:
10578 case EXEC_OACC_ATOMIC
:
10580 gfc_omp_atomic_op aop
10581 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10583 /* Verify this before calling gfc_resolve_code, which might
10585 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10586 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10587 && b
->next
->next
== NULL
)
10588 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10589 && b
->next
->next
!= NULL
10590 && b
->next
->next
->op
== EXEC_ASSIGN
10591 && b
->next
->next
->next
== NULL
));
10595 case EXEC_OACC_PARALLEL_LOOP
:
10596 case EXEC_OACC_PARALLEL
:
10597 case EXEC_OACC_KERNELS_LOOP
:
10598 case EXEC_OACC_KERNELS
:
10599 case EXEC_OACC_DATA
:
10600 case EXEC_OACC_HOST_DATA
:
10601 case EXEC_OACC_LOOP
:
10602 case EXEC_OACC_UPDATE
:
10603 case EXEC_OACC_WAIT
:
10604 case EXEC_OACC_CACHE
:
10605 case EXEC_OACC_ENTER_DATA
:
10606 case EXEC_OACC_EXIT_DATA
:
10607 case EXEC_OACC_ROUTINE
:
10608 case EXEC_OMP_CRITICAL
:
10609 case EXEC_OMP_DISTRIBUTE
:
10610 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10611 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10612 case EXEC_OMP_DISTRIBUTE_SIMD
:
10614 case EXEC_OMP_DO_SIMD
:
10615 case EXEC_OMP_MASTER
:
10616 case EXEC_OMP_ORDERED
:
10617 case EXEC_OMP_PARALLEL
:
10618 case EXEC_OMP_PARALLEL_DO
:
10619 case EXEC_OMP_PARALLEL_DO_SIMD
:
10620 case EXEC_OMP_PARALLEL_SECTIONS
:
10621 case EXEC_OMP_PARALLEL_WORKSHARE
:
10622 case EXEC_OMP_SECTIONS
:
10623 case EXEC_OMP_SIMD
:
10624 case EXEC_OMP_SINGLE
:
10625 case EXEC_OMP_TARGET
:
10626 case EXEC_OMP_TARGET_DATA
:
10627 case EXEC_OMP_TARGET_ENTER_DATA
:
10628 case EXEC_OMP_TARGET_EXIT_DATA
:
10629 case EXEC_OMP_TARGET_PARALLEL
:
10630 case EXEC_OMP_TARGET_PARALLEL_DO
:
10631 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10632 case EXEC_OMP_TARGET_SIMD
:
10633 case EXEC_OMP_TARGET_TEAMS
:
10634 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10635 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10636 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10637 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10638 case EXEC_OMP_TARGET_UPDATE
:
10639 case EXEC_OMP_TASK
:
10640 case EXEC_OMP_TASKGROUP
:
10641 case EXEC_OMP_TASKLOOP
:
10642 case EXEC_OMP_TASKLOOP_SIMD
:
10643 case EXEC_OMP_TASKWAIT
:
10644 case EXEC_OMP_TASKYIELD
:
10645 case EXEC_OMP_TEAMS
:
10646 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10647 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10648 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10649 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10650 case EXEC_OMP_WORKSHARE
:
10654 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10657 gfc_resolve_code (b
->next
, ns
);
10662 /* Does everything to resolve an ordinary assignment. Returns true
10663 if this is an interface assignment. */
10665 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10672 symbol_attribute attr
;
10674 if (gfc_extend_assign (code
, ns
))
10678 if (code
->op
== EXEC_ASSIGN_CALL
)
10680 lhs
= code
->ext
.actual
->expr
;
10681 rhsptr
= &code
->ext
.actual
->next
->expr
;
10685 gfc_actual_arglist
* args
;
10686 gfc_typebound_proc
* tbp
;
10688 gcc_assert (code
->op
== EXEC_COMPCALL
);
10690 args
= code
->expr1
->value
.compcall
.actual
;
10692 rhsptr
= &args
->next
->expr
;
10694 tbp
= code
->expr1
->value
.compcall
.tbp
;
10695 gcc_assert (!tbp
->is_generic
);
10698 /* Make a temporary rhs when there is a default initializer
10699 and rhs is the same symbol as the lhs. */
10700 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10701 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10702 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10703 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10704 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10712 /* Handle the case of a BOZ literal on the RHS. */
10713 if (rhs
->ts
.type
== BT_BOZ
)
10715 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
10716 "statement value nor an actual argument of "
10717 "INT/REAL/DBLE/CMPLX intrinsic subprogram",
10721 switch (lhs
->ts
.type
)
10724 if (!gfc_boz2int (rhs
, lhs
->ts
.kind
))
10728 if (!gfc_boz2real (rhs
, lhs
->ts
.kind
))
10732 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs
->where
);
10737 if (lhs
->ts
.type
== BT_CHARACTER
&& warn_character_truncation
)
10739 HOST_WIDE_INT llen
= 0, rlen
= 0;
10740 if (lhs
->ts
.u
.cl
!= NULL
10741 && lhs
->ts
.u
.cl
->length
!= NULL
10742 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10743 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10745 if (rhs
->expr_type
== EXPR_CONSTANT
)
10746 rlen
= rhs
->value
.character
.length
;
10748 else if (rhs
->ts
.u
.cl
!= NULL
10749 && rhs
->ts
.u
.cl
->length
!= NULL
10750 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10751 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10753 if (rlen
&& llen
&& rlen
> llen
)
10754 gfc_warning_now (OPT_Wcharacter_truncation
,
10755 "CHARACTER expression will be truncated "
10756 "in assignment (%ld/%ld) at %L",
10757 (long) llen
, (long) rlen
, &code
->loc
);
10760 /* Ensure that a vector index expression for the lvalue is evaluated
10761 to a temporary if the lvalue symbol is referenced in it. */
10764 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10765 if (ref
->type
== REF_ARRAY
)
10767 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10768 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10769 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10770 ref
->u
.ar
.start
[n
]))
10772 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10776 if (gfc_pure (NULL
))
10778 if (lhs
->ts
.type
== BT_DERIVED
10779 && lhs
->expr_type
== EXPR_VARIABLE
10780 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10781 && rhs
->expr_type
== EXPR_VARIABLE
10782 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10783 || gfc_is_coindexed (rhs
)))
10785 /* F2008, C1283. */
10786 if (gfc_is_coindexed (rhs
))
10787 gfc_error ("Coindexed expression at %L is assigned to "
10788 "a derived type variable with a POINTER "
10789 "component in a PURE procedure",
10792 gfc_error ("The impure variable at %L is assigned to "
10793 "a derived type variable with a POINTER "
10794 "component in a PURE procedure (12.6)",
10799 /* Fortran 2008, C1283. */
10800 if (gfc_is_coindexed (lhs
))
10802 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10803 "procedure", &rhs
->where
);
10808 if (gfc_implicit_pure (NULL
))
10810 if (lhs
->expr_type
== EXPR_VARIABLE
10811 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10812 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10813 gfc_unset_implicit_pure (NULL
);
10815 if (lhs
->ts
.type
== BT_DERIVED
10816 && lhs
->expr_type
== EXPR_VARIABLE
10817 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10818 && rhs
->expr_type
== EXPR_VARIABLE
10819 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10820 || gfc_is_coindexed (rhs
)))
10821 gfc_unset_implicit_pure (NULL
);
10823 /* Fortran 2008, C1283. */
10824 if (gfc_is_coindexed (lhs
))
10825 gfc_unset_implicit_pure (NULL
);
10828 /* F2008, 7.2.1.2. */
10829 attr
= gfc_expr_attr (lhs
);
10830 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10832 if (attr
.codimension
)
10834 gfc_error ("Assignment to polymorphic coarray at %L is not "
10835 "permitted", &lhs
->where
);
10838 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10839 "polymorphic variable at %L", &lhs
->where
))
10841 if (!flag_realloc_lhs
)
10843 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10844 "requires %<-frealloc-lhs%>", &lhs
->where
);
10848 else if (lhs
->ts
.type
== BT_CLASS
)
10850 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10851 "assignment at %L - check that there is a matching specific "
10852 "subroutine for '=' operator", &lhs
->where
);
10856 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10858 /* F2008, Section 7.2.1.2. */
10859 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10861 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10862 "component in assignment at %L", &lhs
->where
);
10866 /* Assign the 'data' of a class object to a derived type. */
10867 if (lhs
->ts
.type
== BT_DERIVED
10868 && rhs
->ts
.type
== BT_CLASS
10869 && rhs
->expr_type
!= EXPR_ARRAY
)
10870 gfc_add_data_component (rhs
);
10872 /* Make sure there is a vtable and, in particular, a _copy for the
10874 if (UNLIMITED_POLY (lhs
) && lhs
->rank
&& rhs
->ts
.type
!= BT_CLASS
)
10875 gfc_find_vtab (&rhs
->ts
);
10877 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10879 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10880 && code
->expr2
->value
.function
.isym
10881 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10882 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10883 && !gfc_expr_attr (rhs
).allocatable
10884 && !gfc_has_vector_subscript (rhs
)));
10886 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10888 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10889 Additionally, insert this code when the RHS is a CAF as we then use the
10890 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10891 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10892 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10894 if (caf_convert_to_send
)
10896 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10897 && code
->expr2
->value
.function
.isym
10898 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10899 remove_caf_get_intrinsic (code
->expr2
);
10900 code
->op
= EXEC_CALL
;
10901 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10902 code
->resolved_sym
= code
->symtree
->n
.sym
;
10903 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10904 code
->resolved_sym
->attr
.intrinsic
= 1;
10905 code
->resolved_sym
->attr
.subroutine
= 1;
10906 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10907 gfc_commit_symbol (code
->resolved_sym
);
10908 code
->ext
.actual
= gfc_get_actual_arglist ();
10909 code
->ext
.actual
->expr
= lhs
;
10910 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10911 code
->ext
.actual
->next
->expr
= rhs
;
10912 code
->expr1
= NULL
;
10913 code
->expr2
= NULL
;
10920 /* Add a component reference onto an expression. */
10923 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10928 ref
= &((*ref
)->next
);
10929 *ref
= gfc_get_ref ();
10930 (*ref
)->type
= REF_COMPONENT
;
10931 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10932 (*ref
)->u
.c
.component
= c
;
10935 /* Add a full array ref, as necessary. */
10938 gfc_add_full_array_ref (e
, c
->as
);
10939 e
->rank
= c
->as
->rank
;
10944 /* Build an assignment. Keep the argument 'op' for future use, so that
10945 pointer assignments can be made. */
10948 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10949 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10951 gfc_code
*this_code
;
10953 this_code
= gfc_get_code (op
);
10954 this_code
->next
= NULL
;
10955 this_code
->expr1
= gfc_copy_expr (expr1
);
10956 this_code
->expr2
= gfc_copy_expr (expr2
);
10957 this_code
->loc
= loc
;
10958 if (comp1
&& comp2
)
10960 add_comp_ref (this_code
->expr1
, comp1
);
10961 add_comp_ref (this_code
->expr2
, comp2
);
10968 /* Makes a temporary variable expression based on the characteristics of
10969 a given variable expression. */
10972 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10974 static int serial
= 0;
10975 char name
[GFC_MAX_SYMBOL_LEN
];
10977 gfc_array_spec
*as
;
10978 gfc_array_ref
*aref
;
10981 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10982 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10983 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10985 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
10986 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
10988 e
->value
.character
.length
);
10994 /* Obtain the arrayspec for the temporary. */
10995 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10996 && e
->expr_type
!= EXPR_FUNCTION
10997 && e
->expr_type
!= EXPR_OP
)
10999 aref
= gfc_find_array_ref (e
);
11000 if (e
->expr_type
== EXPR_VARIABLE
11001 && e
->symtree
->n
.sym
->as
== aref
->as
)
11005 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
11006 if (ref
->type
== REF_COMPONENT
11007 && ref
->u
.c
.component
->as
== aref
->as
)
11015 /* Add the attributes and the arrayspec to the temporary. */
11016 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
11017 tmp
->n
.sym
->attr
.function
= 0;
11018 tmp
->n
.sym
->attr
.result
= 0;
11019 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
11020 tmp
->n
.sym
->attr
.dummy
= 0;
11021 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
11025 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
11028 if (as
->type
== AS_DEFERRED
)
11029 tmp
->n
.sym
->attr
.allocatable
= 1;
11031 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
11032 || e
->expr_type
== EXPR_FUNCTION
11033 || e
->expr_type
== EXPR_OP
))
11035 tmp
->n
.sym
->as
= gfc_get_array_spec ();
11036 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
11037 tmp
->n
.sym
->as
->rank
= e
->rank
;
11038 tmp
->n
.sym
->attr
.allocatable
= 1;
11039 tmp
->n
.sym
->attr
.dimension
= 1;
11042 tmp
->n
.sym
->attr
.dimension
= 0;
11044 gfc_set_sym_referenced (tmp
->n
.sym
);
11045 gfc_commit_symbol (tmp
->n
.sym
);
11046 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
11048 /* Should the lhs be a section, use its array ref for the
11049 temporary expression. */
11050 if (aref
&& aref
->type
!= AR_FULL
)
11052 gfc_free_ref_list (e
->ref
);
11053 e
->ref
= gfc_copy_ref (ref
);
11059 /* Add one line of code to the code chain, making sure that 'head' and
11060 'tail' are appropriately updated. */
11063 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
11065 gcc_assert (this_code
);
11067 *head
= *tail
= *this_code
;
11069 *tail
= gfc_append_code (*tail
, *this_code
);
11074 /* Counts the potential number of part array references that would
11075 result from resolution of typebound defined assignments. */
11078 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
11081 int c_depth
= 0, t_depth
;
11083 for (c
= derived
->components
; c
; c
= c
->next
)
11085 if ((!gfc_bt_struct (c
->ts
.type
)
11087 || c
->attr
.allocatable
11088 || c
->attr
.proc_pointer_comp
11089 || c
->attr
.class_pointer
11090 || c
->attr
.proc_pointer
)
11091 && !c
->attr
.defined_assign_comp
)
11094 if (c
->as
&& c_depth
== 0)
11097 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
11098 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
11103 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
11105 return depth
+ c_depth
;
11109 /* Implement 7.2.1.3 of the F08 standard:
11110 "An intrinsic assignment where the variable is of derived type is
11111 performed as if each component of the variable were assigned from the
11112 corresponding component of expr using pointer assignment (7.2.2) for
11113 each pointer component, defined assignment for each nonpointer
11114 nonallocatable component of a type that has a type-bound defined
11115 assignment consistent with the component, intrinsic assignment for
11116 each other nonpointer nonallocatable component, ..."
11118 The pointer assignments are taken care of by the intrinsic
11119 assignment of the structure itself. This function recursively adds
11120 defined assignments where required. The recursion is accomplished
11121 by calling gfc_resolve_code.
11123 When the lhs in a defined assignment has intent INOUT, we need a
11124 temporary for the lhs. In pseudo-code:
11126 ! Only call function lhs once.
11127 if (lhs is not a constant or an variable)
11130 ! Do the intrinsic assignment
11132 ! Now do the defined assignments
11133 do over components with typebound defined assignment [%cmp]
11134 #if one component's assignment procedure is INOUT
11136 #if expr2 non-variable
11142 t1%cmp {defined=} expr2%cmp
11148 expr1%cmp {defined=} expr2%cmp
11152 /* The temporary assignments have to be put on top of the additional
11153 code to avoid the result being changed by the intrinsic assignment.
11155 static int component_assignment_level
= 0;
11156 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
11159 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
11161 gfc_component
*comp1
, *comp2
;
11162 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
11164 int error_count
, depth
;
11166 gfc_get_errors (NULL
, &error_count
);
11168 /* Filter out continuing processing after an error. */
11170 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
11171 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
11174 /* TODO: Handle more than one part array reference in assignments. */
11175 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
11176 (*code
)->expr1
->rank
? 1 : 0);
11179 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
11180 "done because multiple part array references would "
11181 "occur in intermediate expressions.", &(*code
)->loc
);
11185 component_assignment_level
++;
11187 /* Create a temporary so that functions get called only once. */
11188 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
11189 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
11191 gfc_expr
*tmp_expr
;
11193 /* Assign the rhs to the temporary. */
11194 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11195 this_code
= build_assignment (EXEC_ASSIGN
,
11196 tmp_expr
, (*code
)->expr2
,
11197 NULL
, NULL
, (*code
)->loc
);
11198 /* Add the code and substitute the rhs expression. */
11199 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
11200 gfc_free_expr ((*code
)->expr2
);
11201 (*code
)->expr2
= tmp_expr
;
11204 /* Do the intrinsic assignment. This is not needed if the lhs is one
11205 of the temporaries generated here, since the intrinsic assignment
11206 to the final result already does this. */
11207 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
11209 this_code
= build_assignment (EXEC_ASSIGN
,
11210 (*code
)->expr1
, (*code
)->expr2
,
11211 NULL
, NULL
, (*code
)->loc
);
11212 add_code_to_chain (&this_code
, &head
, &tail
);
11215 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
11216 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
11219 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
11221 bool inout
= false;
11223 /* The intrinsic assignment does the right thing for pointers
11224 of all kinds and allocatable components. */
11225 if (!gfc_bt_struct (comp1
->ts
.type
)
11226 || comp1
->attr
.pointer
11227 || comp1
->attr
.allocatable
11228 || comp1
->attr
.proc_pointer_comp
11229 || comp1
->attr
.class_pointer
11230 || comp1
->attr
.proc_pointer
)
11233 /* Make an assigment for this component. */
11234 this_code
= build_assignment (EXEC_ASSIGN
,
11235 (*code
)->expr1
, (*code
)->expr2
,
11236 comp1
, comp2
, (*code
)->loc
);
11238 /* Convert the assignment if there is a defined assignment for
11239 this type. Otherwise, using the call from gfc_resolve_code,
11240 recurse into its components. */
11241 gfc_resolve_code (this_code
, ns
);
11243 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11245 gfc_formal_arglist
*dummy_args
;
11247 /* Check that there is a typebound defined assignment. If not,
11248 then this must be a module defined assignment. We cannot
11249 use the defined_assign_comp attribute here because it must
11250 be this derived type that has the defined assignment and not
11252 if (!(comp1
->ts
.u
.derived
->f2k_derived
11253 && comp1
->ts
.u
.derived
->f2k_derived
11254 ->tb_op
[INTRINSIC_ASSIGN
]))
11256 gfc_free_statements (this_code
);
11261 /* If the first argument of the subroutine has intent INOUT
11262 a temporary must be generated and used instead. */
11263 rsym
= this_code
->resolved_sym
;
11264 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11266 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
11268 gfc_code
*temp_code
;
11271 /* Build the temporary required for the assignment and put
11272 it at the head of the generated code. */
11275 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
11276 temp_code
= build_assignment (EXEC_ASSIGN
,
11277 t1
, (*code
)->expr1
,
11278 NULL
, NULL
, (*code
)->loc
);
11280 /* For allocatable LHS, check whether it is allocated. Note
11281 that allocatable components with defined assignment are
11282 not yet support. See PR 57696. */
11283 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11287 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11288 block
= gfc_get_code (EXEC_IF
);
11289 block
->block
= gfc_get_code (EXEC_IF
);
11290 block
->block
->expr1
11291 = gfc_build_intrinsic_call (ns
,
11292 GFC_ISYM_ALLOCATED
, "allocated",
11293 (*code
)->loc
, 1, e
);
11294 block
->block
->next
= temp_code
;
11297 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11300 /* Replace the first actual arg with the component of the
11302 gfc_free_expr (this_code
->ext
.actual
->expr
);
11303 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11304 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11306 /* If the LHS variable is allocatable and wasn't allocated and
11307 the temporary is allocatable, pointer assign the address of
11308 the freshly allocated LHS to the temporary. */
11309 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11310 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11315 cond
= gfc_get_expr ();
11316 cond
->ts
.type
= BT_LOGICAL
;
11317 cond
->ts
.kind
= gfc_default_logical_kind
;
11318 cond
->expr_type
= EXPR_OP
;
11319 cond
->where
= (*code
)->loc
;
11320 cond
->value
.op
.op
= INTRINSIC_NOT
;
11321 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11322 GFC_ISYM_ALLOCATED
, "allocated",
11323 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11324 block
= gfc_get_code (EXEC_IF
);
11325 block
->block
= gfc_get_code (EXEC_IF
);
11326 block
->block
->expr1
= cond
;
11327 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11328 t1
, (*code
)->expr1
,
11329 NULL
, NULL
, (*code
)->loc
);
11330 add_code_to_chain (&block
, &head
, &tail
);
11334 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11336 /* Don't add intrinsic assignments since they are already
11337 effected by the intrinsic assignment of the structure. */
11338 gfc_free_statements (this_code
);
11343 add_code_to_chain (&this_code
, &head
, &tail
);
11347 /* Transfer the value to the final result. */
11348 this_code
= build_assignment (EXEC_ASSIGN
,
11349 (*code
)->expr1
, t1
,
11350 comp1
, comp2
, (*code
)->loc
);
11351 add_code_to_chain (&this_code
, &head
, &tail
);
11355 /* Put the temporary assignments at the top of the generated code. */
11356 if (tmp_head
&& component_assignment_level
== 1)
11358 gfc_append_code (tmp_head
, head
);
11360 tmp_head
= tmp_tail
= NULL
;
11363 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11364 // not accidentally deallocated. Hence, nullify t1.
11365 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11366 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11372 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11373 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11374 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11375 block
= gfc_get_code (EXEC_IF
);
11376 block
->block
= gfc_get_code (EXEC_IF
);
11377 block
->block
->expr1
= cond
;
11378 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11379 t1
, gfc_get_null_expr (&(*code
)->loc
),
11380 NULL
, NULL
, (*code
)->loc
);
11381 gfc_append_code (tail
, block
);
11385 /* Now attach the remaining code chain to the input code. Step on
11386 to the end of the new code since resolution is complete. */
11387 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11388 tail
->next
= (*code
)->next
;
11389 /* Overwrite 'code' because this would place the intrinsic assignment
11390 before the temporary for the lhs is created. */
11391 gfc_free_expr ((*code
)->expr1
);
11392 gfc_free_expr ((*code
)->expr2
);
11398 component_assignment_level
--;
11402 /* F2008: Pointer function assignments are of the form:
11403 ptr_fcn (args) = expr
11404 This function breaks these assignments into two statements:
11405 temporary_pointer => ptr_fcn(args)
11406 temporary_pointer = expr */
11409 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11411 gfc_expr
*tmp_ptr_expr
;
11412 gfc_code
*this_code
;
11413 gfc_component
*comp
;
11416 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11419 /* Even if standard does not support this feature, continue to build
11420 the two statements to avoid upsetting frontend_passes.c. */
11421 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11422 "%L", &(*code
)->loc
);
11424 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11427 s
= comp
->ts
.interface
;
11429 s
= (*code
)->expr1
->symtree
->n
.sym
;
11431 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11433 gfc_error ("The function result on the lhs of the assignment at "
11434 "%L must have the pointer attribute.",
11435 &(*code
)->expr1
->where
);
11436 (*code
)->op
= EXEC_NOP
;
11440 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
11442 /* get_temp_from_expression is set up for ordinary assignments. To that
11443 end, where array bounds are not known, arrays are made allocatable.
11444 Change the temporary to a pointer here. */
11445 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11446 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11447 tmp_ptr_expr
->where
= (*code
)->loc
;
11449 this_code
= build_assignment (EXEC_ASSIGN
,
11450 tmp_ptr_expr
, (*code
)->expr2
,
11451 NULL
, NULL
, (*code
)->loc
);
11452 this_code
->next
= (*code
)->next
;
11453 (*code
)->next
= this_code
;
11454 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11455 (*code
)->expr2
= (*code
)->expr1
;
11456 (*code
)->expr1
= tmp_ptr_expr
;
11462 /* Deferred character length assignments from an operator expression
11463 require a temporary because the character length of the lhs can
11464 change in the course of the assignment. */
11467 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11469 gfc_expr
*tmp_expr
;
11470 gfc_code
*this_code
;
11472 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11473 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11474 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11477 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11480 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
11483 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11484 tmp_expr
->where
= (*code
)->loc
;
11486 /* A new charlen is required to ensure that the variable string
11487 length is different to that of the original lhs. */
11488 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11489 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11490 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11491 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11493 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11495 this_code
= build_assignment (EXEC_ASSIGN
,
11497 gfc_copy_expr (tmp_expr
),
11498 NULL
, NULL
, (*code
)->loc
);
11500 (*code
)->expr1
= tmp_expr
;
11502 this_code
->next
= (*code
)->next
;
11503 (*code
)->next
= this_code
;
11509 /* Given a block of code, recursively resolve everything pointed to by this
11513 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11515 int omp_workshare_save
;
11516 int forall_save
, do_concurrent_save
;
11520 frame
.prev
= cs_base
;
11524 find_reachable_labels (code
);
11526 for (; code
; code
= code
->next
)
11528 frame
.current
= code
;
11529 forall_save
= forall_flag
;
11530 do_concurrent_save
= gfc_do_concurrent_flag
;
11532 if (code
->op
== EXEC_FORALL
)
11535 gfc_resolve_forall (code
, ns
, forall_save
);
11538 else if (code
->block
)
11540 omp_workshare_save
= -1;
11543 case EXEC_OACC_PARALLEL_LOOP
:
11544 case EXEC_OACC_PARALLEL
:
11545 case EXEC_OACC_KERNELS_LOOP
:
11546 case EXEC_OACC_KERNELS
:
11547 case EXEC_OACC_DATA
:
11548 case EXEC_OACC_HOST_DATA
:
11549 case EXEC_OACC_LOOP
:
11550 gfc_resolve_oacc_blocks (code
, ns
);
11552 case EXEC_OMP_PARALLEL_WORKSHARE
:
11553 omp_workshare_save
= omp_workshare_flag
;
11554 omp_workshare_flag
= 1;
11555 gfc_resolve_omp_parallel_blocks (code
, ns
);
11557 case EXEC_OMP_PARALLEL
:
11558 case EXEC_OMP_PARALLEL_DO
:
11559 case EXEC_OMP_PARALLEL_DO_SIMD
:
11560 case EXEC_OMP_PARALLEL_SECTIONS
:
11561 case EXEC_OMP_TARGET_PARALLEL
:
11562 case EXEC_OMP_TARGET_PARALLEL_DO
:
11563 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11564 case EXEC_OMP_TARGET_TEAMS
:
11565 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11566 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11567 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11568 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11569 case EXEC_OMP_TASK
:
11570 case EXEC_OMP_TASKLOOP
:
11571 case EXEC_OMP_TASKLOOP_SIMD
:
11572 case EXEC_OMP_TEAMS
:
11573 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11574 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11575 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11576 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11577 omp_workshare_save
= omp_workshare_flag
;
11578 omp_workshare_flag
= 0;
11579 gfc_resolve_omp_parallel_blocks (code
, ns
);
11581 case EXEC_OMP_DISTRIBUTE
:
11582 case EXEC_OMP_DISTRIBUTE_SIMD
:
11584 case EXEC_OMP_DO_SIMD
:
11585 case EXEC_OMP_SIMD
:
11586 case EXEC_OMP_TARGET_SIMD
:
11587 gfc_resolve_omp_do_blocks (code
, ns
);
11589 case EXEC_SELECT_TYPE
:
11590 /* Blocks are handled in resolve_select_type because we have
11591 to transform the SELECT TYPE into ASSOCIATE first. */
11593 case EXEC_DO_CONCURRENT
:
11594 gfc_do_concurrent_flag
= 1;
11595 gfc_resolve_blocks (code
->block
, ns
);
11596 gfc_do_concurrent_flag
= 2;
11598 case EXEC_OMP_WORKSHARE
:
11599 omp_workshare_save
= omp_workshare_flag
;
11600 omp_workshare_flag
= 1;
11603 gfc_resolve_blocks (code
->block
, ns
);
11607 if (omp_workshare_save
!= -1)
11608 omp_workshare_flag
= omp_workshare_save
;
11612 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11613 t
= gfc_resolve_expr (code
->expr1
);
11614 forall_flag
= forall_save
;
11615 gfc_do_concurrent_flag
= do_concurrent_save
;
11617 if (!gfc_resolve_expr (code
->expr2
))
11620 if (code
->op
== EXEC_ALLOCATE
11621 && !gfc_resolve_expr (code
->expr3
))
11627 case EXEC_END_BLOCK
:
11628 case EXEC_END_NESTED_BLOCK
:
11632 case EXEC_ERROR_STOP
:
11634 case EXEC_CONTINUE
:
11636 case EXEC_ASSIGN_CALL
:
11639 case EXEC_CRITICAL
:
11640 resolve_critical (code
);
11643 case EXEC_SYNC_ALL
:
11644 case EXEC_SYNC_IMAGES
:
11645 case EXEC_SYNC_MEMORY
:
11646 resolve_sync (code
);
11651 case EXEC_EVENT_POST
:
11652 case EXEC_EVENT_WAIT
:
11653 resolve_lock_unlock_event (code
);
11656 case EXEC_FAIL_IMAGE
:
11657 case EXEC_FORM_TEAM
:
11658 case EXEC_CHANGE_TEAM
:
11659 case EXEC_END_TEAM
:
11660 case EXEC_SYNC_TEAM
:
11664 /* Keep track of which entry we are up to. */
11665 current_entry_id
= code
->ext
.entry
->id
;
11669 resolve_where (code
, NULL
);
11673 if (code
->expr1
!= NULL
)
11675 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11676 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11677 "INTEGER variable", &code
->expr1
->where
);
11678 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11679 gfc_error ("Variable %qs has not been assigned a target "
11680 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11681 &code
->expr1
->where
);
11684 resolve_branch (code
->label1
, code
);
11688 if (code
->expr1
!= NULL
11689 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11690 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11691 "INTEGER return specifier", &code
->expr1
->where
);
11694 case EXEC_INIT_ASSIGN
:
11695 case EXEC_END_PROCEDURE
:
11702 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11704 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11705 && code
->expr1
->value
.function
.isym
11706 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11707 remove_caf_get_intrinsic (code
->expr1
);
11709 /* If this is a pointer function in an lvalue variable context,
11710 the new code will have to be resolved afresh. This is also the
11711 case with an error, where the code is transformed into NOP to
11712 prevent ICEs downstream. */
11713 if (resolve_ptr_fcn_assign (&code
, ns
)
11714 || code
->op
== EXEC_NOP
)
11717 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11721 if (resolve_ordinary_assign (code
, ns
))
11723 if (code
->op
== EXEC_COMPCALL
)
11729 /* Check for dependencies in deferred character length array
11730 assignments and generate a temporary, if necessary. */
11731 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11734 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11735 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11736 && code
->expr1
->ts
.u
.derived
11737 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11738 generate_component_assignments (&code
, ns
);
11742 case EXEC_LABEL_ASSIGN
:
11743 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11744 gfc_error ("Label %d referenced at %L is never defined",
11745 code
->label1
->value
, &code
->label1
->where
);
11747 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11748 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11749 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11750 != gfc_default_integer_kind
11751 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11752 gfc_error ("ASSIGN statement at %L requires a scalar "
11753 "default INTEGER variable", &code
->expr1
->where
);
11756 case EXEC_POINTER_ASSIGN
:
11763 /* This is both a variable definition and pointer assignment
11764 context, so check both of them. For rank remapping, a final
11765 array ref may be present on the LHS and fool gfc_expr_attr
11766 used in gfc_check_vardef_context. Remove it. */
11767 e
= remove_last_array_ref (code
->expr1
);
11768 t
= gfc_check_vardef_context (e
, true, false, false,
11769 _("pointer assignment"));
11771 t
= gfc_check_vardef_context (e
, false, false, false,
11772 _("pointer assignment"));
11775 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
11780 /* Assigning a class object always is a regular assign. */
11781 if (code
->expr2
->ts
.type
== BT_CLASS
11782 && code
->expr1
->ts
.type
== BT_CLASS
11783 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11784 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11785 && code
->expr2
->expr_type
== EXPR_VARIABLE
11786 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11788 code
->op
= EXEC_ASSIGN
;
11792 case EXEC_ARITHMETIC_IF
:
11794 gfc_expr
*e
= code
->expr1
;
11796 gfc_resolve_expr (e
);
11797 if (e
->expr_type
== EXPR_NULL
)
11798 gfc_error ("Invalid NULL at %L", &e
->where
);
11800 if (t
&& (e
->rank
> 0
11801 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11802 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11803 "REAL or INTEGER expression", &e
->where
);
11805 resolve_branch (code
->label1
, code
);
11806 resolve_branch (code
->label2
, code
);
11807 resolve_branch (code
->label3
, code
);
11812 if (t
&& code
->expr1
!= NULL
11813 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11814 || code
->expr1
->rank
!= 0))
11815 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11816 &code
->expr1
->where
);
11821 resolve_call (code
);
11824 case EXEC_COMPCALL
:
11826 resolve_typebound_subroutine (code
);
11829 case EXEC_CALL_PPC
:
11830 resolve_ppc_call (code
);
11834 /* Select is complicated. Also, a SELECT construct could be
11835 a transformed computed GOTO. */
11836 resolve_select (code
, false);
11839 case EXEC_SELECT_TYPE
:
11840 resolve_select_type (code
, ns
);
11843 case EXEC_SELECT_RANK
:
11844 resolve_select_rank (code
, ns
);
11848 resolve_block_construct (code
);
11852 if (code
->ext
.iterator
!= NULL
)
11854 gfc_iterator
*iter
= code
->ext
.iterator
;
11855 if (gfc_resolve_iterator (iter
, true, false))
11856 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11861 case EXEC_DO_WHILE
:
11862 if (code
->expr1
== NULL
)
11863 gfc_internal_error ("gfc_resolve_code(): No expression on "
11866 && (code
->expr1
->rank
!= 0
11867 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11868 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11869 "a scalar LOGICAL expression", &code
->expr1
->where
);
11872 case EXEC_ALLOCATE
:
11874 resolve_allocate_deallocate (code
, "ALLOCATE");
11878 case EXEC_DEALLOCATE
:
11880 resolve_allocate_deallocate (code
, "DEALLOCATE");
11885 if (!gfc_resolve_open (code
->ext
.open
))
11888 resolve_branch (code
->ext
.open
->err
, code
);
11892 if (!gfc_resolve_close (code
->ext
.close
))
11895 resolve_branch (code
->ext
.close
->err
, code
);
11898 case EXEC_BACKSPACE
:
11902 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
11905 resolve_branch (code
->ext
.filepos
->err
, code
);
11909 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11912 resolve_branch (code
->ext
.inquire
->err
, code
);
11915 case EXEC_IOLENGTH
:
11916 gcc_assert (code
->ext
.inquire
!= NULL
);
11917 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11920 resolve_branch (code
->ext
.inquire
->err
, code
);
11924 if (!gfc_resolve_wait (code
->ext
.wait
))
11927 resolve_branch (code
->ext
.wait
->err
, code
);
11928 resolve_branch (code
->ext
.wait
->end
, code
);
11929 resolve_branch (code
->ext
.wait
->eor
, code
);
11934 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11937 resolve_branch (code
->ext
.dt
->err
, code
);
11938 resolve_branch (code
->ext
.dt
->end
, code
);
11939 resolve_branch (code
->ext
.dt
->eor
, code
);
11942 case EXEC_TRANSFER
:
11943 resolve_transfer (code
);
11946 case EXEC_DO_CONCURRENT
:
11948 resolve_forall_iterators (code
->ext
.forall_iterator
);
11950 if (code
->expr1
!= NULL
11951 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11952 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11953 "expression", &code
->expr1
->where
);
11956 case EXEC_OACC_PARALLEL_LOOP
:
11957 case EXEC_OACC_PARALLEL
:
11958 case EXEC_OACC_KERNELS_LOOP
:
11959 case EXEC_OACC_KERNELS
:
11960 case EXEC_OACC_DATA
:
11961 case EXEC_OACC_HOST_DATA
:
11962 case EXEC_OACC_LOOP
:
11963 case EXEC_OACC_UPDATE
:
11964 case EXEC_OACC_WAIT
:
11965 case EXEC_OACC_CACHE
:
11966 case EXEC_OACC_ENTER_DATA
:
11967 case EXEC_OACC_EXIT_DATA
:
11968 case EXEC_OACC_ATOMIC
:
11969 case EXEC_OACC_DECLARE
:
11970 gfc_resolve_oacc_directive (code
, ns
);
11973 case EXEC_OMP_ATOMIC
:
11974 case EXEC_OMP_BARRIER
:
11975 case EXEC_OMP_CANCEL
:
11976 case EXEC_OMP_CANCELLATION_POINT
:
11977 case EXEC_OMP_CRITICAL
:
11978 case EXEC_OMP_FLUSH
:
11979 case EXEC_OMP_DISTRIBUTE
:
11980 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11981 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11982 case EXEC_OMP_DISTRIBUTE_SIMD
:
11984 case EXEC_OMP_DO_SIMD
:
11985 case EXEC_OMP_MASTER
:
11986 case EXEC_OMP_ORDERED
:
11987 case EXEC_OMP_SECTIONS
:
11988 case EXEC_OMP_SIMD
:
11989 case EXEC_OMP_SINGLE
:
11990 case EXEC_OMP_TARGET
:
11991 case EXEC_OMP_TARGET_DATA
:
11992 case EXEC_OMP_TARGET_ENTER_DATA
:
11993 case EXEC_OMP_TARGET_EXIT_DATA
:
11994 case EXEC_OMP_TARGET_PARALLEL
:
11995 case EXEC_OMP_TARGET_PARALLEL_DO
:
11996 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11997 case EXEC_OMP_TARGET_SIMD
:
11998 case EXEC_OMP_TARGET_TEAMS
:
11999 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
12000 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12001 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12002 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
12003 case EXEC_OMP_TARGET_UPDATE
:
12004 case EXEC_OMP_TASK
:
12005 case EXEC_OMP_TASKGROUP
:
12006 case EXEC_OMP_TASKLOOP
:
12007 case EXEC_OMP_TASKLOOP_SIMD
:
12008 case EXEC_OMP_TASKWAIT
:
12009 case EXEC_OMP_TASKYIELD
:
12010 case EXEC_OMP_TEAMS
:
12011 case EXEC_OMP_TEAMS_DISTRIBUTE
:
12012 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
12013 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
12014 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
12015 case EXEC_OMP_WORKSHARE
:
12016 gfc_resolve_omp_directive (code
, ns
);
12019 case EXEC_OMP_PARALLEL
:
12020 case EXEC_OMP_PARALLEL_DO
:
12021 case EXEC_OMP_PARALLEL_DO_SIMD
:
12022 case EXEC_OMP_PARALLEL_SECTIONS
:
12023 case EXEC_OMP_PARALLEL_WORKSHARE
:
12024 omp_workshare_save
= omp_workshare_flag
;
12025 omp_workshare_flag
= 0;
12026 gfc_resolve_omp_directive (code
, ns
);
12027 omp_workshare_flag
= omp_workshare_save
;
12031 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
12035 cs_base
= frame
.prev
;
12039 /* Resolve initial values and make sure they are compatible with
12043 resolve_values (gfc_symbol
*sym
)
12047 if (sym
->value
== NULL
)
12050 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
12051 t
= resolve_structure_cons (sym
->value
, 1);
12053 t
= gfc_resolve_expr (sym
->value
);
12058 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
12062 /* Verify any BIND(C) derived types in the namespace so we can report errors
12063 for them once, rather than for each variable declared of that type. */
12066 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
12068 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
12069 && derived_sym
->attr
.is_bind_c
== 1)
12070 verify_bind_c_derived_type (derived_sym
);
12076 /* Check the interfaces of DTIO procedures associated with derived
12077 type 'sym'. These procedures can either have typebound bindings or
12078 can appear in DTIO generic interfaces. */
12081 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
12083 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
12086 gfc_check_dtio_interfaces (sym
);
12091 /* Verify that any binding labels used in a given namespace do not collide
12092 with the names or binding labels of any global symbols. Multiple INTERFACE
12093 for the same procedure are permitted. */
12096 gfc_verify_binding_labels (gfc_symbol
*sym
)
12099 const char *module
;
12101 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
12102 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
12105 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
12108 module
= sym
->module
;
12109 else if (sym
->ns
&& sym
->ns
->proc_name
12110 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
12111 module
= sym
->ns
->proc_name
->name
;
12112 else if (sym
->ns
&& sym
->ns
->parent
12113 && sym
->ns
&& sym
->ns
->parent
->proc_name
12114 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12115 module
= sym
->ns
->parent
->proc_name
->name
;
12121 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
12124 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
12125 gsym
->where
= sym
->declared_at
;
12126 gsym
->sym_name
= sym
->name
;
12127 gsym
->binding_label
= sym
->binding_label
;
12128 gsym
->ns
= sym
->ns
;
12129 gsym
->mod_name
= module
;
12130 if (sym
->attr
.function
)
12131 gsym
->type
= GSYM_FUNCTION
;
12132 else if (sym
->attr
.subroutine
)
12133 gsym
->type
= GSYM_SUBROUTINE
;
12134 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
12135 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
12139 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
12141 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
12142 "identifier as entity at %L", sym
->name
,
12143 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12144 /* Clear the binding label to prevent checking multiple times. */
12145 sym
->binding_label
= NULL
;
12149 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
12150 && (strcmp (module
, gsym
->mod_name
) != 0
12151 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
12153 /* This can only happen if the variable is defined in a module - if it
12154 isn't the same module, reject it. */
12155 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
12156 "uses the same global identifier as entity at %L from module %qs",
12157 sym
->name
, module
, sym
->binding_label
,
12158 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
12159 sym
->binding_label
= NULL
;
12163 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
12164 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
12165 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
12166 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
12167 && (module
!= gsym
->mod_name
12168 || strcmp (gsym
->sym_name
, sym
->name
) != 0
12169 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
12171 /* Print an error if the procedure is defined multiple times; we have to
12172 exclude references to the same procedure via module association or
12173 multiple checks for the same procedure. */
12174 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
12175 "global identifier as entity at %L", sym
->name
,
12176 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12177 sym
->binding_label
= NULL
;
12182 /* Resolve an index expression. */
12185 resolve_index_expr (gfc_expr
*e
)
12187 if (!gfc_resolve_expr (e
))
12190 if (!gfc_simplify_expr (e
, 0))
12193 if (!gfc_specification_expr (e
))
12200 /* Resolve a charlen structure. */
12203 resolve_charlen (gfc_charlen
*cl
)
12206 bool saved_specification_expr
;
12212 saved_specification_expr
= specification_expr
;
12213 specification_expr
= true;
12215 if (cl
->length_from_typespec
)
12217 if (!gfc_resolve_expr (cl
->length
))
12219 specification_expr
= saved_specification_expr
;
12223 if (!gfc_simplify_expr (cl
->length
, 0))
12225 specification_expr
= saved_specification_expr
;
12229 /* cl->length has been resolved. It should have an integer type. */
12230 if (cl
->length
->ts
.type
!= BT_INTEGER
)
12232 gfc_error ("Scalar INTEGER expression expected at %L",
12233 &cl
->length
->where
);
12239 if (!resolve_index_expr (cl
->length
))
12241 specification_expr
= saved_specification_expr
;
12246 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12247 a negative value, the length of character entities declared is zero. */
12248 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12249 && mpz_sgn (cl
->length
->value
.integer
) < 0)
12250 gfc_replace_expr (cl
->length
,
12251 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
12253 /* Check that the character length is not too large. */
12254 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
12255 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12256 && cl
->length
->ts
.type
== BT_INTEGER
12257 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
12259 gfc_error ("String length at %L is too large", &cl
->length
->where
);
12260 specification_expr
= saved_specification_expr
;
12264 specification_expr
= saved_specification_expr
;
12269 /* Test for non-constant shape arrays. */
12272 is_non_constant_shape_array (gfc_symbol
*sym
)
12278 not_constant
= false;
12279 if (sym
->as
!= NULL
)
12281 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12282 has not been simplified; parameter array references. Do the
12283 simplification now. */
12284 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12286 e
= sym
->as
->lower
[i
];
12287 if (e
&& (!resolve_index_expr(e
)
12288 || !gfc_is_constant_expr (e
)))
12289 not_constant
= true;
12290 e
= sym
->as
->upper
[i
];
12291 if (e
&& (!resolve_index_expr(e
)
12292 || !gfc_is_constant_expr (e
)))
12293 not_constant
= true;
12296 return not_constant
;
12299 /* Given a symbol and an initialization expression, add code to initialize
12300 the symbol to the function entry. */
12302 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12306 gfc_namespace
*ns
= sym
->ns
;
12308 /* Search for the function namespace if this is a contained
12309 function without an explicit result. */
12310 if (sym
->attr
.function
&& sym
== sym
->result
12311 && sym
->name
!= sym
->ns
->proc_name
->name
)
12313 ns
= ns
->contained
;
12314 for (;ns
; ns
= ns
->sibling
)
12315 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12321 gfc_free_expr (init
);
12325 /* Build an l-value expression for the result. */
12326 lval
= gfc_lval_expr_from_sym (sym
);
12328 /* Add the code at scope entry. */
12329 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
12330 init_st
->next
= ns
->code
;
12331 ns
->code
= init_st
;
12333 /* Assign the default initializer to the l-value. */
12334 init_st
->loc
= sym
->declared_at
;
12335 init_st
->expr1
= lval
;
12336 init_st
->expr2
= init
;
12340 /* Whether or not we can generate a default initializer for a symbol. */
12343 can_generate_init (gfc_symbol
*sym
)
12345 symbol_attribute
*a
;
12350 /* These symbols should never have a default initialization. */
12355 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
12356 && (CLASS_DATA (sym
)->attr
.class_pointer
12357 || CLASS_DATA (sym
)->attr
.proc_pointer
))
12358 || a
->in_equivalence
12365 || (!a
->referenced
&& !a
->result
)
12366 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
12367 || (a
->function
&& sym
!= sym
->result
)
12372 /* Assign the default initializer to a derived type variable or result. */
12375 apply_default_init (gfc_symbol
*sym
)
12377 gfc_expr
*init
= NULL
;
12379 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12382 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12383 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12385 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12388 build_init_assign (sym
, init
);
12389 sym
->attr
.referenced
= 1;
12393 /* Build an initializer for a local. Returns null if the symbol should not have
12394 a default initialization. */
12397 build_default_init_expr (gfc_symbol
*sym
)
12399 /* These symbols should never have a default initialization. */
12400 if (sym
->attr
.allocatable
12401 || sym
->attr
.external
12403 || sym
->attr
.pointer
12404 || sym
->attr
.in_equivalence
12405 || sym
->attr
.in_common
12408 || sym
->attr
.cray_pointee
12409 || sym
->attr
.cray_pointer
12413 /* Get the appropriate init expression. */
12414 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12417 /* Add an initialization expression to a local variable. */
12419 apply_default_init_local (gfc_symbol
*sym
)
12421 gfc_expr
*init
= NULL
;
12423 /* The symbol should be a variable or a function return value. */
12424 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12425 || (sym
->attr
.function
&& sym
->result
!= sym
))
12428 /* Try to build the initializer expression. If we can't initialize
12429 this symbol, then init will be NULL. */
12430 init
= build_default_init_expr (sym
);
12434 /* For saved variables, we don't want to add an initializer at function
12435 entry, so we just add a static initializer. Note that automatic variables
12436 are stack allocated even with -fno-automatic; we have also to exclude
12437 result variable, which are also nonstatic. */
12438 if (!sym
->attr
.automatic
12439 && (sym
->attr
.save
|| sym
->ns
->save_all
12440 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12441 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12442 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12444 /* Don't clobber an existing initializer! */
12445 gcc_assert (sym
->value
== NULL
);
12450 build_init_assign (sym
, init
);
12454 /* Resolution of common features of flavors variable and procedure. */
12457 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12459 gfc_array_spec
*as
;
12461 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12462 as
= CLASS_DATA (sym
)->as
;
12466 /* Constraints on deferred shape variable. */
12467 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12469 bool pointer
, allocatable
, dimension
;
12471 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12473 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12474 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12475 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12479 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12480 allocatable
= sym
->attr
.allocatable
;
12481 dimension
= sym
->attr
.dimension
;
12486 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12488 gfc_error ("Allocatable array %qs at %L must have a deferred "
12489 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12492 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12493 "%qs at %L may not be ALLOCATABLE",
12494 sym
->name
, &sym
->declared_at
))
12498 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12500 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12501 "assumed rank", sym
->name
, &sym
->declared_at
);
12507 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12508 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12510 gfc_error ("Array %qs at %L cannot have a deferred shape",
12511 sym
->name
, &sym
->declared_at
);
12516 /* Constraints on polymorphic variables. */
12517 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12520 if (sym
->attr
.class_ok
12521 && !sym
->attr
.select_type_temporary
12522 && !UNLIMITED_POLY (sym
)
12523 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12525 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12526 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12527 &sym
->declared_at
);
12532 /* Assume that use associated symbols were checked in the module ns.
12533 Class-variables that are associate-names are also something special
12534 and excepted from the test. */
12535 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12537 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12538 "or pointer", sym
->name
, &sym
->declared_at
);
12547 /* Additional checks for symbols with flavor variable and derived
12548 type. To be called from resolve_fl_variable. */
12551 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12553 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12555 /* Check to see if a derived type is blocked from being host
12556 associated by the presence of another class I symbol in the same
12557 namespace. 14.6.1.3 of the standard and the discussion on
12558 comp.lang.fortran. */
12559 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12560 && !sym
->ts
.u
.derived
->attr
.use_assoc
12561 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12564 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12565 if (s
&& s
->attr
.generic
)
12566 s
= gfc_find_dt_in_generic (s
);
12567 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12569 gfc_error ("The type %qs cannot be host associated at %L "
12570 "because it is blocked by an incompatible object "
12571 "of the same name declared at %L",
12572 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12578 /* 4th constraint in section 11.3: "If an object of a type for which
12579 component-initialization is specified (R429) appears in the
12580 specification-part of a module and does not have the ALLOCATABLE
12581 or POINTER attribute, the object shall have the SAVE attribute."
12583 The check for initializers is performed with
12584 gfc_has_default_initializer because gfc_default_initializer generates
12585 a hidden default for allocatable components. */
12586 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12587 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12588 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12589 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12590 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12591 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12592 "%qs at %L, needed due to the default "
12593 "initialization", sym
->name
, &sym
->declared_at
))
12596 /* Assign default initializer. */
12597 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12598 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12599 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12605 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12606 except in the declaration of an entity or component that has the POINTER
12607 or ALLOCATABLE attribute. */
12610 deferred_requirements (gfc_symbol
*sym
)
12612 if (sym
->ts
.deferred
12613 && !(sym
->attr
.pointer
12614 || sym
->attr
.allocatable
12615 || sym
->attr
.associate_var
12616 || sym
->attr
.omp_udr_artificial_var
))
12618 /* If a function has a result variable, only check the variable. */
12619 if (sym
->result
&& sym
->name
!= sym
->result
->name
)
12622 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12623 "requires either the POINTER or ALLOCATABLE attribute",
12624 sym
->name
, &sym
->declared_at
);
12631 /* Resolve symbols with flavor variable. */
12634 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12636 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
12639 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12642 /* Set this flag to check that variables are parameters of all entries.
12643 This check is effected by the call to gfc_resolve_expr through
12644 is_non_constant_shape_array. */
12645 bool saved_specification_expr
= specification_expr
;
12646 specification_expr
= true;
12648 if (sym
->ns
->proc_name
12649 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12650 || sym
->ns
->proc_name
->attr
.is_main_program
)
12651 && !sym
->attr
.use_assoc
12652 && !sym
->attr
.allocatable
12653 && !sym
->attr
.pointer
12654 && is_non_constant_shape_array (sym
))
12656 /* F08:C541. The shape of an array defined in a main program or module
12657 * needs to be constant. */
12658 gfc_error ("The module or main program array %qs at %L must "
12659 "have constant shape", sym
->name
, &sym
->declared_at
);
12660 specification_expr
= saved_specification_expr
;
12664 /* Constraints on deferred type parameter. */
12665 if (!deferred_requirements (sym
))
12668 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12670 /* Make sure that character string variables with assumed length are
12671 dummy arguments. */
12672 gfc_expr
*e
= NULL
;
12675 e
= sym
->ts
.u
.cl
->length
;
12679 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12680 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12681 && !sym
->attr
.omp_udr_artificial_var
)
12683 gfc_error ("Entity with assumed character length at %L must be a "
12684 "dummy argument or a PARAMETER", &sym
->declared_at
);
12685 specification_expr
= saved_specification_expr
;
12689 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12691 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12692 specification_expr
= saved_specification_expr
;
12696 if (!gfc_is_constant_expr (e
)
12697 && !(e
->expr_type
== EXPR_VARIABLE
12698 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12700 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12701 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12702 || sym
->ns
->proc_name
->attr
.is_main_program
))
12704 gfc_error ("%qs at %L must have constant character length "
12705 "in this context", sym
->name
, &sym
->declared_at
);
12706 specification_expr
= saved_specification_expr
;
12709 if (sym
->attr
.in_common
)
12711 gfc_error ("COMMON variable %qs at %L must have constant "
12712 "character length", sym
->name
, &sym
->declared_at
);
12713 specification_expr
= saved_specification_expr
;
12719 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12720 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12722 /* Determine if the symbol may not have an initializer. */
12723 int no_init_flag
= 0, automatic_flag
= 0;
12724 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12725 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12727 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12728 && is_non_constant_shape_array (sym
))
12730 no_init_flag
= automatic_flag
= 1;
12732 /* Also, they must not have the SAVE attribute.
12733 SAVE_IMPLICIT is checked below. */
12734 if (sym
->as
&& sym
->attr
.codimension
)
12736 int corank
= sym
->as
->corank
;
12737 sym
->as
->corank
= 0;
12738 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12739 sym
->as
->corank
= corank
;
12741 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12743 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12744 specification_expr
= saved_specification_expr
;
12749 /* Ensure that any initializer is simplified. */
12751 gfc_simplify_expr (sym
->value
, 1);
12753 /* Reject illegal initializers. */
12754 if (!sym
->mark
&& sym
->value
)
12756 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12757 && CLASS_DATA (sym
)->attr
.allocatable
))
12758 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12759 sym
->name
, &sym
->declared_at
);
12760 else if (sym
->attr
.external
)
12761 gfc_error ("External %qs at %L cannot have an initializer",
12762 sym
->name
, &sym
->declared_at
);
12763 else if (sym
->attr
.dummy
12764 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12765 gfc_error ("Dummy %qs at %L cannot have an initializer",
12766 sym
->name
, &sym
->declared_at
);
12767 else if (sym
->attr
.intrinsic
)
12768 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12769 sym
->name
, &sym
->declared_at
);
12770 else if (sym
->attr
.result
)
12771 gfc_error ("Function result %qs at %L cannot have an initializer",
12772 sym
->name
, &sym
->declared_at
);
12773 else if (automatic_flag
)
12774 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12775 sym
->name
, &sym
->declared_at
);
12777 goto no_init_error
;
12778 specification_expr
= saved_specification_expr
;
12783 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12785 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12786 specification_expr
= saved_specification_expr
;
12790 specification_expr
= saved_specification_expr
;
12795 /* Compare the dummy characteristics of a module procedure interface
12796 declaration with the corresponding declaration in a submodule. */
12797 static gfc_formal_arglist
*new_formal
;
12798 static char errmsg
[200];
12801 compare_fsyms (gfc_symbol
*sym
)
12805 if (sym
== NULL
|| new_formal
== NULL
)
12808 fsym
= new_formal
->sym
;
12813 if (strcmp (sym
->name
, fsym
->name
) == 0)
12815 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12816 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12821 /* Resolve a procedure. */
12824 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12826 gfc_formal_arglist
*arg
;
12828 if (sym
->attr
.function
12829 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12832 /* Constraints on deferred type parameter. */
12833 if (!deferred_requirements (sym
))
12836 if (sym
->ts
.type
== BT_CHARACTER
)
12838 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12840 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12841 && !resolve_charlen (cl
))
12844 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12845 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12847 gfc_error ("Character-valued statement function %qs at %L must "
12848 "have constant length", sym
->name
, &sym
->declared_at
);
12853 /* Ensure that derived type for are not of a private type. Internal
12854 module procedures are excluded by 2.2.3.3 - i.e., they are not
12855 externally accessible and can access all the objects accessible in
12857 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
12858 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12859 && gfc_check_symbol_access (sym
))
12861 gfc_interface
*iface
;
12863 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12866 && arg
->sym
->ts
.type
== BT_DERIVED
12867 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12868 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12869 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12870 "and cannot be a dummy argument"
12871 " of %qs, which is PUBLIC at %L",
12872 arg
->sym
->name
, sym
->name
,
12873 &sym
->declared_at
))
12875 /* Stop this message from recurring. */
12876 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12881 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12882 PRIVATE to the containing module. */
12883 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12885 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12888 && arg
->sym
->ts
.type
== BT_DERIVED
12889 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12890 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12891 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12892 "PUBLIC interface %qs at %L "
12893 "takes dummy arguments of %qs which "
12894 "is PRIVATE", iface
->sym
->name
,
12895 sym
->name
, &iface
->sym
->declared_at
,
12896 gfc_typename(&arg
->sym
->ts
)))
12898 /* Stop this message from recurring. */
12899 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12906 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12907 && !sym
->attr
.proc_pointer
)
12909 gfc_error ("Function %qs at %L cannot have an initializer",
12910 sym
->name
, &sym
->declared_at
);
12912 /* Make sure no second error is issued for this. */
12913 sym
->value
->error
= 1;
12917 /* An external symbol may not have an initializer because it is taken to be
12918 a procedure. Exception: Procedure Pointers. */
12919 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12921 gfc_error ("External object %qs at %L may not have an initializer",
12922 sym
->name
, &sym
->declared_at
);
12926 /* An elemental function is required to return a scalar 12.7.1 */
12927 if (sym
->attr
.elemental
&& sym
->attr
.function
12928 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)))
12930 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12931 "result", sym
->name
, &sym
->declared_at
);
12932 /* Reset so that the error only occurs once. */
12933 sym
->attr
.elemental
= 0;
12937 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12938 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12940 gfc_error ("Statement function %qs at %L may not have pointer or "
12941 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12945 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12946 char-len-param shall not be array-valued, pointer-valued, recursive
12947 or pure. ....snip... A character value of * may only be used in the
12948 following ways: (i) Dummy arg of procedure - dummy associates with
12949 actual length; (ii) To declare a named constant; or (iii) External
12950 function - but length must be declared in calling scoping unit. */
12951 if (sym
->attr
.function
12952 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12953 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12955 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12956 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12958 if (sym
->as
&& sym
->as
->rank
)
12959 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12960 "array-valued", sym
->name
, &sym
->declared_at
);
12962 if (sym
->attr
.pointer
)
12963 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12964 "pointer-valued", sym
->name
, &sym
->declared_at
);
12966 if (sym
->attr
.pure
)
12967 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12968 "pure", sym
->name
, &sym
->declared_at
);
12970 if (sym
->attr
.recursive
)
12971 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12972 "recursive", sym
->name
, &sym
->declared_at
);
12977 /* Appendix B.2 of the standard. Contained functions give an
12978 error anyway. Deferred character length is an F2003 feature.
12979 Don't warn on intrinsic conversion functions, which start
12980 with two underscores. */
12981 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12982 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12983 gfc_notify_std (GFC_STD_F95_OBS
,
12984 "CHARACTER(*) function %qs at %L",
12985 sym
->name
, &sym
->declared_at
);
12988 /* F2008, C1218. */
12989 if (sym
->attr
.elemental
)
12991 if (sym
->attr
.proc_pointer
)
12993 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12994 sym
->name
, &sym
->declared_at
);
12997 if (sym
->attr
.dummy
)
12999 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
13000 sym
->name
, &sym
->declared_at
);
13005 /* F2018, C15100: "The result of an elemental function shall be scalar,
13006 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
13007 pointer is tested and caught elsewhere. */
13008 if (sym
->attr
.elemental
&& sym
->result
13009 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
13011 gfc_error ("Function result variable %qs at %L of elemental "
13012 "function %qs shall not have an ALLOCATABLE or POINTER "
13013 "attribute", sym
->result
->name
,
13014 &sym
->result
->declared_at
, sym
->name
);
13018 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
13020 gfc_formal_arglist
*curr_arg
;
13021 int has_non_interop_arg
= 0;
13023 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13024 sym
->common_block
))
13026 /* Clear these to prevent looking at them again if there was an
13028 sym
->attr
.is_bind_c
= 0;
13029 sym
->attr
.is_c_interop
= 0;
13030 sym
->ts
.is_c_interop
= 0;
13034 /* So far, no errors have been found. */
13035 sym
->attr
.is_c_interop
= 1;
13036 sym
->ts
.is_c_interop
= 1;
13039 curr_arg
= gfc_sym_get_dummy_args (sym
);
13040 while (curr_arg
!= NULL
)
13042 /* Skip implicitly typed dummy args here. */
13043 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
13044 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
13045 /* If something is found to fail, record the fact so we
13046 can mark the symbol for the procedure as not being
13047 BIND(C) to try and prevent multiple errors being
13049 has_non_interop_arg
= 1;
13051 curr_arg
= curr_arg
->next
;
13054 /* See if any of the arguments were not interoperable and if so, clear
13055 the procedure symbol to prevent duplicate error messages. */
13056 if (has_non_interop_arg
!= 0)
13058 sym
->attr
.is_c_interop
= 0;
13059 sym
->ts
.is_c_interop
= 0;
13060 sym
->attr
.is_bind_c
= 0;
13064 if (!sym
->attr
.proc_pointer
)
13066 if (sym
->attr
.save
== SAVE_EXPLICIT
)
13068 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
13069 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13072 if (sym
->attr
.intent
)
13074 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
13075 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13078 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
13080 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
13081 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13084 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
13085 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
13086 || sym
->attr
.contained
))
13088 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
13089 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13092 if (strcmp ("ppr@", sym
->name
) == 0)
13094 gfc_error ("Procedure pointer result %qs at %L "
13095 "is missing the pointer attribute",
13096 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
13101 /* Assume that a procedure whose body is not known has references
13102 to external arrays. */
13103 if (sym
->attr
.if_source
!= IFSRC_DECL
)
13104 sym
->attr
.array_outer_dependency
= 1;
13106 /* Compare the characteristics of a module procedure with the
13107 interface declaration. Ideally this would be done with
13108 gfc_compare_interfaces but, at present, the formal interface
13109 cannot be copied to the ts.interface. */
13110 if (sym
->attr
.module_procedure
13111 && sym
->attr
.if_source
== IFSRC_DECL
)
13114 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
13116 char *submodule_name
;
13117 strcpy (name
, sym
->ns
->proc_name
->name
);
13118 module_name
= strtok (name
, ".");
13119 submodule_name
= strtok (NULL
, ".");
13121 iface
= sym
->tlink
;
13124 /* Make sure that the result uses the correct charlen for deferred
13126 if (iface
&& sym
->result
13127 && iface
->ts
.type
== BT_CHARACTER
13128 && iface
->ts
.deferred
)
13129 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
13134 /* Check the procedure characteristics. */
13135 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
13137 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
13138 "PROCEDURE at %L and its interface in %s",
13139 &sym
->declared_at
, module_name
);
13143 if (sym
->attr
.pure
!= iface
->attr
.pure
)
13145 gfc_error ("Mismatch in PURE attribute between MODULE "
13146 "PROCEDURE at %L and its interface in %s",
13147 &sym
->declared_at
, module_name
);
13151 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
13153 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
13154 "PROCEDURE at %L and its interface in %s",
13155 &sym
->declared_at
, module_name
);
13159 /* Check the result characteristics. */
13160 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
13162 gfc_error ("%s between the MODULE PROCEDURE declaration "
13163 "in MODULE %qs and the declaration at %L in "
13165 errmsg
, module_name
, &sym
->declared_at
,
13166 submodule_name
? submodule_name
: module_name
);
13171 /* Check the characteristics of the formal arguments. */
13172 if (sym
->formal
&& sym
->formal_ns
)
13174 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
13177 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
13185 /* Resolve a list of finalizer procedures. That is, after they have hopefully
13186 been defined and we now know their defined arguments, check that they fulfill
13187 the requirements of the standard for procedures used as finalizers. */
13190 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
13192 gfc_finalizer
* list
;
13193 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
13194 bool result
= true;
13195 bool seen_scalar
= false;
13198 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
13201 gfc_resolve_finalizers (parent
, finalizable
);
13203 /* Ensure that derived-type components have a their finalizers resolved. */
13204 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
13205 for (c
= derived
->components
; c
; c
= c
->next
)
13206 if (c
->ts
.type
== BT_DERIVED
13207 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
13209 bool has_final2
= false;
13210 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
13211 return false; /* Error. */
13212 has_final
= has_final
|| has_final2
;
13214 /* Return early if not finalizable. */
13218 *finalizable
= false;
13222 /* Walk over the list of finalizer-procedures, check them, and if any one
13223 does not fit in with the standard's definition, print an error and remove
13224 it from the list. */
13225 prev_link
= &derived
->f2k_derived
->finalizers
;
13226 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
13228 gfc_formal_arglist
*dummy_args
;
13233 /* Skip this finalizer if we already resolved it. */
13234 if (list
->proc_tree
)
13236 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
13237 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
13238 seen_scalar
= true;
13239 prev_link
= &(list
->next
);
13243 /* Check this exists and is a SUBROUTINE. */
13244 if (!list
->proc_sym
->attr
.subroutine
)
13246 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
13247 list
->proc_sym
->name
, &list
->where
);
13251 /* We should have exactly one argument. */
13252 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
13253 if (!dummy_args
|| dummy_args
->next
)
13255 gfc_error ("FINAL procedure at %L must have exactly one argument",
13259 arg
= dummy_args
->sym
;
13261 /* This argument must be of our type. */
13262 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
13264 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
13265 &arg
->declared_at
, derived
->name
);
13269 /* It must neither be a pointer nor allocatable nor optional. */
13270 if (arg
->attr
.pointer
)
13272 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13273 &arg
->declared_at
);
13276 if (arg
->attr
.allocatable
)
13278 gfc_error ("Argument of FINAL procedure at %L must not be"
13279 " ALLOCATABLE", &arg
->declared_at
);
13282 if (arg
->attr
.optional
)
13284 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13285 &arg
->declared_at
);
13289 /* It must not be INTENT(OUT). */
13290 if (arg
->attr
.intent
== INTENT_OUT
)
13292 gfc_error ("Argument of FINAL procedure at %L must not be"
13293 " INTENT(OUT)", &arg
->declared_at
);
13297 /* Warn if the procedure is non-scalar and not assumed shape. */
13298 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
13299 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
13300 gfc_warning (OPT_Wsurprising
,
13301 "Non-scalar FINAL procedure at %L should have assumed"
13302 " shape argument", &arg
->declared_at
);
13304 /* Check that it does not match in kind and rank with a FINAL procedure
13305 defined earlier. To really loop over the *earlier* declarations,
13306 we need to walk the tail of the list as new ones were pushed at the
13308 /* TODO: Handle kind parameters once they are implemented. */
13309 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
13310 for (i
= list
->next
; i
; i
= i
->next
)
13312 gfc_formal_arglist
*dummy_args
;
13314 /* Argument list might be empty; that is an error signalled earlier,
13315 but we nevertheless continued resolving. */
13316 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
13319 gfc_symbol
* i_arg
= dummy_args
->sym
;
13320 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
13321 if (i_rank
== my_rank
)
13323 gfc_error ("FINAL procedure %qs declared at %L has the same"
13324 " rank (%d) as %qs",
13325 list
->proc_sym
->name
, &list
->where
, my_rank
,
13326 i
->proc_sym
->name
);
13332 /* Is this the/a scalar finalizer procedure? */
13334 seen_scalar
= true;
13336 /* Find the symtree for this procedure. */
13337 gcc_assert (!list
->proc_tree
);
13338 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
13340 prev_link
= &list
->next
;
13343 /* Remove wrong nodes immediately from the list so we don't risk any
13344 troubles in the future when they might fail later expectations. */
13347 *prev_link
= list
->next
;
13348 gfc_free_finalizer (i
);
13352 if (result
== false)
13355 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13356 were nodes in the list, must have been for arrays. It is surely a good
13357 idea to have a scalar version there if there's something to finalize. */
13358 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
13359 gfc_warning (OPT_Wsurprising
,
13360 "Only array FINAL procedures declared for derived type %qs"
13361 " defined at %L, suggest also scalar one",
13362 derived
->name
, &derived
->declared_at
);
13364 vtab
= gfc_find_derived_vtab (derived
);
13365 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
13366 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
13369 *finalizable
= true;
13375 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13378 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13379 const char* generic_name
, locus where
)
13381 gfc_symbol
*sym1
, *sym2
;
13382 const char *pass1
, *pass2
;
13383 gfc_formal_arglist
*dummy_args
;
13385 gcc_assert (t1
->specific
&& t2
->specific
);
13386 gcc_assert (!t1
->specific
->is_generic
);
13387 gcc_assert (!t2
->specific
->is_generic
);
13388 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13390 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13391 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13396 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13397 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13398 || sym1
->attr
.function
!= sym2
->attr
.function
)
13400 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
13401 " GENERIC %qs at %L",
13402 sym1
->name
, sym2
->name
, generic_name
, &where
);
13406 /* Determine PASS arguments. */
13407 if (t1
->specific
->nopass
)
13409 else if (t1
->specific
->pass_arg
)
13410 pass1
= t1
->specific
->pass_arg
;
13413 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13415 pass1
= dummy_args
->sym
->name
;
13419 if (t2
->specific
->nopass
)
13421 else if (t2
->specific
->pass_arg
)
13422 pass2
= t2
->specific
->pass_arg
;
13425 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13427 pass2
= dummy_args
->sym
->name
;
13432 /* Compare the interfaces. */
13433 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13434 NULL
, 0, pass1
, pass2
))
13436 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13437 sym1
->name
, sym2
->name
, generic_name
, &where
);
13445 /* Worker function for resolving a generic procedure binding; this is used to
13446 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13448 The difference between those cases is finding possible inherited bindings
13449 that are overridden, as one has to look for them in tb_sym_root,
13450 tb_uop_root or tb_op, respectively. Thus the caller must already find
13451 the super-type and set p->overridden correctly. */
13454 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13455 gfc_typebound_proc
* p
, const char* name
)
13457 gfc_tbp_generic
* target
;
13458 gfc_symtree
* first_target
;
13459 gfc_symtree
* inherited
;
13461 gcc_assert (p
&& p
->is_generic
);
13463 /* Try to find the specific bindings for the symtrees in our target-list. */
13464 gcc_assert (p
->u
.generic
);
13465 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13466 if (!target
->specific
)
13468 gfc_typebound_proc
* overridden_tbp
;
13469 gfc_tbp_generic
* g
;
13470 const char* target_name
;
13472 target_name
= target
->specific_st
->name
;
13474 /* Defined for this type directly. */
13475 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13477 target
->specific
= target
->specific_st
->n
.tb
;
13478 goto specific_found
;
13481 /* Look for an inherited specific binding. */
13484 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13489 gcc_assert (inherited
->n
.tb
);
13490 target
->specific
= inherited
->n
.tb
;
13491 goto specific_found
;
13495 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13496 " at %L", target_name
, name
, &p
->where
);
13499 /* Once we've found the specific binding, check it is not ambiguous with
13500 other specifics already found or inherited for the same GENERIC. */
13502 gcc_assert (target
->specific
);
13504 /* This must really be a specific binding! */
13505 if (target
->specific
->is_generic
)
13507 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13508 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13512 /* Check those already resolved on this type directly. */
13513 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13514 if (g
!= target
&& g
->specific
13515 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13518 /* Check for ambiguity with inherited specific targets. */
13519 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13520 overridden_tbp
= overridden_tbp
->overridden
)
13521 if (overridden_tbp
->is_generic
)
13523 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13525 gcc_assert (g
->specific
);
13526 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13532 /* If we attempt to "overwrite" a specific binding, this is an error. */
13533 if (p
->overridden
&& !p
->overridden
->is_generic
)
13535 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
13536 " the same name", name
, &p
->where
);
13540 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13541 all must have the same attributes here. */
13542 first_target
= p
->u
.generic
->specific
->u
.specific
;
13543 gcc_assert (first_target
);
13544 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13545 p
->function
= first_target
->n
.sym
->attr
.function
;
13551 /* Resolve a GENERIC procedure binding for a derived type. */
13554 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13556 gfc_symbol
* super_type
;
13558 /* Find the overridden binding if any. */
13559 st
->n
.tb
->overridden
= NULL
;
13560 super_type
= gfc_get_derived_super_type (derived
);
13563 gfc_symtree
* overridden
;
13564 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13567 if (overridden
&& overridden
->n
.tb
)
13568 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13571 /* Resolve using worker function. */
13572 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13576 /* Retrieve the target-procedure of an operator binding and do some checks in
13577 common for intrinsic and user-defined type-bound operators. */
13580 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13582 gfc_symbol
* target_proc
;
13584 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13585 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13586 gcc_assert (target_proc
);
13588 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13589 if (target
->specific
->nopass
)
13591 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
13595 return target_proc
;
13599 /* Resolve a type-bound intrinsic operator. */
13602 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13603 gfc_typebound_proc
* p
)
13605 gfc_symbol
* super_type
;
13606 gfc_tbp_generic
* target
;
13608 /* If there's already an error here, do nothing (but don't fail again). */
13612 /* Operators should always be GENERIC bindings. */
13613 gcc_assert (p
->is_generic
);
13615 /* Look for an overridden binding. */
13616 super_type
= gfc_get_derived_super_type (derived
);
13617 if (super_type
&& super_type
->f2k_derived
)
13618 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13621 p
->overridden
= NULL
;
13623 /* Resolve general GENERIC properties using worker function. */
13624 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13627 /* Check the targets to be procedures of correct interface. */
13628 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13630 gfc_symbol
* target_proc
;
13632 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13636 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13639 /* Add target to non-typebound operator list. */
13640 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13641 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13643 gfc_interface
*head
, *intr
;
13645 /* Preempt 'gfc_check_new_interface' for submodules, where the
13646 mechanism for handling module procedures winds up resolving
13647 operator interfaces twice and would otherwise cause an error. */
13648 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13649 if (intr
->sym
== target_proc
13650 && target_proc
->attr
.used_in_submodule
)
13653 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13654 target_proc
, p
->where
))
13656 head
= derived
->ns
->op
[op
];
13657 intr
= gfc_get_interface ();
13658 intr
->sym
= target_proc
;
13659 intr
->where
= p
->where
;
13661 derived
->ns
->op
[op
] = intr
;
13673 /* Resolve a type-bound user operator (tree-walker callback). */
13675 static gfc_symbol
* resolve_bindings_derived
;
13676 static bool resolve_bindings_result
;
13678 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13681 resolve_typebound_user_op (gfc_symtree
* stree
)
13683 gfc_symbol
* super_type
;
13684 gfc_tbp_generic
* target
;
13686 gcc_assert (stree
&& stree
->n
.tb
);
13688 if (stree
->n
.tb
->error
)
13691 /* Operators should always be GENERIC bindings. */
13692 gcc_assert (stree
->n
.tb
->is_generic
);
13694 /* Find overridden procedure, if any. */
13695 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13696 if (super_type
&& super_type
->f2k_derived
)
13698 gfc_symtree
* overridden
;
13699 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13700 stree
->name
, true, NULL
);
13702 if (overridden
&& overridden
->n
.tb
)
13703 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13706 stree
->n
.tb
->overridden
= NULL
;
13708 /* Resolve basically using worker function. */
13709 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13712 /* Check the targets to be functions of correct interface. */
13713 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13715 gfc_symbol
* target_proc
;
13717 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13721 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13728 resolve_bindings_result
= false;
13729 stree
->n
.tb
->error
= 1;
13733 /* Resolve the type-bound procedures for a derived type. */
13736 resolve_typebound_procedure (gfc_symtree
* stree
)
13740 gfc_symbol
* me_arg
;
13741 gfc_symbol
* super_type
;
13742 gfc_component
* comp
;
13744 gcc_assert (stree
);
13746 /* Undefined specific symbol from GENERIC target definition. */
13750 if (stree
->n
.tb
->error
)
13753 /* If this is a GENERIC binding, use that routine. */
13754 if (stree
->n
.tb
->is_generic
)
13756 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13761 /* Get the target-procedure to check it. */
13762 gcc_assert (!stree
->n
.tb
->is_generic
);
13763 gcc_assert (stree
->n
.tb
->u
.specific
);
13764 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13765 where
= stree
->n
.tb
->where
;
13767 /* Default access should already be resolved from the parser. */
13768 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13770 if (stree
->n
.tb
->deferred
)
13772 if (!check_proc_interface (proc
, &where
))
13777 /* If proc has not been resolved at this point, proc->name may
13778 actually be a USE associated entity. See PR fortran/89647. */
13779 if (!proc
->resolved
13780 && proc
->attr
.function
== 0 && proc
->attr
.subroutine
== 0)
13783 gfc_find_symbol (proc
->name
, gfc_current_ns
->parent
, 1, &tmp
);
13784 if (tmp
&& tmp
->attr
.use_assoc
)
13786 proc
->module
= tmp
->module
;
13787 proc
->attr
.proc
= tmp
->attr
.proc
;
13788 proc
->attr
.function
= tmp
->attr
.function
;
13789 proc
->attr
.subroutine
= tmp
->attr
.subroutine
;
13790 proc
->attr
.use_assoc
= tmp
->attr
.use_assoc
;
13791 proc
->ts
= tmp
->ts
;
13792 proc
->result
= tmp
->result
;
13796 /* Check for F08:C465. */
13797 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13798 || (proc
->attr
.proc
!= PROC_MODULE
13799 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13800 || proc
->attr
.abstract
)
13802 gfc_error ("%qs must be a module procedure or an external "
13803 "procedure with an explicit interface at %L",
13804 proc
->name
, &where
);
13809 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13810 stree
->n
.tb
->function
= proc
->attr
.function
;
13812 /* Find the super-type of the current derived type. We could do this once and
13813 store in a global if speed is needed, but as long as not I believe this is
13814 more readable and clearer. */
13815 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13817 /* If PASS, resolve and check arguments if not already resolved / loaded
13818 from a .mod file. */
13819 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13821 gfc_formal_arglist
*dummy_args
;
13823 dummy_args
= gfc_sym_get_dummy_args (proc
);
13824 if (stree
->n
.tb
->pass_arg
)
13826 gfc_formal_arglist
*i
;
13828 /* If an explicit passing argument name is given, walk the arg-list
13829 and look for it. */
13832 stree
->n
.tb
->pass_arg_num
= 1;
13833 for (i
= dummy_args
; i
; i
= i
->next
)
13835 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13840 ++stree
->n
.tb
->pass_arg_num
;
13845 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13847 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13848 stree
->n
.tb
->pass_arg
);
13854 /* Otherwise, take the first one; there should in fact be at least
13856 stree
->n
.tb
->pass_arg_num
= 1;
13859 gfc_error ("Procedure %qs with PASS at %L must have at"
13860 " least one argument", proc
->name
, &where
);
13863 me_arg
= dummy_args
->sym
;
13866 /* Now check that the argument-type matches and the passed-object
13867 dummy argument is generally fine. */
13869 gcc_assert (me_arg
);
13871 if (me_arg
->ts
.type
!= BT_CLASS
)
13873 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13874 " at %L", proc
->name
, &where
);
13878 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13879 != resolve_bindings_derived
)
13881 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13882 " the derived-type %qs", me_arg
->name
, proc
->name
,
13883 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13887 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13888 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13890 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13891 " scalar", proc
->name
, &where
);
13894 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13896 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13897 " be ALLOCATABLE", proc
->name
, &where
);
13900 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13902 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13903 " be POINTER", proc
->name
, &where
);
13908 /* If we are extending some type, check that we don't override a procedure
13909 flagged NON_OVERRIDABLE. */
13910 stree
->n
.tb
->overridden
= NULL
;
13913 gfc_symtree
* overridden
;
13914 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13915 stree
->name
, true, NULL
);
13919 if (overridden
->n
.tb
)
13920 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13922 if (!gfc_check_typebound_override (stree
, overridden
))
13927 /* See if there's a name collision with a component directly in this type. */
13928 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13929 if (!strcmp (comp
->name
, stree
->name
))
13931 gfc_error ("Procedure %qs at %L has the same name as a component of"
13933 stree
->name
, &where
, resolve_bindings_derived
->name
);
13937 /* Try to find a name collision with an inherited component. */
13938 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13941 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13942 " component of %qs",
13943 stree
->name
, &where
, resolve_bindings_derived
->name
);
13947 stree
->n
.tb
->error
= 0;
13951 resolve_bindings_result
= false;
13952 stree
->n
.tb
->error
= 1;
13957 resolve_typebound_procedures (gfc_symbol
* derived
)
13960 gfc_symbol
* super_type
;
13962 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13965 super_type
= gfc_get_derived_super_type (derived
);
13967 resolve_symbol (super_type
);
13969 resolve_bindings_derived
= derived
;
13970 resolve_bindings_result
= true;
13972 if (derived
->f2k_derived
->tb_sym_root
)
13973 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13974 &resolve_typebound_procedure
);
13976 if (derived
->f2k_derived
->tb_uop_root
)
13977 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13978 &resolve_typebound_user_op
);
13980 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13982 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13983 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13984 (gfc_intrinsic_op
)op
, p
))
13985 resolve_bindings_result
= false;
13988 return resolve_bindings_result
;
13992 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13993 to give all identical derived types the same backend_decl. */
13995 add_dt_to_dt_list (gfc_symbol
*derived
)
13997 if (!derived
->dt_next
)
13999 if (gfc_derived_types
)
14001 derived
->dt_next
= gfc_derived_types
->dt_next
;
14002 gfc_derived_types
->dt_next
= derived
;
14006 derived
->dt_next
= derived
;
14008 gfc_derived_types
= derived
;
14013 /* Ensure that a derived-type is really not abstract, meaning that every
14014 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
14017 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
14022 if (!ensure_not_abstract_walker (sub
, st
->left
))
14024 if (!ensure_not_abstract_walker (sub
, st
->right
))
14027 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
14029 gfc_symtree
* overriding
;
14030 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
14033 gcc_assert (overriding
->n
.tb
);
14034 if (overriding
->n
.tb
->deferred
)
14036 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
14037 " %qs is DEFERRED and not overridden",
14038 sub
->name
, &sub
->declared_at
, st
->name
);
14047 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
14049 /* The algorithm used here is to recursively travel up the ancestry of sub
14050 and for each ancestor-type, check all bindings. If any of them is
14051 DEFERRED, look it up starting from sub and see if the found (overriding)
14052 binding is not DEFERRED.
14053 This is not the most efficient way to do this, but it should be ok and is
14054 clearer than something sophisticated. */
14056 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
14058 if (!ancestor
->attr
.abstract
)
14061 /* Walk bindings of this ancestor. */
14062 if (ancestor
->f2k_derived
)
14065 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
14070 /* Find next ancestor type and recurse on it. */
14071 ancestor
= gfc_get_derived_super_type (ancestor
);
14073 return ensure_not_abstract (sub
, ancestor
);
14079 /* This check for typebound defined assignments is done recursively
14080 since the order in which derived types are resolved is not always in
14081 order of the declarations. */
14084 check_defined_assignments (gfc_symbol
*derived
)
14088 for (c
= derived
->components
; c
; c
= c
->next
)
14090 if (!gfc_bt_struct (c
->ts
.type
)
14092 || c
->attr
.allocatable
14093 || c
->attr
.proc_pointer_comp
14094 || c
->attr
.class_pointer
14095 || c
->attr
.proc_pointer
)
14098 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
14099 || (c
->ts
.u
.derived
->f2k_derived
14100 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
14102 derived
->attr
.defined_assign_comp
= 1;
14106 check_defined_assignments (c
->ts
.u
.derived
);
14107 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
14109 derived
->attr
.defined_assign_comp
= 1;
14116 /* Resolve a single component of a derived type or structure. */
14119 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
14121 gfc_symbol
*super_type
;
14122 symbol_attribute
*attr
;
14124 if (c
->attr
.artificial
)
14127 /* Do not allow vtype components to be resolved in nameless namespaces
14128 such as block data because the procedure pointers will cause ICEs
14129 and vtables are not needed in these contexts. */
14130 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
14131 && sym
->ns
->proc_name
== NULL
)
14135 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
14136 && c
->attr
.codimension
14137 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
14139 gfc_error ("Coarray component %qs at %L must be allocatable with "
14140 "deferred shape", c
->name
, &c
->loc
);
14145 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
14146 && c
->ts
.u
.derived
->ts
.is_iso_c
)
14148 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14149 "shall not be a coarray", c
->name
, &c
->loc
);
14154 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
14155 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
14156 || c
->attr
.allocatable
))
14158 gfc_error ("Component %qs at %L with coarray component "
14159 "shall be a nonpointer, nonallocatable scalar",
14165 if (c
->ts
.type
== BT_CLASS
)
14167 if (CLASS_DATA (c
))
14169 attr
= &(CLASS_DATA (c
)->attr
);
14171 /* Fix up contiguous attribute. */
14172 if (c
->attr
.contiguous
)
14173 attr
->contiguous
= 1;
14181 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
14183 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
14184 "is not an array pointer", c
->name
, &c
->loc
);
14188 /* F2003, 15.2.1 - length has to be one. */
14189 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
14190 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
14191 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
14192 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
14194 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
14199 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
14201 gfc_symbol
*ifc
= c
->ts
.interface
;
14203 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
14209 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
14211 /* Resolve interface and copy attributes. */
14212 if (ifc
->formal
&& !ifc
->formal_ns
)
14213 resolve_symbol (ifc
);
14214 if (ifc
->attr
.intrinsic
)
14215 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
14219 c
->ts
= ifc
->result
->ts
;
14220 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
14221 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
14222 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
14223 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
14224 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
14229 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
14230 c
->attr
.pointer
= ifc
->attr
.pointer
;
14231 c
->attr
.dimension
= ifc
->attr
.dimension
;
14232 c
->as
= gfc_copy_array_spec (ifc
->as
);
14233 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
14235 c
->ts
.interface
= ifc
;
14236 c
->attr
.function
= ifc
->attr
.function
;
14237 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
14239 c
->attr
.pure
= ifc
->attr
.pure
;
14240 c
->attr
.elemental
= ifc
->attr
.elemental
;
14241 c
->attr
.recursive
= ifc
->attr
.recursive
;
14242 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
14243 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
14244 /* Copy char length. */
14245 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
14247 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
14248 if (cl
->length
&& !cl
->resolved
14249 && !gfc_resolve_expr (cl
->length
))
14258 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
14260 /* Since PPCs are not implicitly typed, a PPC without an explicit
14261 interface must be a subroutine. */
14262 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
14265 /* Procedure pointer components: Check PASS arg. */
14266 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
14267 && !sym
->attr
.vtype
)
14269 gfc_symbol
* me_arg
;
14271 if (c
->tb
->pass_arg
)
14273 gfc_formal_arglist
* i
;
14275 /* If an explicit passing argument name is given, walk the arg-list
14276 and look for it. */
14279 c
->tb
->pass_arg_num
= 1;
14280 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
14282 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
14287 c
->tb
->pass_arg_num
++;
14292 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14293 "at %L has no argument %qs", c
->name
,
14294 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
14301 /* Otherwise, take the first one; there should in fact be at least
14303 c
->tb
->pass_arg_num
= 1;
14304 if (!c
->ts
.interface
->formal
)
14306 gfc_error ("Procedure pointer component %qs with PASS at %L "
14307 "must have at least one argument",
14312 me_arg
= c
->ts
.interface
->formal
->sym
;
14315 /* Now check that the argument-type matches. */
14316 gcc_assert (me_arg
);
14317 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
14318 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
14319 || (me_arg
->ts
.type
== BT_CLASS
14320 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
14322 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14323 " the derived type %qs", me_arg
->name
, c
->name
,
14324 me_arg
->name
, &c
->loc
, sym
->name
);
14329 /* Check for F03:C453. */
14330 if (CLASS_DATA (me_arg
)->attr
.dimension
)
14332 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14333 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
14339 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14341 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14342 "may not have the POINTER attribute", me_arg
->name
,
14343 c
->name
, me_arg
->name
, &c
->loc
);
14348 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14350 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14351 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
14352 me_arg
->name
, &c
->loc
);
14357 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
14359 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14360 " at %L", c
->name
, &c
->loc
);
14366 /* Check type-spec if this is not the parent-type component. */
14367 if (((sym
->attr
.is_class
14368 && (!sym
->components
->ts
.u
.derived
->attr
.extension
14369 || c
!= sym
->components
->ts
.u
.derived
->components
))
14370 || (!sym
->attr
.is_class
14371 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
14372 && !sym
->attr
.vtype
14373 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
14376 super_type
= gfc_get_derived_super_type (sym
);
14378 /* If this type is an extension, set the accessibility of the parent
14381 && ((sym
->attr
.is_class
14382 && c
== sym
->components
->ts
.u
.derived
->components
)
14383 || (!sym
->attr
.is_class
&& c
== sym
->components
))
14384 && strcmp (super_type
->name
, c
->name
) == 0)
14385 c
->attr
.access
= super_type
->attr
.access
;
14387 /* If this type is an extension, see if this component has the same name
14388 as an inherited type-bound procedure. */
14389 if (super_type
&& !sym
->attr
.is_class
14390 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
14392 gfc_error ("Component %qs of %qs at %L has the same name as an"
14393 " inherited type-bound procedure",
14394 c
->name
, sym
->name
, &c
->loc
);
14398 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
14399 && !c
->ts
.deferred
)
14401 if (c
->ts
.u
.cl
->length
== NULL
14402 || (!resolve_charlen(c
->ts
.u
.cl
))
14403 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
14405 gfc_error ("Character length of component %qs needs to "
14406 "be a constant specification expression at %L",
14408 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14413 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14414 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14416 gfc_error ("Character component %qs of %qs at %L with deferred "
14417 "length must be a POINTER or ALLOCATABLE",
14418 c
->name
, sym
->name
, &c
->loc
);
14422 /* Add the hidden deferred length field. */
14423 if (c
->ts
.type
== BT_CHARACTER
14424 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14425 && !c
->attr
.function
14426 && !sym
->attr
.is_class
)
14428 char name
[GFC_MAX_SYMBOL_LEN
+9];
14429 gfc_component
*strlen
;
14430 sprintf (name
, "_%s_length", c
->name
);
14431 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14432 if (strlen
== NULL
)
14434 if (!gfc_add_component (sym
, name
, &strlen
))
14436 strlen
->ts
.type
= BT_INTEGER
;
14437 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14438 strlen
->attr
.access
= ACCESS_PRIVATE
;
14439 strlen
->attr
.artificial
= 1;
14443 if (c
->ts
.type
== BT_DERIVED
14444 && sym
->component_access
!= ACCESS_PRIVATE
14445 && gfc_check_symbol_access (sym
)
14446 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14447 && !c
->ts
.u
.derived
->attr
.use_assoc
14448 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14449 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14450 "PRIVATE type and cannot be a component of "
14451 "%qs, which is PUBLIC at %L", c
->name
,
14452 sym
->name
, &sym
->declared_at
))
14455 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14457 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14458 "type %s", c
->name
, &c
->loc
, sym
->name
);
14462 if (sym
->attr
.sequence
)
14464 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14466 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14467 "not have the SEQUENCE attribute",
14468 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14473 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14474 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14475 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14476 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14477 CLASS_DATA (c
)->ts
.u
.derived
14478 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14480 /* If an allocatable component derived type is of the same type as
14481 the enclosing derived type, we need a vtable generating so that
14482 the __deallocate procedure is created. */
14483 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14484 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14485 gfc_find_vtab (&c
->ts
);
14487 /* Ensure that all the derived type components are put on the
14488 derived type list; even in formal namespaces, where derived type
14489 pointer components might not have been declared. */
14490 if (c
->ts
.type
== BT_DERIVED
14492 && c
->ts
.u
.derived
->components
14494 && sym
!= c
->ts
.u
.derived
)
14495 add_dt_to_dt_list (c
->ts
.u
.derived
);
14497 if (!gfc_resolve_array_spec (c
->as
,
14498 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
14499 || c
->attr
.allocatable
)))
14502 if (c
->initializer
&& !sym
->attr
.vtype
14503 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
14504 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
14511 /* Be nice about the locus for a structure expression - show the locus of the
14512 first non-null sub-expression if we can. */
14515 cons_where (gfc_expr
*struct_expr
)
14517 gfc_constructor
*cons
;
14519 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
14521 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
14522 for (; cons
; cons
= gfc_constructor_next (cons
))
14524 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
14525 return &cons
->expr
->where
;
14528 return &struct_expr
->where
;
14531 /* Resolve the components of a structure type. Much less work than derived
14535 resolve_fl_struct (gfc_symbol
*sym
)
14538 gfc_expr
*init
= NULL
;
14541 /* Make sure UNIONs do not have overlapping initializers. */
14542 if (sym
->attr
.flavor
== FL_UNION
)
14544 for (c
= sym
->components
; c
; c
= c
->next
)
14546 if (init
&& c
->initializer
)
14548 gfc_error ("Conflicting initializers in union at %L and %L",
14549 cons_where (init
), cons_where (c
->initializer
));
14550 gfc_free_expr (c
->initializer
);
14551 c
->initializer
= NULL
;
14554 init
= c
->initializer
;
14559 for (c
= sym
->components
; c
; c
= c
->next
)
14560 if (!resolve_component (c
, sym
))
14566 if (sym
->components
)
14567 add_dt_to_dt_list (sym
);
14573 /* Resolve the components of a derived type. This does not have to wait until
14574 resolution stage, but can be done as soon as the dt declaration has been
14578 resolve_fl_derived0 (gfc_symbol
*sym
)
14580 gfc_symbol
* super_type
;
14582 gfc_formal_arglist
*f
;
14585 if (sym
->attr
.unlimited_polymorphic
)
14588 super_type
= gfc_get_derived_super_type (sym
);
14591 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14593 gfc_error ("As extending type %qs at %L has a coarray component, "
14594 "parent type %qs shall also have one", sym
->name
,
14595 &sym
->declared_at
, super_type
->name
);
14599 /* Ensure the extended type gets resolved before we do. */
14600 if (super_type
&& !resolve_fl_derived0 (super_type
))
14603 /* An ABSTRACT type must be extensible. */
14604 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14606 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14607 sym
->name
, &sym
->declared_at
);
14611 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14615 for ( ; c
!= NULL
; c
= c
->next
)
14616 if (!resolve_component (c
, sym
))
14622 /* Now add the caf token field, where needed. */
14623 if (flag_coarray
!= GFC_FCOARRAY_NONE
14624 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14626 for (c
= sym
->components
; c
; c
= c
->next
)
14627 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14628 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14630 char name
[GFC_MAX_SYMBOL_LEN
+9];
14631 gfc_component
*token
;
14632 sprintf (name
, "_caf_%s", c
->name
);
14633 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14636 if (!gfc_add_component (sym
, name
, &token
))
14638 token
->ts
.type
= BT_VOID
;
14639 token
->ts
.kind
= gfc_default_integer_kind
;
14640 token
->attr
.access
= ACCESS_PRIVATE
;
14641 token
->attr
.artificial
= 1;
14642 token
->attr
.caf_token
= 1;
14647 check_defined_assignments (sym
);
14649 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14650 sym
->attr
.defined_assign_comp
14651 = super_type
->attr
.defined_assign_comp
;
14653 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14654 all DEFERRED bindings are overridden. */
14655 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14656 && !sym
->attr
.is_class
14657 && !ensure_not_abstract (sym
, super_type
))
14660 /* Check that there is a component for every PDT parameter. */
14661 if (sym
->attr
.pdt_template
)
14663 for (f
= sym
->formal
; f
; f
= f
->next
)
14667 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14670 gfc_error ("Parameterized type %qs does not have a component "
14671 "corresponding to parameter %qs at %L", sym
->name
,
14672 f
->sym
->name
, &sym
->declared_at
);
14678 /* Add derived type to the derived type list. */
14679 add_dt_to_dt_list (sym
);
14685 /* The following procedure does the full resolution of a derived type,
14686 including resolution of all type-bound procedures (if present). In contrast
14687 to 'resolve_fl_derived0' this can only be done after the module has been
14688 parsed completely. */
14691 resolve_fl_derived (gfc_symbol
*sym
)
14693 gfc_symbol
*gen_dt
= NULL
;
14695 if (sym
->attr
.unlimited_polymorphic
)
14698 if (!sym
->attr
.is_class
)
14699 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14700 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14701 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14702 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14703 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14704 "%qs at %L being the same name as derived "
14705 "type at %L", sym
->name
,
14706 gen_dt
->generic
->sym
== sym
14707 ? gen_dt
->generic
->next
->sym
->name
14708 : gen_dt
->generic
->sym
->name
,
14709 gen_dt
->generic
->sym
== sym
14710 ? &gen_dt
->generic
->next
->sym
->declared_at
14711 : &gen_dt
->generic
->sym
->declared_at
,
14712 &sym
->declared_at
))
14715 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
14717 gfc_error ("Derived type %qs at %L has not been declared",
14718 sym
->name
, &sym
->declared_at
);
14722 /* Resolve the finalizer procedures. */
14723 if (!gfc_resolve_finalizers (sym
, NULL
))
14726 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14728 /* Fix up incomplete CLASS symbols. */
14729 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14730 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14732 /* Nothing more to do for unlimited polymorphic entities. */
14733 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14735 else if (vptr
->ts
.u
.derived
== NULL
)
14737 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14739 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14740 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14745 if (!resolve_fl_derived0 (sym
))
14748 /* Resolve the type-bound procedures. */
14749 if (!resolve_typebound_procedures (sym
))
14752 /* Generate module vtables subject to their accessibility and their not
14753 being vtables or pdt templates. If this is not done class declarations
14754 in external procedures wind up with their own version and so SELECT TYPE
14755 fails because the vptrs do not have the same address. */
14756 if (gfc_option
.allow_std
& GFC_STD_F2003
14757 && sym
->ns
->proc_name
14758 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14759 && sym
->attr
.access
!= ACCESS_PRIVATE
14760 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14762 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14763 gfc_set_sym_referenced (vtab
);
14771 resolve_fl_namelist (gfc_symbol
*sym
)
14776 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14778 /* Check again, the check in match only works if NAMELIST comes
14780 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14782 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14783 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14787 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14788 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14789 "with assumed shape in namelist %qs at %L",
14790 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14793 if (is_non_constant_shape_array (nl
->sym
)
14794 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14795 "with nonconstant shape in namelist %qs at %L",
14796 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14799 if (nl
->sym
->ts
.type
== BT_CHARACTER
14800 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14801 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14802 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14803 "nonconstant character length in "
14804 "namelist %qs at %L", nl
->sym
->name
,
14805 sym
->name
, &sym
->declared_at
))
14810 /* Reject PRIVATE objects in a PUBLIC namelist. */
14811 if (gfc_check_symbol_access (sym
))
14813 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14815 if (!nl
->sym
->attr
.use_assoc
14816 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14817 && !gfc_check_symbol_access (nl
->sym
))
14819 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14820 "cannot be member of PUBLIC namelist %qs at %L",
14821 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14825 if (nl
->sym
->ts
.type
== BT_DERIVED
14826 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14827 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14829 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14830 "namelist %qs at %L with ALLOCATABLE "
14831 "or POINTER components", nl
->sym
->name
,
14832 sym
->name
, &sym
->declared_at
))
14837 /* Types with private components that came here by USE-association. */
14838 if (nl
->sym
->ts
.type
== BT_DERIVED
14839 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14841 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14842 "components and cannot be member of namelist %qs at %L",
14843 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14847 /* Types with private components that are defined in the same module. */
14848 if (nl
->sym
->ts
.type
== BT_DERIVED
14849 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14850 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14852 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14853 "cannot be a member of PUBLIC namelist %qs at %L",
14854 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14861 /* 14.1.2 A module or internal procedure represent local entities
14862 of the same type as a namelist member and so are not allowed. */
14863 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14865 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14868 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14869 if ((nl
->sym
== sym
->ns
->proc_name
)
14871 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14876 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14877 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14879 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14880 "attribute in %qs at %L", nlsym
->name
,
14881 &sym
->declared_at
);
14888 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14889 nl
->sym
->attr
.asynchronous
= 1;
14896 resolve_fl_parameter (gfc_symbol
*sym
)
14898 /* A parameter array's shape needs to be constant. */
14899 if (sym
->as
!= NULL
14900 && (sym
->as
->type
== AS_DEFERRED
14901 || is_non_constant_shape_array (sym
)))
14903 gfc_error ("Parameter array %qs at %L cannot be automatic "
14904 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14908 /* Constraints on deferred type parameter. */
14909 if (!deferred_requirements (sym
))
14912 /* Make sure a parameter that has been implicitly typed still
14913 matches the implicit type, since PARAMETER statements can precede
14914 IMPLICIT statements. */
14915 if (sym
->attr
.implicit_type
14916 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14919 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14920 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14924 /* Make sure the types of derived parameters are consistent. This
14925 type checking is deferred until resolution because the type may
14926 refer to a derived type from the host. */
14927 if (sym
->ts
.type
== BT_DERIVED
14928 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14930 gfc_error ("Incompatible derived type in PARAMETER at %L",
14931 &sym
->value
->where
);
14935 /* F03:C509,C514. */
14936 if (sym
->ts
.type
== BT_CLASS
)
14938 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14939 sym
->name
, &sym
->declared_at
);
14947 /* Called by resolve_symbol to check PDTs. */
14950 resolve_pdt (gfc_symbol
* sym
)
14952 gfc_symbol
*derived
= NULL
;
14953 gfc_actual_arglist
*param
;
14955 bool const_len_exprs
= true;
14956 bool assumed_len_exprs
= false;
14957 symbol_attribute
*attr
;
14959 if (sym
->ts
.type
== BT_DERIVED
)
14961 derived
= sym
->ts
.u
.derived
;
14962 attr
= &(sym
->attr
);
14964 else if (sym
->ts
.type
== BT_CLASS
)
14966 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14967 attr
= &(CLASS_DATA (sym
)->attr
);
14970 gcc_unreachable ();
14972 gcc_assert (derived
->attr
.pdt_type
);
14974 for (param
= sym
->param_list
; param
; param
= param
->next
)
14976 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14978 if (c
->attr
.pdt_kind
)
14981 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14982 && c
->attr
.pdt_len
)
14983 const_len_exprs
= false;
14984 else if (param
->spec_type
== SPEC_ASSUMED
)
14985 assumed_len_exprs
= true;
14987 if (param
->spec_type
== SPEC_DEFERRED
14988 && !attr
->allocatable
&& !attr
->pointer
)
14989 gfc_error ("The object %qs at %L has a deferred LEN "
14990 "parameter %qs and is neither allocatable "
14991 "nor a pointer", sym
->name
, &sym
->declared_at
,
14996 if (!const_len_exprs
14997 && (sym
->ns
->proc_name
->attr
.is_main_program
14998 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14999 || sym
->attr
.save
!= SAVE_NONE
))
15000 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
15001 "SAVE attribute or be a variable declared in the "
15002 "main program, a module or a submodule(F08/C513)",
15003 sym
->name
, &sym
->declared_at
);
15005 if (assumed_len_exprs
&& !(sym
->attr
.dummy
15006 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
15007 gfc_error ("The object %qs at %L with ASSUMED type parameters "
15008 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
15009 sym
->name
, &sym
->declared_at
);
15013 /* Do anything necessary to resolve a symbol. Right now, we just
15014 assume that an otherwise unknown symbol is a variable. This sort
15015 of thing commonly happens for symbols in module. */
15018 resolve_symbol (gfc_symbol
*sym
)
15020 int check_constant
, mp_flag
;
15021 gfc_symtree
*symtree
;
15022 gfc_symtree
*this_symtree
;
15025 symbol_attribute class_attr
;
15026 gfc_array_spec
*as
;
15027 bool saved_specification_expr
;
15033 /* No symbol will ever have union type; only components can be unions.
15034 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
15035 (just like derived type declaration symbols have flavor FL_DERIVED). */
15036 gcc_assert (sym
->ts
.type
!= BT_UNION
);
15038 /* Coarrayed polymorphic objects with allocatable or pointer components are
15039 yet unsupported for -fcoarray=lib. */
15040 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
15041 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
15042 && CLASS_DATA (sym
)->attr
.codimension
15043 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
15044 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
15046 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
15047 "type coarrays at %L are unsupported", &sym
->declared_at
);
15051 if (sym
->attr
.artificial
)
15054 if (sym
->attr
.unlimited_polymorphic
)
15057 if (sym
->attr
.flavor
== FL_UNKNOWN
15058 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
15059 && !sym
->attr
.generic
&& !sym
->attr
.external
15060 && sym
->attr
.if_source
== IFSRC_UNKNOWN
15061 && sym
->ts
.type
== BT_UNKNOWN
))
15064 /* If we find that a flavorless symbol is an interface in one of the
15065 parent namespaces, find its symtree in this namespace, free the
15066 symbol and set the symtree to point to the interface symbol. */
15067 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
15069 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
15070 if (symtree
&& (symtree
->n
.sym
->generic
||
15071 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
15072 && sym
->ns
->construct_entities
)))
15074 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
15076 if (this_symtree
->n
.sym
== sym
)
15078 symtree
->n
.sym
->refs
++;
15079 gfc_release_symbol (sym
);
15080 this_symtree
->n
.sym
= symtree
->n
.sym
;
15086 /* Otherwise give it a flavor according to such attributes as
15088 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
15089 && sym
->attr
.intrinsic
== 0)
15090 sym
->attr
.flavor
= FL_VARIABLE
;
15091 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
15093 sym
->attr
.flavor
= FL_PROCEDURE
;
15094 if (sym
->attr
.dimension
)
15095 sym
->attr
.function
= 1;
15099 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
15100 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15102 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
15103 && !resolve_procedure_interface (sym
))
15106 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
15107 && (sym
->attr
.procedure
|| sym
->attr
.external
))
15109 if (sym
->attr
.external
)
15110 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
15111 "at %L", &sym
->declared_at
);
15113 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
15114 "at %L", &sym
->declared_at
);
15119 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
15122 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
15123 && !resolve_fl_struct (sym
))
15126 /* Symbols that are module procedures with results (functions) have
15127 the types and array specification copied for type checking in
15128 procedures that call them, as well as for saving to a module
15129 file. These symbols can't stand the scrutiny that their results
15131 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
15133 /* Make sure that the intrinsic is consistent with its internal
15134 representation. This needs to be done before assigning a default
15135 type to avoid spurious warnings. */
15136 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
15137 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
15140 /* Resolve associate names. */
15142 resolve_assoc_var (sym
, true);
15144 /* Assign default type to symbols that need one and don't have one. */
15145 if (sym
->ts
.type
== BT_UNKNOWN
)
15147 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
15149 gfc_set_default_type (sym
, 1, NULL
);
15152 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
15153 && !sym
->attr
.function
&& !sym
->attr
.subroutine
15154 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
15155 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15157 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15159 /* The specific case of an external procedure should emit an error
15160 in the case that there is no implicit type. */
15163 if (!sym
->attr
.mixed_entry_master
)
15164 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
15168 /* Result may be in another namespace. */
15169 resolve_symbol (sym
->result
);
15171 if (!sym
->result
->attr
.proc_pointer
)
15173 sym
->ts
= sym
->result
->ts
;
15174 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
15175 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
15176 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
15177 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
15178 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
15183 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15185 bool saved_specification_expr
= specification_expr
;
15186 specification_expr
= true;
15187 gfc_resolve_array_spec (sym
->result
->as
, false);
15188 specification_expr
= saved_specification_expr
;
15191 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
15193 as
= CLASS_DATA (sym
)->as
;
15194 class_attr
= CLASS_DATA (sym
)->attr
;
15195 class_attr
.pointer
= class_attr
.class_pointer
;
15199 class_attr
= sym
->attr
;
15204 if (sym
->attr
.contiguous
15205 && (!class_attr
.dimension
15206 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
15207 && !class_attr
.pointer
)))
15209 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
15210 "array pointer or an assumed-shape or assumed-rank array",
15211 sym
->name
, &sym
->declared_at
);
15215 /* Assumed size arrays and assumed shape arrays must be dummy
15216 arguments. Array-spec's of implied-shape should have been resolved to
15217 AS_EXPLICIT already. */
15221 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
15222 specification expression. */
15223 if (as
->type
== AS_IMPLIED_SHAPE
)
15226 for (i
=0; i
<as
->rank
; i
++)
15228 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
15230 gfc_error ("Bad specification for assumed size array at %L",
15231 &as
->lower
[i
]->where
);
15238 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
15239 || as
->type
== AS_ASSUMED_SHAPE
)
15240 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
15242 if (as
->type
== AS_ASSUMED_SIZE
)
15243 gfc_error ("Assumed size array at %L must be a dummy argument",
15244 &sym
->declared_at
);
15246 gfc_error ("Assumed shape array at %L must be a dummy argument",
15247 &sym
->declared_at
);
15250 /* TS 29113, C535a. */
15251 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
15252 && !sym
->attr
.select_type_temporary
15253 && !(cs_base
&& cs_base
->current
15254 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
15256 gfc_error ("Assumed-rank array at %L must be a dummy argument",
15257 &sym
->declared_at
);
15260 if (as
->type
== AS_ASSUMED_RANK
15261 && (sym
->attr
.codimension
|| sym
->attr
.value
))
15263 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15264 "CODIMENSION attribute", &sym
->declared_at
);
15269 /* Make sure symbols with known intent or optional are really dummy
15270 variable. Because of ENTRY statement, this has to be deferred
15271 until resolution time. */
15273 if (!sym
->attr
.dummy
15274 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
15276 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
15280 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
15282 gfc_error ("%qs at %L cannot have the VALUE attribute because "
15283 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
15287 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
15289 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
15290 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
15292 gfc_error ("Character dummy variable %qs at %L with VALUE "
15293 "attribute must have constant length",
15294 sym
->name
, &sym
->declared_at
);
15298 if (sym
->ts
.is_c_interop
15299 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
15301 gfc_error ("C interoperable character dummy variable %qs at %L "
15302 "with VALUE attribute must have length one",
15303 sym
->name
, &sym
->declared_at
);
15308 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15309 && sym
->ts
.u
.derived
->attr
.generic
)
15311 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
15312 if (!sym
->ts
.u
.derived
)
15314 gfc_error ("The derived type %qs at %L is of type %qs, "
15315 "which has not been defined", sym
->name
,
15316 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15317 sym
->ts
.type
= BT_UNKNOWN
;
15322 /* Use the same constraints as TYPE(*), except for the type check
15323 and that only scalars and assumed-size arrays are permitted. */
15324 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
15326 if (!sym
->attr
.dummy
)
15328 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15329 "a dummy argument", sym
->name
, &sym
->declared_at
);
15333 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
15334 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
15335 && sym
->ts
.type
!= BT_COMPLEX
)
15337 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15338 "of type TYPE(*) or of an numeric intrinsic type",
15339 sym
->name
, &sym
->declared_at
);
15343 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15344 || sym
->attr
.pointer
|| sym
->attr
.value
)
15346 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15347 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15348 "attribute", sym
->name
, &sym
->declared_at
);
15352 if (sym
->attr
.intent
== INTENT_OUT
)
15354 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15355 "have the INTENT(OUT) attribute",
15356 sym
->name
, &sym
->declared_at
);
15359 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
15361 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15362 "either be a scalar or an assumed-size array",
15363 sym
->name
, &sym
->declared_at
);
15367 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15368 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15370 sym
->ts
.type
= BT_ASSUMED
;
15371 sym
->as
= gfc_get_array_spec ();
15372 sym
->as
->type
= AS_ASSUMED_SIZE
;
15374 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
15376 else if (sym
->ts
.type
== BT_ASSUMED
)
15378 /* TS 29113, C407a. */
15379 if (!sym
->attr
.dummy
)
15381 gfc_error ("Assumed type of variable %s at %L is only permitted "
15382 "for dummy variables", sym
->name
, &sym
->declared_at
);
15385 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15386 || sym
->attr
.pointer
|| sym
->attr
.value
)
15388 gfc_error ("Assumed-type variable %s at %L may not have the "
15389 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15390 sym
->name
, &sym
->declared_at
);
15393 if (sym
->attr
.intent
== INTENT_OUT
)
15395 gfc_error ("Assumed-type variable %s at %L may not have the "
15396 "INTENT(OUT) attribute",
15397 sym
->name
, &sym
->declared_at
);
15400 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
15402 gfc_error ("Assumed-type variable %s at %L shall not be an "
15403 "explicit-shape array", sym
->name
, &sym
->declared_at
);
15408 /* If the symbol is marked as bind(c), that it is declared at module level
15409 scope and verify its type and kind. Do not do the latter for symbols
15410 that are implicitly typed because that is handled in
15411 gfc_set_default_type. Handle dummy arguments and procedure definitions
15412 separately. Also, anything that is use associated is not handled here
15413 but instead is handled in the module it is declared in. Finally, derived
15414 type definitions are allowed to be BIND(C) since that only implies that
15415 they're interoperable, and they are checked fully for interoperability
15416 when a variable is declared of that type. */
15417 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15418 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15419 && sym
->attr
.flavor
!= FL_DERIVED
)
15423 /* First, make sure the variable is declared at the
15424 module-level scope (J3/04-007, Section 15.3). */
15425 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
15426 sym
->attr
.in_common
== 0)
15428 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15429 "is neither a COMMON block nor declared at the "
15430 "module level scope", sym
->name
, &(sym
->declared_at
));
15433 else if (sym
->ts
.type
== BT_CHARACTER
15434 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15435 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15436 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15438 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15439 sym
->name
, &sym
->declared_at
);
15442 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15444 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15446 else if (sym
->attr
.implicit_type
== 0)
15448 /* If type() declaration, we need to verify that the components
15449 of the given type are all C interoperable, etc. */
15450 if (sym
->ts
.type
== BT_DERIVED
&&
15451 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15453 /* Make sure the user marked the derived type as BIND(C). If
15454 not, call the verify routine. This could print an error
15455 for the derived type more than once if multiple variables
15456 of that type are declared. */
15457 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15458 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15462 /* Verify the variable itself as C interoperable if it
15463 is BIND(C). It is not possible for this to succeed if
15464 the verify_bind_c_derived_type failed, so don't have to handle
15465 any error returned by verify_bind_c_derived_type. */
15466 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15467 sym
->common_block
);
15472 /* clear the is_bind_c flag to prevent reporting errors more than
15473 once if something failed. */
15474 sym
->attr
.is_bind_c
= 0;
15479 /* If a derived type symbol has reached this point, without its
15480 type being declared, we have an error. Notice that most
15481 conditions that produce undefined derived types have already
15482 been dealt with. However, the likes of:
15483 implicit type(t) (t) ..... call foo (t) will get us here if
15484 the type is not declared in the scope of the implicit
15485 statement. Change the type to BT_UNKNOWN, both because it is so
15486 and to prevent an ICE. */
15487 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15488 && sym
->ts
.u
.derived
->components
== NULL
15489 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
15491 gfc_error ("The derived type %qs at %L is of type %qs, "
15492 "which has not been defined", sym
->name
,
15493 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15494 sym
->ts
.type
= BT_UNKNOWN
;
15498 /* Make sure that the derived type has been resolved and that the
15499 derived type is visible in the symbol's namespace, if it is a
15500 module function and is not PRIVATE. */
15501 if (sym
->ts
.type
== BT_DERIVED
15502 && sym
->ts
.u
.derived
->attr
.use_assoc
15503 && sym
->ns
->proc_name
15504 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15505 && !resolve_fl_derived (sym
->ts
.u
.derived
))
15508 /* Unless the derived-type declaration is use associated, Fortran 95
15509 does not allow public entries of private derived types.
15510 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15511 161 in 95-006r3. */
15512 if (sym
->ts
.type
== BT_DERIVED
15513 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15514 && !sym
->ts
.u
.derived
->attr
.use_assoc
15515 && gfc_check_symbol_access (sym
)
15516 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15517 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
15518 "derived type %qs",
15519 (sym
->attr
.flavor
== FL_PARAMETER
)
15520 ? "parameter" : "variable",
15521 sym
->name
, &sym
->declared_at
,
15522 sym
->ts
.u
.derived
->name
))
15525 /* F2008, C1302. */
15526 if (sym
->ts
.type
== BT_DERIVED
15527 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15528 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
15529 || sym
->ts
.u
.derived
->attr
.lock_comp
)
15530 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15532 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15533 "type LOCK_TYPE must be a coarray", sym
->name
,
15534 &sym
->declared_at
);
15538 /* TS18508, C702/C703. */
15539 if (sym
->ts
.type
== BT_DERIVED
15540 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15541 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
15542 || sym
->ts
.u
.derived
->attr
.event_comp
)
15543 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15545 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15546 "type EVENT_TYPE must be a coarray", sym
->name
,
15547 &sym
->declared_at
);
15551 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15552 default initialization is defined (5.1.2.4.4). */
15553 if (sym
->ts
.type
== BT_DERIVED
15555 && sym
->attr
.intent
== INTENT_OUT
15557 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15559 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15561 if (c
->initializer
)
15563 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15564 "ASSUMED SIZE and so cannot have a default initializer",
15565 sym
->name
, &sym
->declared_at
);
15572 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15573 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15575 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15576 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15581 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15582 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15584 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15585 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15590 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15591 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15592 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15593 || class_attr
.codimension
)
15594 && (sym
->attr
.result
|| sym
->result
== sym
))
15596 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15597 "a coarray component", sym
->name
, &sym
->declared_at
);
15602 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15603 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15605 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15606 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15611 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15612 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15613 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15614 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15615 || class_attr
.allocatable
))
15617 gfc_error ("Variable %qs at %L with coarray component shall be a "
15618 "nonpointer, nonallocatable scalar, which is not a coarray",
15619 sym
->name
, &sym
->declared_at
);
15623 /* F2008, C526. The function-result case was handled above. */
15624 if (class_attr
.codimension
15625 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15626 || sym
->attr
.select_type_temporary
15627 || sym
->attr
.associate_var
15628 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15629 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15630 || sym
->ns
->proc_name
->attr
.is_main_program
15631 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15633 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15634 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15638 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15639 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15641 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15642 "deferred shape", sym
->name
, &sym
->declared_at
);
15645 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15646 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15648 gfc_error ("Allocatable coarray variable %qs at %L must have "
15649 "deferred shape", sym
->name
, &sym
->declared_at
);
15654 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15655 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15656 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15657 || (class_attr
.codimension
&& class_attr
.allocatable
))
15658 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15660 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15661 "allocatable coarray or have coarray components",
15662 sym
->name
, &sym
->declared_at
);
15666 if (class_attr
.codimension
&& sym
->attr
.dummy
15667 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15669 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15670 "procedure %qs", sym
->name
, &sym
->declared_at
,
15671 sym
->ns
->proc_name
->name
);
15675 if (sym
->ts
.type
== BT_LOGICAL
15676 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15677 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15678 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15681 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15682 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15684 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15685 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15686 "%L with non-C_Bool kind in BIND(C) procedure "
15687 "%qs", sym
->name
, &sym
->declared_at
,
15688 sym
->ns
->proc_name
->name
))
15690 else if (!gfc_logical_kinds
[i
].c_bool
15691 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15692 "%qs at %L with non-C_Bool kind in "
15693 "BIND(C) procedure %qs", sym
->name
,
15695 sym
->attr
.function
? sym
->name
15696 : sym
->ns
->proc_name
->name
))
15700 switch (sym
->attr
.flavor
)
15703 if (!resolve_fl_variable (sym
, mp_flag
))
15708 if (sym
->formal
&& !sym
->formal_ns
)
15710 /* Check that none of the arguments are a namelist. */
15711 gfc_formal_arglist
*formal
= sym
->formal
;
15713 for (; formal
; formal
= formal
->next
)
15714 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15716 gfc_error ("Namelist %qs cannot be an argument to "
15717 "subroutine or function at %L",
15718 formal
->sym
->name
, &sym
->declared_at
);
15723 if (!resolve_fl_procedure (sym
, mp_flag
))
15728 if (!resolve_fl_namelist (sym
))
15733 if (!resolve_fl_parameter (sym
))
15741 /* Resolve array specifier. Check as well some constraints
15742 on COMMON blocks. */
15744 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15746 /* Set the formal_arg_flag so that check_conflict will not throw
15747 an error for host associated variables in the specification
15748 expression for an array_valued function. */
15749 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
15750 formal_arg_flag
= true;
15752 saved_specification_expr
= specification_expr
;
15753 specification_expr
= true;
15754 gfc_resolve_array_spec (sym
->as
, check_constant
);
15755 specification_expr
= saved_specification_expr
;
15757 formal_arg_flag
= false;
15759 /* Resolve formal namespaces. */
15760 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15761 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15762 gfc_resolve (sym
->formal_ns
);
15764 /* Make sure the formal namespace is present. */
15765 if (sym
->formal
&& !sym
->formal_ns
)
15767 gfc_formal_arglist
*formal
= sym
->formal
;
15768 while (formal
&& !formal
->sym
)
15769 formal
= formal
->next
;
15773 sym
->formal_ns
= formal
->sym
->ns
;
15774 if (sym
->ns
!= formal
->sym
->ns
)
15775 sym
->formal_ns
->refs
++;
15779 /* Check threadprivate restrictions. */
15780 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15781 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15782 && (!sym
->attr
.in_common
15783 && sym
->module
== NULL
15784 && (sym
->ns
->proc_name
== NULL
15785 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15786 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15788 /* Check omp declare target restrictions. */
15789 if (sym
->attr
.omp_declare_target
15790 && sym
->attr
.flavor
== FL_VARIABLE
15792 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15793 && (!sym
->attr
.in_common
15794 && sym
->module
== NULL
15795 && (sym
->ns
->proc_name
== NULL
15796 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15797 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15798 sym
->name
, &sym
->declared_at
);
15800 /* If we have come this far we can apply default-initializers, as
15801 described in 14.7.5, to those variables that have not already
15802 been assigned one. */
15803 if (sym
->ts
.type
== BT_DERIVED
15805 && !sym
->attr
.allocatable
15806 && !sym
->attr
.alloc_comp
)
15808 symbol_attribute
*a
= &sym
->attr
;
15810 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15811 && !a
->in_common
&& !a
->use_assoc
15813 && !((a
->function
|| a
->result
)
15815 || sym
->ts
.u
.derived
->attr
.alloc_comp
15816 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15817 && !(a
->function
&& sym
!= sym
->result
))
15818 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15819 apply_default_init (sym
);
15820 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15821 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15822 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15823 /* Mark the result symbol to be referenced, when it has allocatable
15825 sym
->result
->attr
.referenced
= 1;
15828 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15829 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15830 && !CLASS_DATA (sym
)->attr
.class_pointer
15831 && !CLASS_DATA (sym
)->attr
.allocatable
)
15832 apply_default_init (sym
);
15834 /* If this symbol has a type-spec, check it. */
15835 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15836 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15837 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15840 if (sym
->param_list
)
15845 /************* Resolve DATA statements *************/
15849 gfc_data_value
*vnode
;
15855 /* Advance the values structure to point to the next value in the data list. */
15858 next_data_value (void)
15860 while (mpz_cmp_ui (values
.left
, 0) == 0)
15863 if (values
.vnode
->next
== NULL
)
15866 values
.vnode
= values
.vnode
->next
;
15867 mpz_set (values
.left
, values
.vnode
->repeat
);
15875 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15881 ar_type mark
= AR_UNKNOWN
;
15883 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15889 if (!gfc_resolve_expr (var
->expr
))
15893 mpz_init_set_si (offset
, 0);
15896 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15897 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15898 e
= e
->value
.function
.actual
->expr
;
15900 if (e
->expr_type
!= EXPR_VARIABLE
)
15902 gfc_error ("Expecting definable entity near %L", where
);
15906 sym
= e
->symtree
->n
.sym
;
15908 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15910 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15911 sym
->name
, &sym
->declared_at
);
15915 if (e
->ref
== NULL
&& sym
->as
)
15917 gfc_error ("DATA array %qs at %L must be specified in a previous"
15918 " declaration", sym
->name
, where
);
15922 if (gfc_is_coindexed (e
))
15924 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15929 has_pointer
= sym
->attr
.pointer
;
15931 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15933 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15938 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_FULL
)
15940 gfc_error ("DATA element %qs at %L is a pointer and so must "
15941 "be a full array", sym
->name
, where
);
15945 if (values
.vnode
->expr
->expr_type
== EXPR_CONSTANT
)
15947 gfc_error ("DATA object near %L has the pointer attribute "
15948 "and the corresponding DATA value is not a valid "
15949 "initial-data-target", where
);
15955 if (e
->rank
== 0 || has_pointer
)
15957 mpz_init_set_ui (size
, 1);
15964 /* Find the array section reference. */
15965 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15967 if (ref
->type
!= REF_ARRAY
)
15969 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15975 /* Set marks according to the reference pattern. */
15976 switch (ref
->u
.ar
.type
)
15984 /* Get the start position of array section. */
15985 gfc_get_section_index (ar
, section_index
, &offset
);
15990 gcc_unreachable ();
15993 if (!gfc_array_size (e
, &size
))
15995 gfc_error ("Nonconstant array section at %L in DATA statement",
15997 mpz_clear (offset
);
16004 while (mpz_cmp_ui (size
, 0) > 0)
16006 if (!next_data_value ())
16008 gfc_error ("DATA statement at %L has more variables than values",
16014 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
16018 /* If we have more than one element left in the repeat count,
16019 and we have more than one element left in the target variable,
16020 then create a range assignment. */
16021 /* FIXME: Only done for full arrays for now, since array sections
16023 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
16024 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
16028 if (mpz_cmp (size
, values
.left
) >= 0)
16030 mpz_init_set (range
, values
.left
);
16031 mpz_sub (size
, size
, values
.left
);
16032 mpz_set_ui (values
.left
, 0);
16036 mpz_init_set (range
, size
);
16037 mpz_sub (values
.left
, values
.left
, size
);
16038 mpz_set_ui (size
, 0);
16041 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16044 mpz_add (offset
, offset
, range
);
16051 /* Assign initial value to symbol. */
16054 mpz_sub_ui (values
.left
, values
.left
, 1);
16055 mpz_sub_ui (size
, size
, 1);
16057 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16062 if (mark
== AR_FULL
)
16063 mpz_add_ui (offset
, offset
, 1);
16065 /* Modify the array section indexes and recalculate the offset
16066 for next element. */
16067 else if (mark
== AR_SECTION
)
16068 gfc_advance_section (section_index
, ar
, &offset
);
16072 if (mark
== AR_SECTION
)
16074 for (i
= 0; i
< ar
->dimen
; i
++)
16075 mpz_clear (section_index
[i
]);
16079 mpz_clear (offset
);
16085 static bool traverse_data_var (gfc_data_variable
*, locus
*);
16087 /* Iterate over a list of elements in a DATA statement. */
16090 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
16093 iterator_stack frame
;
16094 gfc_expr
*e
, *start
, *end
, *step
;
16095 bool retval
= true;
16097 mpz_init (frame
.value
);
16100 start
= gfc_copy_expr (var
->iter
.start
);
16101 end
= gfc_copy_expr (var
->iter
.end
);
16102 step
= gfc_copy_expr (var
->iter
.step
);
16104 if (!gfc_simplify_expr (start
, 1)
16105 || start
->expr_type
!= EXPR_CONSTANT
)
16107 gfc_error ("start of implied-do loop at %L could not be "
16108 "simplified to a constant value", &start
->where
);
16112 if (!gfc_simplify_expr (end
, 1)
16113 || end
->expr_type
!= EXPR_CONSTANT
)
16115 gfc_error ("end of implied-do loop at %L could not be "
16116 "simplified to a constant value", &start
->where
);
16120 if (!gfc_simplify_expr (step
, 1)
16121 || step
->expr_type
!= EXPR_CONSTANT
)
16123 gfc_error ("step of implied-do loop at %L could not be "
16124 "simplified to a constant value", &start
->where
);
16129 mpz_set (trip
, end
->value
.integer
);
16130 mpz_sub (trip
, trip
, start
->value
.integer
);
16131 mpz_add (trip
, trip
, step
->value
.integer
);
16133 mpz_div (trip
, trip
, step
->value
.integer
);
16135 mpz_set (frame
.value
, start
->value
.integer
);
16137 frame
.prev
= iter_stack
;
16138 frame
.variable
= var
->iter
.var
->symtree
;
16139 iter_stack
= &frame
;
16141 while (mpz_cmp_ui (trip
, 0) > 0)
16143 if (!traverse_data_var (var
->list
, where
))
16149 e
= gfc_copy_expr (var
->expr
);
16150 if (!gfc_simplify_expr (e
, 1))
16157 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
16159 mpz_sub_ui (trip
, trip
, 1);
16163 mpz_clear (frame
.value
);
16166 gfc_free_expr (start
);
16167 gfc_free_expr (end
);
16168 gfc_free_expr (step
);
16170 iter_stack
= frame
.prev
;
16175 /* Type resolve variables in the variable list of a DATA statement. */
16178 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
16182 for (; var
; var
= var
->next
)
16184 if (var
->expr
== NULL
)
16185 t
= traverse_data_list (var
, where
);
16187 t
= check_data_variable (var
, where
);
16197 /* Resolve the expressions and iterators associated with a data statement.
16198 This is separate from the assignment checking because data lists should
16199 only be resolved once. */
16202 resolve_data_variables (gfc_data_variable
*d
)
16204 for (; d
; d
= d
->next
)
16206 if (d
->list
== NULL
)
16208 if (!gfc_resolve_expr (d
->expr
))
16213 if (!gfc_resolve_iterator (&d
->iter
, false, true))
16216 if (!resolve_data_variables (d
->list
))
16225 /* Resolve a single DATA statement. We implement this by storing a pointer to
16226 the value list into static variables, and then recursively traversing the
16227 variables list, expanding iterators and such. */
16230 resolve_data (gfc_data
*d
)
16233 if (!resolve_data_variables (d
->var
))
16236 values
.vnode
= d
->value
;
16237 if (d
->value
== NULL
)
16238 mpz_set_ui (values
.left
, 0);
16240 mpz_set (values
.left
, d
->value
->repeat
);
16242 if (!traverse_data_var (d
->var
, &d
->where
))
16245 /* At this point, we better not have any values left. */
16247 if (next_data_value ())
16248 gfc_error ("DATA statement at %L has more values than variables",
16253 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
16254 accessed by host or use association, is a dummy argument to a pure function,
16255 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
16256 is storage associated with any such variable, shall not be used in the
16257 following contexts: (clients of this function). */
16259 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
16260 procedure. Returns zero if assignment is OK, nonzero if there is a
16263 gfc_impure_variable (gfc_symbol
*sym
)
16268 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
16271 /* Check if the symbol's ns is inside the pure procedure. */
16272 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16276 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
16280 proc
= sym
->ns
->proc_name
;
16281 if (sym
->attr
.dummy
16282 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
16283 || proc
->attr
.function
))
16286 /* TODO: Sort out what can be storage associated, if anything, and include
16287 it here. In principle equivalences should be scanned but it does not
16288 seem to be possible to storage associate an impure variable this way. */
16293 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
16294 current namespace is inside a pure procedure. */
16297 gfc_pure (gfc_symbol
*sym
)
16299 symbol_attribute attr
;
16304 /* Check if the current namespace or one of its parents
16305 belongs to a pure procedure. */
16306 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16308 sym
= ns
->proc_name
;
16312 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
16320 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
16324 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16325 checks if the current namespace is implicitly pure. Note that this
16326 function returns false for a PURE procedure. */
16329 gfc_implicit_pure (gfc_symbol
*sym
)
16335 /* Check if the current procedure is implicit_pure. Walk up
16336 the procedure list until we find a procedure. */
16337 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16339 sym
= ns
->proc_name
;
16343 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16348 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
16349 && !sym
->attr
.pure
;
16354 gfc_unset_implicit_pure (gfc_symbol
*sym
)
16360 /* Check if the current procedure is implicit_pure. Walk up
16361 the procedure list until we find a procedure. */
16362 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16364 sym
= ns
->proc_name
;
16368 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16373 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16374 sym
->attr
.implicit_pure
= 0;
16376 sym
->attr
.pure
= 0;
16380 /* Test whether the current procedure is elemental or not. */
16383 gfc_elemental (gfc_symbol
*sym
)
16385 symbol_attribute attr
;
16388 sym
= gfc_current_ns
->proc_name
;
16393 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
16397 /* Warn about unused labels. */
16400 warn_unused_fortran_label (gfc_st_label
*label
)
16405 warn_unused_fortran_label (label
->left
);
16407 if (label
->defined
== ST_LABEL_UNKNOWN
)
16410 switch (label
->referenced
)
16412 case ST_LABEL_UNKNOWN
:
16413 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
16414 label
->value
, &label
->where
);
16417 case ST_LABEL_BAD_TARGET
:
16418 gfc_warning (OPT_Wunused_label
,
16419 "Label %d at %L defined but cannot be used",
16420 label
->value
, &label
->where
);
16427 warn_unused_fortran_label (label
->right
);
16431 /* Returns the sequence type of a symbol or sequence. */
16434 sequence_type (gfc_typespec ts
)
16443 if (ts
.u
.derived
->components
== NULL
)
16444 return SEQ_NONDEFAULT
;
16446 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16447 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16448 if (sequence_type (c
->ts
) != result
)
16454 if (ts
.kind
!= gfc_default_character_kind
)
16455 return SEQ_NONDEFAULT
;
16457 return SEQ_CHARACTER
;
16460 if (ts
.kind
!= gfc_default_integer_kind
)
16461 return SEQ_NONDEFAULT
;
16463 return SEQ_NUMERIC
;
16466 if (!(ts
.kind
== gfc_default_real_kind
16467 || ts
.kind
== gfc_default_double_kind
))
16468 return SEQ_NONDEFAULT
;
16470 return SEQ_NUMERIC
;
16473 if (ts
.kind
!= gfc_default_complex_kind
)
16474 return SEQ_NONDEFAULT
;
16476 return SEQ_NUMERIC
;
16479 if (ts
.kind
!= gfc_default_logical_kind
)
16480 return SEQ_NONDEFAULT
;
16482 return SEQ_NUMERIC
;
16485 return SEQ_NONDEFAULT
;
16490 /* Resolve derived type EQUIVALENCE object. */
16493 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
16495 gfc_component
*c
= derived
->components
;
16500 /* Shall not be an object of nonsequence derived type. */
16501 if (!derived
->attr
.sequence
)
16503 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16504 "attribute to be an EQUIVALENCE object", sym
->name
,
16509 /* Shall not have allocatable components. */
16510 if (derived
->attr
.alloc_comp
)
16512 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16513 "components to be an EQUIVALENCE object",sym
->name
,
16518 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
16520 gfc_error ("Derived type variable %qs at %L with default "
16521 "initialization cannot be in EQUIVALENCE with a variable "
16522 "in COMMON", sym
->name
, &e
->where
);
16526 for (; c
; c
= c
->next
)
16528 if (gfc_bt_struct (c
->ts
.type
)
16529 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
16532 /* Shall not be an object of sequence derived type containing a pointer
16533 in the structure. */
16534 if (c
->attr
.pointer
)
16536 gfc_error ("Derived type variable %qs at %L with pointer "
16537 "component(s) cannot be an EQUIVALENCE object",
16538 sym
->name
, &e
->where
);
16546 /* Resolve equivalence object.
16547 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16548 an allocatable array, an object of nonsequence derived type, an object of
16549 sequence derived type containing a pointer at any level of component
16550 selection, an automatic object, a function name, an entry name, a result
16551 name, a named constant, a structure component, or a subobject of any of
16552 the preceding objects. A substring shall not have length zero. A
16553 derived type shall not have components with default initialization nor
16554 shall two objects of an equivalence group be initialized.
16555 Either all or none of the objects shall have an protected attribute.
16556 The simple constraints are done in symbol.c(check_conflict) and the rest
16557 are implemented here. */
16560 resolve_equivalence (gfc_equiv
*eq
)
16563 gfc_symbol
*first_sym
;
16566 locus
*last_where
= NULL
;
16567 seq_type eq_type
, last_eq_type
;
16568 gfc_typespec
*last_ts
;
16569 int object
, cnt_protected
;
16572 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16574 first_sym
= eq
->expr
->symtree
->n
.sym
;
16578 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16582 e
->ts
= e
->symtree
->n
.sym
->ts
;
16583 /* match_varspec might not know yet if it is seeing
16584 array reference or substring reference, as it doesn't
16586 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16588 gfc_ref
*ref
= e
->ref
;
16589 sym
= e
->symtree
->n
.sym
;
16591 if (sym
->attr
.dimension
)
16593 ref
->u
.ar
.as
= sym
->as
;
16597 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16598 if (e
->ts
.type
== BT_CHARACTER
16600 && ref
->type
== REF_ARRAY
16601 && ref
->u
.ar
.dimen
== 1
16602 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16603 && ref
->u
.ar
.stride
[0] == NULL
)
16605 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16606 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16609 /* Optimize away the (:) reference. */
16610 if (start
== NULL
&& end
== NULL
)
16613 e
->ref
= ref
->next
;
16615 e
->ref
->next
= ref
->next
;
16620 ref
->type
= REF_SUBSTRING
;
16622 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16624 ref
->u
.ss
.start
= start
;
16625 if (end
== NULL
&& e
->ts
.u
.cl
)
16626 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16627 ref
->u
.ss
.end
= end
;
16628 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16635 /* Any further ref is an error. */
16638 gcc_assert (ref
->type
== REF_ARRAY
);
16639 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16645 if (!gfc_resolve_expr (e
))
16648 sym
= e
->symtree
->n
.sym
;
16650 if (sym
->attr
.is_protected
)
16652 if (cnt_protected
> 0 && cnt_protected
!= object
)
16654 gfc_error ("Either all or none of the objects in the "
16655 "EQUIVALENCE set at %L shall have the "
16656 "PROTECTED attribute",
16661 /* Shall not equivalence common block variables in a PURE procedure. */
16662 if (sym
->ns
->proc_name
16663 && sym
->ns
->proc_name
->attr
.pure
16664 && sym
->attr
.in_common
)
16666 /* Need to check for symbols that may have entered the pure
16667 procedure via a USE statement. */
16668 bool saw_sym
= false;
16669 if (sym
->ns
->use_stmts
)
16672 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16673 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16679 gfc_error ("COMMON block member %qs at %L cannot be an "
16680 "EQUIVALENCE object in the pure procedure %qs",
16681 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16685 /* Shall not be a named constant. */
16686 if (e
->expr_type
== EXPR_CONSTANT
)
16688 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16689 "object", sym
->name
, &e
->where
);
16693 if (e
->ts
.type
== BT_DERIVED
16694 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16697 /* Check that the types correspond correctly:
16699 A numeric sequence structure may be equivalenced to another sequence
16700 structure, an object of default integer type, default real type, double
16701 precision real type, default logical type such that components of the
16702 structure ultimately only become associated to objects of the same
16703 kind. A character sequence structure may be equivalenced to an object
16704 of default character kind or another character sequence structure.
16705 Other objects may be equivalenced only to objects of the same type and
16706 kind parameters. */
16708 /* Identical types are unconditionally OK. */
16709 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16710 goto identical_types
;
16712 last_eq_type
= sequence_type (*last_ts
);
16713 eq_type
= sequence_type (sym
->ts
);
16715 /* Since the pair of objects is not of the same type, mixed or
16716 non-default sequences can be rejected. */
16718 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16719 "statement at %L with different type objects";
16721 && last_eq_type
== SEQ_MIXED
16722 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16723 || (eq_type
== SEQ_MIXED
16724 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16727 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16728 "statement at %L with objects of different type";
16730 && last_eq_type
== SEQ_NONDEFAULT
16731 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16732 || (eq_type
== SEQ_NONDEFAULT
16733 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16736 msg
="Non-CHARACTER object %qs in default CHARACTER "
16737 "EQUIVALENCE statement at %L";
16738 if (last_eq_type
== SEQ_CHARACTER
16739 && eq_type
!= SEQ_CHARACTER
16740 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16743 msg
="Non-NUMERIC object %qs in default NUMERIC "
16744 "EQUIVALENCE statement at %L";
16745 if (last_eq_type
== SEQ_NUMERIC
16746 && eq_type
!= SEQ_NUMERIC
16747 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16752 last_where
= &e
->where
;
16757 /* Shall not be an automatic array. */
16758 if (e
->ref
->type
== REF_ARRAY
16759 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16761 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16762 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16769 /* Shall not be a structure component. */
16770 if (r
->type
== REF_COMPONENT
)
16772 gfc_error ("Structure component %qs at %L cannot be an "
16773 "EQUIVALENCE object",
16774 r
->u
.c
.component
->name
, &e
->where
);
16778 /* A substring shall not have length zero. */
16779 if (r
->type
== REF_SUBSTRING
)
16781 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16783 gfc_error ("Substring at %L has length zero",
16784 &r
->u
.ss
.start
->where
);
16794 /* Function called by resolve_fntype to flag other symbol used in the
16795 length type parameter specification of function resuls. */
16798 flag_fn_result_spec (gfc_expr
*expr
,
16800 int *f ATTRIBUTE_UNUSED
)
16805 if (expr
->expr_type
== EXPR_VARIABLE
)
16807 s
= expr
->symtree
->n
.sym
;
16808 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16814 gfc_error ("Self reference in character length expression "
16815 "for %qs at %L", sym
->name
, &expr
->where
);
16819 if (!s
->fn_result_spec
16820 && s
->attr
.flavor
== FL_PARAMETER
)
16822 /* Function contained in a module.... */
16823 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16826 s
->fn_result_spec
= 1;
16827 /* Make sure that this symbol is translated as a module
16829 st
= gfc_get_unique_symtree (ns
);
16833 /* ... which is use associated and called. */
16834 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16836 /* External function matched with an interface. */
16839 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16840 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16841 && s
->ns
->proc_name
->attr
.function
))
16842 s
->fn_result_spec
= 1;
16849 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16852 resolve_fntype (gfc_namespace
*ns
)
16854 gfc_entry_list
*el
;
16857 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16860 /* If there are any entries, ns->proc_name is the entry master
16861 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16863 sym
= ns
->entries
->sym
;
16865 sym
= ns
->proc_name
;
16866 if (sym
->result
== sym
16867 && sym
->ts
.type
== BT_UNKNOWN
16868 && !gfc_set_default_type (sym
, 0, NULL
)
16869 && !sym
->attr
.untyped
)
16871 gfc_error ("Function %qs at %L has no IMPLICIT type",
16872 sym
->name
, &sym
->declared_at
);
16873 sym
->attr
.untyped
= 1;
16876 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16877 && !sym
->attr
.contained
16878 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16879 && gfc_check_symbol_access (sym
))
16881 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16882 "%L of PRIVATE type %qs", sym
->name
,
16883 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16887 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16889 if (el
->sym
->result
== el
->sym
16890 && el
->sym
->ts
.type
== BT_UNKNOWN
16891 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16892 && !el
->sym
->attr
.untyped
)
16894 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16895 el
->sym
->name
, &el
->sym
->declared_at
);
16896 el
->sym
->attr
.untyped
= 1;
16900 if (sym
->ts
.type
== BT_CHARACTER
)
16901 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16905 /* 12.3.2.1.1 Defined operators. */
16908 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16910 gfc_formal_arglist
*formal
;
16912 if (!sym
->attr
.function
)
16914 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16915 sym
->name
, &where
);
16919 if (sym
->ts
.type
== BT_CHARACTER
16920 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16921 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16922 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16924 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16925 "character length", sym
->name
, &where
);
16929 formal
= gfc_sym_get_dummy_args (sym
);
16930 if (!formal
|| !formal
->sym
)
16932 gfc_error ("User operator procedure %qs at %L must have at least "
16933 "one argument", sym
->name
, &where
);
16937 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16939 gfc_error ("First argument of operator interface at %L must be "
16940 "INTENT(IN)", &where
);
16944 if (formal
->sym
->attr
.optional
)
16946 gfc_error ("First argument of operator interface at %L cannot be "
16947 "optional", &where
);
16951 formal
= formal
->next
;
16952 if (!formal
|| !formal
->sym
)
16955 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16957 gfc_error ("Second argument of operator interface at %L must be "
16958 "INTENT(IN)", &where
);
16962 if (formal
->sym
->attr
.optional
)
16964 gfc_error ("Second argument of operator interface at %L cannot be "
16965 "optional", &where
);
16971 gfc_error ("Operator interface at %L must have, at most, two "
16972 "arguments", &where
);
16980 gfc_resolve_uops (gfc_symtree
*symtree
)
16982 gfc_interface
*itr
;
16984 if (symtree
== NULL
)
16987 gfc_resolve_uops (symtree
->left
);
16988 gfc_resolve_uops (symtree
->right
);
16990 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16991 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16995 /* Examine all of the expressions associated with a program unit,
16996 assign types to all intermediate expressions, make sure that all
16997 assignments are to compatible types and figure out which names
16998 refer to which functions or subroutines. It doesn't check code
16999 block, which is handled by gfc_resolve_code. */
17002 resolve_types (gfc_namespace
*ns
)
17008 gfc_namespace
* old_ns
= gfc_current_ns
;
17010 if (ns
->types_resolved
)
17013 /* Check that all IMPLICIT types are ok. */
17014 if (!ns
->seen_implicit_none
)
17017 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
17018 if (ns
->set_flag
[letter
]
17019 && !resolve_typespec_used (&ns
->default_type
[letter
],
17020 &ns
->implicit_loc
[letter
], NULL
))
17024 gfc_current_ns
= ns
;
17026 resolve_entries (ns
);
17028 resolve_common_vars (&ns
->blank_common
, false);
17029 resolve_common_blocks (ns
->common_root
);
17031 resolve_contained_functions (ns
);
17033 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
17034 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
17035 resolve_formal_arglist (ns
->proc_name
);
17037 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
17039 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
17040 resolve_charlen (cl
);
17042 gfc_traverse_ns (ns
, resolve_symbol
);
17044 resolve_fntype (ns
);
17046 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17048 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
17049 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
17050 "also be PURE", n
->proc_name
->name
,
17051 &n
->proc_name
->declared_at
);
17057 gfc_do_concurrent_flag
= 0;
17058 gfc_check_interfaces (ns
);
17060 gfc_traverse_ns (ns
, resolve_values
);
17062 if (ns
->save_all
|| !flag_automatic
)
17066 for (d
= ns
->data
; d
; d
= d
->next
)
17070 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
17072 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
17074 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
17075 resolve_equivalence (eq
);
17077 /* Warn about unused labels. */
17078 if (warn_unused_label
)
17079 warn_unused_fortran_label (ns
->st_labels
);
17081 gfc_resolve_uops (ns
->uop_root
);
17083 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
17085 gfc_resolve_omp_declare_simd (ns
);
17087 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
17089 ns
->types_resolved
= 1;
17091 gfc_current_ns
= old_ns
;
17095 /* Call gfc_resolve_code recursively. */
17098 resolve_codes (gfc_namespace
*ns
)
17101 bitmap_obstack old_obstack
;
17103 if (ns
->resolved
== 1)
17106 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17109 gfc_current_ns
= ns
;
17111 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
17112 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
17115 /* Set to an out of range value. */
17116 current_entry_id
= -1;
17118 old_obstack
= labels_obstack
;
17119 bitmap_obstack_initialize (&labels_obstack
);
17121 gfc_resolve_oacc_declare (ns
);
17122 gfc_resolve_oacc_routines (ns
);
17123 gfc_resolve_omp_local_vars (ns
);
17124 gfc_resolve_code (ns
->code
, ns
);
17126 bitmap_obstack_release (&labels_obstack
);
17127 labels_obstack
= old_obstack
;
17131 /* This function is called after a complete program unit has been compiled.
17132 Its purpose is to examine all of the expressions associated with a program
17133 unit, assign types to all intermediate expressions, make sure that all
17134 assignments are to compatible types and figure out which names refer to
17135 which functions or subroutines. */
17138 gfc_resolve (gfc_namespace
*ns
)
17140 gfc_namespace
*old_ns
;
17141 code_stack
*old_cs_base
;
17142 struct gfc_omp_saved_state old_omp_state
;
17148 old_ns
= gfc_current_ns
;
17149 old_cs_base
= cs_base
;
17151 /* As gfc_resolve can be called during resolution of an OpenMP construct
17152 body, we should clear any state associated to it, so that say NS's
17153 DO loops are not interpreted as OpenMP loops. */
17154 if (!ns
->construct_entities
)
17155 gfc_omp_save_and_clear_state (&old_omp_state
);
17157 resolve_types (ns
);
17158 component_assignment_level
= 0;
17159 resolve_codes (ns
);
17161 gfc_current_ns
= old_ns
;
17162 cs_base
= old_cs_base
;
17165 gfc_run_passes (ns
);
17167 if (!ns
->construct_entities
)
17168 gfc_omp_restore_state (&old_omp_state
);