1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2019 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 #include "target-memory.h" /* for gfc_simplify_transfer */
31 #include "constructor.h"
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and gfc_resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code
*head
, *current
;
46 struct code_stack
*prev
;
48 /* This bitmap keeps track of the targets valid for a branch from
49 inside this block except for END {IF|SELECT}s of enclosing
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
60 static int forall_flag
;
61 int gfc_do_concurrent_flag
;
63 /* True when we are resolving an expression that is an actual argument to
65 static bool actual_arg
= false;
66 /* True when we are resolving an expression that is the first actual argument
68 static bool first_actual_arg
= false;
71 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
73 static int omp_workshare_flag
;
75 /* True if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static bool formal_arg_flag
= false;
79 /* True if we are resolving a specification expression. */
80 static bool specification_expr
= false;
82 /* The id of the last entry seen. */
83 static int current_entry_id
;
85 /* We use bitmaps to determine if a branch target is valid. */
86 static bitmap_obstack labels_obstack
;
88 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89 static bool inquiry_argument
= false;
93 gfc_is_formal_arg (void)
95 return formal_arg_flag
;
98 /* Is the symbol host associated? */
100 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
102 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
111 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
116 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
118 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name
, where
, ts
->u
.derived
->name
);
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts
->u
.derived
->name
, where
);
138 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
140 /* Several checks for F08:C1216. */
141 if (ifc
->attr
.procedure
)
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc
->name
, where
);
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface
*gen
= ifc
->generic
;
152 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
156 gfc_error ("Interface %qs at %L may not be generic",
161 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
163 gfc_error ("Interface %qs at %L may not be a statement function",
167 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
168 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
169 ifc
->attr
.intrinsic
= 1;
170 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc
->name
, where
);
176 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
178 gfc_error ("Interface %qs at %L must be explicit", ifc
->name
, where
);
185 static void resolve_symbol (gfc_symbol
*sym
);
188 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
191 resolve_procedure_interface (gfc_symbol
*sym
)
193 gfc_symbol
*ifc
= sym
->ts
.interface
;
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym
->name
, &sym
->declared_at
);
204 if (!check_proc_interface (ifc
, &sym
->declared_at
))
207 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc
);
211 if (ifc
->attr
.intrinsic
)
212 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
216 sym
->ts
= ifc
->result
->ts
;
217 sym
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
218 sym
->attr
.pointer
= ifc
->result
->attr
.pointer
;
219 sym
->attr
.dimension
= ifc
->result
->attr
.dimension
;
220 sym
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
221 sym
->as
= gfc_copy_array_spec (ifc
->result
->as
);
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.dimension
= ifc
->attr
.dimension
;
230 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
231 sym
->as
= gfc_copy_array_spec (ifc
->as
);
233 sym
->ts
.interface
= ifc
;
234 sym
->attr
.function
= ifc
->attr
.function
;
235 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
237 sym
->attr
.pure
= ifc
->attr
.pure
;
238 sym
->attr
.elemental
= ifc
->attr
.elemental
;
239 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
240 sym
->attr
.recursive
= ifc
->attr
.recursive
;
241 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
242 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
243 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
244 /* Copy char length. */
245 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
247 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
248 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
249 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
258 /* Resolve types of formal argument lists. These have to be done early so that
259 the formal argument lists of module procedures can be copied to the
260 containing module before the individual procedures are resolved
261 individually. We also resolve argument lists of procedures in interface
262 blocks because they are self-contained scoping units.
264 Since a dummy argument cannot be a non-dummy procedure, the only
265 resort left for untyped names are the IMPLICIT types. */
268 resolve_formal_arglist (gfc_symbol
*proc
)
270 gfc_formal_arglist
*f
;
272 bool saved_specification_expr
;
275 if (proc
->result
!= NULL
)
280 if (gfc_elemental (proc
)
281 || sym
->attr
.pointer
|| sym
->attr
.allocatable
282 || (sym
->as
&& sym
->as
->rank
!= 0))
284 proc
->attr
.always_explicit
= 1;
285 sym
->attr
.always_explicit
= 1;
288 formal_arg_flag
= true;
290 for (f
= proc
->formal
; f
; f
= f
->next
)
298 /* Alternate return placeholder. */
299 if (gfc_elemental (proc
))
300 gfc_error ("Alternate return specifier in elemental subroutine "
301 "%qs at %L is not allowed", proc
->name
,
303 if (proc
->attr
.function
)
304 gfc_error ("Alternate return specifier in function "
305 "%qs at %L is not allowed", proc
->name
,
309 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
310 && !resolve_procedure_interface (sym
))
313 if (strcmp (proc
->name
, sym
->name
) == 0)
315 gfc_error ("Self-referential argument "
316 "%qs at %L is not allowed", sym
->name
,
321 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
322 resolve_formal_arglist (sym
);
324 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
326 if (sym
->attr
.flavor
== FL_UNKNOWN
)
327 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
331 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
332 && (!sym
->attr
.function
|| sym
->result
== sym
))
333 gfc_set_default_type (sym
, 1, sym
->ns
);
336 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
337 ? CLASS_DATA (sym
)->as
: sym
->as
;
339 saved_specification_expr
= specification_expr
;
340 specification_expr
= true;
341 gfc_resolve_array_spec (as
, 0);
342 specification_expr
= saved_specification_expr
;
344 /* We can't tell if an array with dimension (:) is assumed or deferred
345 shape until we know if it has the pointer or allocatable attributes.
347 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
348 && ((sym
->ts
.type
!= BT_CLASS
349 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
350 || (sym
->ts
.type
== BT_CLASS
351 && !(CLASS_DATA (sym
)->attr
.class_pointer
352 || CLASS_DATA (sym
)->attr
.allocatable
)))
353 && sym
->attr
.flavor
!= FL_PROCEDURE
)
355 as
->type
= AS_ASSUMED_SHAPE
;
356 for (i
= 0; i
< as
->rank
; i
++)
357 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
360 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
361 || (as
&& as
->type
== AS_ASSUMED_RANK
)
362 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
363 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
364 && (CLASS_DATA (sym
)->attr
.class_pointer
365 || CLASS_DATA (sym
)->attr
.allocatable
366 || CLASS_DATA (sym
)->attr
.target
))
367 || sym
->attr
.optional
)
369 proc
->attr
.always_explicit
= 1;
371 proc
->result
->attr
.always_explicit
= 1;
374 /* If the flavor is unknown at this point, it has to be a variable.
375 A procedure specification would have already set the type. */
377 if (sym
->attr
.flavor
== FL_UNKNOWN
)
378 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
382 if (sym
->attr
.flavor
== FL_PROCEDURE
)
387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 "also be PURE", sym
->name
, &sym
->declared_at
);
392 else if (!sym
->attr
.pointer
)
394 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
397 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
398 " of pure function %qs at %L with VALUE "
399 "attribute but without INTENT(IN)",
400 sym
->name
, proc
->name
, &sym
->declared_at
);
402 gfc_error ("Argument %qs of pure function %qs at %L must "
403 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
407 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
410 gfc_notify_std (GFC_STD_F2008
, "Argument %qs"
411 " of pure subroutine %qs at %L with VALUE "
412 "attribute but without INTENT", sym
->name
,
413 proc
->name
, &sym
->declared_at
);
415 gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 "must have its INTENT specified or have the "
417 "VALUE attribute", sym
->name
, proc
->name
,
423 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 " may not be polymorphic", sym
->name
, proc
->name
,
432 if (proc
->attr
.implicit_pure
)
434 if (sym
->attr
.flavor
== FL_PROCEDURE
)
437 proc
->attr
.implicit_pure
= 0;
439 else if (!sym
->attr
.pointer
)
441 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
443 proc
->attr
.implicit_pure
= 0;
445 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
447 proc
->attr
.implicit_pure
= 0;
451 if (gfc_elemental (proc
))
454 if (sym
->attr
.codimension
455 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
456 && CLASS_DATA (sym
)->attr
.codimension
))
458 gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 "procedure", sym
->name
, &sym
->declared_at
);
463 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
464 && CLASS_DATA (sym
)->as
))
466 gfc_error ("Argument %qs of elemental procedure at %L must "
467 "be scalar", sym
->name
, &sym
->declared_at
);
471 if (sym
->attr
.allocatable
472 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
473 && CLASS_DATA (sym
)->attr
.allocatable
))
475 gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 "have the ALLOCATABLE attribute", sym
->name
,
481 if (sym
->attr
.pointer
482 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
483 && CLASS_DATA (sym
)->attr
.class_pointer
))
485 gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 "have the POINTER attribute", sym
->name
,
491 if (sym
->attr
.flavor
== FL_PROCEDURE
)
493 gfc_error ("Dummy procedure %qs not allowed in elemental "
494 "procedure %qs at %L", sym
->name
, proc
->name
,
499 /* Fortran 2008 Corrigendum 1, C1290a. */
500 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
502 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 "have its INTENT specified or have the VALUE "
504 "attribute", sym
->name
, proc
->name
,
510 /* Each dummy shall be specified to be scalar. */
511 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
515 /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 shall be specified, explicitly or implicitly, to be scalar. */
517 gfc_error ("Argument '%s' of statement function '%s' at %L "
518 "must be scalar", sym
->name
, proc
->name
,
523 if (sym
->ts
.type
== BT_CHARACTER
)
525 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
526 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
528 gfc_error ("Character-valued argument %qs of statement "
529 "function at %L must have constant length",
530 sym
->name
, &sym
->declared_at
);
536 formal_arg_flag
= false;
540 /* Work function called when searching for symbols that have argument lists
541 associated with them. */
544 find_arglists (gfc_symbol
*sym
)
546 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
547 || gfc_fl_struct (sym
->attr
.flavor
) || sym
->attr
.intrinsic
)
550 resolve_formal_arglist (sym
);
554 /* Given a namespace, resolve all formal argument lists within the namespace.
558 resolve_formal_arglists (gfc_namespace
*ns
)
563 gfc_traverse_ns (ns
, find_arglists
);
568 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
572 if (sym
&& sym
->attr
.flavor
== FL_PROCEDURE
574 && sym
->ns
->parent
->proc_name
575 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_PROCEDURE
576 && !strcmp (sym
->name
, sym
->ns
->parent
->proc_name
->name
))
577 gfc_error ("Contained procedure %qs at %L has the same name as its "
578 "encompassing procedure", sym
->name
, &sym
->declared_at
);
580 /* If this namespace is not a function or an entry master function,
582 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
583 || sym
->attr
.entry_master
)
589 /* Try to find out of what the return type is. */
590 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
592 t
= gfc_set_default_type (sym
->result
, 0, ns
);
594 if (!t
&& !sym
->result
->attr
.untyped
)
596 if (sym
->result
== sym
)
597 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
598 sym
->name
, &sym
->declared_at
);
599 else if (!sym
->result
->attr
.proc_pointer
)
600 gfc_error ("Result %qs of contained function %qs at %L has "
601 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
602 &sym
->result
->declared_at
);
603 sym
->result
->attr
.untyped
= 1;
607 /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
608 type, lists the only ways a character length value of * can be used:
609 dummy arguments of procedures, named constants, function results and
610 in allocate statements if the allocate_object is an assumed length dummy
611 in external functions. Internal function results and results of module
612 procedures are not on this list, ergo, not permitted. */
614 if (sym
->result
->ts
.type
== BT_CHARACTER
)
616 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
617 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
619 /* See if this is a module-procedure and adapt error message
622 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
623 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
625 gfc_error (module_proc
626 ? G_("Character-valued module procedure %qs at %L"
627 " must not be assumed length")
628 : G_("Character-valued internal function %qs at %L"
629 " must not be assumed length"),
630 sym
->name
, &sym
->declared_at
);
636 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
637 introduce duplicates. */
640 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
642 gfc_formal_arglist
*f
, *new_arglist
;
645 for (; new_args
!= NULL
; new_args
= new_args
->next
)
647 new_sym
= new_args
->sym
;
648 /* See if this arg is already in the formal argument list. */
649 for (f
= proc
->formal
; f
; f
= f
->next
)
651 if (new_sym
== f
->sym
)
658 /* Add a new argument. Argument order is not important. */
659 new_arglist
= gfc_get_formal_arglist ();
660 new_arglist
->sym
= new_sym
;
661 new_arglist
->next
= proc
->formal
;
662 proc
->formal
= new_arglist
;
667 /* Flag the arguments that are not present in all entries. */
670 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
672 gfc_formal_arglist
*f
, *head
;
675 for (f
= proc
->formal
; f
; f
= f
->next
)
680 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
682 if (new_args
->sym
== f
->sym
)
689 f
->sym
->attr
.not_always_present
= 1;
694 /* Resolve alternate entry points. If a symbol has multiple entry points we
695 create a new master symbol for the main routine, and turn the existing
696 symbol into an entry point. */
699 resolve_entries (gfc_namespace
*ns
)
701 gfc_namespace
*old_ns
;
705 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
706 static int master_count
= 0;
708 if (ns
->proc_name
== NULL
)
711 /* No need to do anything if this procedure doesn't have alternate entry
716 /* We may already have resolved alternate entry points. */
717 if (ns
->proc_name
->attr
.entry_master
)
720 /* If this isn't a procedure something has gone horribly wrong. */
721 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
723 /* Remember the current namespace. */
724 old_ns
= gfc_current_ns
;
728 /* Add the main entry point to the list of entry points. */
729 el
= gfc_get_entry_list ();
730 el
->sym
= ns
->proc_name
;
732 el
->next
= ns
->entries
;
734 ns
->proc_name
->attr
.entry
= 1;
736 /* If it is a module function, it needs to be in the right namespace
737 so that gfc_get_fake_result_decl can gather up the results. The
738 need for this arose in get_proc_name, where these beasts were
739 left in their own namespace, to keep prior references linked to
740 the entry declaration.*/
741 if (ns
->proc_name
->attr
.function
742 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
745 /* Do the same for entries where the master is not a module
746 procedure. These are retained in the module namespace because
747 of the module procedure declaration. */
748 for (el
= el
->next
; el
; el
= el
->next
)
749 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
750 && el
->sym
->attr
.mod_proc
)
754 /* Add an entry statement for it. */
755 c
= gfc_get_code (EXEC_ENTRY
);
760 /* Create a new symbol for the master function. */
761 /* Give the internal function a unique name (within this file).
762 Also include the function name so the user has some hope of figuring
763 out what is going on. */
764 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
765 master_count
++, ns
->proc_name
->name
);
766 gfc_get_ha_symbol (name
, &proc
);
767 gcc_assert (proc
!= NULL
);
769 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
770 if (ns
->proc_name
->attr
.subroutine
)
771 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
775 gfc_typespec
*ts
, *fts
;
776 gfc_array_spec
*as
, *fas
;
777 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
779 fas
= ns
->entries
->sym
->as
;
780 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
781 fts
= &ns
->entries
->sym
->result
->ts
;
782 if (fts
->type
== BT_UNKNOWN
)
783 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
784 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
786 ts
= &el
->sym
->result
->ts
;
788 as
= as
? as
: el
->sym
->result
->as
;
789 if (ts
->type
== BT_UNKNOWN
)
790 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
792 if (! gfc_compare_types (ts
, fts
)
793 || (el
->sym
->result
->attr
.dimension
794 != ns
->entries
->sym
->result
->attr
.dimension
)
795 || (el
->sym
->result
->attr
.pointer
796 != ns
->entries
->sym
->result
->attr
.pointer
))
798 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
799 && gfc_compare_array_spec (as
, fas
) == 0)
800 gfc_error ("Function %s at %L has entries with mismatched "
801 "array specifications", ns
->entries
->sym
->name
,
802 &ns
->entries
->sym
->declared_at
);
803 /* The characteristics need to match and thus both need to have
804 the same string length, i.e. both len=*, or both len=4.
805 Having both len=<variable> is also possible, but difficult to
806 check at compile time. */
807 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
808 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
809 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
811 && ts
->u
.cl
->length
->expr_type
812 != fts
->u
.cl
->length
->expr_type
)
814 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
815 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
816 fts
->u
.cl
->length
->value
.integer
) != 0)))
817 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
818 "entries returning variables of different "
819 "string lengths", ns
->entries
->sym
->name
,
820 &ns
->entries
->sym
->declared_at
);
825 sym
= ns
->entries
->sym
->result
;
826 /* All result types the same. */
828 if (sym
->attr
.dimension
)
829 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
830 if (sym
->attr
.pointer
)
831 gfc_add_pointer (&proc
->attr
, NULL
);
835 /* Otherwise the result will be passed through a union by
837 proc
->attr
.mixed_entry_master
= 1;
838 for (el
= ns
->entries
; el
; el
= el
->next
)
840 sym
= el
->sym
->result
;
841 if (sym
->attr
.dimension
)
843 if (el
== ns
->entries
)
844 gfc_error ("FUNCTION result %s cannot be an array in "
845 "FUNCTION %s at %L", sym
->name
,
846 ns
->entries
->sym
->name
, &sym
->declared_at
);
848 gfc_error ("ENTRY result %s cannot be an array in "
849 "FUNCTION %s at %L", sym
->name
,
850 ns
->entries
->sym
->name
, &sym
->declared_at
);
852 else if (sym
->attr
.pointer
)
854 if (el
== ns
->entries
)
855 gfc_error ("FUNCTION result %s cannot be a POINTER in "
856 "FUNCTION %s at %L", sym
->name
,
857 ns
->entries
->sym
->name
, &sym
->declared_at
);
859 gfc_error ("ENTRY result %s cannot be a POINTER in "
860 "FUNCTION %s at %L", sym
->name
,
861 ns
->entries
->sym
->name
, &sym
->declared_at
);
866 if (ts
->type
== BT_UNKNOWN
)
867 ts
= gfc_get_default_type (sym
->name
, NULL
);
871 if (ts
->kind
== gfc_default_integer_kind
)
875 if (ts
->kind
== gfc_default_real_kind
876 || ts
->kind
== gfc_default_double_kind
)
880 if (ts
->kind
== gfc_default_complex_kind
)
884 if (ts
->kind
== gfc_default_logical_kind
)
888 /* We will issue error elsewhere. */
896 if (el
== ns
->entries
)
897 gfc_error ("FUNCTION result %s cannot be of type %s "
898 "in FUNCTION %s at %L", sym
->name
,
899 gfc_typename (ts
), ns
->entries
->sym
->name
,
902 gfc_error ("ENTRY result %s cannot be of type %s "
903 "in FUNCTION %s at %L", sym
->name
,
904 gfc_typename (ts
), ns
->entries
->sym
->name
,
911 proc
->attr
.access
= ACCESS_PRIVATE
;
912 proc
->attr
.entry_master
= 1;
914 /* Merge all the entry point arguments. */
915 for (el
= ns
->entries
; el
; el
= el
->next
)
916 merge_argument_lists (proc
, el
->sym
->formal
);
918 /* Check the master formal arguments for any that are not
919 present in all entry points. */
920 for (el
= ns
->entries
; el
; el
= el
->next
)
921 check_argument_lists (proc
, el
->sym
->formal
);
923 /* Use the master function for the function body. */
924 ns
->proc_name
= proc
;
926 /* Finalize the new symbols. */
927 gfc_commit_symbols ();
929 /* Restore the original namespace. */
930 gfc_current_ns
= old_ns
;
934 /* Resolve common variables. */
936 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
938 gfc_symbol
*csym
= common_block
->head
;
940 for (; csym
; csym
= csym
->common_next
)
942 /* gfc_add_in_common may have been called before, but the reported errors
943 have been ignored to continue parsing.
944 We do the checks again here. */
945 if (!csym
->attr
.use_assoc
)
947 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
948 gfc_notify_std (GFC_STD_F2018_OBS
, "COMMON block at %L",
949 &common_block
->where
);
952 if (csym
->value
|| csym
->attr
.data
)
954 if (!csym
->ns
->is_block_data
)
955 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
956 "but only in BLOCK DATA initialization is "
957 "allowed", csym
->name
, &csym
->declared_at
);
958 else if (!named_common
)
959 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
960 "in a blank COMMON but initialization is only "
961 "allowed in named common blocks", csym
->name
,
965 if (UNLIMITED_POLY (csym
))
966 gfc_error_now ("%qs in cannot appear in COMMON at %L "
967 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
969 if (csym
->ts
.type
!= BT_DERIVED
)
972 if (!(csym
->ts
.u
.derived
->attr
.sequence
973 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
974 gfc_error_now ("Derived type variable %qs in COMMON at %L "
975 "has neither the SEQUENCE nor the BIND(C) "
976 "attribute", csym
->name
, &csym
->declared_at
);
977 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
978 gfc_error_now ("Derived type variable %qs in COMMON at %L "
979 "has an ultimate component that is "
980 "allocatable", csym
->name
, &csym
->declared_at
);
981 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
982 gfc_error_now ("Derived type variable %qs in COMMON at %L "
983 "may not have default initializer", csym
->name
,
986 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
987 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
991 /* Resolve common blocks. */
993 resolve_common_blocks (gfc_symtree
*common_root
)
998 if (common_root
== NULL
)
1001 if (common_root
->left
)
1002 resolve_common_blocks (common_root
->left
);
1003 if (common_root
->right
)
1004 resolve_common_blocks (common_root
->right
);
1006 resolve_common_vars (common_root
->n
.common
, true);
1008 /* The common name is a global name - in Fortran 2003 also if it has a
1009 C binding name, since Fortran 2008 only the C binding name is a global
1011 if (!common_root
->n
.common
->binding_label
1012 || gfc_notification_std (GFC_STD_F2008
))
1014 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1015 common_root
->n
.common
->name
);
1017 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1018 && gsym
->type
== GSYM_COMMON
1019 && ((common_root
->n
.common
->binding_label
1020 && (!gsym
->binding_label
1021 || strcmp (common_root
->n
.common
->binding_label
,
1022 gsym
->binding_label
) != 0))
1023 || (!common_root
->n
.common
->binding_label
1024 && gsym
->binding_label
)))
1026 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1027 "identifier and must thus have the same binding name "
1028 "as the same-named COMMON block at %L: %s vs %s",
1029 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1031 common_root
->n
.common
->binding_label
1032 ? common_root
->n
.common
->binding_label
: "(blank)",
1033 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1037 if (gsym
&& gsym
->type
!= GSYM_COMMON
1038 && !common_root
->n
.common
->binding_label
)
1040 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1042 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1046 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1048 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1049 "%L sharing the identifier with global non-COMMON-block "
1050 "entity at %L", common_root
->n
.common
->name
,
1051 &common_root
->n
.common
->where
, &gsym
->where
);
1056 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
, false);
1057 gsym
->type
= GSYM_COMMON
;
1058 gsym
->where
= common_root
->n
.common
->where
;
1064 if (common_root
->n
.common
->binding_label
)
1066 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1067 common_root
->n
.common
->binding_label
);
1068 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1070 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1071 "global identifier as entity at %L",
1072 &common_root
->n
.common
->where
,
1073 common_root
->n
.common
->binding_label
, &gsym
->where
);
1078 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
, true);
1079 gsym
->type
= GSYM_COMMON
;
1080 gsym
->where
= common_root
->n
.common
->where
;
1086 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1090 if (sym
->attr
.flavor
== FL_PARAMETER
)
1091 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1092 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1094 if (sym
->attr
.external
)
1095 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1096 sym
->name
, &common_root
->n
.common
->where
);
1098 if (sym
->attr
.intrinsic
)
1099 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1100 sym
->name
, &common_root
->n
.common
->where
);
1101 else if (sym
->attr
.result
1102 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1103 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1104 "that is also a function result", sym
->name
,
1105 &common_root
->n
.common
->where
);
1106 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1107 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1108 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1109 "that is also a global procedure", sym
->name
,
1110 &common_root
->n
.common
->where
);
1114 /* Resolve contained function types. Because contained functions can call one
1115 another, they have to be worked out before any of the contained procedures
1118 The good news is that if a function doesn't already have a type, the only
1119 way it can get one is through an IMPLICIT type or a RESULT variable, because
1120 by definition contained functions are contained namespace they're contained
1121 in, not in a sibling or parent namespace. */
1124 resolve_contained_functions (gfc_namespace
*ns
)
1126 gfc_namespace
*child
;
1129 resolve_formal_arglists (ns
);
1131 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1133 /* Resolve alternate entry points first. */
1134 resolve_entries (child
);
1136 /* Then check function return types. */
1137 resolve_contained_fntype (child
->proc_name
, child
);
1138 for (el
= child
->entries
; el
; el
= el
->next
)
1139 resolve_contained_fntype (el
->sym
, child
);
1145 /* A Parameterized Derived Type constructor must contain values for
1146 the PDT KIND parameters or they must have a default initializer.
1147 Go through the constructor picking out the KIND expressions,
1148 storing them in 'param_list' and then call gfc_get_pdt_instance
1149 to obtain the PDT instance. */
1151 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1154 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1156 param
= gfc_get_actual_arglist ();
1158 param_list
= param_tail
= param
;
1161 param_tail
->next
= param
;
1162 param_tail
= param_tail
->next
;
1165 param_tail
->name
= c
->name
;
1167 param_tail
->expr
= gfc_copy_expr (expr
);
1168 else if (c
->initializer
)
1169 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1172 param_tail
->spec_type
= SPEC_ASSUMED
;
1173 if (c
->attr
.pdt_kind
)
1175 gfc_error ("The KIND parameter %qs in the PDT constructor "
1176 "at %C has no value", param
->name
);
1185 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1186 gfc_symbol
*derived
)
1188 gfc_constructor
*cons
= NULL
;
1189 gfc_component
*comp
;
1192 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1193 cons
= gfc_constructor_first (expr
->value
.constructor
);
1198 comp
= derived
->components
;
1200 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1203 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1204 && comp
->ts
.type
== BT_DERIVED
)
1206 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1210 else if (comp
->ts
.type
== BT_DERIVED
)
1212 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1216 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1217 && derived
->attr
.pdt_template
)
1219 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1228 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1229 static bool resolve_fl_struct (gfc_symbol
*sym
);
1232 /* Resolve all of the elements of a structure constructor and make sure that
1233 the types are correct. The 'init' flag indicates that the given
1234 constructor is an initializer. */
1237 resolve_structure_cons (gfc_expr
*expr
, int init
)
1239 gfc_constructor
*cons
;
1240 gfc_component
*comp
;
1246 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1248 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1249 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1251 resolve_fl_struct (expr
->ts
.u
.derived
);
1253 /* If this is a Parameterized Derived Type template, find the
1254 instance corresponding to the PDT kind parameters. */
1255 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1258 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1261 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1263 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1266 gfc_free_actual_arglist (param_list
);
1268 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1273 cons
= gfc_constructor_first (expr
->value
.constructor
);
1275 /* A constructor may have references if it is the result of substituting a
1276 parameter variable. In this case we just pull out the component we
1279 comp
= expr
->ref
->u
.c
.sym
->components
;
1281 comp
= expr
->ts
.u
.derived
->components
;
1283 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1290 /* Unions use an EXPR_NULL contrived expression to tell the translation
1291 phase to generate an initializer of the appropriate length.
1293 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1296 if (!gfc_resolve_expr (cons
->expr
))
1302 rank
= comp
->as
? comp
->as
->rank
: 0;
1303 if (comp
->ts
.type
== BT_CLASS
1304 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1305 && CLASS_DATA (comp
)->as
)
1306 rank
= CLASS_DATA (comp
)->as
->rank
;
1308 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1309 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1311 gfc_error ("The rank of the element in the structure "
1312 "constructor at %L does not match that of the "
1313 "component (%d/%d)", &cons
->expr
->where
,
1314 cons
->expr
->rank
, rank
);
1318 /* If we don't have the right type, try to convert it. */
1320 if (!comp
->attr
.proc_pointer
&&
1321 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1323 if (strcmp (comp
->name
, "_extends") == 0)
1325 /* Can afford to be brutal with the _extends initializer.
1326 The derived type can get lost because it is PRIVATE
1327 but it is not usage constrained by the standard. */
1328 cons
->expr
->ts
= comp
->ts
;
1330 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1332 gfc_error ("The element in the structure constructor at %L, "
1333 "for pointer component %qs, is %s but should be %s",
1334 &cons
->expr
->where
, comp
->name
,
1335 gfc_basic_typename (cons
->expr
->ts
.type
),
1336 gfc_basic_typename (comp
->ts
.type
));
1341 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1347 /* For strings, the length of the constructor should be the same as
1348 the one of the structure, ensure this if the lengths are known at
1349 compile time and when we are dealing with PARAMETER or structure
1351 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1352 && comp
->ts
.u
.cl
->length
1353 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1354 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1355 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1356 && cons
->expr
->rank
!= 0
1357 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1358 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1360 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1361 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1363 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1364 to make use of the gfc_resolve_character_array_constructor
1365 machinery. The expression is later simplified away to
1366 an array of string literals. */
1367 gfc_expr
*para
= cons
->expr
;
1368 cons
->expr
= gfc_get_expr ();
1369 cons
->expr
->ts
= para
->ts
;
1370 cons
->expr
->where
= para
->where
;
1371 cons
->expr
->expr_type
= EXPR_ARRAY
;
1372 cons
->expr
->rank
= para
->rank
;
1373 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1374 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1375 para
, &cons
->expr
->where
);
1378 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1380 /* Rely on the cleanup of the namespace to deal correctly with
1381 the old charlen. (There was a block here that attempted to
1382 remove the charlen but broke the chain in so doing.) */
1383 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1384 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1385 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1386 gfc_resolve_character_array_constructor (cons
->expr
);
1390 if (cons
->expr
->expr_type
== EXPR_NULL
1391 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1392 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1393 || (comp
->ts
.type
== BT_CLASS
1394 && (CLASS_DATA (comp
)->attr
.class_pointer
1395 || CLASS_DATA (comp
)->attr
.allocatable
))))
1398 gfc_error ("The NULL in the structure constructor at %L is "
1399 "being applied to component %qs, which is neither "
1400 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1404 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1406 /* Check procedure pointer interface. */
1407 gfc_symbol
*s2
= NULL
;
1412 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1415 s2
= c2
->ts
.interface
;
1418 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1420 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1421 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1423 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1425 s2
= cons
->expr
->symtree
->n
.sym
;
1426 name
= cons
->expr
->symtree
->n
.sym
->name
;
1429 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1430 err
, sizeof (err
), NULL
, NULL
))
1432 gfc_error_opt (OPT_Wargument_mismatch
,
1433 "Interface mismatch for procedure-pointer "
1434 "component %qs in structure constructor at %L:"
1435 " %s", comp
->name
, &cons
->expr
->where
, err
);
1440 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1441 || cons
->expr
->expr_type
== EXPR_NULL
)
1444 a
= gfc_expr_attr (cons
->expr
);
1446 if (!a
.pointer
&& !a
.target
)
1449 gfc_error ("The element in the structure constructor at %L, "
1450 "for pointer component %qs should be a POINTER or "
1451 "a TARGET", &cons
->expr
->where
, comp
->name
);
1456 /* F08:C461. Additional checks for pointer initialization. */
1460 gfc_error ("Pointer initialization target at %L "
1461 "must not be ALLOCATABLE", &cons
->expr
->where
);
1466 gfc_error ("Pointer initialization target at %L "
1467 "must have the SAVE attribute", &cons
->expr
->where
);
1471 /* F2003, C1272 (3). */
1472 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1473 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1474 || gfc_is_coindexed (cons
->expr
));
1475 if (impure
&& gfc_pure (NULL
))
1478 gfc_error ("Invalid expression in the structure constructor for "
1479 "pointer component %qs at %L in PURE procedure",
1480 comp
->name
, &cons
->expr
->where
);
1484 gfc_unset_implicit_pure (NULL
);
1491 /****************** Expression name resolution ******************/
1493 /* Returns 0 if a symbol was not declared with a type or
1494 attribute declaration statement, nonzero otherwise. */
1497 was_declared (gfc_symbol
*sym
)
1503 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1506 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1507 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1508 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1509 || a
.asynchronous
|| a
.codimension
)
1516 /* Determine if a symbol is generic or not. */
1519 generic_sym (gfc_symbol
*sym
)
1523 if (sym
->attr
.generic
||
1524 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1527 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1530 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1537 return generic_sym (s
);
1544 /* Determine if a symbol is specific or not. */
1547 specific_sym (gfc_symbol
*sym
)
1551 if (sym
->attr
.if_source
== IFSRC_IFBODY
1552 || sym
->attr
.proc
== PROC_MODULE
1553 || sym
->attr
.proc
== PROC_INTERNAL
1554 || sym
->attr
.proc
== PROC_ST_FUNCTION
1555 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1556 || sym
->attr
.external
)
1559 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1562 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1564 return (s
== NULL
) ? 0 : specific_sym (s
);
1568 /* Figure out if the procedure is specific, generic or unknown. */
1571 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1574 procedure_kind (gfc_symbol
*sym
)
1576 if (generic_sym (sym
))
1577 return PTYPE_GENERIC
;
1579 if (specific_sym (sym
))
1580 return PTYPE_SPECIFIC
;
1582 return PTYPE_UNKNOWN
;
1585 /* Check references to assumed size arrays. The flag need_full_assumed_size
1586 is nonzero when matching actual arguments. */
1588 static int need_full_assumed_size
= 0;
1591 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1593 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1596 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1597 What should it be? */
1598 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1599 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1600 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1602 gfc_error ("The upper bound in the last dimension must "
1603 "appear in the reference to the assumed size "
1604 "array %qs at %L", sym
->name
, &e
->where
);
1611 /* Look for bad assumed size array references in argument expressions
1612 of elemental and array valued intrinsic procedures. Since this is
1613 called from procedure resolution functions, it only recurses at
1617 resolve_assumed_size_actual (gfc_expr
*e
)
1622 switch (e
->expr_type
)
1625 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1630 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1631 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1642 /* Check a generic procedure, passed as an actual argument, to see if
1643 there is a matching specific name. If none, it is an error, and if
1644 more than one, the reference is ambiguous. */
1646 count_specific_procs (gfc_expr
*e
)
1653 sym
= e
->symtree
->n
.sym
;
1655 for (p
= sym
->generic
; p
; p
= p
->next
)
1656 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1658 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1664 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1668 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1669 "argument at %L", sym
->name
, &e
->where
);
1675 /* See if a call to sym could possibly be a not allowed RECURSION because of
1676 a missing RECURSIVE declaration. This means that either sym is the current
1677 context itself, or sym is the parent of a contained procedure calling its
1678 non-RECURSIVE containing procedure.
1679 This also works if sym is an ENTRY. */
1682 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1684 gfc_symbol
* proc_sym
;
1685 gfc_symbol
* context_proc
;
1686 gfc_namespace
* real_context
;
1688 if (sym
->attr
.flavor
== FL_PROGRAM
1689 || gfc_fl_struct (sym
->attr
.flavor
))
1692 /* If we've got an ENTRY, find real procedure. */
1693 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1694 proc_sym
= sym
->ns
->entries
->sym
;
1698 /* If sym is RECURSIVE, all is well of course. */
1699 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1702 /* Find the context procedure's "real" symbol if it has entries.
1703 We look for a procedure symbol, so recurse on the parents if we don't
1704 find one (like in case of a BLOCK construct). */
1705 for (real_context
= context
; ; real_context
= real_context
->parent
)
1707 /* We should find something, eventually! */
1708 gcc_assert (real_context
);
1710 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1711 : real_context
->proc_name
);
1713 /* In some special cases, there may not be a proc_name, like for this
1715 real(bad_kind()) function foo () ...
1716 when checking the call to bad_kind ().
1717 In these cases, we simply return here and assume that the
1722 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1726 /* A call from sym's body to itself is recursion, of course. */
1727 if (context_proc
== proc_sym
)
1730 /* The same is true if context is a contained procedure and sym the
1732 if (context_proc
->attr
.contained
)
1734 gfc_symbol
* parent_proc
;
1736 gcc_assert (context
->parent
);
1737 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1738 : context
->parent
->proc_name
);
1740 if (parent_proc
== proc_sym
)
1748 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1749 its typespec and formal argument list. */
1752 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1754 gfc_intrinsic_sym
* isym
= NULL
;
1760 /* Already resolved. */
1761 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1764 /* We already know this one is an intrinsic, so we don't call
1765 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1766 gfc_find_subroutine directly to check whether it is a function or
1769 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1771 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1772 isym
= gfc_intrinsic_subroutine_by_id (id
);
1774 else if (sym
->intmod_sym_id
)
1776 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1777 isym
= gfc_intrinsic_function_by_id (id
);
1779 else if (!sym
->attr
.subroutine
)
1780 isym
= gfc_find_function (sym
->name
);
1782 if (isym
&& !sym
->attr
.subroutine
)
1784 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1785 && !sym
->attr
.implicit_type
)
1786 gfc_warning (OPT_Wsurprising
,
1787 "Type specified for intrinsic function %qs at %L is"
1788 " ignored", sym
->name
, &sym
->declared_at
);
1790 if (!sym
->attr
.function
&&
1791 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1796 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1798 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1800 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1801 " specifier", sym
->name
, &sym
->declared_at
);
1805 if (!sym
->attr
.subroutine
&&
1806 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1811 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1816 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1818 sym
->attr
.pure
= isym
->pure
;
1819 sym
->attr
.elemental
= isym
->elemental
;
1821 /* Check it is actually available in the standard settings. */
1822 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1824 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1825 "available in the current standard settings but %s. Use "
1826 "an appropriate %<-std=*%> option or enable "
1827 "%<-fall-intrinsics%> in order to use it.",
1828 sym
->name
, &sym
->declared_at
, symstd
);
1836 /* Resolve a procedure expression, like passing it to a called procedure or as
1837 RHS for a procedure pointer assignment. */
1840 resolve_procedure_expression (gfc_expr
* expr
)
1844 if (expr
->expr_type
!= EXPR_VARIABLE
)
1846 gcc_assert (expr
->symtree
);
1848 sym
= expr
->symtree
->n
.sym
;
1850 if (sym
->attr
.intrinsic
)
1851 gfc_resolve_intrinsic (sym
, &expr
->where
);
1853 if (sym
->attr
.flavor
!= FL_PROCEDURE
1854 || (sym
->attr
.function
&& sym
->result
== sym
))
1857 /* A non-RECURSIVE procedure that is used as procedure expression within its
1858 own body is in danger of being called recursively. */
1859 if (is_illegal_recursion (sym
, gfc_current_ns
))
1860 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1861 " itself recursively. Declare it RECURSIVE or use"
1862 " %<-frecursive%>", sym
->name
, &expr
->where
);
1868 /* Check that name is not a derived type. */
1871 is_dt_name (const char *name
)
1873 gfc_symbol
*dt_list
, *dt_first
;
1875 dt_list
= dt_first
= gfc_derived_types
;
1876 for (; dt_list
; dt_list
= dt_list
->dt_next
)
1878 if (strcmp(dt_list
->name
, name
) == 0)
1880 if (dt_first
== dt_list
->dt_next
)
1887 /* Resolve an actual argument list. Most of the time, this is just
1888 resolving the expressions in the list.
1889 The exception is that we sometimes have to decide whether arguments
1890 that look like procedure arguments are really simple variable
1894 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1895 bool no_formal_args
)
1898 gfc_symtree
*parent_st
;
1900 gfc_component
*comp
;
1901 int save_need_full_assumed_size
;
1902 bool return_value
= false;
1903 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1906 first_actual_arg
= true;
1908 for (; arg
; arg
= arg
->next
)
1913 /* Check the label is a valid branching target. */
1916 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1918 gfc_error ("Label %d referenced at %L is never defined",
1919 arg
->label
->value
, &arg
->label
->where
);
1923 first_actual_arg
= false;
1927 if (e
->expr_type
== EXPR_VARIABLE
1928 && e
->symtree
->n
.sym
->attr
.generic
1930 && count_specific_procs (e
) != 1)
1933 if (e
->ts
.type
!= BT_PROCEDURE
)
1935 save_need_full_assumed_size
= need_full_assumed_size
;
1936 if (e
->expr_type
!= EXPR_VARIABLE
)
1937 need_full_assumed_size
= 0;
1938 if (!gfc_resolve_expr (e
))
1940 need_full_assumed_size
= save_need_full_assumed_size
;
1944 /* See if the expression node should really be a variable reference. */
1946 sym
= e
->symtree
->n
.sym
;
1948 if (sym
->attr
.flavor
== FL_PROCEDURE
&& is_dt_name (sym
->name
))
1950 gfc_error ("Derived type %qs is used as an actual "
1951 "argument at %L", sym
->name
, &e
->where
);
1955 if (sym
->attr
.flavor
== FL_PROCEDURE
1956 || sym
->attr
.intrinsic
1957 || sym
->attr
.external
)
1961 /* If a procedure is not already determined to be something else
1962 check if it is intrinsic. */
1963 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1964 sym
->attr
.intrinsic
= 1;
1966 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1968 gfc_error ("Statement function %qs at %L is not allowed as an "
1969 "actual argument", sym
->name
, &e
->where
);
1972 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1973 sym
->attr
.subroutine
);
1974 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1976 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1977 "actual argument", sym
->name
, &e
->where
);
1980 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1981 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1983 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1984 " used as actual argument at %L",
1985 sym
->name
, &e
->where
))
1989 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1991 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1992 "allowed as an actual argument at %L", sym
->name
,
1996 /* Check if a generic interface has a specific procedure
1997 with the same name before emitting an error. */
1998 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
2001 /* Just in case a specific was found for the expression. */
2002 sym
= e
->symtree
->n
.sym
;
2004 /* If the symbol is the function that names the current (or
2005 parent) scope, then we really have a variable reference. */
2007 if (gfc_is_function_return_value (sym
, sym
->ns
))
2010 /* If all else fails, see if we have a specific intrinsic. */
2011 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
2013 gfc_intrinsic_sym
*isym
;
2015 isym
= gfc_find_function (sym
->name
);
2016 if (isym
== NULL
|| !isym
->specific
)
2018 gfc_error ("Unable to find a specific INTRINSIC procedure "
2019 "for the reference %qs at %L", sym
->name
,
2024 sym
->attr
.intrinsic
= 1;
2025 sym
->attr
.function
= 1;
2028 if (!gfc_resolve_expr (e
))
2033 /* See if the name is a module procedure in a parent unit. */
2035 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2038 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2040 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2044 if (parent_st
== NULL
)
2047 sym
= parent_st
->n
.sym
;
2048 e
->symtree
= parent_st
; /* Point to the right thing. */
2050 if (sym
->attr
.flavor
== FL_PROCEDURE
2051 || sym
->attr
.intrinsic
2052 || sym
->attr
.external
)
2054 if (!gfc_resolve_expr (e
))
2060 e
->expr_type
= EXPR_VARIABLE
;
2062 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2063 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2064 && CLASS_DATA (sym
)->as
))
2066 e
->rank
= sym
->ts
.type
== BT_CLASS
2067 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2068 e
->ref
= gfc_get_ref ();
2069 e
->ref
->type
= REF_ARRAY
;
2070 e
->ref
->u
.ar
.type
= AR_FULL
;
2071 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2072 ? CLASS_DATA (sym
)->as
: sym
->as
;
2075 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2076 primary.c (match_actual_arg). If above code determines that it
2077 is a variable instead, it needs to be resolved as it was not
2078 done at the beginning of this function. */
2079 save_need_full_assumed_size
= need_full_assumed_size
;
2080 if (e
->expr_type
!= EXPR_VARIABLE
)
2081 need_full_assumed_size
= 0;
2082 if (!gfc_resolve_expr (e
))
2084 need_full_assumed_size
= save_need_full_assumed_size
;
2087 /* Check argument list functions %VAL, %LOC and %REF. There is
2088 nothing to do for %REF. */
2089 if (arg
->name
&& arg
->name
[0] == '%')
2091 if (strcmp ("%VAL", arg
->name
) == 0)
2093 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2095 gfc_error ("By-value argument at %L is not of numeric "
2102 gfc_error ("By-value argument at %L cannot be an array or "
2103 "an array section", &e
->where
);
2107 /* Intrinsics are still PROC_UNKNOWN here. However,
2108 since same file external procedures are not resolvable
2109 in gfortran, it is a good deal easier to leave them to
2111 if (ptype
!= PROC_UNKNOWN
2112 && ptype
!= PROC_DUMMY
2113 && ptype
!= PROC_EXTERNAL
2114 && ptype
!= PROC_MODULE
)
2116 gfc_error ("By-value argument at %L is not allowed "
2117 "in this context", &e
->where
);
2122 /* Statement functions have already been excluded above. */
2123 else if (strcmp ("%LOC", arg
->name
) == 0
2124 && e
->ts
.type
== BT_PROCEDURE
)
2126 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2128 gfc_error ("Passing internal procedure at %L by location "
2129 "not allowed", &e
->where
);
2135 comp
= gfc_get_proc_ptr_comp(e
);
2136 if (e
->expr_type
== EXPR_VARIABLE
2137 && comp
&& comp
->attr
.elemental
)
2139 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2140 "allowed as an actual argument at %L", comp
->name
,
2144 /* Fortran 2008, C1237. */
2145 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2146 && gfc_has_ultimate_pointer (e
))
2148 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2149 "component", &e
->where
);
2153 first_actual_arg
= false;
2156 return_value
= true;
2159 actual_arg
= actual_arg_sav
;
2160 first_actual_arg
= first_actual_arg_sav
;
2162 return return_value
;
2166 /* Do the checks of the actual argument list that are specific to elemental
2167 procedures. If called with c == NULL, we have a function, otherwise if
2168 expr == NULL, we have a subroutine. */
2171 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2173 gfc_actual_arglist
*arg0
;
2174 gfc_actual_arglist
*arg
;
2175 gfc_symbol
*esym
= NULL
;
2176 gfc_intrinsic_sym
*isym
= NULL
;
2178 gfc_intrinsic_arg
*iformal
= NULL
;
2179 gfc_formal_arglist
*eformal
= NULL
;
2180 bool formal_optional
= false;
2181 bool set_by_optional
= false;
2185 /* Is this an elemental procedure? */
2186 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2188 if (expr
->value
.function
.esym
!= NULL
2189 && expr
->value
.function
.esym
->attr
.elemental
)
2191 arg0
= expr
->value
.function
.actual
;
2192 esym
= expr
->value
.function
.esym
;
2194 else if (expr
->value
.function
.isym
!= NULL
2195 && expr
->value
.function
.isym
->elemental
)
2197 arg0
= expr
->value
.function
.actual
;
2198 isym
= expr
->value
.function
.isym
;
2203 else if (c
&& c
->ext
.actual
!= NULL
)
2205 arg0
= c
->ext
.actual
;
2207 if (c
->resolved_sym
)
2208 esym
= c
->resolved_sym
;
2210 esym
= c
->symtree
->n
.sym
;
2213 if (!esym
->attr
.elemental
)
2219 /* The rank of an elemental is the rank of its array argument(s). */
2220 for (arg
= arg0
; arg
; arg
= arg
->next
)
2222 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2224 rank
= arg
->expr
->rank
;
2225 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2226 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2227 set_by_optional
= true;
2229 /* Function specific; set the result rank and shape. */
2233 if (!expr
->shape
&& arg
->expr
->shape
)
2235 expr
->shape
= gfc_get_shape (rank
);
2236 for (i
= 0; i
< rank
; i
++)
2237 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2244 /* If it is an array, it shall not be supplied as an actual argument
2245 to an elemental procedure unless an array of the same rank is supplied
2246 as an actual argument corresponding to a nonoptional dummy argument of
2247 that elemental procedure(12.4.1.5). */
2248 formal_optional
= false;
2250 iformal
= isym
->formal
;
2252 eformal
= esym
->formal
;
2254 for (arg
= arg0
; arg
; arg
= arg
->next
)
2258 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2259 formal_optional
= true;
2260 eformal
= eformal
->next
;
2262 else if (isym
&& iformal
)
2264 if (iformal
->optional
)
2265 formal_optional
= true;
2266 iformal
= iformal
->next
;
2269 formal_optional
= true;
2271 if (pedantic
&& arg
->expr
!= NULL
2272 && arg
->expr
->expr_type
== EXPR_VARIABLE
2273 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2276 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2277 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2279 gfc_warning (OPT_Wpedantic
,
2280 "%qs at %L is an array and OPTIONAL; IF IT IS "
2281 "MISSING, it cannot be the actual argument of an "
2282 "ELEMENTAL procedure unless there is a non-optional "
2283 "argument with the same rank (12.4.1.5)",
2284 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2288 for (arg
= arg0
; arg
; arg
= arg
->next
)
2290 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2293 /* Being elemental, the last upper bound of an assumed size array
2294 argument must be present. */
2295 if (resolve_assumed_size_actual (arg
->expr
))
2298 /* Elemental procedure's array actual arguments must conform. */
2301 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2308 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2309 is an array, the intent inout/out variable needs to be also an array. */
2310 if (rank
> 0 && esym
&& expr
== NULL
)
2311 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2312 arg
= arg
->next
, eformal
= eformal
->next
)
2313 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2314 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2315 && arg
->expr
&& arg
->expr
->rank
== 0)
2317 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2318 "ELEMENTAL subroutine %qs is a scalar, but another "
2319 "actual argument is an array", &arg
->expr
->where
,
2320 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2321 : "INOUT", eformal
->sym
->name
, esym
->name
);
2328 /* This function does the checking of references to global procedures
2329 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2330 77 and 95 standards. It checks for a gsymbol for the name, making
2331 one if it does not already exist. If it already exists, then the
2332 reference being resolved must correspond to the type of gsymbol.
2333 Otherwise, the new symbol is equipped with the attributes of the
2334 reference. The corresponding code that is called in creating
2335 global entities is parse.c.
2337 In addition, for all but -std=legacy, the gsymbols are used to
2338 check the interfaces of external procedures from the same file.
2339 The namespace of the gsymbol is resolved and then, once this is
2340 done the interface is checked. */
2344 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2346 if (!gsym_ns
->proc_name
->attr
.recursive
)
2349 if (sym
->ns
== gsym_ns
)
2352 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2359 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2361 if (gsym_ns
->entries
)
2363 gfc_entry_list
*entry
= gsym_ns
->entries
;
2365 for (; entry
; entry
= entry
->next
)
2367 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2369 if (strcmp (gsym_ns
->proc_name
->name
,
2370 sym
->ns
->proc_name
->name
) == 0)
2374 && strcmp (gsym_ns
->proc_name
->name
,
2375 sym
->ns
->parent
->proc_name
->name
) == 0)
2384 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2387 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2389 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2391 for ( ; arg
; arg
= arg
->next
)
2396 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2398 strncpy (errmsg
, _("allocatable argument"), err_len
);
2401 else if (arg
->sym
->attr
.asynchronous
)
2403 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2406 else if (arg
->sym
->attr
.optional
)
2408 strncpy (errmsg
, _("optional argument"), err_len
);
2411 else if (arg
->sym
->attr
.pointer
)
2413 strncpy (errmsg
, _("pointer argument"), err_len
);
2416 else if (arg
->sym
->attr
.target
)
2418 strncpy (errmsg
, _("target argument"), err_len
);
2421 else if (arg
->sym
->attr
.value
)
2423 strncpy (errmsg
, _("value argument"), err_len
);
2426 else if (arg
->sym
->attr
.volatile_
)
2428 strncpy (errmsg
, _("volatile argument"), err_len
);
2431 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2433 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2436 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2438 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2441 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2443 strncpy (errmsg
, _("coarray argument"), err_len
);
2446 else if (false) /* (2d) TODO: parametrized derived type */
2448 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2451 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2453 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2456 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2458 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2461 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2463 /* As assumed-type is unlimited polymorphic (cf. above).
2464 See also TS 29113, Note 6.1. */
2465 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2470 if (sym
->attr
.function
)
2472 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2474 if (res
->attr
.dimension
) /* (3a) */
2476 strncpy (errmsg
, _("array result"), err_len
);
2479 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2481 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2484 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2485 && res
->ts
.u
.cl
->length
2486 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2488 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2493 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2495 strncpy (errmsg
, _("elemental procedure"), err_len
);
2498 else if (sym
->attr
.is_bind_c
) /* (5) */
2500 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2509 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
2513 enum gfc_symbol_type type
;
2516 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2518 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2519 sym
->binding_label
!= NULL
);
2521 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2522 gfc_global_used (gsym
, where
);
2524 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2525 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2526 && gsym
->type
!= GSYM_UNKNOWN
2527 && !gsym
->binding_label
2529 && gsym
->ns
->proc_name
2530 && not_in_recursive (sym
, gsym
->ns
)
2531 && not_entry_self_reference (sym
, gsym
->ns
))
2533 gfc_symbol
*def_sym
;
2534 def_sym
= gsym
->ns
->proc_name
;
2536 if (gsym
->ns
->resolved
!= -1)
2539 /* Resolve the gsymbol namespace if needed. */
2540 if (!gsym
->ns
->resolved
)
2542 gfc_symbol
*old_dt_list
;
2544 /* Stash away derived types so that the backend_decls
2545 do not get mixed up. */
2546 old_dt_list
= gfc_derived_types
;
2547 gfc_derived_types
= NULL
;
2549 gfc_resolve (gsym
->ns
);
2551 /* Store the new derived types with the global namespace. */
2552 if (gfc_derived_types
)
2553 gsym
->ns
->derived_types
= gfc_derived_types
;
2555 /* Restore the derived types of this namespace. */
2556 gfc_derived_types
= old_dt_list
;
2559 /* Make sure that translation for the gsymbol occurs before
2560 the procedure currently being resolved. */
2561 ns
= gfc_global_ns_list
;
2562 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2564 if (ns
->sibling
== gsym
->ns
)
2566 ns
->sibling
= gsym
->ns
->sibling
;
2567 gsym
->ns
->sibling
= gfc_global_ns_list
;
2568 gfc_global_ns_list
= gsym
->ns
;
2573 /* This can happen if a binding name has been specified. */
2574 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2575 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2577 if (def_sym
->attr
.entry_master
|| def_sym
->attr
.entry
)
2579 gfc_entry_list
*entry
;
2580 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2581 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2583 def_sym
= entry
->sym
;
2589 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2591 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2592 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2593 gfc_typename (&def_sym
->ts
));
2597 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2598 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2600 gfc_error ("Explicit interface required for %qs at %L: %s",
2601 sym
->name
, &sym
->declared_at
, reason
);
2605 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2606 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2607 gfc_errors_to_warnings (true);
2609 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2610 reason
, sizeof(reason
), NULL
, NULL
))
2612 gfc_error_opt (OPT_Wargument_mismatch
,
2613 "Interface mismatch in global procedure %qs at %L:"
2614 " %s", sym
->name
, &sym
->declared_at
, reason
);
2620 gfc_errors_to_warnings (false);
2622 if (gsym
->type
== GSYM_UNKNOWN
)
2625 gsym
->where
= *where
;
2632 /************* Function resolution *************/
2634 /* Resolve a function call known to be generic.
2635 Section 14.1.2.4.1. */
2638 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2642 if (sym
->attr
.generic
)
2644 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2647 expr
->value
.function
.name
= s
->name
;
2648 expr
->value
.function
.esym
= s
;
2650 if (s
->ts
.type
!= BT_UNKNOWN
)
2652 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2653 expr
->ts
= s
->result
->ts
;
2656 expr
->rank
= s
->as
->rank
;
2657 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2658 expr
->rank
= s
->result
->as
->rank
;
2660 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2665 /* TODO: Need to search for elemental references in generic
2669 if (sym
->attr
.intrinsic
)
2670 return gfc_intrinsic_func_interface (expr
, 0);
2677 resolve_generic_f (gfc_expr
*expr
)
2681 gfc_interface
*intr
= NULL
;
2683 sym
= expr
->symtree
->n
.sym
;
2687 m
= resolve_generic_f0 (expr
, sym
);
2690 else if (m
== MATCH_ERROR
)
2695 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2696 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2699 if (sym
->ns
->parent
== NULL
)
2701 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2705 if (!generic_sym (sym
))
2709 /* Last ditch attempt. See if the reference is to an intrinsic
2710 that possesses a matching interface. 14.1.2.4 */
2711 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2713 if (gfc_init_expr_flag
)
2714 gfc_error ("Function %qs in initialization expression at %L "
2715 "must be an intrinsic function",
2716 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2718 gfc_error ("There is no specific function for the generic %qs "
2719 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2725 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2728 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2730 return resolve_structure_cons (expr
, 0);
2733 m
= gfc_intrinsic_func_interface (expr
, 0);
2738 gfc_error ("Generic function %qs at %L is not consistent with a "
2739 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2746 /* Resolve a function call known to be specific. */
2749 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2753 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2755 if (sym
->attr
.dummy
)
2757 sym
->attr
.proc
= PROC_DUMMY
;
2761 sym
->attr
.proc
= PROC_EXTERNAL
;
2765 if (sym
->attr
.proc
== PROC_MODULE
2766 || sym
->attr
.proc
== PROC_ST_FUNCTION
2767 || sym
->attr
.proc
== PROC_INTERNAL
)
2770 if (sym
->attr
.intrinsic
)
2772 m
= gfc_intrinsic_func_interface (expr
, 1);
2776 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2777 "with an intrinsic", sym
->name
, &expr
->where
);
2785 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2788 expr
->ts
= sym
->result
->ts
;
2791 expr
->value
.function
.name
= sym
->name
;
2792 expr
->value
.function
.esym
= sym
;
2793 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2795 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2797 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2798 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2799 else if (sym
->as
!= NULL
)
2800 expr
->rank
= sym
->as
->rank
;
2807 resolve_specific_f (gfc_expr
*expr
)
2812 sym
= expr
->symtree
->n
.sym
;
2816 m
= resolve_specific_f0 (sym
, expr
);
2819 if (m
== MATCH_ERROR
)
2822 if (sym
->ns
->parent
== NULL
)
2825 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2831 gfc_error ("Unable to resolve the specific function %qs at %L",
2832 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2837 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2838 candidates in CANDIDATES_LEN. */
2841 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2843 size_t &candidates_len
)
2849 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2850 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2851 vec_push (candidates
, candidates_len
, sym
->name
);
2855 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2859 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2863 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2866 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2868 char **candidates
= NULL
;
2869 size_t candidates_len
= 0;
2870 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2871 return gfc_closest_fuzzy_match (fn
, candidates
);
2875 /* Resolve a procedure call not known to be generic nor specific. */
2878 resolve_unknown_f (gfc_expr
*expr
)
2883 sym
= expr
->symtree
->n
.sym
;
2885 if (sym
->attr
.dummy
)
2887 sym
->attr
.proc
= PROC_DUMMY
;
2888 expr
->value
.function
.name
= sym
->name
;
2892 /* See if we have an intrinsic function reference. */
2894 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2896 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2901 /* The reference is to an external name. */
2903 sym
->attr
.proc
= PROC_EXTERNAL
;
2904 expr
->value
.function
.name
= sym
->name
;
2905 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2907 if (sym
->as
!= NULL
)
2908 expr
->rank
= sym
->as
->rank
;
2910 /* Type of the expression is either the type of the symbol or the
2911 default type of the symbol. */
2914 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2916 if (sym
->ts
.type
!= BT_UNKNOWN
)
2920 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2922 if (ts
->type
== BT_UNKNOWN
)
2925 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2927 gfc_error ("Function %qs at %L has no IMPLICIT type"
2928 "; did you mean %qs?",
2929 sym
->name
, &expr
->where
, guessed
);
2931 gfc_error ("Function %qs at %L has no IMPLICIT type",
2932 sym
->name
, &expr
->where
);
2943 /* Return true, if the symbol is an external procedure. */
2945 is_external_proc (gfc_symbol
*sym
)
2947 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2948 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2949 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2950 && !sym
->attr
.proc_pointer
2951 && !sym
->attr
.use_assoc
2959 /* Figure out if a function reference is pure or not. Also set the name
2960 of the function for a potential error message. Return nonzero if the
2961 function is PURE, zero if not. */
2963 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2966 gfc_pure_function (gfc_expr
*e
, const char **name
)
2969 gfc_component
*comp
;
2973 if (e
->symtree
!= NULL
2974 && e
->symtree
->n
.sym
!= NULL
2975 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2976 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2978 comp
= gfc_get_proc_ptr_comp (e
);
2981 pure
= gfc_pure (comp
->ts
.interface
);
2984 else if (e
->value
.function
.esym
)
2986 pure
= gfc_pure (e
->value
.function
.esym
);
2987 *name
= e
->value
.function
.esym
->name
;
2989 else if (e
->value
.function
.isym
)
2991 pure
= e
->value
.function
.isym
->pure
2992 || e
->value
.function
.isym
->elemental
;
2993 *name
= e
->value
.function
.isym
->name
;
2997 /* Implicit functions are not pure. */
2999 *name
= e
->value
.function
.name
;
3006 /* Check if the expression is a reference to an implicitly pure function. */
3009 gfc_implicit_pure_function (gfc_expr
*e
)
3011 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
3013 return gfc_implicit_pure (comp
->ts
.interface
);
3014 else if (e
->value
.function
.esym
)
3015 return gfc_implicit_pure (e
->value
.function
.esym
);
3022 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3023 int *f ATTRIBUTE_UNUSED
)
3027 /* Don't bother recursing into other statement functions
3028 since they will be checked individually for purity. */
3029 if (e
->expr_type
!= EXPR_FUNCTION
3031 || e
->symtree
->n
.sym
== sym
3032 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3035 return gfc_pure_function (e
, &name
) ? false : true;
3040 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3042 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3046 /* Check if an impure function is allowed in the current context. */
3048 static bool check_pure_function (gfc_expr
*e
)
3050 const char *name
= NULL
;
3051 if (!gfc_pure_function (e
, &name
) && name
)
3055 gfc_error ("Reference to impure function %qs at %L inside a "
3056 "FORALL %s", name
, &e
->where
,
3057 forall_flag
== 2 ? "mask" : "block");
3060 else if (gfc_do_concurrent_flag
)
3062 gfc_error ("Reference to impure function %qs at %L inside a "
3063 "DO CONCURRENT %s", name
, &e
->where
,
3064 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3067 else if (gfc_pure (NULL
))
3069 gfc_error ("Reference to impure function %qs at %L "
3070 "within a PURE procedure", name
, &e
->where
);
3073 if (!gfc_implicit_pure_function (e
))
3074 gfc_unset_implicit_pure (NULL
);
3080 /* Update current procedure's array_outer_dependency flag, considering
3081 a call to procedure SYM. */
3084 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3086 /* Check to see if this is a sibling function that has not yet
3088 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3089 for (; sibling
; sibling
= sibling
->sibling
)
3091 if (sibling
->proc_name
== sym
)
3093 gfc_resolve (sibling
);
3098 /* If SYM has references to outer arrays, so has the procedure calling
3099 SYM. If SYM is a procedure pointer, we can assume the worst. */
3100 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3101 && gfc_current_ns
->proc_name
)
3102 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3106 /* Resolve a function call, which means resolving the arguments, then figuring
3107 out which entity the name refers to. */
3110 resolve_function (gfc_expr
*expr
)
3112 gfc_actual_arglist
*arg
;
3116 procedure_type p
= PROC_INTRINSIC
;
3117 bool no_formal_args
;
3121 sym
= expr
->symtree
->n
.sym
;
3123 /* If this is a procedure pointer component, it has already been resolved. */
3124 if (gfc_is_proc_ptr_comp (expr
))
3127 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3129 if (sym
&& sym
->attr
.intrinsic
3130 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3131 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3134 if (sym
&& sym
->attr
.intrinsic
3135 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3138 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3140 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3144 /* If this is a deferred TBP with an abstract interface (which may
3145 of course be referenced), expr->value.function.esym will be set. */
3146 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3148 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3149 sym
->name
, &expr
->where
);
3153 /* If this is a deferred TBP with an abstract interface, its result
3154 cannot be an assumed length character (F2003: C418). */
3155 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3156 && sym
->result
->ts
.u
.cl
3157 && sym
->result
->ts
.u
.cl
->length
== NULL
3158 && !sym
->result
->ts
.deferred
)
3160 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3161 "character length result (F2008: C418)", sym
->name
,
3166 /* Switch off assumed size checking and do this again for certain kinds
3167 of procedure, once the procedure itself is resolved. */
3168 need_full_assumed_size
++;
3170 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3171 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3173 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3174 inquiry_argument
= true;
3175 no_formal_args
= sym
&& is_external_proc (sym
)
3176 && gfc_sym_get_dummy_args (sym
) == NULL
;
3178 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3181 inquiry_argument
= false;
3185 inquiry_argument
= false;
3187 /* Resume assumed_size checking. */
3188 need_full_assumed_size
--;
3190 /* If the procedure is external, check for usage. */
3191 if (sym
&& is_external_proc (sym
))
3192 resolve_global_procedure (sym
, &expr
->where
, 0);
3194 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3196 && sym
->ts
.u
.cl
->length
== NULL
3198 && !sym
->ts
.deferred
3199 && expr
->value
.function
.esym
== NULL
3200 && !sym
->attr
.contained
)
3202 /* Internal procedures are taken care of in resolve_contained_fntype. */
3203 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3204 "be used at %L since it is not a dummy argument",
3205 sym
->name
, &expr
->where
);
3209 /* See if function is already resolved. */
3211 if (expr
->value
.function
.name
!= NULL
3212 || expr
->value
.function
.isym
!= NULL
)
3214 if (expr
->ts
.type
== BT_UNKNOWN
)
3220 /* Apply the rules of section 14.1.2. */
3222 switch (procedure_kind (sym
))
3225 t
= resolve_generic_f (expr
);
3228 case PTYPE_SPECIFIC
:
3229 t
= resolve_specific_f (expr
);
3233 t
= resolve_unknown_f (expr
);
3237 gfc_internal_error ("resolve_function(): bad function type");
3241 /* If the expression is still a function (it might have simplified),
3242 then we check to see if we are calling an elemental function. */
3244 if (expr
->expr_type
!= EXPR_FUNCTION
)
3247 temp
= need_full_assumed_size
;
3248 need_full_assumed_size
= 0;
3250 if (!resolve_elemental_actual (expr
, NULL
))
3253 if (omp_workshare_flag
3254 && expr
->value
.function
.esym
3255 && ! gfc_elemental (expr
->value
.function
.esym
))
3257 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3258 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3263 #define GENERIC_ID expr->value.function.isym->id
3264 else if (expr
->value
.function
.actual
!= NULL
3265 && expr
->value
.function
.isym
!= NULL
3266 && GENERIC_ID
!= GFC_ISYM_LBOUND
3267 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3268 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3269 && GENERIC_ID
!= GFC_ISYM_LEN
3270 && GENERIC_ID
!= GFC_ISYM_LOC
3271 && GENERIC_ID
!= GFC_ISYM_C_LOC
3272 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3274 /* Array intrinsics must also have the last upper bound of an
3275 assumed size array argument. UBOUND and SIZE have to be
3276 excluded from the check if the second argument is anything
3279 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3281 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3282 && arg
== expr
->value
.function
.actual
3283 && arg
->next
!= NULL
&& arg
->next
->expr
)
3285 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3288 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3291 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3296 if (arg
->expr
!= NULL
3297 && arg
->expr
->rank
> 0
3298 && resolve_assumed_size_actual (arg
->expr
))
3304 need_full_assumed_size
= temp
;
3306 if (!check_pure_function(expr
))
3309 /* Functions without the RECURSIVE attribution are not allowed to
3310 * call themselves. */
3311 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3314 esym
= expr
->value
.function
.esym
;
3316 if (is_illegal_recursion (esym
, gfc_current_ns
))
3318 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3319 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3320 " function %qs is not RECURSIVE",
3321 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3323 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3324 " is not RECURSIVE", esym
->name
, &expr
->where
);
3330 /* Character lengths of use associated functions may contains references to
3331 symbols not referenced from the current program unit otherwise. Make sure
3332 those symbols are marked as referenced. */
3334 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3335 && expr
->value
.function
.esym
->attr
.use_assoc
)
3337 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3340 /* Make sure that the expression has a typespec that works. */
3341 if (expr
->ts
.type
== BT_UNKNOWN
)
3343 if (expr
->symtree
->n
.sym
->result
3344 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3345 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3346 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3349 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3351 if (expr
->value
.function
.esym
)
3352 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3354 update_current_proc_array_outer_dependency (sym
);
3357 /* typebound procedure: Assume the worst. */
3358 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3364 /************* Subroutine resolution *************/
3367 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3374 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3378 else if (gfc_do_concurrent_flag
)
3380 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3384 else if (gfc_pure (NULL
))
3386 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3390 gfc_unset_implicit_pure (NULL
);
3396 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3400 if (sym
->attr
.generic
)
3402 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3405 c
->resolved_sym
= s
;
3406 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3411 /* TODO: Need to search for elemental references in generic interface. */
3414 if (sym
->attr
.intrinsic
)
3415 return gfc_intrinsic_sub_interface (c
, 0);
3422 resolve_generic_s (gfc_code
*c
)
3427 sym
= c
->symtree
->n
.sym
;
3431 m
= resolve_generic_s0 (c
, sym
);
3434 else if (m
== MATCH_ERROR
)
3438 if (sym
->ns
->parent
== NULL
)
3440 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3444 if (!generic_sym (sym
))
3448 /* Last ditch attempt. See if the reference is to an intrinsic
3449 that possesses a matching interface. 14.1.2.4 */
3450 sym
= c
->symtree
->n
.sym
;
3452 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3454 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3455 sym
->name
, &c
->loc
);
3459 m
= gfc_intrinsic_sub_interface (c
, 0);
3463 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3464 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3470 /* Resolve a subroutine call known to be specific. */
3473 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3477 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3479 if (sym
->attr
.dummy
)
3481 sym
->attr
.proc
= PROC_DUMMY
;
3485 sym
->attr
.proc
= PROC_EXTERNAL
;
3489 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3492 if (sym
->attr
.intrinsic
)
3494 m
= gfc_intrinsic_sub_interface (c
, 1);
3498 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3499 "with an intrinsic", sym
->name
, &c
->loc
);
3507 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3509 c
->resolved_sym
= sym
;
3510 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3518 resolve_specific_s (gfc_code
*c
)
3523 sym
= c
->symtree
->n
.sym
;
3527 m
= resolve_specific_s0 (c
, sym
);
3530 if (m
== MATCH_ERROR
)
3533 if (sym
->ns
->parent
== NULL
)
3536 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3542 sym
= c
->symtree
->n
.sym
;
3543 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3544 sym
->name
, &c
->loc
);
3550 /* Resolve a subroutine call not known to be generic nor specific. */
3553 resolve_unknown_s (gfc_code
*c
)
3557 sym
= c
->symtree
->n
.sym
;
3559 if (sym
->attr
.dummy
)
3561 sym
->attr
.proc
= PROC_DUMMY
;
3565 /* See if we have an intrinsic function reference. */
3567 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3569 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3574 /* The reference is to an external name. */
3577 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3579 c
->resolved_sym
= sym
;
3581 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3585 /* Resolve a subroutine call. Although it was tempting to use the same code
3586 for functions, subroutines and functions are stored differently and this
3587 makes things awkward. */
3590 resolve_call (gfc_code
*c
)
3593 procedure_type ptype
= PROC_INTRINSIC
;
3594 gfc_symbol
*csym
, *sym
;
3595 bool no_formal_args
;
3597 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3599 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3601 gfc_error ("%qs at %L has a type, which is not consistent with "
3602 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3606 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3609 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3610 sym
= st
? st
->n
.sym
: NULL
;
3611 if (sym
&& csym
!= sym
3612 && sym
->ns
== gfc_current_ns
3613 && sym
->attr
.flavor
== FL_PROCEDURE
3614 && sym
->attr
.contained
)
3617 if (csym
->attr
.generic
)
3618 c
->symtree
->n
.sym
= sym
;
3621 csym
= c
->symtree
->n
.sym
;
3625 /* If this ia a deferred TBP, c->expr1 will be set. */
3626 if (!c
->expr1
&& csym
)
3628 if (csym
->attr
.abstract
)
3630 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3631 csym
->name
, &c
->loc
);
3635 /* Subroutines without the RECURSIVE attribution are not allowed to
3637 if (is_illegal_recursion (csym
, gfc_current_ns
))
3639 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3640 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3641 "as subroutine %qs is not RECURSIVE",
3642 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3644 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3645 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3651 /* Switch off assumed size checking and do this again for certain kinds
3652 of procedure, once the procedure itself is resolved. */
3653 need_full_assumed_size
++;
3656 ptype
= csym
->attr
.proc
;
3658 no_formal_args
= csym
&& is_external_proc (csym
)
3659 && gfc_sym_get_dummy_args (csym
) == NULL
;
3660 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3663 /* Resume assumed_size checking. */
3664 need_full_assumed_size
--;
3666 /* If external, check for usage. */
3667 if (csym
&& is_external_proc (csym
))
3668 resolve_global_procedure (csym
, &c
->loc
, 1);
3671 if (c
->resolved_sym
== NULL
)
3673 c
->resolved_isym
= NULL
;
3674 switch (procedure_kind (csym
))
3677 t
= resolve_generic_s (c
);
3680 case PTYPE_SPECIFIC
:
3681 t
= resolve_specific_s (c
);
3685 t
= resolve_unknown_s (c
);
3689 gfc_internal_error ("resolve_subroutine(): bad function type");
3693 /* Some checks of elemental subroutine actual arguments. */
3694 if (!resolve_elemental_actual (NULL
, c
))
3698 update_current_proc_array_outer_dependency (csym
);
3700 /* Typebound procedure: Assume the worst. */
3701 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3707 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3708 op1->shape and op2->shape are non-NULL return true if their shapes
3709 match. If both op1->shape and op2->shape are non-NULL return false
3710 if their shapes do not match. If either op1->shape or op2->shape is
3711 NULL, return true. */
3714 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3721 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3723 for (i
= 0; i
< op1
->rank
; i
++)
3725 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3727 gfc_error ("Shapes for operands at %L and %L are not conformable",
3728 &op1
->where
, &op2
->where
);
3738 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3739 For example A .AND. B becomes IAND(A, B). */
3741 logical_to_bitwise (gfc_expr
*e
)
3743 gfc_expr
*tmp
, *op1
, *op2
;
3745 gfc_actual_arglist
*args
= NULL
;
3747 gcc_assert (e
->expr_type
== EXPR_OP
);
3749 isym
= GFC_ISYM_NONE
;
3750 op1
= e
->value
.op
.op1
;
3751 op2
= e
->value
.op
.op2
;
3753 switch (e
->value
.op
.op
)
3756 isym
= GFC_ISYM_NOT
;
3759 isym
= GFC_ISYM_IAND
;
3762 isym
= GFC_ISYM_IOR
;
3764 case INTRINSIC_NEQV
:
3765 isym
= GFC_ISYM_IEOR
;
3768 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3769 Change the old expression to NEQV, which will get replaced by IEOR,
3770 and wrap it in NOT. */
3771 tmp
= gfc_copy_expr (e
);
3772 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3773 tmp
= logical_to_bitwise (tmp
);
3774 isym
= GFC_ISYM_NOT
;
3779 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3782 /* Inherit the original operation's operands as arguments. */
3783 args
= gfc_get_actual_arglist ();
3787 args
->next
= gfc_get_actual_arglist ();
3788 args
->next
->expr
= op2
;
3791 /* Convert the expression to a function call. */
3792 e
->expr_type
= EXPR_FUNCTION
;
3793 e
->value
.function
.actual
= args
;
3794 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3795 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3796 e
->value
.function
.esym
= NULL
;
3798 /* Make up a pre-resolved function call symtree if we need to. */
3799 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3802 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3803 sym
= e
->symtree
->n
.sym
;
3805 sym
->attr
.flavor
= FL_PROCEDURE
;
3806 sym
->attr
.function
= 1;
3807 sym
->attr
.elemental
= 1;
3809 sym
->attr
.referenced
= 1;
3810 gfc_intrinsic_symbol (sym
);
3811 gfc_commit_symbol (sym
);
3814 args
->name
= e
->value
.function
.isym
->formal
->name
;
3815 if (e
->value
.function
.isym
->formal
->next
)
3816 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3821 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3822 candidates in CANDIDATES_LEN. */
3824 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3826 size_t &candidates_len
)
3833 /* Not sure how to properly filter here. Use all for a start.
3834 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3835 these as i suppose they don't make terribly sense. */
3837 if (uop
->n
.uop
->op
!= NULL
)
3838 vec_push (candidates
, candidates_len
, uop
->name
);
3842 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3846 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3849 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3852 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3854 char **candidates
= NULL
;
3855 size_t candidates_len
= 0;
3856 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3857 return gfc_closest_fuzzy_match (op
, candidates
);
3861 /* Callback finding an impure function as an operand to an .and. or
3862 .or. expression. Remember the last function warned about to
3863 avoid double warnings when recursing. */
3866 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3871 static gfc_expr
*last
= NULL
;
3872 bool *found
= (bool *) data
;
3874 if (f
->expr_type
== EXPR_FUNCTION
)
3877 if (f
!= last
&& !gfc_pure_function (f
, &name
)
3878 && !gfc_implicit_pure_function (f
))
3881 gfc_warning (OPT_Wfunction_elimination
,
3882 "Impure function %qs at %L might not be evaluated",
3885 gfc_warning (OPT_Wfunction_elimination
,
3886 "Impure function at %L might not be evaluated",
3896 /* Resolve an operator expression node. This can involve replacing the
3897 operation with a user defined function call. */
3900 resolve_operator (gfc_expr
*e
)
3902 gfc_expr
*op1
, *op2
;
3904 bool dual_locus_error
;
3907 /* Resolve all subnodes-- give them types. */
3909 switch (e
->value
.op
.op
)
3912 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3918 case INTRINSIC_UPLUS
:
3919 case INTRINSIC_UMINUS
:
3920 case INTRINSIC_PARENTHESES
:
3921 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3924 && e
->value
.op
.op1
->ts
.type
== BT_BOZ
&& !e
->value
.op
.op2
)
3926 gfc_error ("BOZ literal constant at %L cannot be an operand of "
3927 "unary operator %qs", &e
->value
.op
.op1
->where
,
3928 gfc_op2string (e
->value
.op
.op
));
3934 /* Typecheck the new node. */
3936 op1
= e
->value
.op
.op1
;
3937 op2
= e
->value
.op
.op2
;
3938 dual_locus_error
= false;
3940 /* op1 and op2 cannot both be BOZ. */
3941 if (op1
&& op1
->ts
.type
== BT_BOZ
3942 && op2
&& op2
->ts
.type
== BT_BOZ
)
3944 gfc_error ("Operands at %L and %L cannot appear as operands of "
3945 "binary operator %qs", &op1
->where
, &op2
->where
,
3946 gfc_op2string (e
->value
.op
.op
));
3950 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3951 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3953 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3957 switch (e
->value
.op
.op
)
3959 case INTRINSIC_UPLUS
:
3960 case INTRINSIC_UMINUS
:
3961 if (op1
->ts
.type
== BT_INTEGER
3962 || op1
->ts
.type
== BT_REAL
3963 || op1
->ts
.type
== BT_COMPLEX
)
3969 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3970 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3973 case INTRINSIC_PLUS
:
3974 case INTRINSIC_MINUS
:
3975 case INTRINSIC_TIMES
:
3976 case INTRINSIC_DIVIDE
:
3977 case INTRINSIC_POWER
:
3978 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3980 gfc_type_convert_binary (e
, 1);
3984 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
3986 _("Unexpected derived-type entities in binary intrinsic "
3987 "numeric operator %%<%s%%> at %%L"),
3988 gfc_op2string (e
->value
.op
.op
));
3991 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3992 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3993 gfc_typename (&op2
->ts
));
3996 case INTRINSIC_CONCAT
:
3997 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3998 && op1
->ts
.kind
== op2
->ts
.kind
)
4000 e
->ts
.type
= BT_CHARACTER
;
4001 e
->ts
.kind
= op1
->ts
.kind
;
4006 _("Operands of string concatenation operator at %%L are %s/%s"),
4007 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
4013 case INTRINSIC_NEQV
:
4014 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4016 e
->ts
.type
= BT_LOGICAL
;
4017 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4018 if (op1
->ts
.kind
< e
->ts
.kind
)
4019 gfc_convert_type (op1
, &e
->ts
, 2);
4020 else if (op2
->ts
.kind
< e
->ts
.kind
)
4021 gfc_convert_type (op2
, &e
->ts
, 2);
4023 if (flag_frontend_optimize
&&
4024 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
4026 /* Warn about short-circuiting
4027 with impure function as second operand. */
4029 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
4034 /* Logical ops on integers become bitwise ops with -fdec. */
4036 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
4038 e
->ts
.type
= BT_INTEGER
;
4039 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4040 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4041 gfc_convert_type (op1
, &e
->ts
, 1);
4042 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4043 gfc_convert_type (op2
, &e
->ts
, 1);
4044 e
= logical_to_bitwise (e
);
4048 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4049 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4050 gfc_typename (&op2
->ts
));
4055 /* Logical ops on integers become bitwise ops with -fdec. */
4056 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4058 e
->ts
.type
= BT_INTEGER
;
4059 e
->ts
.kind
= op1
->ts
.kind
;
4060 e
= logical_to_bitwise (e
);
4064 if (op1
->ts
.type
== BT_LOGICAL
)
4066 e
->ts
.type
= BT_LOGICAL
;
4067 e
->ts
.kind
= op1
->ts
.kind
;
4071 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4072 gfc_typename (&op1
->ts
));
4076 case INTRINSIC_GT_OS
:
4078 case INTRINSIC_GE_OS
:
4080 case INTRINSIC_LT_OS
:
4082 case INTRINSIC_LE_OS
:
4083 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4085 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4092 case INTRINSIC_EQ_OS
:
4094 case INTRINSIC_NE_OS
:
4095 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4096 && op1
->ts
.kind
== op2
->ts
.kind
)
4098 e
->ts
.type
= BT_LOGICAL
;
4099 e
->ts
.kind
= gfc_default_logical_kind
;
4103 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4104 if (op1
->ts
.type
== BT_BOZ
)
4106 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4107 "an operand of a relational operator",
4111 if (op2
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op1
, op2
->ts
.kind
))
4114 if (op2
->ts
.type
== BT_REAL
&& !gfc_boz2real (op1
, op2
->ts
.kind
))
4118 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4119 if (op2
->ts
.type
== BT_BOZ
)
4121 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
4122 "an operand of a relational operator",
4126 if (op1
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (op2
, op1
->ts
.kind
))
4129 if (op1
->ts
.type
== BT_REAL
&& !gfc_boz2real (op2
, op1
->ts
.kind
))
4133 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4135 gfc_type_convert_binary (e
, 1);
4137 e
->ts
.type
= BT_LOGICAL
;
4138 e
->ts
.kind
= gfc_default_logical_kind
;
4140 if (warn_compare_reals
)
4142 gfc_intrinsic_op op
= e
->value
.op
.op
;
4144 /* Type conversion has made sure that the types of op1 and op2
4145 agree, so it is only necessary to check the first one. */
4146 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4147 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4148 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4152 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4153 msg
= "Equality comparison for %s at %L";
4155 msg
= "Inequality comparison for %s at %L";
4157 gfc_warning (OPT_Wcompare_reals
, msg
,
4158 gfc_typename (&op1
->ts
), &op1
->where
);
4165 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4167 _("Logicals at %%L must be compared with %s instead of %s"),
4168 (e
->value
.op
.op
== INTRINSIC_EQ
4169 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4170 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4173 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4174 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4175 gfc_typename (&op2
->ts
));
4179 case INTRINSIC_USER
:
4180 if (e
->value
.op
.uop
->op
== NULL
)
4182 const char *name
= e
->value
.op
.uop
->name
;
4183 const char *guessed
;
4184 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4186 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4189 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4191 else if (op2
== NULL
)
4192 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4193 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4196 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4197 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4198 gfc_typename (&op2
->ts
));
4199 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4204 case INTRINSIC_PARENTHESES
:
4206 if (e
->ts
.type
== BT_CHARACTER
)
4207 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4211 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4214 /* Deal with arrayness of an operand through an operator. */
4216 switch (e
->value
.op
.op
)
4218 case INTRINSIC_PLUS
:
4219 case INTRINSIC_MINUS
:
4220 case INTRINSIC_TIMES
:
4221 case INTRINSIC_DIVIDE
:
4222 case INTRINSIC_POWER
:
4223 case INTRINSIC_CONCAT
:
4227 case INTRINSIC_NEQV
:
4229 case INTRINSIC_EQ_OS
:
4231 case INTRINSIC_NE_OS
:
4233 case INTRINSIC_GT_OS
:
4235 case INTRINSIC_GE_OS
:
4237 case INTRINSIC_LT_OS
:
4239 case INTRINSIC_LE_OS
:
4241 if (op1
->rank
== 0 && op2
->rank
== 0)
4244 if (op1
->rank
== 0 && op2
->rank
!= 0)
4246 e
->rank
= op2
->rank
;
4248 if (e
->shape
== NULL
)
4249 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4252 if (op1
->rank
!= 0 && op2
->rank
== 0)
4254 e
->rank
= op1
->rank
;
4256 if (e
->shape
== NULL
)
4257 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4260 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4262 if (op1
->rank
== op2
->rank
)
4264 e
->rank
= op1
->rank
;
4265 if (e
->shape
== NULL
)
4267 t
= compare_shapes (op1
, op2
);
4271 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4276 /* Allow higher level expressions to work. */
4279 /* Try user-defined operators, and otherwise throw an error. */
4280 dual_locus_error
= true;
4282 _("Inconsistent ranks for operator at %%L and %%L"));
4289 case INTRINSIC_PARENTHESES
:
4291 case INTRINSIC_UPLUS
:
4292 case INTRINSIC_UMINUS
:
4293 /* Simply copy arrayness attribute */
4294 e
->rank
= op1
->rank
;
4296 if (e
->shape
== NULL
)
4297 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4307 /* Attempt to simplify the expression. */
4310 t
= gfc_simplify_expr (e
, 0);
4311 /* Some calls do not succeed in simplification and return false
4312 even though there is no error; e.g. variable references to
4313 PARAMETER arrays. */
4314 if (!gfc_is_constant_expr (e
))
4322 match m
= gfc_extend_expr (e
);
4325 if (m
== MATCH_ERROR
)
4329 if (dual_locus_error
)
4330 gfc_error (msg
, &op1
->where
, &op2
->where
);
4332 gfc_error (msg
, &e
->where
);
4338 /************** Array resolution subroutines **************/
4341 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4343 /* Compare two integer expressions. */
4345 static compare_result
4346 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4350 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4351 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4354 /* If either of the types isn't INTEGER, we must have
4355 raised an error earlier. */
4357 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4360 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4370 /* Compare an integer expression with an integer. */
4372 static compare_result
4373 compare_bound_int (gfc_expr
*a
, int b
)
4377 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4380 if (a
->ts
.type
!= BT_INTEGER
)
4381 gfc_internal_error ("compare_bound_int(): Bad expression");
4383 i
= mpz_cmp_si (a
->value
.integer
, b
);
4393 /* Compare an integer expression with a mpz_t. */
4395 static compare_result
4396 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4400 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4403 if (a
->ts
.type
!= BT_INTEGER
)
4404 gfc_internal_error ("compare_bound_int(): Bad expression");
4406 i
= mpz_cmp (a
->value
.integer
, b
);
4416 /* Compute the last value of a sequence given by a triplet.
4417 Return 0 if it wasn't able to compute the last value, or if the
4418 sequence if empty, and 1 otherwise. */
4421 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4422 gfc_expr
*stride
, mpz_t last
)
4426 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4427 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4428 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4431 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4432 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4435 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4437 if (compare_bound (start
, end
) == CMP_GT
)
4439 mpz_set (last
, end
->value
.integer
);
4443 if (compare_bound_int (stride
, 0) == CMP_GT
)
4445 /* Stride is positive */
4446 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4451 /* Stride is negative */
4452 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4457 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4458 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4459 mpz_sub (last
, end
->value
.integer
, rem
);
4466 /* Compare a single dimension of an array reference to the array
4470 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4474 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4476 gcc_assert (ar
->stride
[i
] == NULL
);
4477 /* This implies [*] as [*:] and [*:3] are not possible. */
4478 if (ar
->start
[i
] == NULL
)
4480 gcc_assert (ar
->end
[i
] == NULL
);
4485 /* Given start, end and stride values, calculate the minimum and
4486 maximum referenced indexes. */
4488 switch (ar
->dimen_type
[i
])
4491 case DIMEN_THIS_IMAGE
:
4496 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4499 gfc_warning (0, "Array reference at %L is out of bounds "
4500 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4501 mpz_get_si (ar
->start
[i
]->value
.integer
),
4502 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4504 gfc_warning (0, "Array reference at %L is out of bounds "
4505 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4506 mpz_get_si (ar
->start
[i
]->value
.integer
),
4507 mpz_get_si (as
->lower
[i
]->value
.integer
),
4511 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4514 gfc_warning (0, "Array reference at %L is out of bounds "
4515 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4516 mpz_get_si (ar
->start
[i
]->value
.integer
),
4517 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4519 gfc_warning (0, "Array reference at %L is out of bounds "
4520 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4521 mpz_get_si (ar
->start
[i
]->value
.integer
),
4522 mpz_get_si (as
->upper
[i
]->value
.integer
),
4531 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4532 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4534 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4536 /* Check for zero stride, which is not allowed. */
4537 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4539 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4543 /* if start == len || (stride > 0 && start < len)
4544 || (stride < 0 && start > len),
4545 then the array section contains at least one element. In this
4546 case, there is an out-of-bounds access if
4547 (start < lower || start > upper). */
4548 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4549 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4550 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4551 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4552 && comp_start_end
== CMP_GT
))
4554 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4556 gfc_warning (0, "Lower array reference at %L is out of bounds "
4557 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4558 mpz_get_si (AR_START
->value
.integer
),
4559 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4562 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4564 gfc_warning (0, "Lower array reference at %L is out of bounds "
4565 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4566 mpz_get_si (AR_START
->value
.integer
),
4567 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4572 /* If we can compute the highest index of the array section,
4573 then it also has to be between lower and upper. */
4574 mpz_init (last_value
);
4575 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4578 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4580 gfc_warning (0, "Upper array reference at %L is out of bounds "
4581 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4582 mpz_get_si (last_value
),
4583 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4584 mpz_clear (last_value
);
4587 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4589 gfc_warning (0, "Upper array reference at %L is out of bounds "
4590 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4591 mpz_get_si (last_value
),
4592 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4593 mpz_clear (last_value
);
4597 mpz_clear (last_value
);
4605 gfc_internal_error ("check_dimension(): Bad array reference");
4612 /* Compare an array reference with an array specification. */
4615 compare_spec_to_ref (gfc_array_ref
*ar
)
4622 /* TODO: Full array sections are only allowed as actual parameters. */
4623 if (as
->type
== AS_ASSUMED_SIZE
4624 && (/*ar->type == AR_FULL
4625 ||*/ (ar
->type
== AR_SECTION
4626 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4628 gfc_error ("Rightmost upper bound of assumed size array section "
4629 "not specified at %L", &ar
->where
);
4633 if (ar
->type
== AR_FULL
)
4636 if (as
->rank
!= ar
->dimen
)
4638 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4639 &ar
->where
, ar
->dimen
, as
->rank
);
4643 /* ar->codimen == 0 is a local array. */
4644 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4646 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4647 &ar
->where
, ar
->codimen
, as
->corank
);
4651 for (i
= 0; i
< as
->rank
; i
++)
4652 if (!check_dimension (i
, ar
, as
))
4655 /* Local access has no coarray spec. */
4656 if (ar
->codimen
!= 0)
4657 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4659 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4660 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4662 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4663 i
+ 1 - as
->rank
, &ar
->where
);
4666 if (!check_dimension (i
, ar
, as
))
4674 /* Resolve one part of an array index. */
4677 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4678 int force_index_integer_kind
)
4685 if (!gfc_resolve_expr (index
))
4688 if (check_scalar
&& index
->rank
!= 0)
4690 gfc_error ("Array index at %L must be scalar", &index
->where
);
4694 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4696 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4697 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4701 if (index
->ts
.type
== BT_REAL
)
4702 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4706 if ((index
->ts
.kind
!= gfc_index_integer_kind
4707 && force_index_integer_kind
)
4708 || index
->ts
.type
!= BT_INTEGER
)
4711 ts
.type
= BT_INTEGER
;
4712 ts
.kind
= gfc_index_integer_kind
;
4714 gfc_convert_type_warn (index
, &ts
, 2, 0);
4720 /* Resolve one part of an array index. */
4723 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4725 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4728 /* Resolve a dim argument to an intrinsic function. */
4731 gfc_resolve_dim_arg (gfc_expr
*dim
)
4736 if (!gfc_resolve_expr (dim
))
4741 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4746 if (dim
->ts
.type
!= BT_INTEGER
)
4748 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4752 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4757 ts
.type
= BT_INTEGER
;
4758 ts
.kind
= gfc_index_integer_kind
;
4760 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4766 /* Given an expression that contains array references, update those array
4767 references to point to the right array specifications. While this is
4768 filled in during matching, this information is difficult to save and load
4769 in a module, so we take care of it here.
4771 The idea here is that the original array reference comes from the
4772 base symbol. We traverse the list of reference structures, setting
4773 the stored reference to references. Component references can
4774 provide an additional array specification. */
4777 find_array_spec (gfc_expr
*e
)
4782 bool class_as
= false;
4784 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4786 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4790 as
= e
->symtree
->n
.sym
->as
;
4792 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4797 gfc_internal_error ("find_array_spec(): Missing spec");
4804 c
= ref
->u
.c
.component
;
4805 if (c
->attr
.dimension
)
4807 if (as
!= NULL
&& !(class_as
&& as
== c
->as
))
4808 gfc_internal_error ("find_array_spec(): unused as(1)");
4820 gfc_internal_error ("find_array_spec(): unused as(2)");
4824 /* Resolve an array reference. */
4827 resolve_array_ref (gfc_array_ref
*ar
)
4829 int i
, check_scalar
;
4832 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4834 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4836 /* Do not force gfc_index_integer_kind for the start. We can
4837 do fine with any integer kind. This avoids temporary arrays
4838 created for indexing with a vector. */
4839 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4841 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4843 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4848 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4852 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4856 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4857 if (e
->expr_type
== EXPR_VARIABLE
4858 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4859 ar
->start
[i
] = gfc_get_parentheses (e
);
4863 gfc_error ("Array index at %L is an array of rank %d",
4864 &ar
->c_where
[i
], e
->rank
);
4868 /* Fill in the upper bound, which may be lower than the
4869 specified one for something like a(2:10:5), which is
4870 identical to a(2:7:5). Only relevant for strides not equal
4871 to one. Don't try a division by zero. */
4872 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4873 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4874 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4875 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4879 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4881 if (ar
->end
[i
] == NULL
)
4884 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4886 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4888 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4889 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4891 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4902 if (ar
->type
== AR_FULL
)
4904 if (ar
->as
->rank
== 0)
4905 ar
->type
= AR_ELEMENT
;
4907 /* Make sure array is the same as array(:,:), this way
4908 we don't need to special case all the time. */
4909 ar
->dimen
= ar
->as
->rank
;
4910 for (i
= 0; i
< ar
->dimen
; i
++)
4912 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4914 gcc_assert (ar
->start
[i
] == NULL
);
4915 gcc_assert (ar
->end
[i
] == NULL
);
4916 gcc_assert (ar
->stride
[i
] == NULL
);
4920 /* If the reference type is unknown, figure out what kind it is. */
4922 if (ar
->type
== AR_UNKNOWN
)
4924 ar
->type
= AR_ELEMENT
;
4925 for (i
= 0; i
< ar
->dimen
; i
++)
4926 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4927 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4929 ar
->type
= AR_SECTION
;
4934 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4937 if (ar
->as
->corank
&& ar
->codimen
== 0)
4940 ar
->codimen
= ar
->as
->corank
;
4941 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4942 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4950 resolve_substring (gfc_ref
*ref
, bool *equal_length
)
4952 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4954 if (ref
->u
.ss
.start
!= NULL
)
4956 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4959 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4961 gfc_error ("Substring start index at %L must be of type INTEGER",
4962 &ref
->u
.ss
.start
->where
);
4966 if (ref
->u
.ss
.start
->rank
!= 0)
4968 gfc_error ("Substring start index at %L must be scalar",
4969 &ref
->u
.ss
.start
->where
);
4973 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4974 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4975 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4977 gfc_error ("Substring start index at %L is less than one",
4978 &ref
->u
.ss
.start
->where
);
4983 if (ref
->u
.ss
.end
!= NULL
)
4985 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4988 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4990 gfc_error ("Substring end index at %L must be of type INTEGER",
4991 &ref
->u
.ss
.end
->where
);
4995 if (ref
->u
.ss
.end
->rank
!= 0)
4997 gfc_error ("Substring end index at %L must be scalar",
4998 &ref
->u
.ss
.end
->where
);
5002 if (ref
->u
.ss
.length
!= NULL
5003 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
5004 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5005 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5007 gfc_error ("Substring end index at %L exceeds the string length",
5008 &ref
->u
.ss
.start
->where
);
5012 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
5013 gfc_integer_kinds
[k
].huge
) == CMP_GT
5014 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
5015 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
5017 gfc_error ("Substring end index at %L is too large",
5018 &ref
->u
.ss
.end
->where
);
5021 /* If the substring has the same length as the original
5022 variable, the reference itself can be deleted. */
5024 if (ref
->u
.ss
.length
!= NULL
5025 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
5026 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
5027 *equal_length
= true;
5034 /* This function supplies missing substring charlens. */
5037 gfc_resolve_substring_charlen (gfc_expr
*e
)
5040 gfc_expr
*start
, *end
;
5041 gfc_typespec
*ts
= NULL
;
5044 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
5046 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
5048 if (char_ref
->type
== REF_COMPONENT
)
5049 ts
= &char_ref
->u
.c
.component
->ts
;
5052 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
5055 gcc_assert (char_ref
->next
== NULL
);
5059 if (e
->ts
.u
.cl
->length
)
5060 gfc_free_expr (e
->ts
.u
.cl
->length
);
5061 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
5065 e
->ts
.type
= BT_CHARACTER
;
5066 e
->ts
.kind
= gfc_default_character_kind
;
5069 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5071 if (char_ref
->u
.ss
.start
)
5072 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5074 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5076 if (char_ref
->u
.ss
.end
)
5077 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5078 else if (e
->expr_type
== EXPR_VARIABLE
)
5081 ts
= &e
->symtree
->n
.sym
->ts
;
5082 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5089 gfc_free_expr (start
);
5090 gfc_free_expr (end
);
5094 /* Length = (end - start + 1).
5095 Check first whether it has a constant length. */
5096 if (gfc_dep_difference (end
, start
, &diff
))
5098 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5101 mpz_add_ui (len
->value
.integer
, diff
, 1);
5103 e
->ts
.u
.cl
->length
= len
;
5104 /* The check for length < 0 is handled below */
5108 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5109 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5110 gfc_get_int_expr (gfc_charlen_int_kind
,
5114 /* F2008, 6.4.1: Both the starting point and the ending point shall
5115 be within the range 1, 2, ..., n unless the starting point exceeds
5116 the ending point, in which case the substring has length zero. */
5118 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5119 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5121 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5122 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5124 /* Make sure that the length is simplified. */
5125 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5126 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5130 /* Resolve subtype references. */
5133 resolve_ref (gfc_expr
*expr
)
5135 int current_part_dimension
, n_components
, seen_part_dimension
;
5136 gfc_ref
*ref
, **prev
;
5139 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5140 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5142 find_array_spec (expr
);
5146 for (prev
= &expr
->ref
; *prev
!= NULL
;
5147 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5148 switch ((*prev
)->type
)
5151 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5160 equal_length
= false;
5161 if (!resolve_substring (*prev
, &equal_length
))
5164 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5166 /* Remove the reference and move the charlen, if any. */
5170 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5171 ref
->u
.ss
.length
= NULL
;
5172 gfc_free_ref_list (ref
);
5177 /* Check constraints on part references. */
5179 current_part_dimension
= 0;
5180 seen_part_dimension
= 0;
5183 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5188 switch (ref
->u
.ar
.type
)
5191 /* Coarray scalar. */
5192 if (ref
->u
.ar
.as
->rank
== 0)
5194 current_part_dimension
= 0;
5199 current_part_dimension
= 1;
5203 current_part_dimension
= 0;
5207 gfc_internal_error ("resolve_ref(): Bad array reference");
5213 if (current_part_dimension
|| seen_part_dimension
)
5216 if (ref
->u
.c
.component
->attr
.pointer
5217 || ref
->u
.c
.component
->attr
.proc_pointer
5218 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5219 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5221 gfc_error ("Component to the right of a part reference "
5222 "with nonzero rank must not have the POINTER "
5223 "attribute at %L", &expr
->where
);
5226 else if (ref
->u
.c
.component
->attr
.allocatable
5227 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5228 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5231 gfc_error ("Component to the right of a part reference "
5232 "with nonzero rank must not have the ALLOCATABLE "
5233 "attribute at %L", &expr
->where
);
5246 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5247 || ref
->next
== NULL
)
5248 && current_part_dimension
5249 && seen_part_dimension
)
5251 gfc_error ("Two or more part references with nonzero rank must "
5252 "not be specified at %L", &expr
->where
);
5256 if (ref
->type
== REF_COMPONENT
)
5258 if (current_part_dimension
)
5259 seen_part_dimension
= 1;
5261 /* reset to make sure */
5262 current_part_dimension
= 0;
5270 /* Given an expression, determine its shape. This is easier than it sounds.
5271 Leaves the shape array NULL if it is not possible to determine the shape. */
5274 expression_shape (gfc_expr
*e
)
5276 mpz_t array
[GFC_MAX_DIMENSIONS
];
5279 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5282 for (i
= 0; i
< e
->rank
; i
++)
5283 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5286 e
->shape
= gfc_get_shape (e
->rank
);
5288 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5293 for (i
--; i
>= 0; i
--)
5294 mpz_clear (array
[i
]);
5298 /* Given a variable expression node, compute the rank of the expression by
5299 examining the base symbol and any reference structures it may have. */
5302 expression_rank (gfc_expr
*e
)
5307 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5308 could lead to serious confusion... */
5309 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5313 if (e
->expr_type
== EXPR_ARRAY
)
5315 /* Constructors can have a rank different from one via RESHAPE(). */
5317 if (e
->symtree
== NULL
)
5323 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5324 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5330 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5332 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5333 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5334 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5336 if (ref
->type
!= REF_ARRAY
)
5339 if (ref
->u
.ar
.type
== AR_FULL
)
5341 rank
= ref
->u
.ar
.as
->rank
;
5345 if (ref
->u
.ar
.type
== AR_SECTION
)
5347 /* Figure out the rank of the section. */
5349 gfc_internal_error ("expression_rank(): Two array specs");
5351 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5352 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5353 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5363 expression_shape (e
);
5368 add_caf_get_intrinsic (gfc_expr
*e
)
5370 gfc_expr
*wrapper
, *tmp_expr
;
5374 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5375 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5380 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5381 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5384 tmp_expr
= XCNEW (gfc_expr
);
5386 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5387 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5388 wrapper
->ts
= e
->ts
;
5389 wrapper
->rank
= e
->rank
;
5391 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5398 remove_caf_get_intrinsic (gfc_expr
*e
)
5400 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5401 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5402 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5403 e
->value
.function
.actual
->expr
= NULL
;
5404 gfc_free_actual_arglist (e
->value
.function
.actual
);
5405 gfc_free_shape (&e
->shape
, e
->rank
);
5411 /* Resolve a variable expression. */
5414 resolve_variable (gfc_expr
*e
)
5421 if (e
->symtree
== NULL
)
5423 sym
= e
->symtree
->n
.sym
;
5425 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5426 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5427 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5429 if (!actual_arg
|| inquiry_argument
)
5431 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5432 "be used as actual argument", sym
->name
, &e
->where
);
5436 /* TS 29113, 407b. */
5437 else if (e
->ts
.type
== BT_ASSUMED
)
5441 gfc_error ("Assumed-type variable %s at %L may only be used "
5442 "as actual argument", sym
->name
, &e
->where
);
5445 else if (inquiry_argument
&& !first_actual_arg
)
5447 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5448 for all inquiry functions in resolve_function; the reason is
5449 that the function-name resolution happens too late in that
5451 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5452 "an inquiry function shall be the first argument",
5453 sym
->name
, &e
->where
);
5457 /* TS 29113, C535b. */
5458 else if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5459 && CLASS_DATA (sym
)->as
5460 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5461 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5462 && sym
->as
->type
== AS_ASSUMED_RANK
))
5463 && !sym
->attr
.select_rank_temporary
)
5466 && !(cs_base
&& cs_base
->current
5467 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
5469 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5470 "actual argument", sym
->name
, &e
->where
);
5473 else if (inquiry_argument
&& !first_actual_arg
)
5475 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5476 for all inquiry functions in resolve_function; the reason is
5477 that the function-name resolution happens too late in that
5479 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5480 "to an inquiry function shall be the first argument",
5481 sym
->name
, &e
->where
);
5486 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5487 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5488 && e
->ref
->next
== NULL
))
5490 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5491 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5494 /* TS 29113, 407b. */
5495 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5496 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5497 && e
->ref
->next
== NULL
))
5499 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5500 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5504 /* TS 29113, C535b. */
5505 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5506 && CLASS_DATA (sym
)->as
5507 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5508 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5509 && sym
->as
->type
== AS_ASSUMED_RANK
))
5511 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5512 && e
->ref
->next
== NULL
))
5514 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5515 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5519 /* For variables that are used in an associate (target => object) where
5520 the object's basetype is array valued while the target is scalar,
5521 the ts' type of the component refs is still array valued, which
5522 can't be translated that way. */
5523 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5524 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5525 && CLASS_DATA (sym
->assoc
->target
)->as
)
5527 gfc_ref
*ref
= e
->ref
;
5533 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5534 /* Stop the loop. */
5544 /* If this is an associate-name, it may be parsed with an array reference
5545 in error even though the target is scalar. Fail directly in this case.
5546 TODO Understand why class scalar expressions must be excluded. */
5547 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5549 if (sym
->ts
.type
== BT_CLASS
)
5550 gfc_fix_class_refs (e
);
5551 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5553 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5555 /* This can happen because the parser did not detect that the
5556 associate name is an array and the expression had no array
5558 gfc_ref
*ref
= gfc_get_ref ();
5559 ref
->type
= REF_ARRAY
;
5560 ref
->u
.ar
= *gfc_get_array_ref();
5561 ref
->u
.ar
.type
= AR_FULL
;
5564 ref
->u
.ar
.as
= sym
->as
;
5565 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5573 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5574 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5576 /* On the other hand, the parser may not have known this is an array;
5577 in this case, we have to add a FULL reference. */
5578 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5580 e
->ref
= gfc_get_ref ();
5581 e
->ref
->type
= REF_ARRAY
;
5582 e
->ref
->u
.ar
.type
= AR_FULL
;
5583 e
->ref
->u
.ar
.dimen
= 0;
5586 /* Like above, but for class types, where the checking whether an array
5587 ref is present is more complicated. Furthermore make sure not to add
5588 the full array ref to _vptr or _len refs. */
5589 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5590 && CLASS_DATA (sym
)->attr
.dimension
5591 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5593 gfc_ref
*ref
, *newref
;
5595 newref
= gfc_get_ref ();
5596 newref
->type
= REF_ARRAY
;
5597 newref
->u
.ar
.type
= AR_FULL
;
5598 newref
->u
.ar
.dimen
= 0;
5599 /* Because this is an associate var and the first ref either is a ref to
5600 the _data component or not, no traversal of the ref chain is
5601 needed. The array ref needs to be inserted after the _data ref,
5602 or when that is not present, which may happend for polymorphic
5603 types, then at the first position. */
5607 else if (ref
->type
== REF_COMPONENT
5608 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5610 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5612 newref
->next
= ref
->next
;
5616 /* Array ref present already. */
5617 gfc_free_ref_list (newref
);
5619 else if (ref
->type
== REF_ARRAY
)
5620 /* Array ref present already. */
5621 gfc_free_ref_list (newref
);
5629 if (e
->ref
&& !resolve_ref (e
))
5632 if (sym
->attr
.flavor
== FL_PROCEDURE
5633 && (!sym
->attr
.function
5634 || (sym
->attr
.function
&& sym
->result
5635 && sym
->result
->attr
.proc_pointer
5636 && !sym
->result
->attr
.function
)))
5638 e
->ts
.type
= BT_PROCEDURE
;
5639 goto resolve_procedure
;
5642 if (sym
->ts
.type
!= BT_UNKNOWN
)
5643 gfc_variable_attr (e
, &e
->ts
);
5644 else if (sym
->attr
.flavor
== FL_PROCEDURE
5645 && sym
->attr
.function
&& sym
->result
5646 && sym
->result
->ts
.type
!= BT_UNKNOWN
5647 && sym
->result
->attr
.proc_pointer
)
5648 e
->ts
= sym
->result
->ts
;
5651 /* Must be a simple variable reference. */
5652 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5657 if (check_assumed_size_reference (sym
, e
))
5660 /* Deal with forward references to entries during gfc_resolve_code, to
5661 satisfy, at least partially, 12.5.2.5. */
5662 if (gfc_current_ns
->entries
5663 && current_entry_id
== sym
->entry_id
5666 && cs_base
->current
->op
!= EXEC_ENTRY
)
5668 gfc_entry_list
*entry
;
5669 gfc_formal_arglist
*formal
;
5671 bool seen
, saved_specification_expr
;
5673 /* If the symbol is a dummy... */
5674 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5676 entry
= gfc_current_ns
->entries
;
5679 /* ...test if the symbol is a parameter of previous entries. */
5680 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5681 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5683 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5690 /* If it has not been seen as a dummy, this is an error. */
5693 if (specification_expr
)
5694 gfc_error ("Variable %qs, used in a specification expression"
5695 ", is referenced at %L before the ENTRY statement "
5696 "in which it is a parameter",
5697 sym
->name
, &cs_base
->current
->loc
);
5699 gfc_error ("Variable %qs is used at %L before the ENTRY "
5700 "statement in which it is a parameter",
5701 sym
->name
, &cs_base
->current
->loc
);
5706 /* Now do the same check on the specification expressions. */
5707 saved_specification_expr
= specification_expr
;
5708 specification_expr
= true;
5709 if (sym
->ts
.type
== BT_CHARACTER
5710 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5714 for (n
= 0; n
< sym
->as
->rank
; n
++)
5716 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5718 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5721 specification_expr
= saved_specification_expr
;
5724 /* Update the symbol's entry level. */
5725 sym
->entry_id
= current_entry_id
+ 1;
5728 /* If a symbol has been host_associated mark it. This is used latter,
5729 to identify if aliasing is possible via host association. */
5730 if (sym
->attr
.flavor
== FL_VARIABLE
5731 && gfc_current_ns
->parent
5732 && (gfc_current_ns
->parent
== sym
->ns
5733 || (gfc_current_ns
->parent
->parent
5734 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5735 sym
->attr
.host_assoc
= 1;
5737 if (gfc_current_ns
->proc_name
5738 && sym
->attr
.dimension
5739 && (sym
->ns
!= gfc_current_ns
5740 || sym
->attr
.use_assoc
5741 || sym
->attr
.in_common
))
5742 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5745 if (t
&& !resolve_procedure_expression (e
))
5748 /* F2008, C617 and C1229. */
5749 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5750 && gfc_is_coindexed (e
))
5752 gfc_ref
*ref
, *ref2
= NULL
;
5754 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5756 if (ref
->type
== REF_COMPONENT
)
5758 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5762 for ( ; ref
; ref
= ref
->next
)
5763 if (ref
->type
== REF_COMPONENT
)
5766 /* Expression itself is not coindexed object. */
5767 if (ref
&& e
->ts
.type
== BT_CLASS
)
5769 gfc_error ("Polymorphic subobject of coindexed object at %L",
5774 /* Expression itself is coindexed object. */
5778 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5779 for ( ; c
; c
= c
->next
)
5780 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5782 gfc_error ("Coindexed object with polymorphic allocatable "
5783 "subcomponent at %L", &e
->where
);
5791 expression_rank (e
);
5793 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5794 add_caf_get_intrinsic (e
);
5796 /* Simplify cases where access to a parameter array results in a
5797 single constant. Suppress errors since those will have been
5798 issued before, as warnings. */
5799 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5801 gfc_push_suppress_errors ();
5802 gfc_simplify_expr (e
, 1);
5803 gfc_pop_suppress_errors ();
5810 /* Checks to see that the correct symbol has been host associated.
5811 The only situation where this arises is that in which a twice
5812 contained function is parsed after the host association is made.
5813 Therefore, on detecting this, change the symbol in the expression
5814 and convert the array reference into an actual arglist if the old
5815 symbol is a variable. */
5817 check_host_association (gfc_expr
*e
)
5819 gfc_symbol
*sym
, *old_sym
;
5823 gfc_actual_arglist
*arg
, *tail
= NULL
;
5824 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5826 /* If the expression is the result of substitution in
5827 interface.c(gfc_extend_expr) because there is no way in
5828 which the host association can be wrong. */
5829 if (e
->symtree
== NULL
5830 || e
->symtree
->n
.sym
== NULL
5831 || e
->user_operator
)
5834 old_sym
= e
->symtree
->n
.sym
;
5836 if (gfc_current_ns
->parent
5837 && old_sym
->ns
!= gfc_current_ns
)
5839 /* Use the 'USE' name so that renamed module symbols are
5840 correctly handled. */
5841 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5843 if (sym
&& old_sym
!= sym
5844 && sym
->ts
.type
== old_sym
->ts
.type
5845 && sym
->attr
.flavor
== FL_PROCEDURE
5846 && sym
->attr
.contained
)
5848 /* Clear the shape, since it might not be valid. */
5849 gfc_free_shape (&e
->shape
, e
->rank
);
5851 /* Give the expression the right symtree! */
5852 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5853 gcc_assert (st
!= NULL
);
5855 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5856 || e
->expr_type
== EXPR_FUNCTION
)
5858 /* Original was function so point to the new symbol, since
5859 the actual argument list is already attached to the
5861 e
->value
.function
.esym
= NULL
;
5866 /* Original was variable so convert array references into
5867 an actual arglist. This does not need any checking now
5868 since resolve_function will take care of it. */
5869 e
->value
.function
.actual
= NULL
;
5870 e
->expr_type
= EXPR_FUNCTION
;
5873 /* Ambiguity will not arise if the array reference is not
5874 the last reference. */
5875 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5876 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5879 gcc_assert (ref
->type
== REF_ARRAY
);
5881 /* Grab the start expressions from the array ref and
5882 copy them into actual arguments. */
5883 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5885 arg
= gfc_get_actual_arglist ();
5886 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5887 if (e
->value
.function
.actual
== NULL
)
5888 tail
= e
->value
.function
.actual
= arg
;
5896 /* Dump the reference list and set the rank. */
5897 gfc_free_ref_list (e
->ref
);
5899 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5902 gfc_resolve_expr (e
);
5906 /* This might have changed! */
5907 return e
->expr_type
== EXPR_FUNCTION
;
5912 gfc_resolve_character_operator (gfc_expr
*e
)
5914 gfc_expr
*op1
= e
->value
.op
.op1
;
5915 gfc_expr
*op2
= e
->value
.op
.op2
;
5916 gfc_expr
*e1
= NULL
;
5917 gfc_expr
*e2
= NULL
;
5919 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5921 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5922 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5923 else if (op1
->expr_type
== EXPR_CONSTANT
)
5924 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5925 op1
->value
.character
.length
);
5927 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5928 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5929 else if (op2
->expr_type
== EXPR_CONSTANT
)
5930 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5931 op2
->value
.character
.length
);
5933 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5943 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5944 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5945 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5946 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5947 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5953 /* Ensure that an character expression has a charlen and, if possible, a
5954 length expression. */
5957 fixup_charlen (gfc_expr
*e
)
5959 /* The cases fall through so that changes in expression type and the need
5960 for multiple fixes are picked up. In all circumstances, a charlen should
5961 be available for the middle end to hang a backend_decl on. */
5962 switch (e
->expr_type
)
5965 gfc_resolve_character_operator (e
);
5969 if (e
->expr_type
== EXPR_ARRAY
)
5970 gfc_resolve_character_array_constructor (e
);
5973 case EXPR_SUBSTRING
:
5974 if (!e
->ts
.u
.cl
&& e
->ref
)
5975 gfc_resolve_substring_charlen (e
);
5980 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5987 /* Update an actual argument to include the passed-object for type-bound
5988 procedures at the right position. */
5990 static gfc_actual_arglist
*
5991 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5994 gcc_assert (argpos
> 0);
5998 gfc_actual_arglist
* result
;
6000 result
= gfc_get_actual_arglist ();
6004 result
->name
= name
;
6010 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
6012 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
6017 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6020 extract_compcall_passed_object (gfc_expr
* e
)
6024 if (e
->expr_type
== EXPR_UNKNOWN
)
6026 gfc_error ("Error in typebound call at %L",
6031 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6033 if (e
->value
.compcall
.base_object
)
6034 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
6037 po
= gfc_get_expr ();
6038 po
->expr_type
= EXPR_VARIABLE
;
6039 po
->symtree
= e
->symtree
;
6040 po
->ref
= gfc_copy_ref (e
->ref
);
6041 po
->where
= e
->where
;
6044 if (!gfc_resolve_expr (po
))
6051 /* Update the arglist of an EXPR_COMPCALL expression to include the
6055 update_compcall_arglist (gfc_expr
* e
)
6058 gfc_typebound_proc
* tbp
;
6060 tbp
= e
->value
.compcall
.tbp
;
6065 po
= extract_compcall_passed_object (e
);
6069 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
6075 if (tbp
->pass_arg_num
<= 0)
6078 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6086 /* Extract the passed object from a PPC call (a copy of it). */
6089 extract_ppc_passed_object (gfc_expr
*e
)
6094 po
= gfc_get_expr ();
6095 po
->expr_type
= EXPR_VARIABLE
;
6096 po
->symtree
= e
->symtree
;
6097 po
->ref
= gfc_copy_ref (e
->ref
);
6098 po
->where
= e
->where
;
6100 /* Remove PPC reference. */
6102 while ((*ref
)->next
)
6103 ref
= &(*ref
)->next
;
6104 gfc_free_ref_list (*ref
);
6107 if (!gfc_resolve_expr (po
))
6114 /* Update the actual arglist of a procedure pointer component to include the
6118 update_ppc_arglist (gfc_expr
* e
)
6122 gfc_typebound_proc
* tb
;
6124 ppc
= gfc_get_proc_ptr_comp (e
);
6132 else if (tb
->nopass
)
6135 po
= extract_ppc_passed_object (e
);
6142 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6147 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6149 gfc_error ("Base object for procedure-pointer component call at %L is of"
6150 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6154 gcc_assert (tb
->pass_arg_num
> 0);
6155 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6163 /* Check that the object a TBP is called on is valid, i.e. it must not be
6164 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6167 check_typebound_baseobject (gfc_expr
* e
)
6170 bool return_value
= false;
6172 base
= extract_compcall_passed_object (e
);
6176 if (base
->ts
.type
!= BT_DERIVED
&& base
->ts
.type
!= BT_CLASS
)
6178 gfc_error ("Error in typebound call at %L", &e
->where
);
6182 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6186 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6188 gfc_error ("Base object for type-bound procedure call at %L is of"
6189 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6193 /* F08:C1230. If the procedure called is NOPASS,
6194 the base object must be scalar. */
6195 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6197 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6198 " be scalar", &e
->where
);
6202 return_value
= true;
6205 gfc_free_expr (base
);
6206 return return_value
;
6210 /* Resolve a call to a type-bound procedure, either function or subroutine,
6211 statically from the data in an EXPR_COMPCALL expression. The adapted
6212 arglist and the target-procedure symtree are returned. */
6215 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6216 gfc_actual_arglist
** actual
)
6218 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6219 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6221 /* Update the actual arglist for PASS. */
6222 if (!update_compcall_arglist (e
))
6225 *actual
= e
->value
.compcall
.actual
;
6226 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6228 gfc_free_ref_list (e
->ref
);
6230 e
->value
.compcall
.actual
= NULL
;
6232 /* If we find a deferred typebound procedure, check for derived types
6233 that an overriding typebound procedure has not been missed. */
6234 if (e
->value
.compcall
.name
6235 && !e
->value
.compcall
.tbp
->non_overridable
6236 && e
->value
.compcall
.base_object
6237 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6240 gfc_symbol
*derived
;
6242 /* Use the derived type of the base_object. */
6243 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6246 /* If necessary, go through the inheritance chain. */
6247 while (!st
&& derived
)
6249 /* Look for the typebound procedure 'name'. */
6250 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6251 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6252 e
->value
.compcall
.name
);
6254 derived
= gfc_get_derived_super_type (derived
);
6257 /* Now find the specific name in the derived type namespace. */
6258 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6259 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6260 derived
->ns
, 1, &st
);
6268 /* Get the ultimate declared type from an expression. In addition,
6269 return the last class/derived type reference and the copy of the
6270 reference list. If check_types is set true, derived types are
6271 identified as well as class references. */
6273 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6274 gfc_expr
*e
, bool check_types
)
6276 gfc_symbol
*declared
;
6283 *new_ref
= gfc_copy_ref (e
->ref
);
6285 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6287 if (ref
->type
!= REF_COMPONENT
)
6290 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6291 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6292 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6294 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6300 if (declared
== NULL
)
6301 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6307 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6308 which of the specific bindings (if any) matches the arglist and transform
6309 the expression into a call of that binding. */
6312 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6314 gfc_typebound_proc
* genproc
;
6315 const char* genname
;
6317 gfc_symbol
*derived
;
6319 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6320 genname
= e
->value
.compcall
.name
;
6321 genproc
= e
->value
.compcall
.tbp
;
6323 if (!genproc
->is_generic
)
6326 /* Try the bindings on this type and in the inheritance hierarchy. */
6327 for (; genproc
; genproc
= genproc
->overridden
)
6331 gcc_assert (genproc
->is_generic
);
6332 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6335 gfc_actual_arglist
* args
;
6338 gcc_assert (g
->specific
);
6340 if (g
->specific
->error
)
6343 target
= g
->specific
->u
.specific
->n
.sym
;
6345 /* Get the right arglist by handling PASS/NOPASS. */
6346 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6347 if (!g
->specific
->nopass
)
6350 po
= extract_compcall_passed_object (e
);
6353 gfc_free_actual_arglist (args
);
6357 gcc_assert (g
->specific
->pass_arg_num
> 0);
6358 gcc_assert (!g
->specific
->error
);
6359 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6360 g
->specific
->pass_arg
);
6362 resolve_actual_arglist (args
, target
->attr
.proc
,
6363 is_external_proc (target
)
6364 && gfc_sym_get_dummy_args (target
) == NULL
);
6366 /* Check if this arglist matches the formal. */
6367 matches
= gfc_arglist_matches_symbol (&args
, target
);
6369 /* Clean up and break out of the loop if we've found it. */
6370 gfc_free_actual_arglist (args
);
6373 e
->value
.compcall
.tbp
= g
->specific
;
6374 genname
= g
->specific_st
->name
;
6375 /* Pass along the name for CLASS methods, where the vtab
6376 procedure pointer component has to be referenced. */
6384 /* Nothing matching found! */
6385 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6386 " %qs at %L", genname
, &e
->where
);
6390 /* Make sure that we have the right specific instance for the name. */
6391 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6393 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6395 e
->value
.compcall
.tbp
= st
->n
.tb
;
6401 /* Resolve a call to a type-bound subroutine. */
6404 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6406 gfc_actual_arglist
* newactual
;
6407 gfc_symtree
* target
;
6409 /* Check that's really a SUBROUTINE. */
6410 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6412 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6413 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6414 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6415 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6416 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6419 gfc_error ("%qs at %L should be a SUBROUTINE",
6420 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6425 if (!check_typebound_baseobject (c
->expr1
))
6428 /* Pass along the name for CLASS methods, where the vtab
6429 procedure pointer component has to be referenced. */
6431 *name
= c
->expr1
->value
.compcall
.name
;
6433 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6436 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6438 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6440 /* Transform into an ordinary EXEC_CALL for now. */
6442 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6445 c
->ext
.actual
= newactual
;
6446 c
->symtree
= target
;
6447 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6449 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6451 gfc_free_expr (c
->expr1
);
6452 c
->expr1
= gfc_get_expr ();
6453 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6454 c
->expr1
->symtree
= target
;
6455 c
->expr1
->where
= c
->loc
;
6457 return resolve_call (c
);
6461 /* Resolve a component-call expression. */
6463 resolve_compcall (gfc_expr
* e
, const char **name
)
6465 gfc_actual_arglist
* newactual
;
6466 gfc_symtree
* target
;
6468 /* Check that's really a FUNCTION. */
6469 if (!e
->value
.compcall
.tbp
->function
)
6471 gfc_error ("%qs at %L should be a FUNCTION",
6472 e
->value
.compcall
.name
, &e
->where
);
6477 /* These must not be assign-calls! */
6478 gcc_assert (!e
->value
.compcall
.assign
);
6480 if (!check_typebound_baseobject (e
))
6483 /* Pass along the name for CLASS methods, where the vtab
6484 procedure pointer component has to be referenced. */
6486 *name
= e
->value
.compcall
.name
;
6488 if (!resolve_typebound_generic_call (e
, name
))
6490 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6492 /* Take the rank from the function's symbol. */
6493 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6494 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6496 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6497 arglist to the TBP's binding target. */
6499 if (!resolve_typebound_static (e
, &target
, &newactual
))
6502 e
->value
.function
.actual
= newactual
;
6503 e
->value
.function
.name
= NULL
;
6504 e
->value
.function
.esym
= target
->n
.sym
;
6505 e
->value
.function
.isym
= NULL
;
6506 e
->symtree
= target
;
6507 e
->ts
= target
->n
.sym
->ts
;
6508 e
->expr_type
= EXPR_FUNCTION
;
6510 /* Resolution is not necessary if this is a class subroutine; this
6511 function only has to identify the specific proc. Resolution of
6512 the call will be done next in resolve_typebound_call. */
6513 return gfc_resolve_expr (e
);
6517 static bool resolve_fl_derived (gfc_symbol
*sym
);
6520 /* Resolve a typebound function, or 'method'. First separate all
6521 the non-CLASS references by calling resolve_compcall directly. */
6524 resolve_typebound_function (gfc_expr
* e
)
6526 gfc_symbol
*declared
;
6538 /* Deal with typebound operators for CLASS objects. */
6539 expr
= e
->value
.compcall
.base_object
;
6540 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6541 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6543 /* If the base_object is not a variable, the corresponding actual
6544 argument expression must be stored in e->base_expression so
6545 that the corresponding tree temporary can be used as the base
6546 object in gfc_conv_procedure_call. */
6547 if (expr
->expr_type
!= EXPR_VARIABLE
)
6549 gfc_actual_arglist
*args
;
6551 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6553 if (expr
== args
->expr
)
6558 /* Since the typebound operators are generic, we have to ensure
6559 that any delays in resolution are corrected and that the vtab
6562 declared
= ts
.u
.derived
;
6563 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6564 if (c
->ts
.u
.derived
== NULL
)
6565 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6567 if (!resolve_compcall (e
, &name
))
6570 /* Use the generic name if it is there. */
6571 name
= name
? name
: e
->value
.function
.esym
->name
;
6572 e
->symtree
= expr
->symtree
;
6573 e
->ref
= gfc_copy_ref (expr
->ref
);
6574 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6576 /* Trim away the extraneous references that emerge from nested
6577 use of interface.c (extend_expr). */
6578 if (class_ref
&& class_ref
->next
)
6580 gfc_free_ref_list (class_ref
->next
);
6581 class_ref
->next
= NULL
;
6583 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6585 gfc_free_ref_list (e
->ref
);
6589 gfc_add_vptr_component (e
);
6590 gfc_add_component_ref (e
, name
);
6591 e
->value
.function
.esym
= NULL
;
6592 if (expr
->expr_type
!= EXPR_VARIABLE
)
6593 e
->base_expr
= expr
;
6598 return resolve_compcall (e
, NULL
);
6600 if (!resolve_ref (e
))
6603 /* Get the CLASS declared type. */
6604 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6606 if (!resolve_fl_derived (declared
))
6609 /* Weed out cases of the ultimate component being a derived type. */
6610 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6611 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6613 gfc_free_ref_list (new_ref
);
6614 return resolve_compcall (e
, NULL
);
6617 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6619 /* Treat the call as if it is a typebound procedure, in order to roll
6620 out the correct name for the specific function. */
6621 if (!resolve_compcall (e
, &name
))
6623 gfc_free_ref_list (new_ref
);
6630 /* Convert the expression to a procedure pointer component call. */
6631 e
->value
.function
.esym
= NULL
;
6637 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6638 gfc_add_vptr_component (e
);
6639 gfc_add_component_ref (e
, name
);
6641 /* Recover the typespec for the expression. This is really only
6642 necessary for generic procedures, where the additional call
6643 to gfc_add_component_ref seems to throw the collection of the
6644 correct typespec. */
6648 gfc_free_ref_list (new_ref
);
6653 /* Resolve a typebound subroutine, or 'method'. First separate all
6654 the non-CLASS references by calling resolve_typebound_call
6658 resolve_typebound_subroutine (gfc_code
*code
)
6660 gfc_symbol
*declared
;
6670 st
= code
->expr1
->symtree
;
6672 /* Deal with typebound operators for CLASS objects. */
6673 expr
= code
->expr1
->value
.compcall
.base_object
;
6674 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6675 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6677 /* If the base_object is not a variable, the corresponding actual
6678 argument expression must be stored in e->base_expression so
6679 that the corresponding tree temporary can be used as the base
6680 object in gfc_conv_procedure_call. */
6681 if (expr
->expr_type
!= EXPR_VARIABLE
)
6683 gfc_actual_arglist
*args
;
6685 args
= code
->expr1
->value
.function
.actual
;
6686 for (; args
; args
= args
->next
)
6687 if (expr
== args
->expr
)
6691 /* Since the typebound operators are generic, we have to ensure
6692 that any delays in resolution are corrected and that the vtab
6694 declared
= expr
->ts
.u
.derived
;
6695 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6696 if (c
->ts
.u
.derived
== NULL
)
6697 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6699 if (!resolve_typebound_call (code
, &name
, NULL
))
6702 /* Use the generic name if it is there. */
6703 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6704 code
->expr1
->symtree
= expr
->symtree
;
6705 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6707 /* Trim away the extraneous references that emerge from nested
6708 use of interface.c (extend_expr). */
6709 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6710 if (class_ref
&& class_ref
->next
)
6712 gfc_free_ref_list (class_ref
->next
);
6713 class_ref
->next
= NULL
;
6715 else if (code
->expr1
->ref
&& !class_ref
)
6717 gfc_free_ref_list (code
->expr1
->ref
);
6718 code
->expr1
->ref
= NULL
;
6721 /* Now use the procedure in the vtable. */
6722 gfc_add_vptr_component (code
->expr1
);
6723 gfc_add_component_ref (code
->expr1
, name
);
6724 code
->expr1
->value
.function
.esym
= NULL
;
6725 if (expr
->expr_type
!= EXPR_VARIABLE
)
6726 code
->expr1
->base_expr
= expr
;
6731 return resolve_typebound_call (code
, NULL
, NULL
);
6733 if (!resolve_ref (code
->expr1
))
6736 /* Get the CLASS declared type. */
6737 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6739 /* Weed out cases of the ultimate component being a derived type. */
6740 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6741 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6743 gfc_free_ref_list (new_ref
);
6744 return resolve_typebound_call (code
, NULL
, NULL
);
6747 if (!resolve_typebound_call (code
, &name
, &overridable
))
6749 gfc_free_ref_list (new_ref
);
6752 ts
= code
->expr1
->ts
;
6756 /* Convert the expression to a procedure pointer component call. */
6757 code
->expr1
->value
.function
.esym
= NULL
;
6758 code
->expr1
->symtree
= st
;
6761 code
->expr1
->ref
= new_ref
;
6763 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6764 gfc_add_vptr_component (code
->expr1
);
6765 gfc_add_component_ref (code
->expr1
, name
);
6767 /* Recover the typespec for the expression. This is really only
6768 necessary for generic procedures, where the additional call
6769 to gfc_add_component_ref seems to throw the collection of the
6770 correct typespec. */
6771 code
->expr1
->ts
= ts
;
6774 gfc_free_ref_list (new_ref
);
6780 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6783 resolve_ppc_call (gfc_code
* c
)
6785 gfc_component
*comp
;
6787 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6788 gcc_assert (comp
!= NULL
);
6790 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6791 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6793 if (!comp
->attr
.subroutine
)
6794 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6796 if (!resolve_ref (c
->expr1
))
6799 if (!update_ppc_arglist (c
->expr1
))
6802 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6804 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6805 !(comp
->ts
.interface
6806 && comp
->ts
.interface
->formal
)))
6809 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6812 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6818 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6821 resolve_expr_ppc (gfc_expr
* e
)
6823 gfc_component
*comp
;
6825 comp
= gfc_get_proc_ptr_comp (e
);
6826 gcc_assert (comp
!= NULL
);
6828 /* Convert to EXPR_FUNCTION. */
6829 e
->expr_type
= EXPR_FUNCTION
;
6830 e
->value
.function
.isym
= NULL
;
6831 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6833 if (comp
->as
!= NULL
)
6834 e
->rank
= comp
->as
->rank
;
6836 if (!comp
->attr
.function
)
6837 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6839 if (!resolve_ref (e
))
6842 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6843 !(comp
->ts
.interface
6844 && comp
->ts
.interface
->formal
)))
6847 if (!update_ppc_arglist (e
))
6850 if (!check_pure_function(e
))
6853 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6860 gfc_is_expandable_expr (gfc_expr
*e
)
6862 gfc_constructor
*con
;
6864 if (e
->expr_type
== EXPR_ARRAY
)
6866 /* Traverse the constructor looking for variables that are flavor
6867 parameter. Parameters must be expanded since they are fully used at
6869 con
= gfc_constructor_first (e
->value
.constructor
);
6870 for (; con
; con
= gfc_constructor_next (con
))
6872 if (con
->expr
->expr_type
== EXPR_VARIABLE
6873 && con
->expr
->symtree
6874 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6875 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6877 if (con
->expr
->expr_type
== EXPR_ARRAY
6878 && gfc_is_expandable_expr (con
->expr
))
6887 /* Sometimes variables in specification expressions of the result
6888 of module procedures in submodules wind up not being the 'real'
6889 dummy. Find this, if possible, in the namespace of the first
6893 fixup_unique_dummy (gfc_expr
*e
)
6895 gfc_symtree
*st
= NULL
;
6896 gfc_symbol
*s
= NULL
;
6898 if (e
->symtree
->n
.sym
->ns
->proc_name
6899 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6900 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6903 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6906 && st
->n
.sym
!= NULL
6907 && st
->n
.sym
->attr
.dummy
)
6911 /* Resolve an expression. That is, make sure that types of operands agree
6912 with their operators, intrinsic operators are converted to function calls
6913 for overloaded types and unresolved function references are resolved. */
6916 gfc_resolve_expr (gfc_expr
*e
)
6919 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6921 if (e
== NULL
|| e
->do_not_resolve_again
)
6924 /* inquiry_argument only applies to variables. */
6925 inquiry_save
= inquiry_argument
;
6926 actual_arg_save
= actual_arg
;
6927 first_actual_arg_save
= first_actual_arg
;
6929 if (e
->expr_type
!= EXPR_VARIABLE
)
6931 inquiry_argument
= false;
6933 first_actual_arg
= false;
6935 else if (e
->symtree
!= NULL
6936 && *e
->symtree
->name
== '@'
6937 && e
->symtree
->n
.sym
->attr
.dummy
)
6939 /* Deal with submodule specification expressions that are not
6940 found to be referenced in module.c(read_cleanup). */
6941 fixup_unique_dummy (e
);
6944 switch (e
->expr_type
)
6947 t
= resolve_operator (e
);
6953 if (check_host_association (e
))
6954 t
= resolve_function (e
);
6956 t
= resolve_variable (e
);
6958 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6959 && e
->ref
->type
!= REF_SUBSTRING
)
6960 gfc_resolve_substring_charlen (e
);
6965 t
= resolve_typebound_function (e
);
6968 case EXPR_SUBSTRING
:
6969 t
= resolve_ref (e
);
6978 t
= resolve_expr_ppc (e
);
6983 if (!resolve_ref (e
))
6986 t
= gfc_resolve_array_constructor (e
);
6987 /* Also try to expand a constructor. */
6990 expression_rank (e
);
6991 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6992 gfc_expand_constructor (e
, false);
6995 /* This provides the opportunity for the length of constructors with
6996 character valued function elements to propagate the string length
6997 to the expression. */
6998 if (t
&& e
->ts
.type
== BT_CHARACTER
)
7000 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
7001 here rather then add a duplicate test for it above. */
7002 gfc_expand_constructor (e
, false);
7003 t
= gfc_resolve_character_array_constructor (e
);
7008 case EXPR_STRUCTURE
:
7009 t
= resolve_ref (e
);
7013 t
= resolve_structure_cons (e
, 0);
7017 t
= gfc_simplify_expr (e
, 0);
7021 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7024 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
7027 inquiry_argument
= inquiry_save
;
7028 actual_arg
= actual_arg_save
;
7029 first_actual_arg
= first_actual_arg_save
;
7031 /* For some reason, resolving these expressions a second time mangles
7032 the typespec of the expression itself. */
7033 if (t
&& e
->expr_type
== EXPR_VARIABLE
7034 && e
->symtree
->n
.sym
->attr
.select_rank_temporary
7035 && UNLIMITED_POLY (e
->symtree
->n
.sym
))
7036 e
->do_not_resolve_again
= 1;
7042 /* Resolve an expression from an iterator. They must be scalar and have
7043 INTEGER or (optionally) REAL type. */
7046 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
7047 const char *name_msgid
)
7049 if (!gfc_resolve_expr (expr
))
7052 if (expr
->rank
!= 0)
7054 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
7058 if (expr
->ts
.type
!= BT_INTEGER
)
7060 if (expr
->ts
.type
== BT_REAL
)
7063 return gfc_notify_std (GFC_STD_F95_DEL
,
7064 "%s at %L must be integer",
7065 _(name_msgid
), &expr
->where
);
7068 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
7075 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
7083 /* Resolve the expressions in an iterator structure. If REAL_OK is
7084 false allow only INTEGER type iterators, otherwise allow REAL types.
7085 Set own_scope to true for ac-implied-do and data-implied-do as those
7086 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7089 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
7091 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7094 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7095 _("iterator variable")))
7098 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7099 "Start expression in DO loop"))
7102 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7103 "End expression in DO loop"))
7106 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7107 "Step expression in DO loop"))
7110 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7112 if ((iter
->step
->ts
.type
== BT_INTEGER
7113 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7114 || (iter
->step
->ts
.type
== BT_REAL
7115 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7117 gfc_error ("Step expression in DO loop at %L cannot be zero",
7118 &iter
->step
->where
);
7123 /* Convert start, end, and step to the same type as var. */
7124 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7125 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7126 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7128 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7129 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7130 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7132 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7133 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7134 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7136 if (iter
->start
->expr_type
== EXPR_CONSTANT
7137 && iter
->end
->expr_type
== EXPR_CONSTANT
7138 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7141 if (iter
->start
->ts
.type
== BT_INTEGER
)
7143 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7144 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7148 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7149 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7151 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7152 gfc_warning (OPT_Wzerotrip
,
7153 "DO loop at %L will be executed zero times",
7154 &iter
->step
->where
);
7157 if (iter
->end
->expr_type
== EXPR_CONSTANT
7158 && iter
->end
->ts
.type
== BT_INTEGER
7159 && iter
->step
->expr_type
== EXPR_CONSTANT
7160 && iter
->step
->ts
.type
== BT_INTEGER
7161 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7162 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7164 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7165 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7167 if (is_step_positive
7168 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7169 gfc_warning (OPT_Wundefined_do_loop
,
7170 "DO loop at %L is undefined as it overflows",
7171 &iter
->step
->where
);
7172 else if (!is_step_positive
7173 && mpz_cmp (iter
->end
->value
.integer
,
7174 gfc_integer_kinds
[k
].min_int
) == 0)
7175 gfc_warning (OPT_Wundefined_do_loop
,
7176 "DO loop at %L is undefined as it underflows",
7177 &iter
->step
->where
);
7184 /* Traversal function for find_forall_index. f == 2 signals that
7185 that variable itself is not to be checked - only the references. */
7188 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7190 if (expr
->expr_type
!= EXPR_VARIABLE
)
7193 /* A scalar assignment */
7194 if (!expr
->ref
|| *f
== 1)
7196 if (expr
->symtree
->n
.sym
== sym
)
7208 /* Check whether the FORALL index appears in the expression or not.
7209 Returns true if SYM is found in EXPR. */
7212 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7214 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7221 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7222 to be a scalar INTEGER variable. The subscripts and stride are scalar
7223 INTEGERs, and if stride is a constant it must be nonzero.
7224 Furthermore "A subscript or stride in a forall-triplet-spec shall
7225 not contain a reference to any index-name in the
7226 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7229 resolve_forall_iterators (gfc_forall_iterator
*it
)
7231 gfc_forall_iterator
*iter
, *iter2
;
7233 for (iter
= it
; iter
; iter
= iter
->next
)
7235 if (gfc_resolve_expr (iter
->var
)
7236 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7237 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7240 if (gfc_resolve_expr (iter
->start
)
7241 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7242 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7243 &iter
->start
->where
);
7244 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7245 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7247 if (gfc_resolve_expr (iter
->end
)
7248 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7249 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7251 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7252 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7254 if (gfc_resolve_expr (iter
->stride
))
7256 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7257 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7258 &iter
->stride
->where
, "INTEGER");
7260 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7261 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7262 gfc_error ("FORALL stride expression at %L cannot be zero",
7263 &iter
->stride
->where
);
7265 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7266 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7269 for (iter
= it
; iter
; iter
= iter
->next
)
7270 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7272 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7273 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7274 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7275 gfc_error ("FORALL index %qs may not appear in triplet "
7276 "specification at %L", iter
->var
->symtree
->name
,
7277 &iter2
->start
->where
);
7282 /* Given a pointer to a symbol that is a derived type, see if it's
7283 inaccessible, i.e. if it's defined in another module and the components are
7284 PRIVATE. The search is recursive if necessary. Returns zero if no
7285 inaccessible components are found, nonzero otherwise. */
7288 derived_inaccessible (gfc_symbol
*sym
)
7292 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7295 for (c
= sym
->components
; c
; c
= c
->next
)
7297 /* Prevent an infinite loop through this function. */
7298 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7299 && sym
== c
->ts
.u
.derived
)
7302 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7310 /* Resolve the argument of a deallocate expression. The expression must be
7311 a pointer or a full array. */
7314 resolve_deallocate_expr (gfc_expr
*e
)
7316 symbol_attribute attr
;
7317 int allocatable
, pointer
;
7323 if (!gfc_resolve_expr (e
))
7326 if (e
->expr_type
!= EXPR_VARIABLE
)
7329 sym
= e
->symtree
->n
.sym
;
7330 unlimited
= UNLIMITED_POLY(sym
);
7332 if (sym
->ts
.type
== BT_CLASS
)
7334 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7335 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7339 allocatable
= sym
->attr
.allocatable
;
7340 pointer
= sym
->attr
.pointer
;
7342 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7347 if (ref
->u
.ar
.type
!= AR_FULL
7348 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7349 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7354 c
= ref
->u
.c
.component
;
7355 if (c
->ts
.type
== BT_CLASS
)
7357 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7358 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7362 allocatable
= c
->attr
.allocatable
;
7363 pointer
= c
->attr
.pointer
;
7374 attr
= gfc_expr_attr (e
);
7376 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7379 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7385 if (gfc_is_coindexed (e
))
7387 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7392 && !gfc_check_vardef_context (e
, true, true, false,
7393 _("DEALLOCATE object")))
7395 if (!gfc_check_vardef_context (e
, false, true, false,
7396 _("DEALLOCATE object")))
7403 /* Returns true if the expression e contains a reference to the symbol sym. */
7405 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7407 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7414 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7416 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7420 /* Given the expression node e for an allocatable/pointer of derived type to be
7421 allocated, get the expression node to be initialized afterwards (needed for
7422 derived types with default initializers, and derived types with allocatable
7423 components that need nullification.) */
7426 gfc_expr_to_initialize (gfc_expr
*e
)
7432 result
= gfc_copy_expr (e
);
7434 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7435 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7436 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7438 ref
->u
.ar
.type
= AR_FULL
;
7440 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7441 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7446 gfc_free_shape (&result
->shape
, result
->rank
);
7448 /* Recalculate rank, shape, etc. */
7449 gfc_resolve_expr (result
);
7454 /* If the last ref of an expression is an array ref, return a copy of the
7455 expression with that one removed. Otherwise, a copy of the original
7456 expression. This is used for allocate-expressions and pointer assignment
7457 LHS, where there may be an array specification that needs to be stripped
7458 off when using gfc_check_vardef_context. */
7461 remove_last_array_ref (gfc_expr
* e
)
7466 e2
= gfc_copy_expr (e
);
7467 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7468 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7470 gfc_free_ref_list (*r
);
7479 /* Used in resolve_allocate_expr to check that a allocation-object and
7480 a source-expr are conformable. This does not catch all possible
7481 cases; in particular a runtime checking is needed. */
7484 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7487 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7489 /* First compare rank. */
7490 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7491 || (!tail
&& e1
->rank
!= e2
->rank
))
7493 gfc_error ("Source-expr at %L must be scalar or have the "
7494 "same rank as the allocate-object at %L",
7495 &e1
->where
, &e2
->where
);
7506 for (i
= 0; i
< e1
->rank
; i
++)
7508 if (tail
->u
.ar
.start
[i
] == NULL
)
7511 if (tail
->u
.ar
.end
[i
])
7513 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7514 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7515 mpz_add_ui (s
, s
, 1);
7519 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7522 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7524 gfc_error ("Source-expr at %L and allocate-object at %L must "
7525 "have the same shape", &e1
->where
, &e2
->where
);
7538 /* Resolve the expression in an ALLOCATE statement, doing the additional
7539 checks to see whether the expression is OK or not. The expression must
7540 have a trailing array reference that gives the size of the array. */
7543 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7545 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7549 symbol_attribute attr
;
7550 gfc_ref
*ref
, *ref2
;
7553 gfc_symbol
*sym
= NULL
;
7558 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7559 checking of coarrays. */
7560 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7561 if (ref
->next
== NULL
)
7564 if (ref
&& ref
->type
== REF_ARRAY
)
7565 ref
->u
.ar
.in_allocate
= true;
7567 if (!gfc_resolve_expr (e
))
7570 /* Make sure the expression is allocatable or a pointer. If it is
7571 pointer, the next-to-last reference must be a pointer. */
7575 sym
= e
->symtree
->n
.sym
;
7577 /* Check whether ultimate component is abstract and CLASS. */
7580 /* Is the allocate-object unlimited polymorphic? */
7581 unlimited
= UNLIMITED_POLY(e
);
7583 if (e
->expr_type
!= EXPR_VARIABLE
)
7586 attr
= gfc_expr_attr (e
);
7587 pointer
= attr
.pointer
;
7588 dimension
= attr
.dimension
;
7589 codimension
= attr
.codimension
;
7593 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7595 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7596 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7597 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7598 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7599 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7603 allocatable
= sym
->attr
.allocatable
;
7604 pointer
= sym
->attr
.pointer
;
7605 dimension
= sym
->attr
.dimension
;
7606 codimension
= sym
->attr
.codimension
;
7611 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7616 if (ref
->u
.ar
.codimen
> 0)
7619 for (n
= ref
->u
.ar
.dimen
;
7620 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7621 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7628 if (ref
->next
!= NULL
)
7636 gfc_error ("Coindexed allocatable object at %L",
7641 c
= ref
->u
.c
.component
;
7642 if (c
->ts
.type
== BT_CLASS
)
7644 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7645 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7646 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7647 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7648 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7652 allocatable
= c
->attr
.allocatable
;
7653 pointer
= c
->attr
.pointer
;
7654 dimension
= c
->attr
.dimension
;
7655 codimension
= c
->attr
.codimension
;
7656 is_abstract
= c
->attr
.abstract
;
7669 /* Check for F08:C628. */
7670 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7672 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7677 /* Some checks for the SOURCE tag. */
7680 /* Check F03:C631. */
7681 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7683 gfc_error ("Type of entity at %L is type incompatible with "
7684 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7688 /* Check F03:C632 and restriction following Note 6.18. */
7689 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7692 /* Check F03:C633. */
7693 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7695 gfc_error ("The allocate-object at %L and the source-expr at %L "
7696 "shall have the same kind type parameter",
7697 &e
->where
, &code
->expr3
->where
);
7701 /* Check F2008, C642. */
7702 if (code
->expr3
->ts
.type
== BT_DERIVED
7703 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7704 || (code
->expr3
->ts
.u
.derived
->from_intmod
7705 == INTMOD_ISO_FORTRAN_ENV
7706 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7707 == ISOFORTRAN_LOCK_TYPE
)))
7709 gfc_error ("The source-expr at %L shall neither be of type "
7710 "LOCK_TYPE nor have a LOCK_TYPE component if "
7711 "allocate-object at %L is a coarray",
7712 &code
->expr3
->where
, &e
->where
);
7716 /* Check TS18508, C702/C703. */
7717 if (code
->expr3
->ts
.type
== BT_DERIVED
7718 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7719 || (code
->expr3
->ts
.u
.derived
->from_intmod
7720 == INTMOD_ISO_FORTRAN_ENV
7721 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7722 == ISOFORTRAN_EVENT_TYPE
)))
7724 gfc_error ("The source-expr at %L shall neither be of type "
7725 "EVENT_TYPE nor have a EVENT_TYPE component if "
7726 "allocate-object at %L is a coarray",
7727 &code
->expr3
->where
, &e
->where
);
7732 /* Check F08:C629. */
7733 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7736 gcc_assert (e
->ts
.type
== BT_CLASS
);
7737 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7738 "type-spec or source-expr", sym
->name
, &e
->where
);
7742 /* Check F08:C632. */
7743 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7744 && !UNLIMITED_POLY (e
))
7748 if (!e
->ts
.u
.cl
->length
)
7751 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7752 code
->ext
.alloc
.ts
.u
.cl
->length
);
7753 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7755 gfc_error ("Allocating %s at %L with type-spec requires the same "
7756 "character-length parameter as in the declaration",
7757 sym
->name
, &e
->where
);
7762 /* In the variable definition context checks, gfc_expr_attr is used
7763 on the expression. This is fooled by the array specification
7764 present in e, thus we have to eliminate that one temporarily. */
7765 e2
= remove_last_array_ref (e
);
7768 t
= gfc_check_vardef_context (e2
, true, true, false,
7769 _("ALLOCATE object"));
7771 t
= gfc_check_vardef_context (e2
, false, true, false,
7772 _("ALLOCATE object"));
7777 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7778 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7780 /* For class arrays, the initialization with SOURCE is done
7781 using _copy and trans_call. It is convenient to exploit that
7782 when the allocated type is different from the declared type but
7783 no SOURCE exists by setting expr3. */
7784 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7786 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7787 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7788 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7790 /* We have to zero initialize the integer variable. */
7791 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7794 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7796 /* Make sure the vtab symbol is present when
7797 the module variables are generated. */
7798 gfc_typespec ts
= e
->ts
;
7800 ts
= code
->expr3
->ts
;
7801 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7802 ts
= code
->ext
.alloc
.ts
;
7804 /* Finding the vtab also publishes the type's symbol. Therefore this
7805 statement is necessary. */
7806 gfc_find_derived_vtab (ts
.u
.derived
);
7808 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7810 /* Again, make sure the vtab symbol is present when
7811 the module variables are generated. */
7812 gfc_typespec
*ts
= NULL
;
7814 ts
= &code
->expr3
->ts
;
7816 ts
= &code
->ext
.alloc
.ts
;
7820 /* Finding the vtab also publishes the type's symbol. Therefore this
7821 statement is necessary. */
7825 if (dimension
== 0 && codimension
== 0)
7828 /* Make sure the last reference node is an array specification. */
7830 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7831 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7836 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7837 "in ALLOCATE statement at %L", &e
->where
))
7839 if (code
->expr3
->rank
!= 0)
7840 *array_alloc_wo_spec
= true;
7843 gfc_error ("Array specification or array-valued SOURCE= "
7844 "expression required in ALLOCATE statement at %L",
7851 gfc_error ("Array specification required in ALLOCATE statement "
7852 "at %L", &e
->where
);
7857 /* Make sure that the array section reference makes sense in the
7858 context of an ALLOCATE specification. */
7863 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7865 switch (ar
->dimen_type
[i
])
7867 case DIMEN_THIS_IMAGE
:
7868 gfc_error ("Coarray specification required in ALLOCATE statement "
7869 "at %L", &e
->where
);
7873 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0)
7875 /* If ar->stride[i] is NULL, we issued a previous error. */
7876 if (ar
->stride
[i
] == NULL
)
7877 gfc_error ("Bad array specification in ALLOCATE statement "
7878 "at %L", &e
->where
);
7881 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
7883 gfc_error ("Upper cobound is less than lower cobound at %L",
7884 &ar
->start
[i
]->where
);
7890 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
7892 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
7893 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
7895 gfc_error ("Upper cobound is less than lower cobound "
7896 "of 1 at %L", &ar
->start
[i
]->where
);
7906 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7912 for (i
= 0; i
< ar
->dimen
; i
++)
7914 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7917 switch (ar
->dimen_type
[i
])
7923 if (ar
->start
[i
] != NULL
7924 && ar
->end
[i
] != NULL
7925 && ar
->stride
[i
] == NULL
)
7933 case DIMEN_THIS_IMAGE
:
7934 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7940 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7942 sym
= a
->expr
->symtree
->n
.sym
;
7944 /* TODO - check derived type components. */
7945 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7948 if ((ar
->start
[i
] != NULL
7949 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7950 || (ar
->end
[i
] != NULL
7951 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7953 gfc_error ("%qs must not appear in the array specification at "
7954 "%L in the same ALLOCATE statement where it is "
7955 "itself allocated", sym
->name
, &ar
->where
);
7961 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7963 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7964 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7966 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7968 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7969 "statement at %L", &e
->where
);
7975 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7976 && ar
->stride
[i
] == NULL
)
7979 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7993 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7995 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7996 gfc_alloc
*a
, *p
, *q
;
7999 errmsg
= code
->expr2
;
8001 /* Check the stat variable. */
8004 gfc_check_vardef_context (stat
, false, false, false,
8005 _("STAT variable"));
8007 if ((stat
->ts
.type
!= BT_INTEGER
8008 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
8009 || stat
->ref
->type
== REF_COMPONENT
)))
8011 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8012 "variable", &stat
->where
);
8014 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8015 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
8017 gfc_ref
*ref1
, *ref2
;
8020 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
8021 ref1
= ref1
->next
, ref2
= ref2
->next
)
8023 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8025 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8034 gfc_error ("Stat-variable at %L shall not be %sd within "
8035 "the same %s statement", &stat
->where
, fcn
, fcn
);
8041 /* Check the errmsg variable. */
8045 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
8048 gfc_check_vardef_context (errmsg
, false, false, false,
8049 _("ERRMSG variable"));
8051 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8052 F18:R930 errmsg-variable is scalar-default-char-variable
8053 F18:R906 default-char-variable is variable
8054 F18:C906 default-char-variable shall be default character. */
8055 if ((errmsg
->ts
.type
!= BT_CHARACTER
8057 && (errmsg
->ref
->type
== REF_ARRAY
8058 || errmsg
->ref
->type
== REF_COMPONENT
)))
8060 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
8061 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8062 "variable", &errmsg
->where
);
8064 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8065 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
8067 gfc_ref
*ref1
, *ref2
;
8070 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
8071 ref1
= ref1
->next
, ref2
= ref2
->next
)
8073 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
8075 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
8084 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8085 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
8091 /* Check that an allocate-object appears only once in the statement. */
8093 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8096 for (q
= p
->next
; q
; q
= q
->next
)
8099 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8101 /* This is a potential collision. */
8102 gfc_ref
*pr
= pe
->ref
;
8103 gfc_ref
*qr
= qe
->ref
;
8105 /* Follow the references until
8106 a) They start to differ, in which case there is no error;
8107 you can deallocate a%b and a%c in a single statement
8108 b) Both of them stop, which is an error
8109 c) One of them stops, which is also an error. */
8112 if (pr
== NULL
&& qr
== NULL
)
8114 gfc_error ("Allocate-object at %L also appears at %L",
8115 &pe
->where
, &qe
->where
);
8118 else if (pr
!= NULL
&& qr
== NULL
)
8120 gfc_error ("Allocate-object at %L is subobject of"
8121 " object at %L", &pe
->where
, &qe
->where
);
8124 else if (pr
== NULL
&& qr
!= NULL
)
8126 gfc_error ("Allocate-object at %L is subobject of"
8127 " object at %L", &qe
->where
, &pe
->where
);
8130 /* Here, pr != NULL && qr != NULL */
8131 gcc_assert(pr
->type
== qr
->type
);
8132 if (pr
->type
== REF_ARRAY
)
8134 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8136 gcc_assert (qr
->type
== REF_ARRAY
);
8138 if (pr
->next
&& qr
->next
)
8141 gfc_array_ref
*par
= &(pr
->u
.ar
);
8142 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8144 for (i
=0; i
<par
->dimen
; i
++)
8146 if ((par
->start
[i
] != NULL
8147 || qar
->start
[i
] != NULL
)
8148 && gfc_dep_compare_expr (par
->start
[i
],
8149 qar
->start
[i
]) != 0)
8156 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8169 if (strcmp (fcn
, "ALLOCATE") == 0)
8171 bool arr_alloc_wo_spec
= false;
8173 /* Resolving the expr3 in the loop over all objects to allocate would
8174 execute loop invariant code for each loop item. Therefore do it just
8176 if (code
->expr3
&& code
->expr3
->mold
8177 && code
->expr3
->ts
.type
== BT_DERIVED
)
8179 /* Default initialization via MOLD (non-polymorphic). */
8180 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8183 gfc_resolve_expr (rhs
);
8184 gfc_free_expr (code
->expr3
);
8188 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8189 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8191 if (arr_alloc_wo_spec
&& code
->expr3
)
8193 /* Mark the allocate to have to take the array specification
8195 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8200 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8201 resolve_deallocate_expr (a
->expr
);
8206 /************ SELECT CASE resolution subroutines ************/
8208 /* Callback function for our mergesort variant. Determines interval
8209 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8210 op1 > op2. Assumes we're not dealing with the default case.
8211 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8212 There are nine situations to check. */
8215 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8219 if (op1
->low
== NULL
) /* op1 = (:L) */
8221 /* op2 = (:N), so overlap. */
8223 /* op2 = (M:) or (M:N), L < M */
8224 if (op2
->low
!= NULL
8225 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8228 else if (op1
->high
== NULL
) /* op1 = (K:) */
8230 /* op2 = (M:), so overlap. */
8232 /* op2 = (:N) or (M:N), K > N */
8233 if (op2
->high
!= NULL
8234 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8237 else /* op1 = (K:L) */
8239 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8240 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8242 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8243 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8245 else /* op2 = (M:N) */
8249 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8252 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8261 /* Merge-sort a double linked case list, detecting overlap in the
8262 process. LIST is the head of the double linked case list before it
8263 is sorted. Returns the head of the sorted list if we don't see any
8264 overlap, or NULL otherwise. */
8267 check_case_overlap (gfc_case
*list
)
8269 gfc_case
*p
, *q
, *e
, *tail
;
8270 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8272 /* If the passed list was empty, return immediately. */
8279 /* Loop unconditionally. The only exit from this loop is a return
8280 statement, when we've finished sorting the case list. */
8287 /* Count the number of merges we do in this pass. */
8290 /* Loop while there exists a merge to be done. */
8295 /* Count this merge. */
8298 /* Cut the list in two pieces by stepping INSIZE places
8299 forward in the list, starting from P. */
8302 for (i
= 0; i
< insize
; i
++)
8311 /* Now we have two lists. Merge them! */
8312 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8314 /* See from which the next case to merge comes from. */
8317 /* P is empty so the next case must come from Q. */
8322 else if (qsize
== 0 || q
== NULL
)
8331 cmp
= compare_cases (p
, q
);
8334 /* The whole case range for P is less than the
8342 /* The whole case range for Q is greater than
8343 the case range for P. */
8350 /* The cases overlap, or they are the same
8351 element in the list. Either way, we must
8352 issue an error and get the next case from P. */
8353 /* FIXME: Sort P and Q by line number. */
8354 gfc_error ("CASE label at %L overlaps with CASE "
8355 "label at %L", &p
->where
, &q
->where
);
8363 /* Add the next element to the merged list. */
8372 /* P has now stepped INSIZE places along, and so has Q. So
8373 they're the same. */
8378 /* If we have done only one merge or none at all, we've
8379 finished sorting the cases. */
8388 /* Otherwise repeat, merging lists twice the size. */
8394 /* Check to see if an expression is suitable for use in a CASE statement.
8395 Makes sure that all case expressions are scalar constants of the same
8396 type. Return false if anything is wrong. */
8399 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8401 if (e
== NULL
) return true;
8403 if (e
->ts
.type
!= case_expr
->ts
.type
)
8405 gfc_error ("Expression in CASE statement at %L must be of type %s",
8406 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8410 /* C805 (R808) For a given case-construct, each case-value shall be of
8411 the same type as case-expr. For character type, length differences
8412 are allowed, but the kind type parameters shall be the same. */
8414 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8416 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8417 &e
->where
, case_expr
->ts
.kind
);
8421 /* Convert the case value kind to that of case expression kind,
8424 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8425 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8429 gfc_error ("Expression in CASE statement at %L must be scalar",
8438 /* Given a completely parsed select statement, we:
8440 - Validate all expressions and code within the SELECT.
8441 - Make sure that the selection expression is not of the wrong type.
8442 - Make sure that no case ranges overlap.
8443 - Eliminate unreachable cases and unreachable code resulting from
8444 removing case labels.
8446 The standard does allow unreachable cases, e.g. CASE (5:3). But
8447 they are a hassle for code generation, and to prevent that, we just
8448 cut them out here. This is not necessary for overlapping cases
8449 because they are illegal and we never even try to generate code.
8451 We have the additional caveat that a SELECT construct could have
8452 been a computed GOTO in the source code. Fortunately we can fairly
8453 easily work around that here: The case_expr for a "real" SELECT CASE
8454 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8455 we have to do is make sure that the case_expr is a scalar integer
8459 resolve_select (gfc_code
*code
, bool select_type
)
8462 gfc_expr
*case_expr
;
8463 gfc_case
*cp
, *default_case
, *tail
, *head
;
8464 int seen_unreachable
;
8470 if (code
->expr1
== NULL
)
8472 /* This was actually a computed GOTO statement. */
8473 case_expr
= code
->expr2
;
8474 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8475 gfc_error ("Selection expression in computed GOTO statement "
8476 "at %L must be a scalar integer expression",
8479 /* Further checking is not necessary because this SELECT was built
8480 by the compiler, so it should always be OK. Just move the
8481 case_expr from expr2 to expr so that we can handle computed
8482 GOTOs as normal SELECTs from here on. */
8483 code
->expr1
= code
->expr2
;
8488 case_expr
= code
->expr1
;
8489 type
= case_expr
->ts
.type
;
8492 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8494 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8495 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8497 /* Punt. Going on here just produce more garbage error messages. */
8502 if (!select_type
&& case_expr
->rank
!= 0)
8504 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8505 "expression", &case_expr
->where
);
8511 /* Raise a warning if an INTEGER case value exceeds the range of
8512 the case-expr. Later, all expressions will be promoted to the
8513 largest kind of all case-labels. */
8515 if (type
== BT_INTEGER
)
8516 for (body
= code
->block
; body
; body
= body
->block
)
8517 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8520 && gfc_check_integer_range (cp
->low
->value
.integer
,
8521 case_expr
->ts
.kind
) != ARITH_OK
)
8522 gfc_warning (0, "Expression in CASE statement at %L is "
8523 "not in the range of %s", &cp
->low
->where
,
8524 gfc_typename (&case_expr
->ts
));
8527 && cp
->low
!= cp
->high
8528 && gfc_check_integer_range (cp
->high
->value
.integer
,
8529 case_expr
->ts
.kind
) != ARITH_OK
)
8530 gfc_warning (0, "Expression in CASE statement at %L is "
8531 "not in the range of %s", &cp
->high
->where
,
8532 gfc_typename (&case_expr
->ts
));
8535 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8536 of the SELECT CASE expression and its CASE values. Walk the lists
8537 of case values, and if we find a mismatch, promote case_expr to
8538 the appropriate kind. */
8540 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8542 for (body
= code
->block
; body
; body
= body
->block
)
8544 /* Walk the case label list. */
8545 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8547 /* Intercept the DEFAULT case. It does not have a kind. */
8548 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8551 /* Unreachable case ranges are discarded, so ignore. */
8552 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8553 && cp
->low
!= cp
->high
8554 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8558 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8559 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8561 if (cp
->high
!= NULL
8562 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8563 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8568 /* Assume there is no DEFAULT case. */
8569 default_case
= NULL
;
8574 for (body
= code
->block
; body
; body
= body
->block
)
8576 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8578 seen_unreachable
= 0;
8580 /* Walk the case label list, making sure that all case labels
8582 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8584 /* Count the number of cases in the whole construct. */
8587 /* Intercept the DEFAULT case. */
8588 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8590 if (default_case
!= NULL
)
8592 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8593 "by a second DEFAULT CASE at %L",
8594 &default_case
->where
, &cp
->where
);
8605 /* Deal with single value cases and case ranges. Errors are
8606 issued from the validation function. */
8607 if (!validate_case_label_expr (cp
->low
, case_expr
)
8608 || !validate_case_label_expr (cp
->high
, case_expr
))
8614 if (type
== BT_LOGICAL
8615 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8616 || cp
->low
!= cp
->high
))
8618 gfc_error ("Logical range in CASE statement at %L is not "
8619 "allowed", &cp
->low
->where
);
8624 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8627 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8628 if (value
& seen_logical
)
8630 gfc_error ("Constant logical value in CASE statement "
8631 "is repeated at %L",
8636 seen_logical
|= value
;
8639 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8640 && cp
->low
!= cp
->high
8641 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8643 if (warn_surprising
)
8644 gfc_warning (OPT_Wsurprising
,
8645 "Range specification at %L can never be matched",
8648 cp
->unreachable
= 1;
8649 seen_unreachable
= 1;
8653 /* If the case range can be matched, it can also overlap with
8654 other cases. To make sure it does not, we put it in a
8655 double linked list here. We sort that with a merge sort
8656 later on to detect any overlapping cases. */
8660 head
->right
= head
->left
= NULL
;
8665 tail
->right
->left
= tail
;
8672 /* It there was a failure in the previous case label, give up
8673 for this case label list. Continue with the next block. */
8677 /* See if any case labels that are unreachable have been seen.
8678 If so, we eliminate them. This is a bit of a kludge because
8679 the case lists for a single case statement (label) is a
8680 single forward linked lists. */
8681 if (seen_unreachable
)
8683 /* Advance until the first case in the list is reachable. */
8684 while (body
->ext
.block
.case_list
!= NULL
8685 && body
->ext
.block
.case_list
->unreachable
)
8687 gfc_case
*n
= body
->ext
.block
.case_list
;
8688 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8690 gfc_free_case_list (n
);
8693 /* Strip all other unreachable cases. */
8694 if (body
->ext
.block
.case_list
)
8696 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8698 if (cp
->next
->unreachable
)
8700 gfc_case
*n
= cp
->next
;
8701 cp
->next
= cp
->next
->next
;
8703 gfc_free_case_list (n
);
8710 /* See if there were overlapping cases. If the check returns NULL,
8711 there was overlap. In that case we don't do anything. If head
8712 is non-NULL, we prepend the DEFAULT case. The sorted list can
8713 then used during code generation for SELECT CASE constructs with
8714 a case expression of a CHARACTER type. */
8717 head
= check_case_overlap (head
);
8719 /* Prepend the default_case if it is there. */
8720 if (head
!= NULL
&& default_case
)
8722 default_case
->left
= NULL
;
8723 default_case
->right
= head
;
8724 head
->left
= default_case
;
8728 /* Eliminate dead blocks that may be the result if we've seen
8729 unreachable case labels for a block. */
8730 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8732 if (body
->block
->ext
.block
.case_list
== NULL
)
8734 /* Cut the unreachable block from the code chain. */
8735 gfc_code
*c
= body
->block
;
8736 body
->block
= c
->block
;
8738 /* Kill the dead block, but not the blocks below it. */
8740 gfc_free_statements (c
);
8744 /* More than two cases is legal but insane for logical selects.
8745 Issue a warning for it. */
8746 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8747 gfc_warning (OPT_Wsurprising
,
8748 "Logical SELECT CASE block at %L has more that two cases",
8753 /* Check if a derived type is extensible. */
8756 gfc_type_is_extensible (gfc_symbol
*sym
)
8758 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8759 || (sym
->attr
.is_class
8760 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8765 resolve_types (gfc_namespace
*ns
);
8767 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8768 correct as well as possibly the array-spec. */
8771 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8775 gcc_assert (sym
->assoc
);
8776 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8778 /* If this is for SELECT TYPE, the target may not yet be set. In that
8779 case, return. Resolution will be called later manually again when
8781 target
= sym
->assoc
->target
;
8784 gcc_assert (!sym
->assoc
->dangling
);
8786 if (resolve_target
&& !gfc_resolve_expr (target
))
8789 /* For variable targets, we get some attributes from the target. */
8790 if (target
->expr_type
== EXPR_VARIABLE
)
8794 gcc_assert (target
->symtree
);
8795 tsym
= target
->symtree
->n
.sym
;
8797 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8798 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8800 sym
->attr
.target
= tsym
->attr
.target
8801 || gfc_expr_attr (target
).pointer
;
8802 if (is_subref_array (target
))
8803 sym
->attr
.subref_array_pointer
= 1;
8806 if (target
->expr_type
== EXPR_NULL
)
8808 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8811 else if (target
->ts
.type
== BT_UNKNOWN
)
8813 gfc_error ("Selector at %L has no type", &target
->where
);
8817 /* Get type if this was not already set. Note that it can be
8818 some other type than the target in case this is a SELECT TYPE
8819 selector! So we must not update when the type is already there. */
8820 if (sym
->ts
.type
== BT_UNKNOWN
)
8821 sym
->ts
= target
->ts
;
8823 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8825 /* See if this is a valid association-to-variable. */
8826 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8827 && !gfc_has_vector_subscript (target
));
8829 /* Finally resolve if this is an array or not. */
8830 if (sym
->attr
.dimension
&& target
->rank
== 0)
8832 /* primary.c makes the assumption that a reference to an associate
8833 name followed by a left parenthesis is an array reference. */
8834 if (sym
->ts
.type
!= BT_CHARACTER
)
8835 gfc_error ("Associate-name %qs at %L is used as array",
8836 sym
->name
, &sym
->declared_at
);
8837 sym
->attr
.dimension
= 0;
8842 /* We cannot deal with class selectors that need temporaries. */
8843 if (target
->ts
.type
== BT_CLASS
8844 && gfc_ref_needs_temporary_p (target
->ref
))
8846 gfc_error ("CLASS selector at %L needs a temporary which is not "
8847 "yet implemented", &target
->where
);
8851 if (target
->ts
.type
== BT_CLASS
)
8852 gfc_fix_class_refs (target
);
8854 if (target
->rank
!= 0 && !sym
->attr
.select_rank_temporary
)
8857 /* The rank may be incorrectly guessed at parsing, therefore make sure
8858 it is corrected now. */
8859 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8862 sym
->as
= gfc_get_array_spec ();
8864 as
->rank
= target
->rank
;
8865 as
->type
= AS_DEFERRED
;
8866 as
->corank
= gfc_get_corank (target
);
8867 sym
->attr
.dimension
= 1;
8868 if (as
->corank
!= 0)
8869 sym
->attr
.codimension
= 1;
8871 else if (sym
->ts
.type
== BT_CLASS
&& (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
8873 if (!CLASS_DATA (sym
)->as
)
8874 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
8875 as
= CLASS_DATA (sym
)->as
;
8876 as
->rank
= target
->rank
;
8877 as
->type
= AS_DEFERRED
;
8878 as
->corank
= gfc_get_corank (target
);
8879 CLASS_DATA (sym
)->attr
.dimension
= 1;
8880 if (as
->corank
!= 0)
8881 CLASS_DATA (sym
)->attr
.codimension
= 1;
8884 else if (!sym
->attr
.select_rank_temporary
)
8886 /* target's rank is 0, but the type of the sym is still array valued,
8887 which has to be corrected. */
8888 if (sym
->ts
.type
== BT_CLASS
8889 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
8892 symbol_attribute attr
;
8893 /* The associated variable's type is still the array type
8894 correct this now. */
8895 gfc_typespec
*ts
= &target
->ts
;
8898 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8903 ts
= &ref
->u
.c
.component
->ts
;
8906 if (ts
->type
== BT_CLASS
)
8907 ts
= &ts
->u
.derived
->components
->ts
;
8913 /* Create a scalar instance of the current class type. Because the
8914 rank of a class array goes into its name, the type has to be
8915 rebuild. The alternative of (re-)setting just the attributes
8916 and as in the current type, destroys the type also in other
8920 sym
->ts
.type
= BT_CLASS
;
8921 attr
= CLASS_DATA (sym
)->attr
;
8923 attr
.associate_var
= 1;
8924 attr
.dimension
= attr
.codimension
= 0;
8925 attr
.class_pointer
= 1;
8926 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8928 /* Make sure the _vptr is set. */
8929 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8930 if (c
->ts
.u
.derived
== NULL
)
8931 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8932 CLASS_DATA (sym
)->attr
.pointer
= 1;
8933 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8934 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8935 gfc_commit_symbol (sym
->ts
.u
.derived
);
8936 /* _vptr now has the _vtab in it, change it to the _vtype. */
8937 if (c
->ts
.u
.derived
->attr
.vtab
)
8938 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8939 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8940 resolve_types (c
->ts
.u
.derived
->ns
);
8944 /* Mark this as an associate variable. */
8945 sym
->attr
.associate_var
= 1;
8947 /* Fix up the type-spec for CHARACTER types. */
8948 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8951 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8953 if (sym
->ts
.deferred
&& target
->expr_type
== EXPR_VARIABLE
8954 && target
->symtree
->n
.sym
->attr
.dummy
8955 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
8957 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8958 sym
->ts
.deferred
= 1;
8961 if (!sym
->ts
.u
.cl
->length
8962 && !sym
->ts
.deferred
8963 && target
->expr_type
== EXPR_CONSTANT
)
8965 sym
->ts
.u
.cl
->length
=
8966 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8967 target
->value
.character
.length
);
8969 else if ((!sym
->ts
.u
.cl
->length
8970 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8971 && target
->expr_type
!= EXPR_VARIABLE
)
8973 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8974 sym
->ts
.deferred
= 1;
8976 /* This is reset in trans-stmt.c after the assignment
8977 of the target expression to the associate name. */
8978 sym
->attr
.allocatable
= 1;
8982 /* If the target is a good class object, so is the associate variable. */
8983 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8984 sym
->attr
.class_ok
= 1;
8988 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8989 array reference, where necessary. The symbols are artificial and so
8990 the dimension attribute and arrayspec can also be set. In addition,
8991 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8992 This is corrected here as well.*/
8995 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8996 int rank
, gfc_ref
*ref
)
8998 gfc_ref
*nref
= (*expr1
)->ref
;
8999 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
9000 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
9001 (*expr1
)->rank
= rank
;
9002 if (sym1
->ts
.type
== BT_CLASS
)
9004 if ((*expr1
)->ts
.type
!= BT_CLASS
)
9005 (*expr1
)->ts
= sym1
->ts
;
9007 CLASS_DATA (sym1
)->attr
.dimension
= 1;
9008 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
9009 CLASS_DATA (sym1
)->as
9010 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
9014 sym1
->attr
.dimension
= 1;
9015 if (sym1
->as
== NULL
&& sym2
)
9016 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
9019 for (; nref
; nref
= nref
->next
)
9020 if (nref
->next
== NULL
)
9023 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
9024 nref
->next
= gfc_copy_ref (ref
);
9025 else if (ref
&& !nref
)
9026 (*expr1
)->ref
= gfc_copy_ref (ref
);
9031 build_loc_call (gfc_expr
*sym_expr
)
9034 loc_call
= gfc_get_expr ();
9035 loc_call
->expr_type
= EXPR_FUNCTION
;
9036 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
9037 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
9038 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
9039 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
9040 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
9041 loc_call
->ts
.type
= BT_INTEGER
;
9042 loc_call
->ts
.kind
= gfc_index_integer_kind
;
9043 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
9044 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
9045 loc_call
->value
.function
.actual
->expr
= sym_expr
;
9046 loc_call
->where
= sym_expr
->where
;
9050 /* Resolve a SELECT TYPE statement. */
9053 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
9055 gfc_symbol
*selector_type
;
9056 gfc_code
*body
, *new_st
, *if_st
, *tail
;
9057 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
9060 char name
[GFC_MAX_SYMBOL_LEN
];
9064 gfc_ref
* ref
= NULL
;
9065 gfc_expr
*selector_expr
= NULL
;
9067 ns
= code
->ext
.block
.ns
;
9070 /* Check for F03:C813. */
9071 if (code
->expr1
->ts
.type
!= BT_CLASS
9072 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
9074 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9075 "at %L", &code
->loc
);
9079 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
9084 gfc_ref
*ref2
= NULL
;
9085 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
9086 if (ref
->type
== REF_COMPONENT
9087 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
9092 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9093 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9094 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9098 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9099 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9100 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
9103 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
9104 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9106 /* F2008: C803 The selector expression must not be coindexed. */
9107 if (gfc_is_coindexed (code
->expr2
))
9109 gfc_error ("Selector at %L must not be coindexed",
9110 &code
->expr2
->where
);
9117 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9119 if (gfc_is_coindexed (code
->expr1
))
9121 gfc_error ("Selector at %L must not be coindexed",
9122 &code
->expr1
->where
);
9127 /* Loop over TYPE IS / CLASS IS cases. */
9128 for (body
= code
->block
; body
; body
= body
->block
)
9130 c
= body
->ext
.block
.case_list
;
9134 /* Check for repeated cases. */
9135 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9137 gfc_case
*d
= tail
->ext
.block
.case_list
;
9141 if (c
->ts
.type
== d
->ts
.type
9142 && ((c
->ts
.type
== BT_DERIVED
9143 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9144 && !strcmp (c
->ts
.u
.derived
->name
,
9145 d
->ts
.u
.derived
->name
))
9146 || c
->ts
.type
== BT_UNKNOWN
9147 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9148 && c
->ts
.kind
== d
->ts
.kind
)))
9150 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9151 &c
->where
, &d
->where
);
9157 /* Check F03:C815. */
9158 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9159 && !selector_type
->attr
.unlimited_polymorphic
9160 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9162 gfc_error ("Derived type %qs at %L must be extensible",
9163 c
->ts
.u
.derived
->name
, &c
->where
);
9168 /* Check F03:C816. */
9169 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
9170 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9171 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9173 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9174 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9175 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9177 gfc_error ("Unexpected intrinsic type %qs at %L",
9178 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9183 /* Check F03:C814. */
9184 if (c
->ts
.type
== BT_CHARACTER
9185 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9187 gfc_error ("The type-spec at %L shall specify that each length "
9188 "type parameter is assumed", &c
->where
);
9193 /* Intercept the DEFAULT case. */
9194 if (c
->ts
.type
== BT_UNKNOWN
)
9196 /* Check F03:C818. */
9199 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9200 "by a second DEFAULT CASE at %L",
9201 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9206 default_case
= body
;
9213 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9214 target if present. If there are any EXIT statements referring to the
9215 SELECT TYPE construct, this is no problem because the gfc_code
9216 reference stays the same and EXIT is equally possible from the BLOCK
9217 it is changed to. */
9218 code
->op
= EXEC_BLOCK
;
9221 gfc_association_list
* assoc
;
9223 assoc
= gfc_get_association_list ();
9224 assoc
->st
= code
->expr1
->symtree
;
9225 assoc
->target
= gfc_copy_expr (code
->expr2
);
9226 assoc
->target
->where
= code
->expr2
->where
;
9227 /* assoc->variable will be set by resolve_assoc_var. */
9229 code
->ext
.block
.assoc
= assoc
;
9230 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9232 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9235 code
->ext
.block
.assoc
= NULL
;
9237 /* Ensure that the selector rank and arrayspec are available to
9238 correct expressions in which they might be missing. */
9239 if (code
->expr2
&& code
->expr2
->rank
)
9241 rank
= code
->expr2
->rank
;
9242 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9243 if (ref
->next
== NULL
)
9245 if (ref
&& ref
->type
== REF_ARRAY
)
9246 ref
= gfc_copy_ref (ref
);
9248 /* Fixup expr1 if necessary. */
9250 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9252 else if (code
->expr1
->rank
)
9254 rank
= code
->expr1
->rank
;
9255 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9256 if (ref
->next
== NULL
)
9258 if (ref
&& ref
->type
== REF_ARRAY
)
9259 ref
= gfc_copy_ref (ref
);
9262 /* Add EXEC_SELECT to switch on type. */
9263 new_st
= gfc_get_code (code
->op
);
9264 new_st
->expr1
= code
->expr1
;
9265 new_st
->expr2
= code
->expr2
;
9266 new_st
->block
= code
->block
;
9267 code
->expr1
= code
->expr2
= NULL
;
9272 ns
->code
->next
= new_st
;
9274 code
->op
= EXEC_SELECT_TYPE
;
9276 /* Use the intrinsic LOC function to generate an integer expression
9277 for the vtable of the selector. Note that the rank of the selector
9278 expression has to be set to zero. */
9279 gfc_add_vptr_component (code
->expr1
);
9280 code
->expr1
->rank
= 0;
9281 code
->expr1
= build_loc_call (code
->expr1
);
9282 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9284 /* Loop over TYPE IS / CLASS IS cases. */
9285 for (body
= code
->block
; body
; body
= body
->block
)
9289 c
= body
->ext
.block
.case_list
;
9291 /* Generate an index integer expression for address of the
9292 TYPE/CLASS vtable and store it in c->low. The hash expression
9293 is stored in c->high and is used to resolve intrinsic cases. */
9294 if (c
->ts
.type
!= BT_UNKNOWN
)
9296 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9298 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9300 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9301 c
->ts
.u
.derived
->hash_value
);
9305 vtab
= gfc_find_vtab (&c
->ts
);
9306 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9307 e
= CLASS_DATA (vtab
)->initializer
;
9308 c
->high
= gfc_copy_expr (e
);
9309 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9312 ts
.kind
= gfc_integer_4_kind
;
9313 ts
.type
= BT_INTEGER
;
9314 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9318 e
= gfc_lval_expr_from_sym (vtab
);
9319 c
->low
= build_loc_call (e
);
9324 /* Associate temporary to selector. This should only be done
9325 when this case is actually true, so build a new ASSOCIATE
9326 that does precisely this here (instead of using the
9329 if (c
->ts
.type
== BT_CLASS
)
9330 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9331 else if (c
->ts
.type
== BT_DERIVED
)
9332 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9333 else if (c
->ts
.type
== BT_CHARACTER
)
9335 HOST_WIDE_INT charlen
= 0;
9336 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9337 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9338 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9339 snprintf (name
, sizeof (name
),
9340 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9341 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9344 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9347 st
= gfc_find_symtree (ns
->sym_root
, name
);
9348 gcc_assert (st
->n
.sym
->assoc
);
9349 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9350 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9351 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9353 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9354 /* Fixup the target expression if necessary. */
9356 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9359 new_st
= gfc_get_code (EXEC_BLOCK
);
9360 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9361 new_st
->ext
.block
.ns
->code
= body
->next
;
9362 body
->next
= new_st
;
9364 /* Chain in the new list only if it is marked as dangling. Otherwise
9365 there is a CASE label overlap and this is already used. Just ignore,
9366 the error is diagnosed elsewhere. */
9367 if (st
->n
.sym
->assoc
->dangling
)
9369 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9370 st
->n
.sym
->assoc
->dangling
= 0;
9373 resolve_assoc_var (st
->n
.sym
, false);
9376 /* Take out CLASS IS cases for separate treatment. */
9378 while (body
&& body
->block
)
9380 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9382 /* Add to class_is list. */
9383 if (class_is
== NULL
)
9385 class_is
= body
->block
;
9390 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9391 tail
->block
= body
->block
;
9394 /* Remove from EXEC_SELECT list. */
9395 body
->block
= body
->block
->block
;
9408 /* Add a default case to hold the CLASS IS cases. */
9409 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9410 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9412 tail
->ext
.block
.case_list
= gfc_get_case ();
9413 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9415 default_case
= tail
;
9418 /* More than one CLASS IS block? */
9419 if (class_is
->block
)
9423 /* Sort CLASS IS blocks by extension level. */
9427 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9430 /* F03:C817 (check for doubles). */
9431 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9432 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9434 gfc_error ("Double CLASS IS block in SELECT TYPE "
9436 &c2
->ext
.block
.case_list
->where
);
9439 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9440 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9443 (*c1
)->block
= c2
->block
;
9453 /* Generate IF chain. */
9454 if_st
= gfc_get_code (EXEC_IF
);
9456 for (body
= class_is
; body
; body
= body
->block
)
9458 new_st
->block
= gfc_get_code (EXEC_IF
);
9459 new_st
= new_st
->block
;
9460 /* Set up IF condition: Call _gfortran_is_extension_of. */
9461 new_st
->expr1
= gfc_get_expr ();
9462 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9463 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9464 new_st
->expr1
->ts
.kind
= 4;
9465 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9466 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9467 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9468 /* Set up arguments. */
9469 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9470 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9471 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9472 new_st
->expr1
->where
= code
->loc
;
9473 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9474 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9475 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9476 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9477 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9478 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9479 new_st
->next
= body
->next
;
9481 if (default_case
->next
)
9483 new_st
->block
= gfc_get_code (EXEC_IF
);
9484 new_st
= new_st
->block
;
9485 new_st
->next
= default_case
->next
;
9488 /* Replace CLASS DEFAULT code by the IF chain. */
9489 default_case
->next
= if_st
;
9492 /* Resolve the internal code. This cannot be done earlier because
9493 it requires that the sym->assoc of selectors is set already. */
9494 gfc_current_ns
= ns
;
9495 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9496 gfc_current_ns
= old_ns
;
9503 /* Resolve a SELECT RANK statement. */
9506 resolve_select_rank (gfc_code
*code
, gfc_namespace
*old_ns
)
9509 gfc_code
*body
, *new_st
, *tail
;
9511 char tname
[GFC_MAX_SYMBOL_LEN
];
9512 char name
[2 * GFC_MAX_SYMBOL_LEN
];
9514 gfc_expr
*selector_expr
= NULL
;
9516 HOST_WIDE_INT charlen
= 0;
9518 ns
= code
->ext
.block
.ns
;
9521 code
->op
= EXEC_BLOCK
;
9524 gfc_association_list
* assoc
;
9526 assoc
= gfc_get_association_list ();
9527 assoc
->st
= code
->expr1
->symtree
;
9528 assoc
->target
= gfc_copy_expr (code
->expr2
);
9529 assoc
->target
->where
= code
->expr2
->where
;
9530 /* assoc->variable will be set by resolve_assoc_var. */
9532 code
->ext
.block
.assoc
= assoc
;
9533 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9535 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9538 code
->ext
.block
.assoc
= NULL
;
9540 /* Loop over RANK cases. Note that returning on the errors causes a
9541 cascade of further errors because the case blocks do not compile
9543 for (body
= code
->block
; body
; body
= body
->block
)
9545 c
= body
->ext
.block
.case_list
;
9547 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9551 /* Check for repeated cases. */
9552 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9554 gfc_case
*d
= tail
->ext
.block
.case_list
;
9560 /* Check F2018: C1153. */
9561 if (!c
->low
&& !d
->low
)
9562 gfc_error ("RANK DEFAULT at %L is repeated at %L",
9563 &c
->where
, &d
->where
);
9565 if (!c
->low
|| !d
->low
)
9568 /* Check F2018: C1153. */
9569 case_value2
= (int) mpz_get_si (d
->low
->value
.integer
);
9570 if ((case_value
== case_value2
) && case_value
== -1)
9571 gfc_error ("RANK (*) at %L is repeated at %L",
9572 &c
->where
, &d
->where
);
9573 else if (case_value
== case_value2
)
9574 gfc_error ("RANK (%i) at %L is repeated at %L",
9575 case_value
, &c
->where
, &d
->where
);
9581 /* Check F2018: C1155. */
9582 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9583 || gfc_expr_attr (code
->expr1
).pointer
))
9584 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9585 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9587 if (case_value
== -1 && (gfc_expr_attr (code
->expr1
).allocatable
9588 || gfc_expr_attr (code
->expr1
).pointer
))
9589 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9590 "allocatable selector at %L", &c
->where
, &code
->expr1
->where
);
9593 /* Add EXEC_SELECT to switch on rank. */
9594 new_st
= gfc_get_code (code
->op
);
9595 new_st
->expr1
= code
->expr1
;
9596 new_st
->expr2
= code
->expr2
;
9597 new_st
->block
= code
->block
;
9598 code
->expr1
= code
->expr2
= NULL
;
9603 ns
->code
->next
= new_st
;
9605 code
->op
= EXEC_SELECT_RANK
;
9607 selector_expr
= code
->expr1
;
9609 /* Loop over SELECT RANK cases. */
9610 for (body
= code
->block
; body
; body
= body
->block
)
9612 c
= body
->ext
.block
.case_list
;
9615 /* Pass on the default case. */
9619 /* Associate temporary to selector. This should only be done
9620 when this case is actually true, so build a new ASSOCIATE
9621 that does precisely this here (instead of using the
9623 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9624 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9625 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9627 if (c
->ts
.type
== BT_CLASS
)
9628 sprintf (tname
, "class_%s", c
->ts
.u
.derived
->name
);
9629 else if (c
->ts
.type
== BT_DERIVED
)
9630 sprintf (tname
, "type_%s", c
->ts
.u
.derived
->name
);
9631 else if (c
->ts
.type
!= BT_CHARACTER
)
9632 sprintf (tname
, "%s_%d", gfc_basic_typename (c
->ts
.type
), c
->ts
.kind
);
9634 sprintf (tname
, "%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9635 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9637 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
9638 if (case_value
>= 0)
9639 sprintf (name
, "__tmp_%s_rank_%d", tname
, case_value
);
9641 sprintf (name
, "__tmp_%s_rank_m%d", tname
, -case_value
);
9643 st
= gfc_find_symtree (ns
->sym_root
, name
);
9644 gcc_assert (st
->n
.sym
->assoc
);
9646 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9647 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9649 new_st
= gfc_get_code (EXEC_BLOCK
);
9650 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9651 new_st
->ext
.block
.ns
->code
= body
->next
;
9652 body
->next
= new_st
;
9654 /* Chain in the new list only if it is marked as dangling. Otherwise
9655 there is a CASE label overlap and this is already used. Just ignore,
9656 the error is diagnosed elsewhere. */
9657 if (st
->n
.sym
->assoc
->dangling
)
9659 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9660 st
->n
.sym
->assoc
->dangling
= 0;
9663 resolve_assoc_var (st
->n
.sym
, false);
9666 gfc_current_ns
= ns
;
9667 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9668 gfc_current_ns
= old_ns
;
9672 /* Resolve a transfer statement. This is making sure that:
9673 -- a derived type being transferred has only non-pointer components
9674 -- a derived type being transferred doesn't have private components, unless
9675 it's being transferred from the module where the type was defined
9676 -- we're not trying to transfer a whole assumed size array. */
9679 resolve_transfer (gfc_code
*code
)
9681 gfc_symbol
*sym
, *derived
;
9685 bool formatted
= false;
9686 gfc_dt
*dt
= code
->ext
.dt
;
9687 gfc_symbol
*dtio_sub
= NULL
;
9691 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9692 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9693 exp
= exp
->value
.op
.op1
;
9695 if (exp
&& exp
->expr_type
== EXPR_NULL
9698 gfc_error ("Invalid context for NULL () intrinsic at %L",
9703 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9704 && exp
->expr_type
!= EXPR_FUNCTION
9705 && exp
->expr_type
!= EXPR_STRUCTURE
))
9708 /* If we are reading, the variable will be changed. Note that
9709 code->ext.dt may be NULL if the TRANSFER is related to
9710 an INQUIRE statement -- but in this case, we are not reading, either. */
9711 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9712 && !gfc_check_vardef_context (exp
, false, false, false,
9716 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
9717 || exp
->expr_type
== EXPR_FUNCTION
9718 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9720 /* Go to actual component transferred. */
9721 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9722 if (ref
->type
== REF_COMPONENT
)
9723 ts
= &ref
->u
.c
.component
->ts
;
9725 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9726 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9728 derived
= ts
->u
.derived
;
9730 /* Determine when to use the formatted DTIO procedure. */
9731 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9734 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9735 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9736 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9738 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9741 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9742 /* Check to see if this is a nested DTIO call, with the
9743 dummy as the io-list object. */
9744 if (sym
&& sym
== dtio_sub
&& sym
->formal
9745 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9746 && exp
->ref
== NULL
)
9748 if (!sym
->attr
.recursive
)
9750 gfc_error ("DTIO %s procedure at %L must be recursive",
9751 sym
->name
, &sym
->declared_at
);
9758 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9760 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9761 "it is processed by a defined input/output procedure",
9766 if (ts
->type
== BT_DERIVED
)
9768 /* Check that transferred derived type doesn't contain POINTER
9769 components unless it is processed by a defined input/output
9771 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9773 gfc_error ("Data transfer element at %L cannot have POINTER "
9774 "components unless it is processed by a defined "
9775 "input/output procedure", &code
->loc
);
9780 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9782 gfc_error ("Data transfer element at %L cannot have "
9783 "procedure pointer components", &code
->loc
);
9787 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9789 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9790 "components unless it is processed by a defined "
9791 "input/output procedure", &code
->loc
);
9795 /* C_PTR and C_FUNPTR have private components which means they cannot
9796 be printed. However, if -std=gnu and not -pedantic, allow
9797 the component to be printed to help debugging. */
9798 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9800 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9801 "cannot have PRIVATE components", &code
->loc
))
9804 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9806 gfc_error ("Data transfer element at %L cannot have "
9807 "PRIVATE components unless it is processed by "
9808 "a defined input/output procedure", &code
->loc
);
9813 if (exp
->expr_type
== EXPR_STRUCTURE
)
9816 sym
= exp
->symtree
->n
.sym
;
9818 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9819 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9821 gfc_error ("Data transfer element at %L cannot be a full reference to "
9822 "an assumed-size array", &code
->loc
);
9826 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9827 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9831 /*********** Toplevel code resolution subroutines ***********/
9833 /* Find the set of labels that are reachable from this block. We also
9834 record the last statement in each block. */
9837 find_reachable_labels (gfc_code
*block
)
9844 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9846 /* Collect labels in this block. We don't keep those corresponding
9847 to END {IF|SELECT}, these are checked in resolve_branch by going
9848 up through the code_stack. */
9849 for (c
= block
; c
; c
= c
->next
)
9851 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9852 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9855 /* Merge with labels from parent block. */
9858 gcc_assert (cs_base
->prev
->reachable_labels
);
9859 bitmap_ior_into (cs_base
->reachable_labels
,
9860 cs_base
->prev
->reachable_labels
);
9866 resolve_lock_unlock_event (gfc_code
*code
)
9868 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9869 && code
->expr1
->value
.function
.isym
9870 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9871 remove_caf_get_intrinsic (code
->expr1
);
9873 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9874 && (code
->expr1
->ts
.type
!= BT_DERIVED
9875 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9876 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9877 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9878 || code
->expr1
->rank
!= 0
9879 || (!gfc_is_coarray (code
->expr1
) &&
9880 !gfc_is_coindexed (code
->expr1
))))
9881 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9882 &code
->expr1
->where
);
9883 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9884 && (code
->expr1
->ts
.type
!= BT_DERIVED
9885 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9886 || code
->expr1
->ts
.u
.derived
->from_intmod
9887 != INTMOD_ISO_FORTRAN_ENV
9888 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9889 != ISOFORTRAN_EVENT_TYPE
9890 || code
->expr1
->rank
!= 0))
9891 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9892 &code
->expr1
->where
);
9893 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9894 && !gfc_is_coindexed (code
->expr1
))
9895 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9896 &code
->expr1
->where
);
9897 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9898 gfc_error ("Event variable argument at %L must be a coarray but not "
9899 "coindexed", &code
->expr1
->where
);
9903 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9904 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9905 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9906 &code
->expr2
->where
);
9909 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9910 _("STAT variable")))
9915 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9916 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9917 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9918 &code
->expr3
->where
);
9921 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9922 _("ERRMSG variable")))
9925 /* Check for LOCK the ACQUIRED_LOCK. */
9926 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9927 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9928 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9929 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9930 "variable", &code
->expr4
->where
);
9932 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9933 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9934 _("ACQUIRED_LOCK variable")))
9937 /* Check for EVENT WAIT the UNTIL_COUNT. */
9938 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9940 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9941 || code
->expr4
->rank
!= 0)
9942 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9943 "expression", &code
->expr4
->where
);
9949 resolve_critical (gfc_code
*code
)
9951 gfc_symtree
*symtree
;
9952 gfc_symbol
*lock_type
;
9953 char name
[GFC_MAX_SYMBOL_LEN
];
9954 static int serial
= 0;
9956 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9959 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9960 GFC_PREFIX ("lock_type"));
9962 lock_type
= symtree
->n
.sym
;
9965 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9968 lock_type
= symtree
->n
.sym
;
9969 lock_type
->attr
.flavor
= FL_DERIVED
;
9970 lock_type
->attr
.zero_comp
= 1;
9971 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9972 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9975 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9976 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9979 code
->resolved_sym
= symtree
->n
.sym
;
9980 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9981 symtree
->n
.sym
->attr
.referenced
= 1;
9982 symtree
->n
.sym
->attr
.artificial
= 1;
9983 symtree
->n
.sym
->attr
.codimension
= 1;
9984 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9985 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9986 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9987 symtree
->n
.sym
->as
->corank
= 1;
9988 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9989 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9990 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9992 gfc_commit_symbols();
9997 resolve_sync (gfc_code
*code
)
9999 /* Check imageset. The * case matches expr1 == NULL. */
10002 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
10003 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
10004 "INTEGER expression", &code
->expr1
->where
);
10005 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
10006 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
10007 gfc_error ("Imageset argument at %L must between 1 and num_images()",
10008 &code
->expr1
->where
);
10009 else if (code
->expr1
->expr_type
== EXPR_ARRAY
10010 && gfc_simplify_expr (code
->expr1
, 0))
10012 gfc_constructor
*cons
;
10013 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
10014 for (; cons
; cons
= gfc_constructor_next (cons
))
10015 if (cons
->expr
->expr_type
== EXPR_CONSTANT
10016 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
10017 gfc_error ("Imageset argument at %L must between 1 and "
10018 "num_images()", &cons
->expr
->where
);
10023 gfc_resolve_expr (code
->expr2
);
10025 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
10026 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
10027 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10028 &code
->expr2
->where
);
10030 /* Check ERRMSG. */
10031 gfc_resolve_expr (code
->expr3
);
10033 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
10034 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
10035 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10036 &code
->expr3
->where
);
10040 /* Given a branch to a label, see if the branch is conforming.
10041 The code node describes where the branch is located. */
10044 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
10051 /* Step one: is this a valid branching target? */
10053 if (label
->defined
== ST_LABEL_UNKNOWN
)
10055 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
10060 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
10062 gfc_error ("Statement at %L is not a valid branch target statement "
10063 "for the branch statement at %L", &label
->where
, &code
->loc
);
10067 /* Step two: make sure this branch is not a branch to itself ;-) */
10069 if (code
->here
== label
)
10072 "Branch at %L may result in an infinite loop", &code
->loc
);
10076 /* Step three: See if the label is in the same block as the
10077 branching statement. The hard work has been done by setting up
10078 the bitmap reachable_labels. */
10080 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
10082 /* Check now whether there is a CRITICAL construct; if so, check
10083 whether the label is still visible outside of the CRITICAL block,
10084 which is invalid. */
10085 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10087 if (stack
->current
->op
== EXEC_CRITICAL
10088 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10089 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
10090 "label at %L", &code
->loc
, &label
->where
);
10091 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
10092 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
10093 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
10094 "for label at %L", &code
->loc
, &label
->where
);
10100 /* Step four: If we haven't found the label in the bitmap, it may
10101 still be the label of the END of the enclosing block, in which
10102 case we find it by going up the code_stack. */
10104 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
10106 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
10108 if (stack
->current
->op
== EXEC_CRITICAL
)
10110 /* Note: A label at END CRITICAL does not leave the CRITICAL
10111 construct as END CRITICAL is still part of it. */
10112 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
10113 " at %L", &code
->loc
, &label
->where
);
10116 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
10118 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
10119 "label at %L", &code
->loc
, &label
->where
);
10126 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
10130 /* The label is not in an enclosing block, so illegal. This was
10131 allowed in Fortran 66, so we allow it as extension. No
10132 further checks are necessary in this case. */
10133 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
10134 "as the GOTO statement at %L", &label
->where
,
10140 /* Check whether EXPR1 has the same shape as EXPR2. */
10143 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
10145 mpz_t shape
[GFC_MAX_DIMENSIONS
];
10146 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
10147 bool result
= false;
10150 /* Compare the rank. */
10151 if (expr1
->rank
!= expr2
->rank
)
10154 /* Compare the size of each dimension. */
10155 for (i
=0; i
<expr1
->rank
; i
++)
10157 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
10160 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
10163 if (mpz_cmp (shape
[i
], shape2
[i
]))
10167 /* When either of the two expression is an assumed size array, we
10168 ignore the comparison of dimension sizes. */
10173 gfc_clear_shape (shape
, i
);
10174 gfc_clear_shape (shape2
, i
);
10179 /* Check whether a WHERE assignment target or a WHERE mask expression
10180 has the same shape as the outmost WHERE mask expression. */
10183 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
10187 gfc_expr
*e
= NULL
;
10189 cblock
= code
->block
;
10191 /* Store the first WHERE mask-expr of the WHERE statement or construct.
10192 In case of nested WHERE, only the outmost one is stored. */
10193 if (mask
== NULL
) /* outmost WHERE */
10195 else /* inner WHERE */
10202 /* Check if the mask-expr has a consistent shape with the
10203 outmost WHERE mask-expr. */
10204 if (!resolve_where_shape (cblock
->expr1
, e
))
10205 gfc_error ("WHERE mask at %L has inconsistent shape",
10206 &cblock
->expr1
->where
);
10209 /* the assignment statement of a WHERE statement, or the first
10210 statement in where-body-construct of a WHERE construct */
10211 cnext
= cblock
->next
;
10216 /* WHERE assignment statement */
10219 /* Check shape consistent for WHERE assignment target. */
10220 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
10221 gfc_error ("WHERE assignment target at %L has "
10222 "inconsistent shape", &cnext
->expr1
->where
);
10226 case EXEC_ASSIGN_CALL
:
10227 resolve_call (cnext
);
10228 if (!cnext
->resolved_sym
->attr
.elemental
)
10229 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10230 &cnext
->ext
.actual
->expr
->where
);
10233 /* WHERE or WHERE construct is part of a where-body-construct */
10235 resolve_where (cnext
, e
);
10239 gfc_error ("Unsupported statement inside WHERE at %L",
10242 /* the next statement within the same where-body-construct */
10243 cnext
= cnext
->next
;
10245 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10246 cblock
= cblock
->block
;
10251 /* Resolve assignment in FORALL construct.
10252 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10253 FORALL index variables. */
10256 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10260 for (n
= 0; n
< nvar
; n
++)
10262 gfc_symbol
*forall_index
;
10264 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10266 /* Check whether the assignment target is one of the FORALL index
10268 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10269 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10270 gfc_error ("Assignment to a FORALL index variable at %L",
10271 &code
->expr1
->where
);
10274 /* If one of the FORALL index variables doesn't appear in the
10275 assignment variable, then there could be a many-to-one
10276 assignment. Emit a warning rather than an error because the
10277 mask could be resolving this problem. */
10278 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10279 gfc_warning (0, "The FORALL with index %qs is not used on the "
10280 "left side of the assignment at %L and so might "
10281 "cause multiple assignment to this object",
10282 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10288 /* Resolve WHERE statement in FORALL construct. */
10291 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10292 gfc_expr
**var_expr
)
10297 cblock
= code
->block
;
10300 /* the assignment statement of a WHERE statement, or the first
10301 statement in where-body-construct of a WHERE construct */
10302 cnext
= cblock
->next
;
10307 /* WHERE assignment statement */
10309 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10312 /* WHERE operator assignment statement */
10313 case EXEC_ASSIGN_CALL
:
10314 resolve_call (cnext
);
10315 if (!cnext
->resolved_sym
->attr
.elemental
)
10316 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10317 &cnext
->ext
.actual
->expr
->where
);
10320 /* WHERE or WHERE construct is part of a where-body-construct */
10322 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10326 gfc_error ("Unsupported statement inside WHERE at %L",
10329 /* the next statement within the same where-body-construct */
10330 cnext
= cnext
->next
;
10332 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10333 cblock
= cblock
->block
;
10338 /* Traverse the FORALL body to check whether the following errors exist:
10339 1. For assignment, check if a many-to-one assignment happens.
10340 2. For WHERE statement, check the WHERE body to see if there is any
10341 many-to-one assignment. */
10344 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10348 c
= code
->block
->next
;
10354 case EXEC_POINTER_ASSIGN
:
10355 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10358 case EXEC_ASSIGN_CALL
:
10362 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10363 there is no need to handle it here. */
10367 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10372 /* The next statement in the FORALL body. */
10378 /* Counts the number of iterators needed inside a forall construct, including
10379 nested forall constructs. This is used to allocate the needed memory
10380 in gfc_resolve_forall. */
10383 gfc_count_forall_iterators (gfc_code
*code
)
10385 int max_iters
, sub_iters
, current_iters
;
10386 gfc_forall_iterator
*fa
;
10388 gcc_assert(code
->op
== EXEC_FORALL
);
10392 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10395 code
= code
->block
->next
;
10399 if (code
->op
== EXEC_FORALL
)
10401 sub_iters
= gfc_count_forall_iterators (code
);
10402 if (sub_iters
> max_iters
)
10403 max_iters
= sub_iters
;
10408 return current_iters
+ max_iters
;
10412 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10413 gfc_resolve_forall_body to resolve the FORALL body. */
10416 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10418 static gfc_expr
**var_expr
;
10419 static int total_var
= 0;
10420 static int nvar
= 0;
10421 int i
, old_nvar
, tmp
;
10422 gfc_forall_iterator
*fa
;
10426 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10429 /* Start to resolve a FORALL construct */
10430 if (forall_save
== 0)
10432 /* Count the total number of FORALL indices in the nested FORALL
10433 construct in order to allocate the VAR_EXPR with proper size. */
10434 total_var
= gfc_count_forall_iterators (code
);
10436 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10437 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10440 /* The information about FORALL iterator, including FORALL indices start, end
10441 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10442 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10444 /* Fortran 20008: C738 (R753). */
10445 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10447 gfc_error ("FORALL index-name at %L must be a scalar variable "
10448 "of type integer", &fa
->var
->where
);
10452 /* Check if any outer FORALL index name is the same as the current
10454 for (i
= 0; i
< nvar
; i
++)
10456 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10457 gfc_error ("An outer FORALL construct already has an index "
10458 "with this name %L", &fa
->var
->where
);
10461 /* Record the current FORALL index. */
10462 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10466 /* No memory leak. */
10467 gcc_assert (nvar
<= total_var
);
10470 /* Resolve the FORALL body. */
10471 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10473 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10474 gfc_resolve_blocks (code
->block
, ns
);
10478 /* Free only the VAR_EXPRs allocated in this frame. */
10479 for (i
= nvar
; i
< tmp
; i
++)
10480 gfc_free_expr (var_expr
[i
]);
10484 /* We are in the outermost FORALL construct. */
10485 gcc_assert (forall_save
== 0);
10487 /* VAR_EXPR is not needed any more. */
10494 /* Resolve a BLOCK construct statement. */
10497 resolve_block_construct (gfc_code
* code
)
10499 /* Resolve the BLOCK's namespace. */
10500 gfc_resolve (code
->ext
.block
.ns
);
10502 /* For an ASSOCIATE block, the associations (and their targets) are already
10503 resolved during resolve_symbol. */
10507 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10511 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10515 for (; b
; b
= b
->block
)
10517 t
= gfc_resolve_expr (b
->expr1
);
10518 if (!gfc_resolve_expr (b
->expr2
))
10524 if (t
&& b
->expr1
!= NULL
10525 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10526 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10532 && b
->expr1
!= NULL
10533 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10534 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10539 resolve_branch (b
->label1
, b
);
10543 resolve_block_construct (b
);
10547 case EXEC_SELECT_TYPE
:
10548 case EXEC_SELECT_RANK
:
10551 case EXEC_DO_WHILE
:
10552 case EXEC_DO_CONCURRENT
:
10553 case EXEC_CRITICAL
:
10556 case EXEC_IOLENGTH
:
10560 case EXEC_OMP_ATOMIC
:
10561 case EXEC_OACC_ATOMIC
:
10563 gfc_omp_atomic_op aop
10564 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10566 /* Verify this before calling gfc_resolve_code, which might
10568 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10569 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10570 && b
->next
->next
== NULL
)
10571 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10572 && b
->next
->next
!= NULL
10573 && b
->next
->next
->op
== EXEC_ASSIGN
10574 && b
->next
->next
->next
== NULL
));
10578 case EXEC_OACC_PARALLEL_LOOP
:
10579 case EXEC_OACC_PARALLEL
:
10580 case EXEC_OACC_KERNELS_LOOP
:
10581 case EXEC_OACC_KERNELS
:
10582 case EXEC_OACC_DATA
:
10583 case EXEC_OACC_HOST_DATA
:
10584 case EXEC_OACC_LOOP
:
10585 case EXEC_OACC_UPDATE
:
10586 case EXEC_OACC_WAIT
:
10587 case EXEC_OACC_CACHE
:
10588 case EXEC_OACC_ENTER_DATA
:
10589 case EXEC_OACC_EXIT_DATA
:
10590 case EXEC_OACC_ROUTINE
:
10591 case EXEC_OMP_CRITICAL
:
10592 case EXEC_OMP_DISTRIBUTE
:
10593 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10594 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10595 case EXEC_OMP_DISTRIBUTE_SIMD
:
10597 case EXEC_OMP_DO_SIMD
:
10598 case EXEC_OMP_MASTER
:
10599 case EXEC_OMP_ORDERED
:
10600 case EXEC_OMP_PARALLEL
:
10601 case EXEC_OMP_PARALLEL_DO
:
10602 case EXEC_OMP_PARALLEL_DO_SIMD
:
10603 case EXEC_OMP_PARALLEL_SECTIONS
:
10604 case EXEC_OMP_PARALLEL_WORKSHARE
:
10605 case EXEC_OMP_SECTIONS
:
10606 case EXEC_OMP_SIMD
:
10607 case EXEC_OMP_SINGLE
:
10608 case EXEC_OMP_TARGET
:
10609 case EXEC_OMP_TARGET_DATA
:
10610 case EXEC_OMP_TARGET_ENTER_DATA
:
10611 case EXEC_OMP_TARGET_EXIT_DATA
:
10612 case EXEC_OMP_TARGET_PARALLEL
:
10613 case EXEC_OMP_TARGET_PARALLEL_DO
:
10614 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10615 case EXEC_OMP_TARGET_SIMD
:
10616 case EXEC_OMP_TARGET_TEAMS
:
10617 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10618 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10619 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10620 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10621 case EXEC_OMP_TARGET_UPDATE
:
10622 case EXEC_OMP_TASK
:
10623 case EXEC_OMP_TASKGROUP
:
10624 case EXEC_OMP_TASKLOOP
:
10625 case EXEC_OMP_TASKLOOP_SIMD
:
10626 case EXEC_OMP_TASKWAIT
:
10627 case EXEC_OMP_TASKYIELD
:
10628 case EXEC_OMP_TEAMS
:
10629 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10630 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10631 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10632 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10633 case EXEC_OMP_WORKSHARE
:
10637 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10640 gfc_resolve_code (b
->next
, ns
);
10645 /* Does everything to resolve an ordinary assignment. Returns true
10646 if this is an interface assignment. */
10648 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10655 symbol_attribute attr
;
10657 if (gfc_extend_assign (code
, ns
))
10661 if (code
->op
== EXEC_ASSIGN_CALL
)
10663 lhs
= code
->ext
.actual
->expr
;
10664 rhsptr
= &code
->ext
.actual
->next
->expr
;
10668 gfc_actual_arglist
* args
;
10669 gfc_typebound_proc
* tbp
;
10671 gcc_assert (code
->op
== EXEC_COMPCALL
);
10673 args
= code
->expr1
->value
.compcall
.actual
;
10675 rhsptr
= &args
->next
->expr
;
10677 tbp
= code
->expr1
->value
.compcall
.tbp
;
10678 gcc_assert (!tbp
->is_generic
);
10681 /* Make a temporary rhs when there is a default initializer
10682 and rhs is the same symbol as the lhs. */
10683 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10684 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10685 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10686 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10687 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10695 /* Handle the case of a BOZ literal on the RHS. */
10696 if (rhs
->ts
.type
== BT_BOZ
)
10698 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
10699 "statement value nor an actual argument of "
10700 "INT/REAL/DBLE/CMPLX intrinsic subprogram",
10704 switch (lhs
->ts
.type
)
10707 if (!gfc_boz2int (rhs
, lhs
->ts
.kind
))
10711 if (!gfc_boz2real (rhs
, lhs
->ts
.kind
))
10715 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs
->where
);
10720 if (lhs
->ts
.type
== BT_CHARACTER
&& warn_character_truncation
)
10722 HOST_WIDE_INT llen
= 0, rlen
= 0;
10723 if (lhs
->ts
.u
.cl
!= NULL
10724 && lhs
->ts
.u
.cl
->length
!= NULL
10725 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10726 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10728 if (rhs
->expr_type
== EXPR_CONSTANT
)
10729 rlen
= rhs
->value
.character
.length
;
10731 else if (rhs
->ts
.u
.cl
!= NULL
10732 && rhs
->ts
.u
.cl
->length
!= NULL
10733 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10734 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10736 if (rlen
&& llen
&& rlen
> llen
)
10737 gfc_warning_now (OPT_Wcharacter_truncation
,
10738 "CHARACTER expression will be truncated "
10739 "in assignment (%ld/%ld) at %L",
10740 (long) llen
, (long) rlen
, &code
->loc
);
10743 /* Ensure that a vector index expression for the lvalue is evaluated
10744 to a temporary if the lvalue symbol is referenced in it. */
10747 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10748 if (ref
->type
== REF_ARRAY
)
10750 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10751 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10752 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10753 ref
->u
.ar
.start
[n
]))
10755 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10759 if (gfc_pure (NULL
))
10761 if (lhs
->ts
.type
== BT_DERIVED
10762 && lhs
->expr_type
== EXPR_VARIABLE
10763 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10764 && rhs
->expr_type
== EXPR_VARIABLE
10765 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10766 || gfc_is_coindexed (rhs
)))
10768 /* F2008, C1283. */
10769 if (gfc_is_coindexed (rhs
))
10770 gfc_error ("Coindexed expression at %L is assigned to "
10771 "a derived type variable with a POINTER "
10772 "component in a PURE procedure",
10775 gfc_error ("The impure variable at %L is assigned to "
10776 "a derived type variable with a POINTER "
10777 "component in a PURE procedure (12.6)",
10782 /* Fortran 2008, C1283. */
10783 if (gfc_is_coindexed (lhs
))
10785 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10786 "procedure", &rhs
->where
);
10791 if (gfc_implicit_pure (NULL
))
10793 if (lhs
->expr_type
== EXPR_VARIABLE
10794 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10795 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10796 gfc_unset_implicit_pure (NULL
);
10798 if (lhs
->ts
.type
== BT_DERIVED
10799 && lhs
->expr_type
== EXPR_VARIABLE
10800 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10801 && rhs
->expr_type
== EXPR_VARIABLE
10802 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10803 || gfc_is_coindexed (rhs
)))
10804 gfc_unset_implicit_pure (NULL
);
10806 /* Fortran 2008, C1283. */
10807 if (gfc_is_coindexed (lhs
))
10808 gfc_unset_implicit_pure (NULL
);
10811 /* F2008, 7.2.1.2. */
10812 attr
= gfc_expr_attr (lhs
);
10813 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10815 if (attr
.codimension
)
10817 gfc_error ("Assignment to polymorphic coarray at %L is not "
10818 "permitted", &lhs
->where
);
10821 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10822 "polymorphic variable at %L", &lhs
->where
))
10824 if (!flag_realloc_lhs
)
10826 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10827 "requires %<-frealloc-lhs%>", &lhs
->where
);
10831 else if (lhs
->ts
.type
== BT_CLASS
)
10833 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10834 "assignment at %L - check that there is a matching specific "
10835 "subroutine for '=' operator", &lhs
->where
);
10839 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10841 /* F2008, Section 7.2.1.2. */
10842 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10844 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10845 "component in assignment at %L", &lhs
->where
);
10849 /* Assign the 'data' of a class object to a derived type. */
10850 if (lhs
->ts
.type
== BT_DERIVED
10851 && rhs
->ts
.type
== BT_CLASS
10852 && rhs
->expr_type
!= EXPR_ARRAY
)
10853 gfc_add_data_component (rhs
);
10855 /* Make sure there is a vtable and, in particular, a _copy for the
10857 if (UNLIMITED_POLY (lhs
) && lhs
->rank
&& rhs
->ts
.type
!= BT_CLASS
)
10858 gfc_find_vtab (&rhs
->ts
);
10860 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10862 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10863 && code
->expr2
->value
.function
.isym
10864 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10865 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10866 && !gfc_expr_attr (rhs
).allocatable
10867 && !gfc_has_vector_subscript (rhs
)));
10869 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10871 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10872 Additionally, insert this code when the RHS is a CAF as we then use the
10873 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10874 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10875 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10877 if (caf_convert_to_send
)
10879 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10880 && code
->expr2
->value
.function
.isym
10881 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10882 remove_caf_get_intrinsic (code
->expr2
);
10883 code
->op
= EXEC_CALL
;
10884 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10885 code
->resolved_sym
= code
->symtree
->n
.sym
;
10886 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10887 code
->resolved_sym
->attr
.intrinsic
= 1;
10888 code
->resolved_sym
->attr
.subroutine
= 1;
10889 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10890 gfc_commit_symbol (code
->resolved_sym
);
10891 code
->ext
.actual
= gfc_get_actual_arglist ();
10892 code
->ext
.actual
->expr
= lhs
;
10893 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10894 code
->ext
.actual
->next
->expr
= rhs
;
10895 code
->expr1
= NULL
;
10896 code
->expr2
= NULL
;
10903 /* Add a component reference onto an expression. */
10906 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10911 ref
= &((*ref
)->next
);
10912 *ref
= gfc_get_ref ();
10913 (*ref
)->type
= REF_COMPONENT
;
10914 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10915 (*ref
)->u
.c
.component
= c
;
10918 /* Add a full array ref, as necessary. */
10921 gfc_add_full_array_ref (e
, c
->as
);
10922 e
->rank
= c
->as
->rank
;
10927 /* Build an assignment. Keep the argument 'op' for future use, so that
10928 pointer assignments can be made. */
10931 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10932 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10934 gfc_code
*this_code
;
10936 this_code
= gfc_get_code (op
);
10937 this_code
->next
= NULL
;
10938 this_code
->expr1
= gfc_copy_expr (expr1
);
10939 this_code
->expr2
= gfc_copy_expr (expr2
);
10940 this_code
->loc
= loc
;
10941 if (comp1
&& comp2
)
10943 add_comp_ref (this_code
->expr1
, comp1
);
10944 add_comp_ref (this_code
->expr2
, comp2
);
10951 /* Makes a temporary variable expression based on the characteristics of
10952 a given variable expression. */
10955 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10957 static int serial
= 0;
10958 char name
[GFC_MAX_SYMBOL_LEN
];
10960 gfc_array_spec
*as
;
10961 gfc_array_ref
*aref
;
10964 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10965 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10966 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10968 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
10969 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
10971 e
->value
.character
.length
);
10977 /* Obtain the arrayspec for the temporary. */
10978 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10979 && e
->expr_type
!= EXPR_FUNCTION
10980 && e
->expr_type
!= EXPR_OP
)
10982 aref
= gfc_find_array_ref (e
);
10983 if (e
->expr_type
== EXPR_VARIABLE
10984 && e
->symtree
->n
.sym
->as
== aref
->as
)
10988 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10989 if (ref
->type
== REF_COMPONENT
10990 && ref
->u
.c
.component
->as
== aref
->as
)
10998 /* Add the attributes and the arrayspec to the temporary. */
10999 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
11000 tmp
->n
.sym
->attr
.function
= 0;
11001 tmp
->n
.sym
->attr
.result
= 0;
11002 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
11003 tmp
->n
.sym
->attr
.dummy
= 0;
11004 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
11008 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
11011 if (as
->type
== AS_DEFERRED
)
11012 tmp
->n
.sym
->attr
.allocatable
= 1;
11014 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
11015 || e
->expr_type
== EXPR_FUNCTION
11016 || e
->expr_type
== EXPR_OP
))
11018 tmp
->n
.sym
->as
= gfc_get_array_spec ();
11019 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
11020 tmp
->n
.sym
->as
->rank
= e
->rank
;
11021 tmp
->n
.sym
->attr
.allocatable
= 1;
11022 tmp
->n
.sym
->attr
.dimension
= 1;
11025 tmp
->n
.sym
->attr
.dimension
= 0;
11027 gfc_set_sym_referenced (tmp
->n
.sym
);
11028 gfc_commit_symbol (tmp
->n
.sym
);
11029 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
11031 /* Should the lhs be a section, use its array ref for the
11032 temporary expression. */
11033 if (aref
&& aref
->type
!= AR_FULL
)
11035 gfc_free_ref_list (e
->ref
);
11036 e
->ref
= gfc_copy_ref (ref
);
11042 /* Add one line of code to the code chain, making sure that 'head' and
11043 'tail' are appropriately updated. */
11046 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
11048 gcc_assert (this_code
);
11050 *head
= *tail
= *this_code
;
11052 *tail
= gfc_append_code (*tail
, *this_code
);
11057 /* Counts the potential number of part array references that would
11058 result from resolution of typebound defined assignments. */
11061 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
11064 int c_depth
= 0, t_depth
;
11066 for (c
= derived
->components
; c
; c
= c
->next
)
11068 if ((!gfc_bt_struct (c
->ts
.type
)
11070 || c
->attr
.allocatable
11071 || c
->attr
.proc_pointer_comp
11072 || c
->attr
.class_pointer
11073 || c
->attr
.proc_pointer
)
11074 && !c
->attr
.defined_assign_comp
)
11077 if (c
->as
&& c_depth
== 0)
11080 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
11081 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
11086 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
11088 return depth
+ c_depth
;
11092 /* Implement 7.2.1.3 of the F08 standard:
11093 "An intrinsic assignment where the variable is of derived type is
11094 performed as if each component of the variable were assigned from the
11095 corresponding component of expr using pointer assignment (7.2.2) for
11096 each pointer component, defined assignment for each nonpointer
11097 nonallocatable component of a type that has a type-bound defined
11098 assignment consistent with the component, intrinsic assignment for
11099 each other nonpointer nonallocatable component, ..."
11101 The pointer assignments are taken care of by the intrinsic
11102 assignment of the structure itself. This function recursively adds
11103 defined assignments where required. The recursion is accomplished
11104 by calling gfc_resolve_code.
11106 When the lhs in a defined assignment has intent INOUT, we need a
11107 temporary for the lhs. In pseudo-code:
11109 ! Only call function lhs once.
11110 if (lhs is not a constant or an variable)
11113 ! Do the intrinsic assignment
11115 ! Now do the defined assignments
11116 do over components with typebound defined assignment [%cmp]
11117 #if one component's assignment procedure is INOUT
11119 #if expr2 non-variable
11125 t1%cmp {defined=} expr2%cmp
11131 expr1%cmp {defined=} expr2%cmp
11135 /* The temporary assignments have to be put on top of the additional
11136 code to avoid the result being changed by the intrinsic assignment.
11138 static int component_assignment_level
= 0;
11139 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
11142 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
11144 gfc_component
*comp1
, *comp2
;
11145 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
11147 int error_count
, depth
;
11149 gfc_get_errors (NULL
, &error_count
);
11151 /* Filter out continuing processing after an error. */
11153 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
11154 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
11157 /* TODO: Handle more than one part array reference in assignments. */
11158 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
11159 (*code
)->expr1
->rank
? 1 : 0);
11162 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
11163 "done because multiple part array references would "
11164 "occur in intermediate expressions.", &(*code
)->loc
);
11168 component_assignment_level
++;
11170 /* Create a temporary so that functions get called only once. */
11171 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
11172 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
11174 gfc_expr
*tmp_expr
;
11176 /* Assign the rhs to the temporary. */
11177 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11178 this_code
= build_assignment (EXEC_ASSIGN
,
11179 tmp_expr
, (*code
)->expr2
,
11180 NULL
, NULL
, (*code
)->loc
);
11181 /* Add the code and substitute the rhs expression. */
11182 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
11183 gfc_free_expr ((*code
)->expr2
);
11184 (*code
)->expr2
= tmp_expr
;
11187 /* Do the intrinsic assignment. This is not needed if the lhs is one
11188 of the temporaries generated here, since the intrinsic assignment
11189 to the final result already does this. */
11190 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
11192 this_code
= build_assignment (EXEC_ASSIGN
,
11193 (*code
)->expr1
, (*code
)->expr2
,
11194 NULL
, NULL
, (*code
)->loc
);
11195 add_code_to_chain (&this_code
, &head
, &tail
);
11198 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
11199 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
11202 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
11204 bool inout
= false;
11206 /* The intrinsic assignment does the right thing for pointers
11207 of all kinds and allocatable components. */
11208 if (!gfc_bt_struct (comp1
->ts
.type
)
11209 || comp1
->attr
.pointer
11210 || comp1
->attr
.allocatable
11211 || comp1
->attr
.proc_pointer_comp
11212 || comp1
->attr
.class_pointer
11213 || comp1
->attr
.proc_pointer
)
11216 /* Make an assigment for this component. */
11217 this_code
= build_assignment (EXEC_ASSIGN
,
11218 (*code
)->expr1
, (*code
)->expr2
,
11219 comp1
, comp2
, (*code
)->loc
);
11221 /* Convert the assignment if there is a defined assignment for
11222 this type. Otherwise, using the call from gfc_resolve_code,
11223 recurse into its components. */
11224 gfc_resolve_code (this_code
, ns
);
11226 if (this_code
->op
== EXEC_ASSIGN_CALL
)
11228 gfc_formal_arglist
*dummy_args
;
11230 /* Check that there is a typebound defined assignment. If not,
11231 then this must be a module defined assignment. We cannot
11232 use the defined_assign_comp attribute here because it must
11233 be this derived type that has the defined assignment and not
11235 if (!(comp1
->ts
.u
.derived
->f2k_derived
11236 && comp1
->ts
.u
.derived
->f2k_derived
11237 ->tb_op
[INTRINSIC_ASSIGN
]))
11239 gfc_free_statements (this_code
);
11244 /* If the first argument of the subroutine has intent INOUT
11245 a temporary must be generated and used instead. */
11246 rsym
= this_code
->resolved_sym
;
11247 dummy_args
= gfc_sym_get_dummy_args (rsym
);
11249 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
11251 gfc_code
*temp_code
;
11254 /* Build the temporary required for the assignment and put
11255 it at the head of the generated code. */
11258 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
11259 temp_code
= build_assignment (EXEC_ASSIGN
,
11260 t1
, (*code
)->expr1
,
11261 NULL
, NULL
, (*code
)->loc
);
11263 /* For allocatable LHS, check whether it is allocated. Note
11264 that allocatable components with defined assignment are
11265 not yet support. See PR 57696. */
11266 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11270 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11271 block
= gfc_get_code (EXEC_IF
);
11272 block
->block
= gfc_get_code (EXEC_IF
);
11273 block
->block
->expr1
11274 = gfc_build_intrinsic_call (ns
,
11275 GFC_ISYM_ALLOCATED
, "allocated",
11276 (*code
)->loc
, 1, e
);
11277 block
->block
->next
= temp_code
;
11280 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11283 /* Replace the first actual arg with the component of the
11285 gfc_free_expr (this_code
->ext
.actual
->expr
);
11286 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11287 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11289 /* If the LHS variable is allocatable and wasn't allocated and
11290 the temporary is allocatable, pointer assign the address of
11291 the freshly allocated LHS to the temporary. */
11292 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11293 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11298 cond
= gfc_get_expr ();
11299 cond
->ts
.type
= BT_LOGICAL
;
11300 cond
->ts
.kind
= gfc_default_logical_kind
;
11301 cond
->expr_type
= EXPR_OP
;
11302 cond
->where
= (*code
)->loc
;
11303 cond
->value
.op
.op
= INTRINSIC_NOT
;
11304 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11305 GFC_ISYM_ALLOCATED
, "allocated",
11306 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11307 block
= gfc_get_code (EXEC_IF
);
11308 block
->block
= gfc_get_code (EXEC_IF
);
11309 block
->block
->expr1
= cond
;
11310 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11311 t1
, (*code
)->expr1
,
11312 NULL
, NULL
, (*code
)->loc
);
11313 add_code_to_chain (&block
, &head
, &tail
);
11317 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11319 /* Don't add intrinsic assignments since they are already
11320 effected by the intrinsic assignment of the structure. */
11321 gfc_free_statements (this_code
);
11326 add_code_to_chain (&this_code
, &head
, &tail
);
11330 /* Transfer the value to the final result. */
11331 this_code
= build_assignment (EXEC_ASSIGN
,
11332 (*code
)->expr1
, t1
,
11333 comp1
, comp2
, (*code
)->loc
);
11334 add_code_to_chain (&this_code
, &head
, &tail
);
11338 /* Put the temporary assignments at the top of the generated code. */
11339 if (tmp_head
&& component_assignment_level
== 1)
11341 gfc_append_code (tmp_head
, head
);
11343 tmp_head
= tmp_tail
= NULL
;
11346 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11347 // not accidentally deallocated. Hence, nullify t1.
11348 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11349 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11355 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11356 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11357 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11358 block
= gfc_get_code (EXEC_IF
);
11359 block
->block
= gfc_get_code (EXEC_IF
);
11360 block
->block
->expr1
= cond
;
11361 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11362 t1
, gfc_get_null_expr (&(*code
)->loc
),
11363 NULL
, NULL
, (*code
)->loc
);
11364 gfc_append_code (tail
, block
);
11368 /* Now attach the remaining code chain to the input code. Step on
11369 to the end of the new code since resolution is complete. */
11370 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11371 tail
->next
= (*code
)->next
;
11372 /* Overwrite 'code' because this would place the intrinsic assignment
11373 before the temporary for the lhs is created. */
11374 gfc_free_expr ((*code
)->expr1
);
11375 gfc_free_expr ((*code
)->expr2
);
11381 component_assignment_level
--;
11385 /* F2008: Pointer function assignments are of the form:
11386 ptr_fcn (args) = expr
11387 This function breaks these assignments into two statements:
11388 temporary_pointer => ptr_fcn(args)
11389 temporary_pointer = expr */
11392 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11394 gfc_expr
*tmp_ptr_expr
;
11395 gfc_code
*this_code
;
11396 gfc_component
*comp
;
11399 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11402 /* Even if standard does not support this feature, continue to build
11403 the two statements to avoid upsetting frontend_passes.c. */
11404 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11405 "%L", &(*code
)->loc
);
11407 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11410 s
= comp
->ts
.interface
;
11412 s
= (*code
)->expr1
->symtree
->n
.sym
;
11414 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11416 gfc_error ("The function result on the lhs of the assignment at "
11417 "%L must have the pointer attribute.",
11418 &(*code
)->expr1
->where
);
11419 (*code
)->op
= EXEC_NOP
;
11423 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
11425 /* get_temp_from_expression is set up for ordinary assignments. To that
11426 end, where array bounds are not known, arrays are made allocatable.
11427 Change the temporary to a pointer here. */
11428 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11429 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11430 tmp_ptr_expr
->where
= (*code
)->loc
;
11432 this_code
= build_assignment (EXEC_ASSIGN
,
11433 tmp_ptr_expr
, (*code
)->expr2
,
11434 NULL
, NULL
, (*code
)->loc
);
11435 this_code
->next
= (*code
)->next
;
11436 (*code
)->next
= this_code
;
11437 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11438 (*code
)->expr2
= (*code
)->expr1
;
11439 (*code
)->expr1
= tmp_ptr_expr
;
11445 /* Deferred character length assignments from an operator expression
11446 require a temporary because the character length of the lhs can
11447 change in the course of the assignment. */
11450 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11452 gfc_expr
*tmp_expr
;
11453 gfc_code
*this_code
;
11455 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11456 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11457 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11460 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11463 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
11466 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11467 tmp_expr
->where
= (*code
)->loc
;
11469 /* A new charlen is required to ensure that the variable string
11470 length is different to that of the original lhs. */
11471 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11472 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11473 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11474 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11476 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11478 this_code
= build_assignment (EXEC_ASSIGN
,
11480 gfc_copy_expr (tmp_expr
),
11481 NULL
, NULL
, (*code
)->loc
);
11483 (*code
)->expr1
= tmp_expr
;
11485 this_code
->next
= (*code
)->next
;
11486 (*code
)->next
= this_code
;
11492 /* Given a block of code, recursively resolve everything pointed to by this
11496 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11498 int omp_workshare_save
;
11499 int forall_save
, do_concurrent_save
;
11503 frame
.prev
= cs_base
;
11507 find_reachable_labels (code
);
11509 for (; code
; code
= code
->next
)
11511 frame
.current
= code
;
11512 forall_save
= forall_flag
;
11513 do_concurrent_save
= gfc_do_concurrent_flag
;
11515 if (code
->op
== EXEC_FORALL
)
11518 gfc_resolve_forall (code
, ns
, forall_save
);
11521 else if (code
->block
)
11523 omp_workshare_save
= -1;
11526 case EXEC_OACC_PARALLEL_LOOP
:
11527 case EXEC_OACC_PARALLEL
:
11528 case EXEC_OACC_KERNELS_LOOP
:
11529 case EXEC_OACC_KERNELS
:
11530 case EXEC_OACC_DATA
:
11531 case EXEC_OACC_HOST_DATA
:
11532 case EXEC_OACC_LOOP
:
11533 gfc_resolve_oacc_blocks (code
, ns
);
11535 case EXEC_OMP_PARALLEL_WORKSHARE
:
11536 omp_workshare_save
= omp_workshare_flag
;
11537 omp_workshare_flag
= 1;
11538 gfc_resolve_omp_parallel_blocks (code
, ns
);
11540 case EXEC_OMP_PARALLEL
:
11541 case EXEC_OMP_PARALLEL_DO
:
11542 case EXEC_OMP_PARALLEL_DO_SIMD
:
11543 case EXEC_OMP_PARALLEL_SECTIONS
:
11544 case EXEC_OMP_TARGET_PARALLEL
:
11545 case EXEC_OMP_TARGET_PARALLEL_DO
:
11546 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11547 case EXEC_OMP_TARGET_TEAMS
:
11548 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11549 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11550 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11551 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11552 case EXEC_OMP_TASK
:
11553 case EXEC_OMP_TASKLOOP
:
11554 case EXEC_OMP_TASKLOOP_SIMD
:
11555 case EXEC_OMP_TEAMS
:
11556 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11557 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11558 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11559 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11560 omp_workshare_save
= omp_workshare_flag
;
11561 omp_workshare_flag
= 0;
11562 gfc_resolve_omp_parallel_blocks (code
, ns
);
11564 case EXEC_OMP_DISTRIBUTE
:
11565 case EXEC_OMP_DISTRIBUTE_SIMD
:
11567 case EXEC_OMP_DO_SIMD
:
11568 case EXEC_OMP_SIMD
:
11569 case EXEC_OMP_TARGET_SIMD
:
11570 gfc_resolve_omp_do_blocks (code
, ns
);
11572 case EXEC_SELECT_TYPE
:
11573 /* Blocks are handled in resolve_select_type because we have
11574 to transform the SELECT TYPE into ASSOCIATE first. */
11576 case EXEC_DO_CONCURRENT
:
11577 gfc_do_concurrent_flag
= 1;
11578 gfc_resolve_blocks (code
->block
, ns
);
11579 gfc_do_concurrent_flag
= 2;
11581 case EXEC_OMP_WORKSHARE
:
11582 omp_workshare_save
= omp_workshare_flag
;
11583 omp_workshare_flag
= 1;
11586 gfc_resolve_blocks (code
->block
, ns
);
11590 if (omp_workshare_save
!= -1)
11591 omp_workshare_flag
= omp_workshare_save
;
11595 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11596 t
= gfc_resolve_expr (code
->expr1
);
11597 forall_flag
= forall_save
;
11598 gfc_do_concurrent_flag
= do_concurrent_save
;
11600 if (!gfc_resolve_expr (code
->expr2
))
11603 if (code
->op
== EXEC_ALLOCATE
11604 && !gfc_resolve_expr (code
->expr3
))
11610 case EXEC_END_BLOCK
:
11611 case EXEC_END_NESTED_BLOCK
:
11615 case EXEC_ERROR_STOP
:
11617 case EXEC_CONTINUE
:
11619 case EXEC_ASSIGN_CALL
:
11622 case EXEC_CRITICAL
:
11623 resolve_critical (code
);
11626 case EXEC_SYNC_ALL
:
11627 case EXEC_SYNC_IMAGES
:
11628 case EXEC_SYNC_MEMORY
:
11629 resolve_sync (code
);
11634 case EXEC_EVENT_POST
:
11635 case EXEC_EVENT_WAIT
:
11636 resolve_lock_unlock_event (code
);
11639 case EXEC_FAIL_IMAGE
:
11640 case EXEC_FORM_TEAM
:
11641 case EXEC_CHANGE_TEAM
:
11642 case EXEC_END_TEAM
:
11643 case EXEC_SYNC_TEAM
:
11647 /* Keep track of which entry we are up to. */
11648 current_entry_id
= code
->ext
.entry
->id
;
11652 resolve_where (code
, NULL
);
11656 if (code
->expr1
!= NULL
)
11658 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11659 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11660 "INTEGER variable", &code
->expr1
->where
);
11661 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11662 gfc_error ("Variable %qs has not been assigned a target "
11663 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11664 &code
->expr1
->where
);
11667 resolve_branch (code
->label1
, code
);
11671 if (code
->expr1
!= NULL
11672 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11673 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11674 "INTEGER return specifier", &code
->expr1
->where
);
11677 case EXEC_INIT_ASSIGN
:
11678 case EXEC_END_PROCEDURE
:
11685 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11687 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11688 && code
->expr1
->value
.function
.isym
11689 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11690 remove_caf_get_intrinsic (code
->expr1
);
11692 /* If this is a pointer function in an lvalue variable context,
11693 the new code will have to be resolved afresh. This is also the
11694 case with an error, where the code is transformed into NOP to
11695 prevent ICEs downstream. */
11696 if (resolve_ptr_fcn_assign (&code
, ns
)
11697 || code
->op
== EXEC_NOP
)
11700 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11704 if (resolve_ordinary_assign (code
, ns
))
11706 if (code
->op
== EXEC_COMPCALL
)
11712 /* Check for dependencies in deferred character length array
11713 assignments and generate a temporary, if necessary. */
11714 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11717 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11718 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11719 && code
->expr1
->ts
.u
.derived
11720 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11721 generate_component_assignments (&code
, ns
);
11725 case EXEC_LABEL_ASSIGN
:
11726 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11727 gfc_error ("Label %d referenced at %L is never defined",
11728 code
->label1
->value
, &code
->label1
->where
);
11730 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11731 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11732 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11733 != gfc_default_integer_kind
11734 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11735 gfc_error ("ASSIGN statement at %L requires a scalar "
11736 "default INTEGER variable", &code
->expr1
->where
);
11739 case EXEC_POINTER_ASSIGN
:
11746 /* This is both a variable definition and pointer assignment
11747 context, so check both of them. For rank remapping, a final
11748 array ref may be present on the LHS and fool gfc_expr_attr
11749 used in gfc_check_vardef_context. Remove it. */
11750 e
= remove_last_array_ref (code
->expr1
);
11751 t
= gfc_check_vardef_context (e
, true, false, false,
11752 _("pointer assignment"));
11754 t
= gfc_check_vardef_context (e
, false, false, false,
11755 _("pointer assignment"));
11758 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
11763 /* Assigning a class object always is a regular assign. */
11764 if (code
->expr2
->ts
.type
== BT_CLASS
11765 && code
->expr1
->ts
.type
== BT_CLASS
11766 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11767 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11768 && code
->expr2
->expr_type
== EXPR_VARIABLE
11769 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11771 code
->op
= EXEC_ASSIGN
;
11775 case EXEC_ARITHMETIC_IF
:
11777 gfc_expr
*e
= code
->expr1
;
11779 gfc_resolve_expr (e
);
11780 if (e
->expr_type
== EXPR_NULL
)
11781 gfc_error ("Invalid NULL at %L", &e
->where
);
11783 if (t
&& (e
->rank
> 0
11784 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11785 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11786 "REAL or INTEGER expression", &e
->where
);
11788 resolve_branch (code
->label1
, code
);
11789 resolve_branch (code
->label2
, code
);
11790 resolve_branch (code
->label3
, code
);
11795 if (t
&& code
->expr1
!= NULL
11796 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11797 || code
->expr1
->rank
!= 0))
11798 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11799 &code
->expr1
->where
);
11804 resolve_call (code
);
11807 case EXEC_COMPCALL
:
11809 resolve_typebound_subroutine (code
);
11812 case EXEC_CALL_PPC
:
11813 resolve_ppc_call (code
);
11817 /* Select is complicated. Also, a SELECT construct could be
11818 a transformed computed GOTO. */
11819 resolve_select (code
, false);
11822 case EXEC_SELECT_TYPE
:
11823 resolve_select_type (code
, ns
);
11826 case EXEC_SELECT_RANK
:
11827 resolve_select_rank (code
, ns
);
11831 resolve_block_construct (code
);
11835 if (code
->ext
.iterator
!= NULL
)
11837 gfc_iterator
*iter
= code
->ext
.iterator
;
11838 if (gfc_resolve_iterator (iter
, true, false))
11839 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11844 case EXEC_DO_WHILE
:
11845 if (code
->expr1
== NULL
)
11846 gfc_internal_error ("gfc_resolve_code(): No expression on "
11849 && (code
->expr1
->rank
!= 0
11850 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11851 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11852 "a scalar LOGICAL expression", &code
->expr1
->where
);
11855 case EXEC_ALLOCATE
:
11857 resolve_allocate_deallocate (code
, "ALLOCATE");
11861 case EXEC_DEALLOCATE
:
11863 resolve_allocate_deallocate (code
, "DEALLOCATE");
11868 if (!gfc_resolve_open (code
->ext
.open
))
11871 resolve_branch (code
->ext
.open
->err
, code
);
11875 if (!gfc_resolve_close (code
->ext
.close
))
11878 resolve_branch (code
->ext
.close
->err
, code
);
11881 case EXEC_BACKSPACE
:
11885 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
11888 resolve_branch (code
->ext
.filepos
->err
, code
);
11892 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11895 resolve_branch (code
->ext
.inquire
->err
, code
);
11898 case EXEC_IOLENGTH
:
11899 gcc_assert (code
->ext
.inquire
!= NULL
);
11900 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11903 resolve_branch (code
->ext
.inquire
->err
, code
);
11907 if (!gfc_resolve_wait (code
->ext
.wait
))
11910 resolve_branch (code
->ext
.wait
->err
, code
);
11911 resolve_branch (code
->ext
.wait
->end
, code
);
11912 resolve_branch (code
->ext
.wait
->eor
, code
);
11917 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11920 resolve_branch (code
->ext
.dt
->err
, code
);
11921 resolve_branch (code
->ext
.dt
->end
, code
);
11922 resolve_branch (code
->ext
.dt
->eor
, code
);
11925 case EXEC_TRANSFER
:
11926 resolve_transfer (code
);
11929 case EXEC_DO_CONCURRENT
:
11931 resolve_forall_iterators (code
->ext
.forall_iterator
);
11933 if (code
->expr1
!= NULL
11934 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11935 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11936 "expression", &code
->expr1
->where
);
11939 case EXEC_OACC_PARALLEL_LOOP
:
11940 case EXEC_OACC_PARALLEL
:
11941 case EXEC_OACC_KERNELS_LOOP
:
11942 case EXEC_OACC_KERNELS
:
11943 case EXEC_OACC_DATA
:
11944 case EXEC_OACC_HOST_DATA
:
11945 case EXEC_OACC_LOOP
:
11946 case EXEC_OACC_UPDATE
:
11947 case EXEC_OACC_WAIT
:
11948 case EXEC_OACC_CACHE
:
11949 case EXEC_OACC_ENTER_DATA
:
11950 case EXEC_OACC_EXIT_DATA
:
11951 case EXEC_OACC_ATOMIC
:
11952 case EXEC_OACC_DECLARE
:
11953 gfc_resolve_oacc_directive (code
, ns
);
11956 case EXEC_OMP_ATOMIC
:
11957 case EXEC_OMP_BARRIER
:
11958 case EXEC_OMP_CANCEL
:
11959 case EXEC_OMP_CANCELLATION_POINT
:
11960 case EXEC_OMP_CRITICAL
:
11961 case EXEC_OMP_FLUSH
:
11962 case EXEC_OMP_DISTRIBUTE
:
11963 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11964 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11965 case EXEC_OMP_DISTRIBUTE_SIMD
:
11967 case EXEC_OMP_DO_SIMD
:
11968 case EXEC_OMP_MASTER
:
11969 case EXEC_OMP_ORDERED
:
11970 case EXEC_OMP_SECTIONS
:
11971 case EXEC_OMP_SIMD
:
11972 case EXEC_OMP_SINGLE
:
11973 case EXEC_OMP_TARGET
:
11974 case EXEC_OMP_TARGET_DATA
:
11975 case EXEC_OMP_TARGET_ENTER_DATA
:
11976 case EXEC_OMP_TARGET_EXIT_DATA
:
11977 case EXEC_OMP_TARGET_PARALLEL
:
11978 case EXEC_OMP_TARGET_PARALLEL_DO
:
11979 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11980 case EXEC_OMP_TARGET_SIMD
:
11981 case EXEC_OMP_TARGET_TEAMS
:
11982 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11983 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11984 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11985 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11986 case EXEC_OMP_TARGET_UPDATE
:
11987 case EXEC_OMP_TASK
:
11988 case EXEC_OMP_TASKGROUP
:
11989 case EXEC_OMP_TASKLOOP
:
11990 case EXEC_OMP_TASKLOOP_SIMD
:
11991 case EXEC_OMP_TASKWAIT
:
11992 case EXEC_OMP_TASKYIELD
:
11993 case EXEC_OMP_TEAMS
:
11994 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11995 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11996 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11997 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11998 case EXEC_OMP_WORKSHARE
:
11999 gfc_resolve_omp_directive (code
, ns
);
12002 case EXEC_OMP_PARALLEL
:
12003 case EXEC_OMP_PARALLEL_DO
:
12004 case EXEC_OMP_PARALLEL_DO_SIMD
:
12005 case EXEC_OMP_PARALLEL_SECTIONS
:
12006 case EXEC_OMP_PARALLEL_WORKSHARE
:
12007 omp_workshare_save
= omp_workshare_flag
;
12008 omp_workshare_flag
= 0;
12009 gfc_resolve_omp_directive (code
, ns
);
12010 omp_workshare_flag
= omp_workshare_save
;
12014 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
12018 cs_base
= frame
.prev
;
12022 /* Resolve initial values and make sure they are compatible with
12026 resolve_values (gfc_symbol
*sym
)
12030 if (sym
->value
== NULL
)
12033 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
12034 t
= resolve_structure_cons (sym
->value
, 1);
12036 t
= gfc_resolve_expr (sym
->value
);
12041 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
12045 /* Verify any BIND(C) derived types in the namespace so we can report errors
12046 for them once, rather than for each variable declared of that type. */
12049 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
12051 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
12052 && derived_sym
->attr
.is_bind_c
== 1)
12053 verify_bind_c_derived_type (derived_sym
);
12059 /* Check the interfaces of DTIO procedures associated with derived
12060 type 'sym'. These procedures can either have typebound bindings or
12061 can appear in DTIO generic interfaces. */
12064 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
12066 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
12069 gfc_check_dtio_interfaces (sym
);
12074 /* Verify that any binding labels used in a given namespace do not collide
12075 with the names or binding labels of any global symbols. Multiple INTERFACE
12076 for the same procedure are permitted. */
12079 gfc_verify_binding_labels (gfc_symbol
*sym
)
12082 const char *module
;
12084 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
12085 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
12088 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
12091 module
= sym
->module
;
12092 else if (sym
->ns
&& sym
->ns
->proc_name
12093 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
12094 module
= sym
->ns
->proc_name
->name
;
12095 else if (sym
->ns
&& sym
->ns
->parent
12096 && sym
->ns
&& sym
->ns
->parent
->proc_name
12097 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12098 module
= sym
->ns
->parent
->proc_name
->name
;
12104 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
12107 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
12108 gsym
->where
= sym
->declared_at
;
12109 gsym
->sym_name
= sym
->name
;
12110 gsym
->binding_label
= sym
->binding_label
;
12111 gsym
->ns
= sym
->ns
;
12112 gsym
->mod_name
= module
;
12113 if (sym
->attr
.function
)
12114 gsym
->type
= GSYM_FUNCTION
;
12115 else if (sym
->attr
.subroutine
)
12116 gsym
->type
= GSYM_SUBROUTINE
;
12117 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
12118 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
12122 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
12124 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
12125 "identifier as entity at %L", sym
->name
,
12126 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12127 /* Clear the binding label to prevent checking multiple times. */
12128 sym
->binding_label
= NULL
;
12132 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
12133 && (strcmp (module
, gsym
->mod_name
) != 0
12134 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
12136 /* This can only happen if the variable is defined in a module - if it
12137 isn't the same module, reject it. */
12138 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
12139 "uses the same global identifier as entity at %L from module %qs",
12140 sym
->name
, module
, sym
->binding_label
,
12141 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
12142 sym
->binding_label
= NULL
;
12146 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
12147 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
12148 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
12149 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
12150 && (module
!= gsym
->mod_name
12151 || strcmp (gsym
->sym_name
, sym
->name
) != 0
12152 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
12154 /* Print an error if the procedure is defined multiple times; we have to
12155 exclude references to the same procedure via module association or
12156 multiple checks for the same procedure. */
12157 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
12158 "global identifier as entity at %L", sym
->name
,
12159 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
12160 sym
->binding_label
= NULL
;
12165 /* Resolve an index expression. */
12168 resolve_index_expr (gfc_expr
*e
)
12170 if (!gfc_resolve_expr (e
))
12173 if (!gfc_simplify_expr (e
, 0))
12176 if (!gfc_specification_expr (e
))
12183 /* Resolve a charlen structure. */
12186 resolve_charlen (gfc_charlen
*cl
)
12189 bool saved_specification_expr
;
12195 saved_specification_expr
= specification_expr
;
12196 specification_expr
= true;
12198 if (cl
->length_from_typespec
)
12200 if (!gfc_resolve_expr (cl
->length
))
12202 specification_expr
= saved_specification_expr
;
12206 if (!gfc_simplify_expr (cl
->length
, 0))
12208 specification_expr
= saved_specification_expr
;
12212 /* cl->length has been resolved. It should have an integer type. */
12213 if (cl
->length
->ts
.type
!= BT_INTEGER
)
12215 gfc_error ("Scalar INTEGER expression expected at %L",
12216 &cl
->length
->where
);
12222 if (!resolve_index_expr (cl
->length
))
12224 specification_expr
= saved_specification_expr
;
12229 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12230 a negative value, the length of character entities declared is zero. */
12231 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12232 && mpz_sgn (cl
->length
->value
.integer
) < 0)
12233 gfc_replace_expr (cl
->length
,
12234 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
12236 /* Check that the character length is not too large. */
12237 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
12238 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
12239 && cl
->length
->ts
.type
== BT_INTEGER
12240 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
12242 gfc_error ("String length at %L is too large", &cl
->length
->where
);
12243 specification_expr
= saved_specification_expr
;
12247 specification_expr
= saved_specification_expr
;
12252 /* Test for non-constant shape arrays. */
12255 is_non_constant_shape_array (gfc_symbol
*sym
)
12261 not_constant
= false;
12262 if (sym
->as
!= NULL
)
12264 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12265 has not been simplified; parameter array references. Do the
12266 simplification now. */
12267 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12269 e
= sym
->as
->lower
[i
];
12270 if (e
&& (!resolve_index_expr(e
)
12271 || !gfc_is_constant_expr (e
)))
12272 not_constant
= true;
12273 e
= sym
->as
->upper
[i
];
12274 if (e
&& (!resolve_index_expr(e
)
12275 || !gfc_is_constant_expr (e
)))
12276 not_constant
= true;
12279 return not_constant
;
12282 /* Given a symbol and an initialization expression, add code to initialize
12283 the symbol to the function entry. */
12285 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12289 gfc_namespace
*ns
= sym
->ns
;
12291 /* Search for the function namespace if this is a contained
12292 function without an explicit result. */
12293 if (sym
->attr
.function
&& sym
== sym
->result
12294 && sym
->name
!= sym
->ns
->proc_name
->name
)
12296 ns
= ns
->contained
;
12297 for (;ns
; ns
= ns
->sibling
)
12298 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12304 gfc_free_expr (init
);
12308 /* Build an l-value expression for the result. */
12309 lval
= gfc_lval_expr_from_sym (sym
);
12311 /* Add the code at scope entry. */
12312 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
12313 init_st
->next
= ns
->code
;
12314 ns
->code
= init_st
;
12316 /* Assign the default initializer to the l-value. */
12317 init_st
->loc
= sym
->declared_at
;
12318 init_st
->expr1
= lval
;
12319 init_st
->expr2
= init
;
12323 /* Whether or not we can generate a default initializer for a symbol. */
12326 can_generate_init (gfc_symbol
*sym
)
12328 symbol_attribute
*a
;
12333 /* These symbols should never have a default initialization. */
12338 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
12339 && (CLASS_DATA (sym
)->attr
.class_pointer
12340 || CLASS_DATA (sym
)->attr
.proc_pointer
))
12341 || a
->in_equivalence
12348 || (!a
->referenced
&& !a
->result
)
12349 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
12350 || (a
->function
&& sym
!= sym
->result
)
12355 /* Assign the default initializer to a derived type variable or result. */
12358 apply_default_init (gfc_symbol
*sym
)
12360 gfc_expr
*init
= NULL
;
12362 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12365 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12366 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12368 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12371 build_init_assign (sym
, init
);
12372 sym
->attr
.referenced
= 1;
12376 /* Build an initializer for a local. Returns null if the symbol should not have
12377 a default initialization. */
12380 build_default_init_expr (gfc_symbol
*sym
)
12382 /* These symbols should never have a default initialization. */
12383 if (sym
->attr
.allocatable
12384 || sym
->attr
.external
12386 || sym
->attr
.pointer
12387 || sym
->attr
.in_equivalence
12388 || sym
->attr
.in_common
12391 || sym
->attr
.cray_pointee
12392 || sym
->attr
.cray_pointer
12396 /* Get the appropriate init expression. */
12397 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12400 /* Add an initialization expression to a local variable. */
12402 apply_default_init_local (gfc_symbol
*sym
)
12404 gfc_expr
*init
= NULL
;
12406 /* The symbol should be a variable or a function return value. */
12407 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12408 || (sym
->attr
.function
&& sym
->result
!= sym
))
12411 /* Try to build the initializer expression. If we can't initialize
12412 this symbol, then init will be NULL. */
12413 init
= build_default_init_expr (sym
);
12417 /* For saved variables, we don't want to add an initializer at function
12418 entry, so we just add a static initializer. Note that automatic variables
12419 are stack allocated even with -fno-automatic; we have also to exclude
12420 result variable, which are also nonstatic. */
12421 if (!sym
->attr
.automatic
12422 && (sym
->attr
.save
|| sym
->ns
->save_all
12423 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12424 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12425 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12427 /* Don't clobber an existing initializer! */
12428 gcc_assert (sym
->value
== NULL
);
12433 build_init_assign (sym
, init
);
12437 /* Resolution of common features of flavors variable and procedure. */
12440 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12442 gfc_array_spec
*as
;
12444 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12445 as
= CLASS_DATA (sym
)->as
;
12449 /* Constraints on deferred shape variable. */
12450 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12452 bool pointer
, allocatable
, dimension
;
12454 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12456 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12457 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12458 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12462 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12463 allocatable
= sym
->attr
.allocatable
;
12464 dimension
= sym
->attr
.dimension
;
12469 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12471 gfc_error ("Allocatable array %qs at %L must have a deferred "
12472 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12475 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12476 "%qs at %L may not be ALLOCATABLE",
12477 sym
->name
, &sym
->declared_at
))
12481 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12483 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12484 "assumed rank", sym
->name
, &sym
->declared_at
);
12490 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12491 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12493 gfc_error ("Array %qs at %L cannot have a deferred shape",
12494 sym
->name
, &sym
->declared_at
);
12499 /* Constraints on polymorphic variables. */
12500 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12503 if (sym
->attr
.class_ok
12504 && !sym
->attr
.select_type_temporary
12505 && !UNLIMITED_POLY (sym
)
12506 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12508 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12509 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12510 &sym
->declared_at
);
12515 /* Assume that use associated symbols were checked in the module ns.
12516 Class-variables that are associate-names are also something special
12517 and excepted from the test. */
12518 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12520 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12521 "or pointer", sym
->name
, &sym
->declared_at
);
12530 /* Additional checks for symbols with flavor variable and derived
12531 type. To be called from resolve_fl_variable. */
12534 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12536 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12538 /* Check to see if a derived type is blocked from being host
12539 associated by the presence of another class I symbol in the same
12540 namespace. 14.6.1.3 of the standard and the discussion on
12541 comp.lang.fortran. */
12542 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12543 && !sym
->ts
.u
.derived
->attr
.use_assoc
12544 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12547 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12548 if (s
&& s
->attr
.generic
)
12549 s
= gfc_find_dt_in_generic (s
);
12550 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12552 gfc_error ("The type %qs cannot be host associated at %L "
12553 "because it is blocked by an incompatible object "
12554 "of the same name declared at %L",
12555 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12561 /* 4th constraint in section 11.3: "If an object of a type for which
12562 component-initialization is specified (R429) appears in the
12563 specification-part of a module and does not have the ALLOCATABLE
12564 or POINTER attribute, the object shall have the SAVE attribute."
12566 The check for initializers is performed with
12567 gfc_has_default_initializer because gfc_default_initializer generates
12568 a hidden default for allocatable components. */
12569 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12570 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12571 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12572 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12573 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12574 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12575 "%qs at %L, needed due to the default "
12576 "initialization", sym
->name
, &sym
->declared_at
))
12579 /* Assign default initializer. */
12580 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12581 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12582 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12588 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12589 except in the declaration of an entity or component that has the POINTER
12590 or ALLOCATABLE attribute. */
12593 deferred_requirements (gfc_symbol
*sym
)
12595 if (sym
->ts
.deferred
12596 && !(sym
->attr
.pointer
12597 || sym
->attr
.allocatable
12598 || sym
->attr
.associate_var
12599 || sym
->attr
.omp_udr_artificial_var
))
12601 /* If a function has a result variable, only check the variable. */
12602 if (sym
->result
&& sym
->name
!= sym
->result
->name
)
12605 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12606 "requires either the POINTER or ALLOCATABLE attribute",
12607 sym
->name
, &sym
->declared_at
);
12614 /* Resolve symbols with flavor variable. */
12617 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12619 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
12622 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12625 /* Set this flag to check that variables are parameters of all entries.
12626 This check is effected by the call to gfc_resolve_expr through
12627 is_non_constant_shape_array. */
12628 bool saved_specification_expr
= specification_expr
;
12629 specification_expr
= true;
12631 if (sym
->ns
->proc_name
12632 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12633 || sym
->ns
->proc_name
->attr
.is_main_program
)
12634 && !sym
->attr
.use_assoc
12635 && !sym
->attr
.allocatable
12636 && !sym
->attr
.pointer
12637 && is_non_constant_shape_array (sym
))
12639 /* F08:C541. The shape of an array defined in a main program or module
12640 * needs to be constant. */
12641 gfc_error ("The module or main program array %qs at %L must "
12642 "have constant shape", sym
->name
, &sym
->declared_at
);
12643 specification_expr
= saved_specification_expr
;
12647 /* Constraints on deferred type parameter. */
12648 if (!deferred_requirements (sym
))
12651 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12653 /* Make sure that character string variables with assumed length are
12654 dummy arguments. */
12655 gfc_expr
*e
= NULL
;
12658 e
= sym
->ts
.u
.cl
->length
;
12662 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12663 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12664 && !sym
->attr
.omp_udr_artificial_var
)
12666 gfc_error ("Entity with assumed character length at %L must be a "
12667 "dummy argument or a PARAMETER", &sym
->declared_at
);
12668 specification_expr
= saved_specification_expr
;
12672 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12674 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12675 specification_expr
= saved_specification_expr
;
12679 if (!gfc_is_constant_expr (e
)
12680 && !(e
->expr_type
== EXPR_VARIABLE
12681 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12683 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12684 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12685 || sym
->ns
->proc_name
->attr
.is_main_program
))
12687 gfc_error ("%qs at %L must have constant character length "
12688 "in this context", sym
->name
, &sym
->declared_at
);
12689 specification_expr
= saved_specification_expr
;
12692 if (sym
->attr
.in_common
)
12694 gfc_error ("COMMON variable %qs at %L must have constant "
12695 "character length", sym
->name
, &sym
->declared_at
);
12696 specification_expr
= saved_specification_expr
;
12702 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12703 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12705 /* Determine if the symbol may not have an initializer. */
12706 int no_init_flag
= 0, automatic_flag
= 0;
12707 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12708 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12710 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12711 && is_non_constant_shape_array (sym
))
12713 no_init_flag
= automatic_flag
= 1;
12715 /* Also, they must not have the SAVE attribute.
12716 SAVE_IMPLICIT is checked below. */
12717 if (sym
->as
&& sym
->attr
.codimension
)
12719 int corank
= sym
->as
->corank
;
12720 sym
->as
->corank
= 0;
12721 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12722 sym
->as
->corank
= corank
;
12724 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12726 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12727 specification_expr
= saved_specification_expr
;
12732 /* Ensure that any initializer is simplified. */
12734 gfc_simplify_expr (sym
->value
, 1);
12736 /* Reject illegal initializers. */
12737 if (!sym
->mark
&& sym
->value
)
12739 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12740 && CLASS_DATA (sym
)->attr
.allocatable
))
12741 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12742 sym
->name
, &sym
->declared_at
);
12743 else if (sym
->attr
.external
)
12744 gfc_error ("External %qs at %L cannot have an initializer",
12745 sym
->name
, &sym
->declared_at
);
12746 else if (sym
->attr
.dummy
12747 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12748 gfc_error ("Dummy %qs at %L cannot have an initializer",
12749 sym
->name
, &sym
->declared_at
);
12750 else if (sym
->attr
.intrinsic
)
12751 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12752 sym
->name
, &sym
->declared_at
);
12753 else if (sym
->attr
.result
)
12754 gfc_error ("Function result %qs at %L cannot have an initializer",
12755 sym
->name
, &sym
->declared_at
);
12756 else if (automatic_flag
)
12757 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12758 sym
->name
, &sym
->declared_at
);
12760 goto no_init_error
;
12761 specification_expr
= saved_specification_expr
;
12766 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12768 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12769 specification_expr
= saved_specification_expr
;
12773 specification_expr
= saved_specification_expr
;
12778 /* Compare the dummy characteristics of a module procedure interface
12779 declaration with the corresponding declaration in a submodule. */
12780 static gfc_formal_arglist
*new_formal
;
12781 static char errmsg
[200];
12784 compare_fsyms (gfc_symbol
*sym
)
12788 if (sym
== NULL
|| new_formal
== NULL
)
12791 fsym
= new_formal
->sym
;
12796 if (strcmp (sym
->name
, fsym
->name
) == 0)
12798 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12799 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12804 /* Resolve a procedure. */
12807 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12809 gfc_formal_arglist
*arg
;
12811 if (sym
->attr
.function
12812 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12815 /* Constraints on deferred type parameter. */
12816 if (!deferred_requirements (sym
))
12819 if (sym
->ts
.type
== BT_CHARACTER
)
12821 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12823 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12824 && !resolve_charlen (cl
))
12827 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12828 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12830 gfc_error ("Character-valued statement function %qs at %L must "
12831 "have constant length", sym
->name
, &sym
->declared_at
);
12836 /* Ensure that derived type for are not of a private type. Internal
12837 module procedures are excluded by 2.2.3.3 - i.e., they are not
12838 externally accessible and can access all the objects accessible in
12840 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
12841 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12842 && gfc_check_symbol_access (sym
))
12844 gfc_interface
*iface
;
12846 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12849 && arg
->sym
->ts
.type
== BT_DERIVED
12850 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12851 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12852 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12853 "and cannot be a dummy argument"
12854 " of %qs, which is PUBLIC at %L",
12855 arg
->sym
->name
, sym
->name
,
12856 &sym
->declared_at
))
12858 /* Stop this message from recurring. */
12859 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12864 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12865 PRIVATE to the containing module. */
12866 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12868 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12871 && arg
->sym
->ts
.type
== BT_DERIVED
12872 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12873 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12874 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12875 "PUBLIC interface %qs at %L "
12876 "takes dummy arguments of %qs which "
12877 "is PRIVATE", iface
->sym
->name
,
12878 sym
->name
, &iface
->sym
->declared_at
,
12879 gfc_typename(&arg
->sym
->ts
)))
12881 /* Stop this message from recurring. */
12882 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12889 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12890 && !sym
->attr
.proc_pointer
)
12892 gfc_error ("Function %qs at %L cannot have an initializer",
12893 sym
->name
, &sym
->declared_at
);
12895 /* Make sure no second error is issued for this. */
12896 sym
->value
->error
= 1;
12900 /* An external symbol may not have an initializer because it is taken to be
12901 a procedure. Exception: Procedure Pointers. */
12902 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12904 gfc_error ("External object %qs at %L may not have an initializer",
12905 sym
->name
, &sym
->declared_at
);
12909 /* An elemental function is required to return a scalar 12.7.1 */
12910 if (sym
->attr
.elemental
&& sym
->attr
.function
12911 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)))
12913 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12914 "result", sym
->name
, &sym
->declared_at
);
12915 /* Reset so that the error only occurs once. */
12916 sym
->attr
.elemental
= 0;
12920 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12921 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12923 gfc_error ("Statement function %qs at %L may not have pointer or "
12924 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12928 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12929 char-len-param shall not be array-valued, pointer-valued, recursive
12930 or pure. ....snip... A character value of * may only be used in the
12931 following ways: (i) Dummy arg of procedure - dummy associates with
12932 actual length; (ii) To declare a named constant; or (iii) External
12933 function - but length must be declared in calling scoping unit. */
12934 if (sym
->attr
.function
12935 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12936 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12938 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12939 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12941 if (sym
->as
&& sym
->as
->rank
)
12942 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12943 "array-valued", sym
->name
, &sym
->declared_at
);
12945 if (sym
->attr
.pointer
)
12946 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12947 "pointer-valued", sym
->name
, &sym
->declared_at
);
12949 if (sym
->attr
.pure
)
12950 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12951 "pure", sym
->name
, &sym
->declared_at
);
12953 if (sym
->attr
.recursive
)
12954 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12955 "recursive", sym
->name
, &sym
->declared_at
);
12960 /* Appendix B.2 of the standard. Contained functions give an
12961 error anyway. Deferred character length is an F2003 feature.
12962 Don't warn on intrinsic conversion functions, which start
12963 with two underscores. */
12964 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12965 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12966 gfc_notify_std (GFC_STD_F95_OBS
,
12967 "CHARACTER(*) function %qs at %L",
12968 sym
->name
, &sym
->declared_at
);
12971 /* F2008, C1218. */
12972 if (sym
->attr
.elemental
)
12974 if (sym
->attr
.proc_pointer
)
12976 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12977 sym
->name
, &sym
->declared_at
);
12980 if (sym
->attr
.dummy
)
12982 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12983 sym
->name
, &sym
->declared_at
);
12988 /* F2018, C15100: "The result of an elemental function shall be scalar,
12989 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
12990 pointer is tested and caught elsewhere. */
12991 if (sym
->attr
.elemental
&& sym
->result
12992 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
12994 gfc_error ("Function result variable %qs at %L of elemental "
12995 "function %qs shall not have an ALLOCATABLE or POINTER "
12996 "attribute", sym
->result
->name
,
12997 &sym
->result
->declared_at
, sym
->name
);
13001 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
13003 gfc_formal_arglist
*curr_arg
;
13004 int has_non_interop_arg
= 0;
13006 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13007 sym
->common_block
))
13009 /* Clear these to prevent looking at them again if there was an
13011 sym
->attr
.is_bind_c
= 0;
13012 sym
->attr
.is_c_interop
= 0;
13013 sym
->ts
.is_c_interop
= 0;
13017 /* So far, no errors have been found. */
13018 sym
->attr
.is_c_interop
= 1;
13019 sym
->ts
.is_c_interop
= 1;
13022 curr_arg
= gfc_sym_get_dummy_args (sym
);
13023 while (curr_arg
!= NULL
)
13025 /* Skip implicitly typed dummy args here. */
13026 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
13027 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
13028 /* If something is found to fail, record the fact so we
13029 can mark the symbol for the procedure as not being
13030 BIND(C) to try and prevent multiple errors being
13032 has_non_interop_arg
= 1;
13034 curr_arg
= curr_arg
->next
;
13037 /* See if any of the arguments were not interoperable and if so, clear
13038 the procedure symbol to prevent duplicate error messages. */
13039 if (has_non_interop_arg
!= 0)
13041 sym
->attr
.is_c_interop
= 0;
13042 sym
->ts
.is_c_interop
= 0;
13043 sym
->attr
.is_bind_c
= 0;
13047 if (!sym
->attr
.proc_pointer
)
13049 if (sym
->attr
.save
== SAVE_EXPLICIT
)
13051 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
13052 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13055 if (sym
->attr
.intent
)
13057 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
13058 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13061 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
13063 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
13064 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13067 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
13068 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
13069 || sym
->attr
.contained
))
13071 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
13072 "in %qs at %L", sym
->name
, &sym
->declared_at
);
13075 if (strcmp ("ppr@", sym
->name
) == 0)
13077 gfc_error ("Procedure pointer result %qs at %L "
13078 "is missing the pointer attribute",
13079 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
13084 /* Assume that a procedure whose body is not known has references
13085 to external arrays. */
13086 if (sym
->attr
.if_source
!= IFSRC_DECL
)
13087 sym
->attr
.array_outer_dependency
= 1;
13089 /* Compare the characteristics of a module procedure with the
13090 interface declaration. Ideally this would be done with
13091 gfc_compare_interfaces but, at present, the formal interface
13092 cannot be copied to the ts.interface. */
13093 if (sym
->attr
.module_procedure
13094 && sym
->attr
.if_source
== IFSRC_DECL
)
13097 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
13099 char *submodule_name
;
13100 strcpy (name
, sym
->ns
->proc_name
->name
);
13101 module_name
= strtok (name
, ".");
13102 submodule_name
= strtok (NULL
, ".");
13104 iface
= sym
->tlink
;
13107 /* Make sure that the result uses the correct charlen for deferred
13109 if (iface
&& sym
->result
13110 && iface
->ts
.type
== BT_CHARACTER
13111 && iface
->ts
.deferred
)
13112 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
13117 /* Check the procedure characteristics. */
13118 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
13120 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
13121 "PROCEDURE at %L and its interface in %s",
13122 &sym
->declared_at
, module_name
);
13126 if (sym
->attr
.pure
!= iface
->attr
.pure
)
13128 gfc_error ("Mismatch in PURE attribute between MODULE "
13129 "PROCEDURE at %L and its interface in %s",
13130 &sym
->declared_at
, module_name
);
13134 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
13136 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
13137 "PROCEDURE at %L and its interface in %s",
13138 &sym
->declared_at
, module_name
);
13142 /* Check the result characteristics. */
13143 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
13145 gfc_error ("%s between the MODULE PROCEDURE declaration "
13146 "in MODULE %qs and the declaration at %L in "
13148 errmsg
, module_name
, &sym
->declared_at
,
13149 submodule_name
? submodule_name
: module_name
);
13154 /* Check the characteristics of the formal arguments. */
13155 if (sym
->formal
&& sym
->formal_ns
)
13157 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
13160 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
13168 /* Resolve a list of finalizer procedures. That is, after they have hopefully
13169 been defined and we now know their defined arguments, check that they fulfill
13170 the requirements of the standard for procedures used as finalizers. */
13173 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
13175 gfc_finalizer
* list
;
13176 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
13177 bool result
= true;
13178 bool seen_scalar
= false;
13181 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
13184 gfc_resolve_finalizers (parent
, finalizable
);
13186 /* Ensure that derived-type components have a their finalizers resolved. */
13187 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
13188 for (c
= derived
->components
; c
; c
= c
->next
)
13189 if (c
->ts
.type
== BT_DERIVED
13190 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
13192 bool has_final2
= false;
13193 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
13194 return false; /* Error. */
13195 has_final
= has_final
|| has_final2
;
13197 /* Return early if not finalizable. */
13201 *finalizable
= false;
13205 /* Walk over the list of finalizer-procedures, check them, and if any one
13206 does not fit in with the standard's definition, print an error and remove
13207 it from the list. */
13208 prev_link
= &derived
->f2k_derived
->finalizers
;
13209 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
13211 gfc_formal_arglist
*dummy_args
;
13216 /* Skip this finalizer if we already resolved it. */
13217 if (list
->proc_tree
)
13219 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
13220 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
13221 seen_scalar
= true;
13222 prev_link
= &(list
->next
);
13226 /* Check this exists and is a SUBROUTINE. */
13227 if (!list
->proc_sym
->attr
.subroutine
)
13229 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
13230 list
->proc_sym
->name
, &list
->where
);
13234 /* We should have exactly one argument. */
13235 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
13236 if (!dummy_args
|| dummy_args
->next
)
13238 gfc_error ("FINAL procedure at %L must have exactly one argument",
13242 arg
= dummy_args
->sym
;
13244 /* This argument must be of our type. */
13245 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
13247 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
13248 &arg
->declared_at
, derived
->name
);
13252 /* It must neither be a pointer nor allocatable nor optional. */
13253 if (arg
->attr
.pointer
)
13255 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13256 &arg
->declared_at
);
13259 if (arg
->attr
.allocatable
)
13261 gfc_error ("Argument of FINAL procedure at %L must not be"
13262 " ALLOCATABLE", &arg
->declared_at
);
13265 if (arg
->attr
.optional
)
13267 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13268 &arg
->declared_at
);
13272 /* It must not be INTENT(OUT). */
13273 if (arg
->attr
.intent
== INTENT_OUT
)
13275 gfc_error ("Argument of FINAL procedure at %L must not be"
13276 " INTENT(OUT)", &arg
->declared_at
);
13280 /* Warn if the procedure is non-scalar and not assumed shape. */
13281 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
13282 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
13283 gfc_warning (OPT_Wsurprising
,
13284 "Non-scalar FINAL procedure at %L should have assumed"
13285 " shape argument", &arg
->declared_at
);
13287 /* Check that it does not match in kind and rank with a FINAL procedure
13288 defined earlier. To really loop over the *earlier* declarations,
13289 we need to walk the tail of the list as new ones were pushed at the
13291 /* TODO: Handle kind parameters once they are implemented. */
13292 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
13293 for (i
= list
->next
; i
; i
= i
->next
)
13295 gfc_formal_arglist
*dummy_args
;
13297 /* Argument list might be empty; that is an error signalled earlier,
13298 but we nevertheless continued resolving. */
13299 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
13302 gfc_symbol
* i_arg
= dummy_args
->sym
;
13303 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
13304 if (i_rank
== my_rank
)
13306 gfc_error ("FINAL procedure %qs declared at %L has the same"
13307 " rank (%d) as %qs",
13308 list
->proc_sym
->name
, &list
->where
, my_rank
,
13309 i
->proc_sym
->name
);
13315 /* Is this the/a scalar finalizer procedure? */
13317 seen_scalar
= true;
13319 /* Find the symtree for this procedure. */
13320 gcc_assert (!list
->proc_tree
);
13321 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
13323 prev_link
= &list
->next
;
13326 /* Remove wrong nodes immediately from the list so we don't risk any
13327 troubles in the future when they might fail later expectations. */
13330 *prev_link
= list
->next
;
13331 gfc_free_finalizer (i
);
13335 if (result
== false)
13338 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13339 were nodes in the list, must have been for arrays. It is surely a good
13340 idea to have a scalar version there if there's something to finalize. */
13341 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
13342 gfc_warning (OPT_Wsurprising
,
13343 "Only array FINAL procedures declared for derived type %qs"
13344 " defined at %L, suggest also scalar one",
13345 derived
->name
, &derived
->declared_at
);
13347 vtab
= gfc_find_derived_vtab (derived
);
13348 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
13349 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
13352 *finalizable
= true;
13358 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13361 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13362 const char* generic_name
, locus where
)
13364 gfc_symbol
*sym1
, *sym2
;
13365 const char *pass1
, *pass2
;
13366 gfc_formal_arglist
*dummy_args
;
13368 gcc_assert (t1
->specific
&& t2
->specific
);
13369 gcc_assert (!t1
->specific
->is_generic
);
13370 gcc_assert (!t2
->specific
->is_generic
);
13371 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13373 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13374 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13379 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13380 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13381 || sym1
->attr
.function
!= sym2
->attr
.function
)
13383 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
13384 " GENERIC %qs at %L",
13385 sym1
->name
, sym2
->name
, generic_name
, &where
);
13389 /* Determine PASS arguments. */
13390 if (t1
->specific
->nopass
)
13392 else if (t1
->specific
->pass_arg
)
13393 pass1
= t1
->specific
->pass_arg
;
13396 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13398 pass1
= dummy_args
->sym
->name
;
13402 if (t2
->specific
->nopass
)
13404 else if (t2
->specific
->pass_arg
)
13405 pass2
= t2
->specific
->pass_arg
;
13408 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13410 pass2
= dummy_args
->sym
->name
;
13415 /* Compare the interfaces. */
13416 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13417 NULL
, 0, pass1
, pass2
))
13419 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13420 sym1
->name
, sym2
->name
, generic_name
, &where
);
13428 /* Worker function for resolving a generic procedure binding; this is used to
13429 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13431 The difference between those cases is finding possible inherited bindings
13432 that are overridden, as one has to look for them in tb_sym_root,
13433 tb_uop_root or tb_op, respectively. Thus the caller must already find
13434 the super-type and set p->overridden correctly. */
13437 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13438 gfc_typebound_proc
* p
, const char* name
)
13440 gfc_tbp_generic
* target
;
13441 gfc_symtree
* first_target
;
13442 gfc_symtree
* inherited
;
13444 gcc_assert (p
&& p
->is_generic
);
13446 /* Try to find the specific bindings for the symtrees in our target-list. */
13447 gcc_assert (p
->u
.generic
);
13448 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13449 if (!target
->specific
)
13451 gfc_typebound_proc
* overridden_tbp
;
13452 gfc_tbp_generic
* g
;
13453 const char* target_name
;
13455 target_name
= target
->specific_st
->name
;
13457 /* Defined for this type directly. */
13458 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13460 target
->specific
= target
->specific_st
->n
.tb
;
13461 goto specific_found
;
13464 /* Look for an inherited specific binding. */
13467 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13472 gcc_assert (inherited
->n
.tb
);
13473 target
->specific
= inherited
->n
.tb
;
13474 goto specific_found
;
13478 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13479 " at %L", target_name
, name
, &p
->where
);
13482 /* Once we've found the specific binding, check it is not ambiguous with
13483 other specifics already found or inherited for the same GENERIC. */
13485 gcc_assert (target
->specific
);
13487 /* This must really be a specific binding! */
13488 if (target
->specific
->is_generic
)
13490 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13491 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13495 /* Check those already resolved on this type directly. */
13496 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13497 if (g
!= target
&& g
->specific
13498 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13501 /* Check for ambiguity with inherited specific targets. */
13502 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13503 overridden_tbp
= overridden_tbp
->overridden
)
13504 if (overridden_tbp
->is_generic
)
13506 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13508 gcc_assert (g
->specific
);
13509 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13515 /* If we attempt to "overwrite" a specific binding, this is an error. */
13516 if (p
->overridden
&& !p
->overridden
->is_generic
)
13518 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
13519 " the same name", name
, &p
->where
);
13523 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13524 all must have the same attributes here. */
13525 first_target
= p
->u
.generic
->specific
->u
.specific
;
13526 gcc_assert (first_target
);
13527 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13528 p
->function
= first_target
->n
.sym
->attr
.function
;
13534 /* Resolve a GENERIC procedure binding for a derived type. */
13537 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13539 gfc_symbol
* super_type
;
13541 /* Find the overridden binding if any. */
13542 st
->n
.tb
->overridden
= NULL
;
13543 super_type
= gfc_get_derived_super_type (derived
);
13546 gfc_symtree
* overridden
;
13547 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13550 if (overridden
&& overridden
->n
.tb
)
13551 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13554 /* Resolve using worker function. */
13555 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13559 /* Retrieve the target-procedure of an operator binding and do some checks in
13560 common for intrinsic and user-defined type-bound operators. */
13563 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13565 gfc_symbol
* target_proc
;
13567 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13568 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13569 gcc_assert (target_proc
);
13571 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13572 if (target
->specific
->nopass
)
13574 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
13578 return target_proc
;
13582 /* Resolve a type-bound intrinsic operator. */
13585 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13586 gfc_typebound_proc
* p
)
13588 gfc_symbol
* super_type
;
13589 gfc_tbp_generic
* target
;
13591 /* If there's already an error here, do nothing (but don't fail again). */
13595 /* Operators should always be GENERIC bindings. */
13596 gcc_assert (p
->is_generic
);
13598 /* Look for an overridden binding. */
13599 super_type
= gfc_get_derived_super_type (derived
);
13600 if (super_type
&& super_type
->f2k_derived
)
13601 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13604 p
->overridden
= NULL
;
13606 /* Resolve general GENERIC properties using worker function. */
13607 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13610 /* Check the targets to be procedures of correct interface. */
13611 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13613 gfc_symbol
* target_proc
;
13615 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13619 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13622 /* Add target to non-typebound operator list. */
13623 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13624 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13626 gfc_interface
*head
, *intr
;
13628 /* Preempt 'gfc_check_new_interface' for submodules, where the
13629 mechanism for handling module procedures winds up resolving
13630 operator interfaces twice and would otherwise cause an error. */
13631 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13632 if (intr
->sym
== target_proc
13633 && target_proc
->attr
.used_in_submodule
)
13636 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13637 target_proc
, p
->where
))
13639 head
= derived
->ns
->op
[op
];
13640 intr
= gfc_get_interface ();
13641 intr
->sym
= target_proc
;
13642 intr
->where
= p
->where
;
13644 derived
->ns
->op
[op
] = intr
;
13656 /* Resolve a type-bound user operator (tree-walker callback). */
13658 static gfc_symbol
* resolve_bindings_derived
;
13659 static bool resolve_bindings_result
;
13661 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13664 resolve_typebound_user_op (gfc_symtree
* stree
)
13666 gfc_symbol
* super_type
;
13667 gfc_tbp_generic
* target
;
13669 gcc_assert (stree
&& stree
->n
.tb
);
13671 if (stree
->n
.tb
->error
)
13674 /* Operators should always be GENERIC bindings. */
13675 gcc_assert (stree
->n
.tb
->is_generic
);
13677 /* Find overridden procedure, if any. */
13678 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13679 if (super_type
&& super_type
->f2k_derived
)
13681 gfc_symtree
* overridden
;
13682 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13683 stree
->name
, true, NULL
);
13685 if (overridden
&& overridden
->n
.tb
)
13686 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13689 stree
->n
.tb
->overridden
= NULL
;
13691 /* Resolve basically using worker function. */
13692 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13695 /* Check the targets to be functions of correct interface. */
13696 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13698 gfc_symbol
* target_proc
;
13700 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13704 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13711 resolve_bindings_result
= false;
13712 stree
->n
.tb
->error
= 1;
13716 /* Resolve the type-bound procedures for a derived type. */
13719 resolve_typebound_procedure (gfc_symtree
* stree
)
13723 gfc_symbol
* me_arg
;
13724 gfc_symbol
* super_type
;
13725 gfc_component
* comp
;
13727 gcc_assert (stree
);
13729 /* Undefined specific symbol from GENERIC target definition. */
13733 if (stree
->n
.tb
->error
)
13736 /* If this is a GENERIC binding, use that routine. */
13737 if (stree
->n
.tb
->is_generic
)
13739 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13744 /* Get the target-procedure to check it. */
13745 gcc_assert (!stree
->n
.tb
->is_generic
);
13746 gcc_assert (stree
->n
.tb
->u
.specific
);
13747 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13748 where
= stree
->n
.tb
->where
;
13750 /* Default access should already be resolved from the parser. */
13751 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13753 if (stree
->n
.tb
->deferred
)
13755 if (!check_proc_interface (proc
, &where
))
13760 /* If proc has not been resolved at this point, proc->name may
13761 actually be a USE associated entity. See PR fortran/89647. */
13762 if (!proc
->resolved
13763 && proc
->attr
.function
== 0 && proc
->attr
.subroutine
== 0)
13766 gfc_find_symbol (proc
->name
, gfc_current_ns
->parent
, 1, &tmp
);
13767 if (tmp
&& tmp
->attr
.use_assoc
)
13769 proc
->module
= tmp
->module
;
13770 proc
->attr
.proc
= tmp
->attr
.proc
;
13771 proc
->attr
.function
= tmp
->attr
.function
;
13772 proc
->attr
.subroutine
= tmp
->attr
.subroutine
;
13773 proc
->attr
.use_assoc
= tmp
->attr
.use_assoc
;
13774 proc
->ts
= tmp
->ts
;
13775 proc
->result
= tmp
->result
;
13779 /* Check for F08:C465. */
13780 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13781 || (proc
->attr
.proc
!= PROC_MODULE
13782 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13783 || proc
->attr
.abstract
)
13785 gfc_error ("%qs must be a module procedure or an external "
13786 "procedure with an explicit interface at %L",
13787 proc
->name
, &where
);
13792 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13793 stree
->n
.tb
->function
= proc
->attr
.function
;
13795 /* Find the super-type of the current derived type. We could do this once and
13796 store in a global if speed is needed, but as long as not I believe this is
13797 more readable and clearer. */
13798 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13800 /* If PASS, resolve and check arguments if not already resolved / loaded
13801 from a .mod file. */
13802 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13804 gfc_formal_arglist
*dummy_args
;
13806 dummy_args
= gfc_sym_get_dummy_args (proc
);
13807 if (stree
->n
.tb
->pass_arg
)
13809 gfc_formal_arglist
*i
;
13811 /* If an explicit passing argument name is given, walk the arg-list
13812 and look for it. */
13815 stree
->n
.tb
->pass_arg_num
= 1;
13816 for (i
= dummy_args
; i
; i
= i
->next
)
13818 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13823 ++stree
->n
.tb
->pass_arg_num
;
13828 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13830 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13831 stree
->n
.tb
->pass_arg
);
13837 /* Otherwise, take the first one; there should in fact be at least
13839 stree
->n
.tb
->pass_arg_num
= 1;
13842 gfc_error ("Procedure %qs with PASS at %L must have at"
13843 " least one argument", proc
->name
, &where
);
13846 me_arg
= dummy_args
->sym
;
13849 /* Now check that the argument-type matches and the passed-object
13850 dummy argument is generally fine. */
13852 gcc_assert (me_arg
);
13854 if (me_arg
->ts
.type
!= BT_CLASS
)
13856 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13857 " at %L", proc
->name
, &where
);
13861 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13862 != resolve_bindings_derived
)
13864 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13865 " the derived-type %qs", me_arg
->name
, proc
->name
,
13866 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13870 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13871 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13873 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13874 " scalar", proc
->name
, &where
);
13877 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13879 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13880 " be ALLOCATABLE", proc
->name
, &where
);
13883 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13885 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13886 " be POINTER", proc
->name
, &where
);
13891 /* If we are extending some type, check that we don't override a procedure
13892 flagged NON_OVERRIDABLE. */
13893 stree
->n
.tb
->overridden
= NULL
;
13896 gfc_symtree
* overridden
;
13897 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13898 stree
->name
, true, NULL
);
13902 if (overridden
->n
.tb
)
13903 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13905 if (!gfc_check_typebound_override (stree
, overridden
))
13910 /* See if there's a name collision with a component directly in this type. */
13911 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13912 if (!strcmp (comp
->name
, stree
->name
))
13914 gfc_error ("Procedure %qs at %L has the same name as a component of"
13916 stree
->name
, &where
, resolve_bindings_derived
->name
);
13920 /* Try to find a name collision with an inherited component. */
13921 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13924 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13925 " component of %qs",
13926 stree
->name
, &where
, resolve_bindings_derived
->name
);
13930 stree
->n
.tb
->error
= 0;
13934 resolve_bindings_result
= false;
13935 stree
->n
.tb
->error
= 1;
13940 resolve_typebound_procedures (gfc_symbol
* derived
)
13943 gfc_symbol
* super_type
;
13945 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13948 super_type
= gfc_get_derived_super_type (derived
);
13950 resolve_symbol (super_type
);
13952 resolve_bindings_derived
= derived
;
13953 resolve_bindings_result
= true;
13955 if (derived
->f2k_derived
->tb_sym_root
)
13956 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13957 &resolve_typebound_procedure
);
13959 if (derived
->f2k_derived
->tb_uop_root
)
13960 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13961 &resolve_typebound_user_op
);
13963 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13965 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13966 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13967 (gfc_intrinsic_op
)op
, p
))
13968 resolve_bindings_result
= false;
13971 return resolve_bindings_result
;
13975 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13976 to give all identical derived types the same backend_decl. */
13978 add_dt_to_dt_list (gfc_symbol
*derived
)
13980 if (!derived
->dt_next
)
13982 if (gfc_derived_types
)
13984 derived
->dt_next
= gfc_derived_types
->dt_next
;
13985 gfc_derived_types
->dt_next
= derived
;
13989 derived
->dt_next
= derived
;
13991 gfc_derived_types
= derived
;
13996 /* Ensure that a derived-type is really not abstract, meaning that every
13997 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
14000 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
14005 if (!ensure_not_abstract_walker (sub
, st
->left
))
14007 if (!ensure_not_abstract_walker (sub
, st
->right
))
14010 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
14012 gfc_symtree
* overriding
;
14013 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
14016 gcc_assert (overriding
->n
.tb
);
14017 if (overriding
->n
.tb
->deferred
)
14019 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
14020 " %qs is DEFERRED and not overridden",
14021 sub
->name
, &sub
->declared_at
, st
->name
);
14030 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
14032 /* The algorithm used here is to recursively travel up the ancestry of sub
14033 and for each ancestor-type, check all bindings. If any of them is
14034 DEFERRED, look it up starting from sub and see if the found (overriding)
14035 binding is not DEFERRED.
14036 This is not the most efficient way to do this, but it should be ok and is
14037 clearer than something sophisticated. */
14039 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
14041 if (!ancestor
->attr
.abstract
)
14044 /* Walk bindings of this ancestor. */
14045 if (ancestor
->f2k_derived
)
14048 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
14053 /* Find next ancestor type and recurse on it. */
14054 ancestor
= gfc_get_derived_super_type (ancestor
);
14056 return ensure_not_abstract (sub
, ancestor
);
14062 /* This check for typebound defined assignments is done recursively
14063 since the order in which derived types are resolved is not always in
14064 order of the declarations. */
14067 check_defined_assignments (gfc_symbol
*derived
)
14071 for (c
= derived
->components
; c
; c
= c
->next
)
14073 if (!gfc_bt_struct (c
->ts
.type
)
14075 || c
->attr
.allocatable
14076 || c
->attr
.proc_pointer_comp
14077 || c
->attr
.class_pointer
14078 || c
->attr
.proc_pointer
)
14081 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
14082 || (c
->ts
.u
.derived
->f2k_derived
14083 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
14085 derived
->attr
.defined_assign_comp
= 1;
14089 check_defined_assignments (c
->ts
.u
.derived
);
14090 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
14092 derived
->attr
.defined_assign_comp
= 1;
14099 /* Resolve a single component of a derived type or structure. */
14102 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
14104 gfc_symbol
*super_type
;
14105 symbol_attribute
*attr
;
14107 if (c
->attr
.artificial
)
14110 /* Do not allow vtype components to be resolved in nameless namespaces
14111 such as block data because the procedure pointers will cause ICEs
14112 and vtables are not needed in these contexts. */
14113 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
14114 && sym
->ns
->proc_name
== NULL
)
14118 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
14119 && c
->attr
.codimension
14120 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
14122 gfc_error ("Coarray component %qs at %L must be allocatable with "
14123 "deferred shape", c
->name
, &c
->loc
);
14128 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
14129 && c
->ts
.u
.derived
->ts
.is_iso_c
)
14131 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14132 "shall not be a coarray", c
->name
, &c
->loc
);
14137 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
14138 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
14139 || c
->attr
.allocatable
))
14141 gfc_error ("Component %qs at %L with coarray component "
14142 "shall be a nonpointer, nonallocatable scalar",
14148 if (c
->ts
.type
== BT_CLASS
)
14150 if (CLASS_DATA (c
))
14152 attr
= &(CLASS_DATA (c
)->attr
);
14154 /* Fix up contiguous attribute. */
14155 if (c
->attr
.contiguous
)
14156 attr
->contiguous
= 1;
14164 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
14166 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
14167 "is not an array pointer", c
->name
, &c
->loc
);
14171 /* F2003, 15.2.1 - length has to be one. */
14172 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
14173 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
14174 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
14175 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
14177 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
14182 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
14184 gfc_symbol
*ifc
= c
->ts
.interface
;
14186 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
14192 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
14194 /* Resolve interface and copy attributes. */
14195 if (ifc
->formal
&& !ifc
->formal_ns
)
14196 resolve_symbol (ifc
);
14197 if (ifc
->attr
.intrinsic
)
14198 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
14202 c
->ts
= ifc
->result
->ts
;
14203 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
14204 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
14205 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
14206 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
14207 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
14212 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
14213 c
->attr
.pointer
= ifc
->attr
.pointer
;
14214 c
->attr
.dimension
= ifc
->attr
.dimension
;
14215 c
->as
= gfc_copy_array_spec (ifc
->as
);
14216 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
14218 c
->ts
.interface
= ifc
;
14219 c
->attr
.function
= ifc
->attr
.function
;
14220 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
14222 c
->attr
.pure
= ifc
->attr
.pure
;
14223 c
->attr
.elemental
= ifc
->attr
.elemental
;
14224 c
->attr
.recursive
= ifc
->attr
.recursive
;
14225 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
14226 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
14227 /* Copy char length. */
14228 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
14230 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
14231 if (cl
->length
&& !cl
->resolved
14232 && !gfc_resolve_expr (cl
->length
))
14241 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
14243 /* Since PPCs are not implicitly typed, a PPC without an explicit
14244 interface must be a subroutine. */
14245 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
14248 /* Procedure pointer components: Check PASS arg. */
14249 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
14250 && !sym
->attr
.vtype
)
14252 gfc_symbol
* me_arg
;
14254 if (c
->tb
->pass_arg
)
14256 gfc_formal_arglist
* i
;
14258 /* If an explicit passing argument name is given, walk the arg-list
14259 and look for it. */
14262 c
->tb
->pass_arg_num
= 1;
14263 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
14265 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
14270 c
->tb
->pass_arg_num
++;
14275 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14276 "at %L has no argument %qs", c
->name
,
14277 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
14284 /* Otherwise, take the first one; there should in fact be at least
14286 c
->tb
->pass_arg_num
= 1;
14287 if (!c
->ts
.interface
->formal
)
14289 gfc_error ("Procedure pointer component %qs with PASS at %L "
14290 "must have at least one argument",
14295 me_arg
= c
->ts
.interface
->formal
->sym
;
14298 /* Now check that the argument-type matches. */
14299 gcc_assert (me_arg
);
14300 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
14301 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
14302 || (me_arg
->ts
.type
== BT_CLASS
14303 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
14305 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14306 " the derived type %qs", me_arg
->name
, c
->name
,
14307 me_arg
->name
, &c
->loc
, sym
->name
);
14312 /* Check for F03:C453. */
14313 if (CLASS_DATA (me_arg
)->attr
.dimension
)
14315 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14316 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
14322 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14324 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14325 "may not have the POINTER attribute", me_arg
->name
,
14326 c
->name
, me_arg
->name
, &c
->loc
);
14331 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14333 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14334 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
14335 me_arg
->name
, &c
->loc
);
14340 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
14342 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14343 " at %L", c
->name
, &c
->loc
);
14349 /* Check type-spec if this is not the parent-type component. */
14350 if (((sym
->attr
.is_class
14351 && (!sym
->components
->ts
.u
.derived
->attr
.extension
14352 || c
!= sym
->components
->ts
.u
.derived
->components
))
14353 || (!sym
->attr
.is_class
14354 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
14355 && !sym
->attr
.vtype
14356 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
14359 super_type
= gfc_get_derived_super_type (sym
);
14361 /* If this type is an extension, set the accessibility of the parent
14364 && ((sym
->attr
.is_class
14365 && c
== sym
->components
->ts
.u
.derived
->components
)
14366 || (!sym
->attr
.is_class
&& c
== sym
->components
))
14367 && strcmp (super_type
->name
, c
->name
) == 0)
14368 c
->attr
.access
= super_type
->attr
.access
;
14370 /* If this type is an extension, see if this component has the same name
14371 as an inherited type-bound procedure. */
14372 if (super_type
&& !sym
->attr
.is_class
14373 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
14375 gfc_error ("Component %qs of %qs at %L has the same name as an"
14376 " inherited type-bound procedure",
14377 c
->name
, sym
->name
, &c
->loc
);
14381 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
14382 && !c
->ts
.deferred
)
14384 if (c
->ts
.u
.cl
->length
== NULL
14385 || (!resolve_charlen(c
->ts
.u
.cl
))
14386 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
14388 gfc_error ("Character length of component %qs needs to "
14389 "be a constant specification expression at %L",
14391 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14396 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14397 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14399 gfc_error ("Character component %qs of %qs at %L with deferred "
14400 "length must be a POINTER or ALLOCATABLE",
14401 c
->name
, sym
->name
, &c
->loc
);
14405 /* Add the hidden deferred length field. */
14406 if (c
->ts
.type
== BT_CHARACTER
14407 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14408 && !c
->attr
.function
14409 && !sym
->attr
.is_class
)
14411 char name
[GFC_MAX_SYMBOL_LEN
+9];
14412 gfc_component
*strlen
;
14413 sprintf (name
, "_%s_length", c
->name
);
14414 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14415 if (strlen
== NULL
)
14417 if (!gfc_add_component (sym
, name
, &strlen
))
14419 strlen
->ts
.type
= BT_INTEGER
;
14420 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14421 strlen
->attr
.access
= ACCESS_PRIVATE
;
14422 strlen
->attr
.artificial
= 1;
14426 if (c
->ts
.type
== BT_DERIVED
14427 && sym
->component_access
!= ACCESS_PRIVATE
14428 && gfc_check_symbol_access (sym
)
14429 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14430 && !c
->ts
.u
.derived
->attr
.use_assoc
14431 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14432 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14433 "PRIVATE type and cannot be a component of "
14434 "%qs, which is PUBLIC at %L", c
->name
,
14435 sym
->name
, &sym
->declared_at
))
14438 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14440 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14441 "type %s", c
->name
, &c
->loc
, sym
->name
);
14445 if (sym
->attr
.sequence
)
14447 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14449 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14450 "not have the SEQUENCE attribute",
14451 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14456 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14457 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14458 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14459 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14460 CLASS_DATA (c
)->ts
.u
.derived
14461 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14463 /* If an allocatable component derived type is of the same type as
14464 the enclosing derived type, we need a vtable generating so that
14465 the __deallocate procedure is created. */
14466 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14467 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14468 gfc_find_vtab (&c
->ts
);
14470 /* Ensure that all the derived type components are put on the
14471 derived type list; even in formal namespaces, where derived type
14472 pointer components might not have been declared. */
14473 if (c
->ts
.type
== BT_DERIVED
14475 && c
->ts
.u
.derived
->components
14477 && sym
!= c
->ts
.u
.derived
)
14478 add_dt_to_dt_list (c
->ts
.u
.derived
);
14480 if (!gfc_resolve_array_spec (c
->as
,
14481 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
14482 || c
->attr
.allocatable
)))
14485 if (c
->initializer
&& !sym
->attr
.vtype
14486 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
14487 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
14494 /* Be nice about the locus for a structure expression - show the locus of the
14495 first non-null sub-expression if we can. */
14498 cons_where (gfc_expr
*struct_expr
)
14500 gfc_constructor
*cons
;
14502 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
14504 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
14505 for (; cons
; cons
= gfc_constructor_next (cons
))
14507 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
14508 return &cons
->expr
->where
;
14511 return &struct_expr
->where
;
14514 /* Resolve the components of a structure type. Much less work than derived
14518 resolve_fl_struct (gfc_symbol
*sym
)
14521 gfc_expr
*init
= NULL
;
14524 /* Make sure UNIONs do not have overlapping initializers. */
14525 if (sym
->attr
.flavor
== FL_UNION
)
14527 for (c
= sym
->components
; c
; c
= c
->next
)
14529 if (init
&& c
->initializer
)
14531 gfc_error ("Conflicting initializers in union at %L and %L",
14532 cons_where (init
), cons_where (c
->initializer
));
14533 gfc_free_expr (c
->initializer
);
14534 c
->initializer
= NULL
;
14537 init
= c
->initializer
;
14542 for (c
= sym
->components
; c
; c
= c
->next
)
14543 if (!resolve_component (c
, sym
))
14549 if (sym
->components
)
14550 add_dt_to_dt_list (sym
);
14556 /* Resolve the components of a derived type. This does not have to wait until
14557 resolution stage, but can be done as soon as the dt declaration has been
14561 resolve_fl_derived0 (gfc_symbol
*sym
)
14563 gfc_symbol
* super_type
;
14565 gfc_formal_arglist
*f
;
14568 if (sym
->attr
.unlimited_polymorphic
)
14571 super_type
= gfc_get_derived_super_type (sym
);
14574 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14576 gfc_error ("As extending type %qs at %L has a coarray component, "
14577 "parent type %qs shall also have one", sym
->name
,
14578 &sym
->declared_at
, super_type
->name
);
14582 /* Ensure the extended type gets resolved before we do. */
14583 if (super_type
&& !resolve_fl_derived0 (super_type
))
14586 /* An ABSTRACT type must be extensible. */
14587 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14589 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14590 sym
->name
, &sym
->declared_at
);
14594 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14598 for ( ; c
!= NULL
; c
= c
->next
)
14599 if (!resolve_component (c
, sym
))
14605 /* Now add the caf token field, where needed. */
14606 if (flag_coarray
!= GFC_FCOARRAY_NONE
14607 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14609 for (c
= sym
->components
; c
; c
= c
->next
)
14610 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14611 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14613 char name
[GFC_MAX_SYMBOL_LEN
+9];
14614 gfc_component
*token
;
14615 sprintf (name
, "_caf_%s", c
->name
);
14616 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14619 if (!gfc_add_component (sym
, name
, &token
))
14621 token
->ts
.type
= BT_VOID
;
14622 token
->ts
.kind
= gfc_default_integer_kind
;
14623 token
->attr
.access
= ACCESS_PRIVATE
;
14624 token
->attr
.artificial
= 1;
14625 token
->attr
.caf_token
= 1;
14630 check_defined_assignments (sym
);
14632 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14633 sym
->attr
.defined_assign_comp
14634 = super_type
->attr
.defined_assign_comp
;
14636 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14637 all DEFERRED bindings are overridden. */
14638 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14639 && !sym
->attr
.is_class
14640 && !ensure_not_abstract (sym
, super_type
))
14643 /* Check that there is a component for every PDT parameter. */
14644 if (sym
->attr
.pdt_template
)
14646 for (f
= sym
->formal
; f
; f
= f
->next
)
14650 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14653 gfc_error ("Parameterized type %qs does not have a component "
14654 "corresponding to parameter %qs at %L", sym
->name
,
14655 f
->sym
->name
, &sym
->declared_at
);
14661 /* Add derived type to the derived type list. */
14662 add_dt_to_dt_list (sym
);
14668 /* The following procedure does the full resolution of a derived type,
14669 including resolution of all type-bound procedures (if present). In contrast
14670 to 'resolve_fl_derived0' this can only be done after the module has been
14671 parsed completely. */
14674 resolve_fl_derived (gfc_symbol
*sym
)
14676 gfc_symbol
*gen_dt
= NULL
;
14678 if (sym
->attr
.unlimited_polymorphic
)
14681 if (!sym
->attr
.is_class
)
14682 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14683 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14684 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14685 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14686 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14687 "%qs at %L being the same name as derived "
14688 "type at %L", sym
->name
,
14689 gen_dt
->generic
->sym
== sym
14690 ? gen_dt
->generic
->next
->sym
->name
14691 : gen_dt
->generic
->sym
->name
,
14692 gen_dt
->generic
->sym
== sym
14693 ? &gen_dt
->generic
->next
->sym
->declared_at
14694 : &gen_dt
->generic
->sym
->declared_at
,
14695 &sym
->declared_at
))
14698 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
14700 gfc_error ("Derived type %qs at %L has not been declared",
14701 sym
->name
, &sym
->declared_at
);
14705 /* Resolve the finalizer procedures. */
14706 if (!gfc_resolve_finalizers (sym
, NULL
))
14709 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14711 /* Fix up incomplete CLASS symbols. */
14712 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14713 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14715 /* Nothing more to do for unlimited polymorphic entities. */
14716 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14718 else if (vptr
->ts
.u
.derived
== NULL
)
14720 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14722 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14723 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14728 if (!resolve_fl_derived0 (sym
))
14731 /* Resolve the type-bound procedures. */
14732 if (!resolve_typebound_procedures (sym
))
14735 /* Generate module vtables subject to their accessibility and their not
14736 being vtables or pdt templates. If this is not done class declarations
14737 in external procedures wind up with their own version and so SELECT TYPE
14738 fails because the vptrs do not have the same address. */
14739 if (gfc_option
.allow_std
& GFC_STD_F2003
14740 && sym
->ns
->proc_name
14741 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14742 && sym
->attr
.access
!= ACCESS_PRIVATE
14743 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14745 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14746 gfc_set_sym_referenced (vtab
);
14754 resolve_fl_namelist (gfc_symbol
*sym
)
14759 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14761 /* Check again, the check in match only works if NAMELIST comes
14763 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14765 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14766 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14770 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14771 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14772 "with assumed shape in namelist %qs at %L",
14773 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14776 if (is_non_constant_shape_array (nl
->sym
)
14777 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14778 "with nonconstant shape in namelist %qs at %L",
14779 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14782 if (nl
->sym
->ts
.type
== BT_CHARACTER
14783 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14784 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14785 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14786 "nonconstant character length in "
14787 "namelist %qs at %L", nl
->sym
->name
,
14788 sym
->name
, &sym
->declared_at
))
14793 /* Reject PRIVATE objects in a PUBLIC namelist. */
14794 if (gfc_check_symbol_access (sym
))
14796 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14798 if (!nl
->sym
->attr
.use_assoc
14799 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14800 && !gfc_check_symbol_access (nl
->sym
))
14802 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14803 "cannot be member of PUBLIC namelist %qs at %L",
14804 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14808 if (nl
->sym
->ts
.type
== BT_DERIVED
14809 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14810 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14812 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14813 "namelist %qs at %L with ALLOCATABLE "
14814 "or POINTER components", nl
->sym
->name
,
14815 sym
->name
, &sym
->declared_at
))
14820 /* Types with private components that came here by USE-association. */
14821 if (nl
->sym
->ts
.type
== BT_DERIVED
14822 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14824 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14825 "components and cannot be member of namelist %qs at %L",
14826 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14830 /* Types with private components that are defined in the same module. */
14831 if (nl
->sym
->ts
.type
== BT_DERIVED
14832 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14833 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14835 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14836 "cannot be a member of PUBLIC namelist %qs at %L",
14837 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14844 /* 14.1.2 A module or internal procedure represent local entities
14845 of the same type as a namelist member and so are not allowed. */
14846 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14848 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14851 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14852 if ((nl
->sym
== sym
->ns
->proc_name
)
14854 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14859 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14860 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14862 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14863 "attribute in %qs at %L", nlsym
->name
,
14864 &sym
->declared_at
);
14871 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14872 nl
->sym
->attr
.asynchronous
= 1;
14879 resolve_fl_parameter (gfc_symbol
*sym
)
14881 /* A parameter array's shape needs to be constant. */
14882 if (sym
->as
!= NULL
14883 && (sym
->as
->type
== AS_DEFERRED
14884 || is_non_constant_shape_array (sym
)))
14886 gfc_error ("Parameter array %qs at %L cannot be automatic "
14887 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14891 /* Constraints on deferred type parameter. */
14892 if (!deferred_requirements (sym
))
14895 /* Make sure a parameter that has been implicitly typed still
14896 matches the implicit type, since PARAMETER statements can precede
14897 IMPLICIT statements. */
14898 if (sym
->attr
.implicit_type
14899 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14902 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14903 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14907 /* Make sure the types of derived parameters are consistent. This
14908 type checking is deferred until resolution because the type may
14909 refer to a derived type from the host. */
14910 if (sym
->ts
.type
== BT_DERIVED
14911 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14913 gfc_error ("Incompatible derived type in PARAMETER at %L",
14914 &sym
->value
->where
);
14918 /* F03:C509,C514. */
14919 if (sym
->ts
.type
== BT_CLASS
)
14921 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14922 sym
->name
, &sym
->declared_at
);
14930 /* Called by resolve_symbol to check PDTs. */
14933 resolve_pdt (gfc_symbol
* sym
)
14935 gfc_symbol
*derived
= NULL
;
14936 gfc_actual_arglist
*param
;
14938 bool const_len_exprs
= true;
14939 bool assumed_len_exprs
= false;
14940 symbol_attribute
*attr
;
14942 if (sym
->ts
.type
== BT_DERIVED
)
14944 derived
= sym
->ts
.u
.derived
;
14945 attr
= &(sym
->attr
);
14947 else if (sym
->ts
.type
== BT_CLASS
)
14949 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14950 attr
= &(CLASS_DATA (sym
)->attr
);
14953 gcc_unreachable ();
14955 gcc_assert (derived
->attr
.pdt_type
);
14957 for (param
= sym
->param_list
; param
; param
= param
->next
)
14959 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14961 if (c
->attr
.pdt_kind
)
14964 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14965 && c
->attr
.pdt_len
)
14966 const_len_exprs
= false;
14967 else if (param
->spec_type
== SPEC_ASSUMED
)
14968 assumed_len_exprs
= true;
14970 if (param
->spec_type
== SPEC_DEFERRED
14971 && !attr
->allocatable
&& !attr
->pointer
)
14972 gfc_error ("The object %qs at %L has a deferred LEN "
14973 "parameter %qs and is neither allocatable "
14974 "nor a pointer", sym
->name
, &sym
->declared_at
,
14979 if (!const_len_exprs
14980 && (sym
->ns
->proc_name
->attr
.is_main_program
14981 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14982 || sym
->attr
.save
!= SAVE_NONE
))
14983 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14984 "SAVE attribute or be a variable declared in the "
14985 "main program, a module or a submodule(F08/C513)",
14986 sym
->name
, &sym
->declared_at
);
14988 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14989 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14990 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14991 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14992 sym
->name
, &sym
->declared_at
);
14996 /* Do anything necessary to resolve a symbol. Right now, we just
14997 assume that an otherwise unknown symbol is a variable. This sort
14998 of thing commonly happens for symbols in module. */
15001 resolve_symbol (gfc_symbol
*sym
)
15003 int check_constant
, mp_flag
;
15004 gfc_symtree
*symtree
;
15005 gfc_symtree
*this_symtree
;
15008 symbol_attribute class_attr
;
15009 gfc_array_spec
*as
;
15010 bool saved_specification_expr
;
15016 /* No symbol will ever have union type; only components can be unions.
15017 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
15018 (just like derived type declaration symbols have flavor FL_DERIVED). */
15019 gcc_assert (sym
->ts
.type
!= BT_UNION
);
15021 /* Coarrayed polymorphic objects with allocatable or pointer components are
15022 yet unsupported for -fcoarray=lib. */
15023 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
15024 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
15025 && CLASS_DATA (sym
)->attr
.codimension
15026 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
15027 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
15029 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
15030 "type coarrays at %L are unsupported", &sym
->declared_at
);
15034 if (sym
->attr
.artificial
)
15037 if (sym
->attr
.unlimited_polymorphic
)
15040 if (sym
->attr
.flavor
== FL_UNKNOWN
15041 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
15042 && !sym
->attr
.generic
&& !sym
->attr
.external
15043 && sym
->attr
.if_source
== IFSRC_UNKNOWN
15044 && sym
->ts
.type
== BT_UNKNOWN
))
15047 /* If we find that a flavorless symbol is an interface in one of the
15048 parent namespaces, find its symtree in this namespace, free the
15049 symbol and set the symtree to point to the interface symbol. */
15050 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
15052 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
15053 if (symtree
&& (symtree
->n
.sym
->generic
||
15054 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
15055 && sym
->ns
->construct_entities
)))
15057 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
15059 if (this_symtree
->n
.sym
== sym
)
15061 symtree
->n
.sym
->refs
++;
15062 gfc_release_symbol (sym
);
15063 this_symtree
->n
.sym
= symtree
->n
.sym
;
15069 /* Otherwise give it a flavor according to such attributes as
15071 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
15072 && sym
->attr
.intrinsic
== 0)
15073 sym
->attr
.flavor
= FL_VARIABLE
;
15074 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
15076 sym
->attr
.flavor
= FL_PROCEDURE
;
15077 if (sym
->attr
.dimension
)
15078 sym
->attr
.function
= 1;
15082 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
15083 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15085 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
15086 && !resolve_procedure_interface (sym
))
15089 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
15090 && (sym
->attr
.procedure
|| sym
->attr
.external
))
15092 if (sym
->attr
.external
)
15093 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
15094 "at %L", &sym
->declared_at
);
15096 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
15097 "at %L", &sym
->declared_at
);
15102 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
15105 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
15106 && !resolve_fl_struct (sym
))
15109 /* Symbols that are module procedures with results (functions) have
15110 the types and array specification copied for type checking in
15111 procedures that call them, as well as for saving to a module
15112 file. These symbols can't stand the scrutiny that their results
15114 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
15116 /* Make sure that the intrinsic is consistent with its internal
15117 representation. This needs to be done before assigning a default
15118 type to avoid spurious warnings. */
15119 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
15120 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
15123 /* Resolve associate names. */
15125 resolve_assoc_var (sym
, true);
15127 /* Assign default type to symbols that need one and don't have one. */
15128 if (sym
->ts
.type
== BT_UNKNOWN
)
15130 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
15132 gfc_set_default_type (sym
, 1, NULL
);
15135 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
15136 && !sym
->attr
.function
&& !sym
->attr
.subroutine
15137 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
15138 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
15140 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15142 /* The specific case of an external procedure should emit an error
15143 in the case that there is no implicit type. */
15146 if (!sym
->attr
.mixed_entry_master
)
15147 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
15151 /* Result may be in another namespace. */
15152 resolve_symbol (sym
->result
);
15154 if (!sym
->result
->attr
.proc_pointer
)
15156 sym
->ts
= sym
->result
->ts
;
15157 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
15158 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
15159 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
15160 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
15161 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
15166 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
15168 bool saved_specification_expr
= specification_expr
;
15169 specification_expr
= true;
15170 gfc_resolve_array_spec (sym
->result
->as
, false);
15171 specification_expr
= saved_specification_expr
;
15174 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
15176 as
= CLASS_DATA (sym
)->as
;
15177 class_attr
= CLASS_DATA (sym
)->attr
;
15178 class_attr
.pointer
= class_attr
.class_pointer
;
15182 class_attr
= sym
->attr
;
15187 if (sym
->attr
.contiguous
15188 && (!class_attr
.dimension
15189 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
15190 && !class_attr
.pointer
)))
15192 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
15193 "array pointer or an assumed-shape or assumed-rank array",
15194 sym
->name
, &sym
->declared_at
);
15198 /* Assumed size arrays and assumed shape arrays must be dummy
15199 arguments. Array-spec's of implied-shape should have been resolved to
15200 AS_EXPLICIT already. */
15204 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
15205 specification expression. */
15206 if (as
->type
== AS_IMPLIED_SHAPE
)
15209 for (i
=0; i
<as
->rank
; i
++)
15211 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
15213 gfc_error ("Bad specification for assumed size array at %L",
15214 &as
->lower
[i
]->where
);
15221 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
15222 || as
->type
== AS_ASSUMED_SHAPE
)
15223 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
15225 if (as
->type
== AS_ASSUMED_SIZE
)
15226 gfc_error ("Assumed size array at %L must be a dummy argument",
15227 &sym
->declared_at
);
15229 gfc_error ("Assumed shape array at %L must be a dummy argument",
15230 &sym
->declared_at
);
15233 /* TS 29113, C535a. */
15234 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
15235 && !sym
->attr
.select_type_temporary
15236 && !(cs_base
&& cs_base
->current
15237 && cs_base
->current
->op
== EXEC_SELECT_RANK
))
15239 gfc_error ("Assumed-rank array at %L must be a dummy argument",
15240 &sym
->declared_at
);
15243 if (as
->type
== AS_ASSUMED_RANK
15244 && (sym
->attr
.codimension
|| sym
->attr
.value
))
15246 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15247 "CODIMENSION attribute", &sym
->declared_at
);
15252 /* Make sure symbols with known intent or optional are really dummy
15253 variable. Because of ENTRY statement, this has to be deferred
15254 until resolution time. */
15256 if (!sym
->attr
.dummy
15257 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
15259 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
15263 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
15265 gfc_error ("%qs at %L cannot have the VALUE attribute because "
15266 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
15270 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
15272 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
15273 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
15275 gfc_error ("Character dummy variable %qs at %L with VALUE "
15276 "attribute must have constant length",
15277 sym
->name
, &sym
->declared_at
);
15281 if (sym
->ts
.is_c_interop
15282 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
15284 gfc_error ("C interoperable character dummy variable %qs at %L "
15285 "with VALUE attribute must have length one",
15286 sym
->name
, &sym
->declared_at
);
15291 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15292 && sym
->ts
.u
.derived
->attr
.generic
)
15294 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
15295 if (!sym
->ts
.u
.derived
)
15297 gfc_error ("The derived type %qs at %L is of type %qs, "
15298 "which has not been defined", sym
->name
,
15299 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15300 sym
->ts
.type
= BT_UNKNOWN
;
15305 /* Use the same constraints as TYPE(*), except for the type check
15306 and that only scalars and assumed-size arrays are permitted. */
15307 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
15309 if (!sym
->attr
.dummy
)
15311 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15312 "a dummy argument", sym
->name
, &sym
->declared_at
);
15316 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
15317 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
15318 && sym
->ts
.type
!= BT_COMPLEX
)
15320 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15321 "of type TYPE(*) or of an numeric intrinsic type",
15322 sym
->name
, &sym
->declared_at
);
15326 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15327 || sym
->attr
.pointer
|| sym
->attr
.value
)
15329 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15330 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15331 "attribute", sym
->name
, &sym
->declared_at
);
15335 if (sym
->attr
.intent
== INTENT_OUT
)
15337 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15338 "have the INTENT(OUT) attribute",
15339 sym
->name
, &sym
->declared_at
);
15342 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
15344 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15345 "either be a scalar or an assumed-size array",
15346 sym
->name
, &sym
->declared_at
);
15350 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15351 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15353 sym
->ts
.type
= BT_ASSUMED
;
15354 sym
->as
= gfc_get_array_spec ();
15355 sym
->as
->type
= AS_ASSUMED_SIZE
;
15357 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
15359 else if (sym
->ts
.type
== BT_ASSUMED
)
15361 /* TS 29113, C407a. */
15362 if (!sym
->attr
.dummy
)
15364 gfc_error ("Assumed type of variable %s at %L is only permitted "
15365 "for dummy variables", sym
->name
, &sym
->declared_at
);
15368 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15369 || sym
->attr
.pointer
|| sym
->attr
.value
)
15371 gfc_error ("Assumed-type variable %s at %L may not have the "
15372 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15373 sym
->name
, &sym
->declared_at
);
15376 if (sym
->attr
.intent
== INTENT_OUT
)
15378 gfc_error ("Assumed-type variable %s at %L may not have the "
15379 "INTENT(OUT) attribute",
15380 sym
->name
, &sym
->declared_at
);
15383 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
15385 gfc_error ("Assumed-type variable %s at %L shall not be an "
15386 "explicit-shape array", sym
->name
, &sym
->declared_at
);
15391 /* If the symbol is marked as bind(c), that it is declared at module level
15392 scope and verify its type and kind. Do not do the latter for symbols
15393 that are implicitly typed because that is handled in
15394 gfc_set_default_type. Handle dummy arguments and procedure definitions
15395 separately. Also, anything that is use associated is not handled here
15396 but instead is handled in the module it is declared in. Finally, derived
15397 type definitions are allowed to be BIND(C) since that only implies that
15398 they're interoperable, and they are checked fully for interoperability
15399 when a variable is declared of that type. */
15400 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15401 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15402 && sym
->attr
.flavor
!= FL_DERIVED
)
15406 /* First, make sure the variable is declared at the
15407 module-level scope (J3/04-007, Section 15.3). */
15408 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
15409 sym
->attr
.in_common
== 0)
15411 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15412 "is neither a COMMON block nor declared at the "
15413 "module level scope", sym
->name
, &(sym
->declared_at
));
15416 else if (sym
->ts
.type
== BT_CHARACTER
15417 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15418 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15419 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15421 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15422 sym
->name
, &sym
->declared_at
);
15425 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15427 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15429 else if (sym
->attr
.implicit_type
== 0)
15431 /* If type() declaration, we need to verify that the components
15432 of the given type are all C interoperable, etc. */
15433 if (sym
->ts
.type
== BT_DERIVED
&&
15434 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15436 /* Make sure the user marked the derived type as BIND(C). If
15437 not, call the verify routine. This could print an error
15438 for the derived type more than once if multiple variables
15439 of that type are declared. */
15440 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15441 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15445 /* Verify the variable itself as C interoperable if it
15446 is BIND(C). It is not possible for this to succeed if
15447 the verify_bind_c_derived_type failed, so don't have to handle
15448 any error returned by verify_bind_c_derived_type. */
15449 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15450 sym
->common_block
);
15455 /* clear the is_bind_c flag to prevent reporting errors more than
15456 once if something failed. */
15457 sym
->attr
.is_bind_c
= 0;
15462 /* If a derived type symbol has reached this point, without its
15463 type being declared, we have an error. Notice that most
15464 conditions that produce undefined derived types have already
15465 been dealt with. However, the likes of:
15466 implicit type(t) (t) ..... call foo (t) will get us here if
15467 the type is not declared in the scope of the implicit
15468 statement. Change the type to BT_UNKNOWN, both because it is so
15469 and to prevent an ICE. */
15470 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15471 && sym
->ts
.u
.derived
->components
== NULL
15472 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
15474 gfc_error ("The derived type %qs at %L is of type %qs, "
15475 "which has not been defined", sym
->name
,
15476 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15477 sym
->ts
.type
= BT_UNKNOWN
;
15481 /* Make sure that the derived type has been resolved and that the
15482 derived type is visible in the symbol's namespace, if it is a
15483 module function and is not PRIVATE. */
15484 if (sym
->ts
.type
== BT_DERIVED
15485 && sym
->ts
.u
.derived
->attr
.use_assoc
15486 && sym
->ns
->proc_name
15487 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15488 && !resolve_fl_derived (sym
->ts
.u
.derived
))
15491 /* Unless the derived-type declaration is use associated, Fortran 95
15492 does not allow public entries of private derived types.
15493 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15494 161 in 95-006r3. */
15495 if (sym
->ts
.type
== BT_DERIVED
15496 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15497 && !sym
->ts
.u
.derived
->attr
.use_assoc
15498 && gfc_check_symbol_access (sym
)
15499 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15500 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
15501 "derived type %qs",
15502 (sym
->attr
.flavor
== FL_PARAMETER
)
15503 ? "parameter" : "variable",
15504 sym
->name
, &sym
->declared_at
,
15505 sym
->ts
.u
.derived
->name
))
15508 /* F2008, C1302. */
15509 if (sym
->ts
.type
== BT_DERIVED
15510 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15511 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
15512 || sym
->ts
.u
.derived
->attr
.lock_comp
)
15513 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15515 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15516 "type LOCK_TYPE must be a coarray", sym
->name
,
15517 &sym
->declared_at
);
15521 /* TS18508, C702/C703. */
15522 if (sym
->ts
.type
== BT_DERIVED
15523 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15524 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
15525 || sym
->ts
.u
.derived
->attr
.event_comp
)
15526 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15528 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15529 "type EVENT_TYPE must be a coarray", sym
->name
,
15530 &sym
->declared_at
);
15534 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15535 default initialization is defined (5.1.2.4.4). */
15536 if (sym
->ts
.type
== BT_DERIVED
15538 && sym
->attr
.intent
== INTENT_OUT
15540 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15542 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15544 if (c
->initializer
)
15546 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15547 "ASSUMED SIZE and so cannot have a default initializer",
15548 sym
->name
, &sym
->declared_at
);
15555 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15556 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15558 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15559 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15564 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15565 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15567 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15568 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15573 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15574 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15575 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15576 || class_attr
.codimension
)
15577 && (sym
->attr
.result
|| sym
->result
== sym
))
15579 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15580 "a coarray component", sym
->name
, &sym
->declared_at
);
15585 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15586 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15588 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15589 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15594 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15595 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15596 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15597 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15598 || class_attr
.allocatable
))
15600 gfc_error ("Variable %qs at %L with coarray component shall be a "
15601 "nonpointer, nonallocatable scalar, which is not a coarray",
15602 sym
->name
, &sym
->declared_at
);
15606 /* F2008, C526. The function-result case was handled above. */
15607 if (class_attr
.codimension
15608 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15609 || sym
->attr
.select_type_temporary
15610 || sym
->attr
.associate_var
15611 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15612 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15613 || sym
->ns
->proc_name
->attr
.is_main_program
15614 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15616 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15617 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15621 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15622 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15624 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15625 "deferred shape", sym
->name
, &sym
->declared_at
);
15628 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15629 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15631 gfc_error ("Allocatable coarray variable %qs at %L must have "
15632 "deferred shape", sym
->name
, &sym
->declared_at
);
15637 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15638 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15639 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15640 || (class_attr
.codimension
&& class_attr
.allocatable
))
15641 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15643 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15644 "allocatable coarray or have coarray components",
15645 sym
->name
, &sym
->declared_at
);
15649 if (class_attr
.codimension
&& sym
->attr
.dummy
15650 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15652 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15653 "procedure %qs", sym
->name
, &sym
->declared_at
,
15654 sym
->ns
->proc_name
->name
);
15658 if (sym
->ts
.type
== BT_LOGICAL
15659 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15660 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15661 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15664 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15665 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15667 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15668 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15669 "%L with non-C_Bool kind in BIND(C) procedure "
15670 "%qs", sym
->name
, &sym
->declared_at
,
15671 sym
->ns
->proc_name
->name
))
15673 else if (!gfc_logical_kinds
[i
].c_bool
15674 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15675 "%qs at %L with non-C_Bool kind in "
15676 "BIND(C) procedure %qs", sym
->name
,
15678 sym
->attr
.function
? sym
->name
15679 : sym
->ns
->proc_name
->name
))
15683 switch (sym
->attr
.flavor
)
15686 if (!resolve_fl_variable (sym
, mp_flag
))
15691 if (sym
->formal
&& !sym
->formal_ns
)
15693 /* Check that none of the arguments are a namelist. */
15694 gfc_formal_arglist
*formal
= sym
->formal
;
15696 for (; formal
; formal
= formal
->next
)
15697 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15699 gfc_error ("Namelist %qs cannot be an argument to "
15700 "subroutine or function at %L",
15701 formal
->sym
->name
, &sym
->declared_at
);
15706 if (!resolve_fl_procedure (sym
, mp_flag
))
15711 if (!resolve_fl_namelist (sym
))
15716 if (!resolve_fl_parameter (sym
))
15724 /* Resolve array specifier. Check as well some constraints
15725 on COMMON blocks. */
15727 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15729 /* Set the formal_arg_flag so that check_conflict will not throw
15730 an error for host associated variables in the specification
15731 expression for an array_valued function. */
15732 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
15733 formal_arg_flag
= true;
15735 saved_specification_expr
= specification_expr
;
15736 specification_expr
= true;
15737 gfc_resolve_array_spec (sym
->as
, check_constant
);
15738 specification_expr
= saved_specification_expr
;
15740 formal_arg_flag
= false;
15742 /* Resolve formal namespaces. */
15743 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15744 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15745 gfc_resolve (sym
->formal_ns
);
15747 /* Make sure the formal namespace is present. */
15748 if (sym
->formal
&& !sym
->formal_ns
)
15750 gfc_formal_arglist
*formal
= sym
->formal
;
15751 while (formal
&& !formal
->sym
)
15752 formal
= formal
->next
;
15756 sym
->formal_ns
= formal
->sym
->ns
;
15757 if (sym
->ns
!= formal
->sym
->ns
)
15758 sym
->formal_ns
->refs
++;
15762 /* Check threadprivate restrictions. */
15763 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15764 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15765 && (!sym
->attr
.in_common
15766 && sym
->module
== NULL
15767 && (sym
->ns
->proc_name
== NULL
15768 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15769 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15771 /* Check omp declare target restrictions. */
15772 if (sym
->attr
.omp_declare_target
15773 && sym
->attr
.flavor
== FL_VARIABLE
15775 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15776 && (!sym
->attr
.in_common
15777 && sym
->module
== NULL
15778 && (sym
->ns
->proc_name
== NULL
15779 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15780 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15781 sym
->name
, &sym
->declared_at
);
15783 /* If we have come this far we can apply default-initializers, as
15784 described in 14.7.5, to those variables that have not already
15785 been assigned one. */
15786 if (sym
->ts
.type
== BT_DERIVED
15788 && !sym
->attr
.allocatable
15789 && !sym
->attr
.alloc_comp
)
15791 symbol_attribute
*a
= &sym
->attr
;
15793 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15794 && !a
->in_common
&& !a
->use_assoc
15796 && !((a
->function
|| a
->result
)
15798 || sym
->ts
.u
.derived
->attr
.alloc_comp
15799 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15800 && !(a
->function
&& sym
!= sym
->result
))
15801 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15802 apply_default_init (sym
);
15803 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15804 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15805 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15806 /* Mark the result symbol to be referenced, when it has allocatable
15808 sym
->result
->attr
.referenced
= 1;
15811 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15812 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15813 && !CLASS_DATA (sym
)->attr
.class_pointer
15814 && !CLASS_DATA (sym
)->attr
.allocatable
)
15815 apply_default_init (sym
);
15817 /* If this symbol has a type-spec, check it. */
15818 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15819 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15820 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15823 if (sym
->param_list
)
15828 /************* Resolve DATA statements *************/
15832 gfc_data_value
*vnode
;
15838 /* Advance the values structure to point to the next value in the data list. */
15841 next_data_value (void)
15843 while (mpz_cmp_ui (values
.left
, 0) == 0)
15846 if (values
.vnode
->next
== NULL
)
15849 values
.vnode
= values
.vnode
->next
;
15850 mpz_set (values
.left
, values
.vnode
->repeat
);
15858 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15864 ar_type mark
= AR_UNKNOWN
;
15866 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15872 if (!gfc_resolve_expr (var
->expr
))
15876 mpz_init_set_si (offset
, 0);
15879 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15880 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15881 e
= e
->value
.function
.actual
->expr
;
15883 if (e
->expr_type
!= EXPR_VARIABLE
)
15885 gfc_error ("Expecting definable entity near %L", where
);
15889 sym
= e
->symtree
->n
.sym
;
15891 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15893 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15894 sym
->name
, &sym
->declared_at
);
15898 if (e
->ref
== NULL
&& sym
->as
)
15900 gfc_error ("DATA array %qs at %L must be specified in a previous"
15901 " declaration", sym
->name
, where
);
15905 if (gfc_is_coindexed (e
))
15907 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15912 has_pointer
= sym
->attr
.pointer
;
15914 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15916 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15921 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_FULL
)
15923 gfc_error ("DATA element %qs at %L is a pointer and so must "
15924 "be a full array", sym
->name
, where
);
15928 if (values
.vnode
->expr
->expr_type
== EXPR_CONSTANT
)
15930 gfc_error ("DATA object near %L has the pointer attribute "
15931 "and the corresponding DATA value is not a valid "
15932 "initial-data-target", where
);
15938 if (e
->rank
== 0 || has_pointer
)
15940 mpz_init_set_ui (size
, 1);
15947 /* Find the array section reference. */
15948 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15950 if (ref
->type
!= REF_ARRAY
)
15952 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15958 /* Set marks according to the reference pattern. */
15959 switch (ref
->u
.ar
.type
)
15967 /* Get the start position of array section. */
15968 gfc_get_section_index (ar
, section_index
, &offset
);
15973 gcc_unreachable ();
15976 if (!gfc_array_size (e
, &size
))
15978 gfc_error ("Nonconstant array section at %L in DATA statement",
15980 mpz_clear (offset
);
15987 while (mpz_cmp_ui (size
, 0) > 0)
15989 if (!next_data_value ())
15991 gfc_error ("DATA statement at %L has more variables than values",
15997 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
16001 /* If we have more than one element left in the repeat count,
16002 and we have more than one element left in the target variable,
16003 then create a range assignment. */
16004 /* FIXME: Only done for full arrays for now, since array sections
16006 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
16007 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
16011 if (mpz_cmp (size
, values
.left
) >= 0)
16013 mpz_init_set (range
, values
.left
);
16014 mpz_sub (size
, size
, values
.left
);
16015 mpz_set_ui (values
.left
, 0);
16019 mpz_init_set (range
, size
);
16020 mpz_sub (values
.left
, values
.left
, size
);
16021 mpz_set_ui (size
, 0);
16024 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16027 mpz_add (offset
, offset
, range
);
16034 /* Assign initial value to symbol. */
16037 mpz_sub_ui (values
.left
, values
.left
, 1);
16038 mpz_sub_ui (size
, size
, 1);
16040 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
16045 if (mark
== AR_FULL
)
16046 mpz_add_ui (offset
, offset
, 1);
16048 /* Modify the array section indexes and recalculate the offset
16049 for next element. */
16050 else if (mark
== AR_SECTION
)
16051 gfc_advance_section (section_index
, ar
, &offset
);
16055 if (mark
== AR_SECTION
)
16057 for (i
= 0; i
< ar
->dimen
; i
++)
16058 mpz_clear (section_index
[i
]);
16062 mpz_clear (offset
);
16068 static bool traverse_data_var (gfc_data_variable
*, locus
*);
16070 /* Iterate over a list of elements in a DATA statement. */
16073 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
16076 iterator_stack frame
;
16077 gfc_expr
*e
, *start
, *end
, *step
;
16078 bool retval
= true;
16080 mpz_init (frame
.value
);
16083 start
= gfc_copy_expr (var
->iter
.start
);
16084 end
= gfc_copy_expr (var
->iter
.end
);
16085 step
= gfc_copy_expr (var
->iter
.step
);
16087 if (!gfc_simplify_expr (start
, 1)
16088 || start
->expr_type
!= EXPR_CONSTANT
)
16090 gfc_error ("start of implied-do loop at %L could not be "
16091 "simplified to a constant value", &start
->where
);
16095 if (!gfc_simplify_expr (end
, 1)
16096 || end
->expr_type
!= EXPR_CONSTANT
)
16098 gfc_error ("end of implied-do loop at %L could not be "
16099 "simplified to a constant value", &start
->where
);
16103 if (!gfc_simplify_expr (step
, 1)
16104 || step
->expr_type
!= EXPR_CONSTANT
)
16106 gfc_error ("step of implied-do loop at %L could not be "
16107 "simplified to a constant value", &start
->where
);
16112 mpz_set (trip
, end
->value
.integer
);
16113 mpz_sub (trip
, trip
, start
->value
.integer
);
16114 mpz_add (trip
, trip
, step
->value
.integer
);
16116 mpz_div (trip
, trip
, step
->value
.integer
);
16118 mpz_set (frame
.value
, start
->value
.integer
);
16120 frame
.prev
= iter_stack
;
16121 frame
.variable
= var
->iter
.var
->symtree
;
16122 iter_stack
= &frame
;
16124 while (mpz_cmp_ui (trip
, 0) > 0)
16126 if (!traverse_data_var (var
->list
, where
))
16132 e
= gfc_copy_expr (var
->expr
);
16133 if (!gfc_simplify_expr (e
, 1))
16140 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
16142 mpz_sub_ui (trip
, trip
, 1);
16146 mpz_clear (frame
.value
);
16149 gfc_free_expr (start
);
16150 gfc_free_expr (end
);
16151 gfc_free_expr (step
);
16153 iter_stack
= frame
.prev
;
16158 /* Type resolve variables in the variable list of a DATA statement. */
16161 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
16165 for (; var
; var
= var
->next
)
16167 if (var
->expr
== NULL
)
16168 t
= traverse_data_list (var
, where
);
16170 t
= check_data_variable (var
, where
);
16180 /* Resolve the expressions and iterators associated with a data statement.
16181 This is separate from the assignment checking because data lists should
16182 only be resolved once. */
16185 resolve_data_variables (gfc_data_variable
*d
)
16187 for (; d
; d
= d
->next
)
16189 if (d
->list
== NULL
)
16191 if (!gfc_resolve_expr (d
->expr
))
16196 if (!gfc_resolve_iterator (&d
->iter
, false, true))
16199 if (!resolve_data_variables (d
->list
))
16208 /* Resolve a single DATA statement. We implement this by storing a pointer to
16209 the value list into static variables, and then recursively traversing the
16210 variables list, expanding iterators and such. */
16213 resolve_data (gfc_data
*d
)
16216 if (!resolve_data_variables (d
->var
))
16219 values
.vnode
= d
->value
;
16220 if (d
->value
== NULL
)
16221 mpz_set_ui (values
.left
, 0);
16223 mpz_set (values
.left
, d
->value
->repeat
);
16225 if (!traverse_data_var (d
->var
, &d
->where
))
16228 /* At this point, we better not have any values left. */
16230 if (next_data_value ())
16231 gfc_error ("DATA statement at %L has more values than variables",
16236 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
16237 accessed by host or use association, is a dummy argument to a pure function,
16238 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
16239 is storage associated with any such variable, shall not be used in the
16240 following contexts: (clients of this function). */
16242 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
16243 procedure. Returns zero if assignment is OK, nonzero if there is a
16246 gfc_impure_variable (gfc_symbol
*sym
)
16251 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
16254 /* Check if the symbol's ns is inside the pure procedure. */
16255 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16259 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
16263 proc
= sym
->ns
->proc_name
;
16264 if (sym
->attr
.dummy
16265 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
16266 || proc
->attr
.function
))
16269 /* TODO: Sort out what can be storage associated, if anything, and include
16270 it here. In principle equivalences should be scanned but it does not
16271 seem to be possible to storage associate an impure variable this way. */
16276 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
16277 current namespace is inside a pure procedure. */
16280 gfc_pure (gfc_symbol
*sym
)
16282 symbol_attribute attr
;
16287 /* Check if the current namespace or one of its parents
16288 belongs to a pure procedure. */
16289 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16291 sym
= ns
->proc_name
;
16295 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
16303 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
16307 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16308 checks if the current namespace is implicitly pure. Note that this
16309 function returns false for a PURE procedure. */
16312 gfc_implicit_pure (gfc_symbol
*sym
)
16318 /* Check if the current procedure is implicit_pure. Walk up
16319 the procedure list until we find a procedure. */
16320 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16322 sym
= ns
->proc_name
;
16326 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16331 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
16332 && !sym
->attr
.pure
;
16337 gfc_unset_implicit_pure (gfc_symbol
*sym
)
16343 /* Check if the current procedure is implicit_pure. Walk up
16344 the procedure list until we find a procedure. */
16345 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16347 sym
= ns
->proc_name
;
16351 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16356 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16357 sym
->attr
.implicit_pure
= 0;
16359 sym
->attr
.pure
= 0;
16363 /* Test whether the current procedure is elemental or not. */
16366 gfc_elemental (gfc_symbol
*sym
)
16368 symbol_attribute attr
;
16371 sym
= gfc_current_ns
->proc_name
;
16376 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
16380 /* Warn about unused labels. */
16383 warn_unused_fortran_label (gfc_st_label
*label
)
16388 warn_unused_fortran_label (label
->left
);
16390 if (label
->defined
== ST_LABEL_UNKNOWN
)
16393 switch (label
->referenced
)
16395 case ST_LABEL_UNKNOWN
:
16396 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
16397 label
->value
, &label
->where
);
16400 case ST_LABEL_BAD_TARGET
:
16401 gfc_warning (OPT_Wunused_label
,
16402 "Label %d at %L defined but cannot be used",
16403 label
->value
, &label
->where
);
16410 warn_unused_fortran_label (label
->right
);
16414 /* Returns the sequence type of a symbol or sequence. */
16417 sequence_type (gfc_typespec ts
)
16426 if (ts
.u
.derived
->components
== NULL
)
16427 return SEQ_NONDEFAULT
;
16429 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16430 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16431 if (sequence_type (c
->ts
) != result
)
16437 if (ts
.kind
!= gfc_default_character_kind
)
16438 return SEQ_NONDEFAULT
;
16440 return SEQ_CHARACTER
;
16443 if (ts
.kind
!= gfc_default_integer_kind
)
16444 return SEQ_NONDEFAULT
;
16446 return SEQ_NUMERIC
;
16449 if (!(ts
.kind
== gfc_default_real_kind
16450 || ts
.kind
== gfc_default_double_kind
))
16451 return SEQ_NONDEFAULT
;
16453 return SEQ_NUMERIC
;
16456 if (ts
.kind
!= gfc_default_complex_kind
)
16457 return SEQ_NONDEFAULT
;
16459 return SEQ_NUMERIC
;
16462 if (ts
.kind
!= gfc_default_logical_kind
)
16463 return SEQ_NONDEFAULT
;
16465 return SEQ_NUMERIC
;
16468 return SEQ_NONDEFAULT
;
16473 /* Resolve derived type EQUIVALENCE object. */
16476 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
16478 gfc_component
*c
= derived
->components
;
16483 /* Shall not be an object of nonsequence derived type. */
16484 if (!derived
->attr
.sequence
)
16486 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16487 "attribute to be an EQUIVALENCE object", sym
->name
,
16492 /* Shall not have allocatable components. */
16493 if (derived
->attr
.alloc_comp
)
16495 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16496 "components to be an EQUIVALENCE object",sym
->name
,
16501 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
16503 gfc_error ("Derived type variable %qs at %L with default "
16504 "initialization cannot be in EQUIVALENCE with a variable "
16505 "in COMMON", sym
->name
, &e
->where
);
16509 for (; c
; c
= c
->next
)
16511 if (gfc_bt_struct (c
->ts
.type
)
16512 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
16515 /* Shall not be an object of sequence derived type containing a pointer
16516 in the structure. */
16517 if (c
->attr
.pointer
)
16519 gfc_error ("Derived type variable %qs at %L with pointer "
16520 "component(s) cannot be an EQUIVALENCE object",
16521 sym
->name
, &e
->where
);
16529 /* Resolve equivalence object.
16530 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16531 an allocatable array, an object of nonsequence derived type, an object of
16532 sequence derived type containing a pointer at any level of component
16533 selection, an automatic object, a function name, an entry name, a result
16534 name, a named constant, a structure component, or a subobject of any of
16535 the preceding objects. A substring shall not have length zero. A
16536 derived type shall not have components with default initialization nor
16537 shall two objects of an equivalence group be initialized.
16538 Either all or none of the objects shall have an protected attribute.
16539 The simple constraints are done in symbol.c(check_conflict) and the rest
16540 are implemented here. */
16543 resolve_equivalence (gfc_equiv
*eq
)
16546 gfc_symbol
*first_sym
;
16549 locus
*last_where
= NULL
;
16550 seq_type eq_type
, last_eq_type
;
16551 gfc_typespec
*last_ts
;
16552 int object
, cnt_protected
;
16555 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16557 first_sym
= eq
->expr
->symtree
->n
.sym
;
16561 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16565 e
->ts
= e
->symtree
->n
.sym
->ts
;
16566 /* match_varspec might not know yet if it is seeing
16567 array reference or substring reference, as it doesn't
16569 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16571 gfc_ref
*ref
= e
->ref
;
16572 sym
= e
->symtree
->n
.sym
;
16574 if (sym
->attr
.dimension
)
16576 ref
->u
.ar
.as
= sym
->as
;
16580 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16581 if (e
->ts
.type
== BT_CHARACTER
16583 && ref
->type
== REF_ARRAY
16584 && ref
->u
.ar
.dimen
== 1
16585 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16586 && ref
->u
.ar
.stride
[0] == NULL
)
16588 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16589 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16592 /* Optimize away the (:) reference. */
16593 if (start
== NULL
&& end
== NULL
)
16596 e
->ref
= ref
->next
;
16598 e
->ref
->next
= ref
->next
;
16603 ref
->type
= REF_SUBSTRING
;
16605 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16607 ref
->u
.ss
.start
= start
;
16608 if (end
== NULL
&& e
->ts
.u
.cl
)
16609 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16610 ref
->u
.ss
.end
= end
;
16611 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16618 /* Any further ref is an error. */
16621 gcc_assert (ref
->type
== REF_ARRAY
);
16622 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16628 if (!gfc_resolve_expr (e
))
16631 sym
= e
->symtree
->n
.sym
;
16633 if (sym
->attr
.is_protected
)
16635 if (cnt_protected
> 0 && cnt_protected
!= object
)
16637 gfc_error ("Either all or none of the objects in the "
16638 "EQUIVALENCE set at %L shall have the "
16639 "PROTECTED attribute",
16644 /* Shall not equivalence common block variables in a PURE procedure. */
16645 if (sym
->ns
->proc_name
16646 && sym
->ns
->proc_name
->attr
.pure
16647 && sym
->attr
.in_common
)
16649 /* Need to check for symbols that may have entered the pure
16650 procedure via a USE statement. */
16651 bool saw_sym
= false;
16652 if (sym
->ns
->use_stmts
)
16655 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16656 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16662 gfc_error ("COMMON block member %qs at %L cannot be an "
16663 "EQUIVALENCE object in the pure procedure %qs",
16664 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16668 /* Shall not be a named constant. */
16669 if (e
->expr_type
== EXPR_CONSTANT
)
16671 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16672 "object", sym
->name
, &e
->where
);
16676 if (e
->ts
.type
== BT_DERIVED
16677 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16680 /* Check that the types correspond correctly:
16682 A numeric sequence structure may be equivalenced to another sequence
16683 structure, an object of default integer type, default real type, double
16684 precision real type, default logical type such that components of the
16685 structure ultimately only become associated to objects of the same
16686 kind. A character sequence structure may be equivalenced to an object
16687 of default character kind or another character sequence structure.
16688 Other objects may be equivalenced only to objects of the same type and
16689 kind parameters. */
16691 /* Identical types are unconditionally OK. */
16692 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16693 goto identical_types
;
16695 last_eq_type
= sequence_type (*last_ts
);
16696 eq_type
= sequence_type (sym
->ts
);
16698 /* Since the pair of objects is not of the same type, mixed or
16699 non-default sequences can be rejected. */
16701 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16702 "statement at %L with different type objects";
16704 && last_eq_type
== SEQ_MIXED
16705 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16706 || (eq_type
== SEQ_MIXED
16707 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16710 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16711 "statement at %L with objects of different type";
16713 && last_eq_type
== SEQ_NONDEFAULT
16714 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16715 || (eq_type
== SEQ_NONDEFAULT
16716 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16719 msg
="Non-CHARACTER object %qs in default CHARACTER "
16720 "EQUIVALENCE statement at %L";
16721 if (last_eq_type
== SEQ_CHARACTER
16722 && eq_type
!= SEQ_CHARACTER
16723 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16726 msg
="Non-NUMERIC object %qs in default NUMERIC "
16727 "EQUIVALENCE statement at %L";
16728 if (last_eq_type
== SEQ_NUMERIC
16729 && eq_type
!= SEQ_NUMERIC
16730 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16735 last_where
= &e
->where
;
16740 /* Shall not be an automatic array. */
16741 if (e
->ref
->type
== REF_ARRAY
16742 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16744 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16745 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16752 /* Shall not be a structure component. */
16753 if (r
->type
== REF_COMPONENT
)
16755 gfc_error ("Structure component %qs at %L cannot be an "
16756 "EQUIVALENCE object",
16757 r
->u
.c
.component
->name
, &e
->where
);
16761 /* A substring shall not have length zero. */
16762 if (r
->type
== REF_SUBSTRING
)
16764 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16766 gfc_error ("Substring at %L has length zero",
16767 &r
->u
.ss
.start
->where
);
16777 /* Function called by resolve_fntype to flag other symbol used in the
16778 length type parameter specification of function resuls. */
16781 flag_fn_result_spec (gfc_expr
*expr
,
16783 int *f ATTRIBUTE_UNUSED
)
16788 if (expr
->expr_type
== EXPR_VARIABLE
)
16790 s
= expr
->symtree
->n
.sym
;
16791 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16797 gfc_error ("Self reference in character length expression "
16798 "for %qs at %L", sym
->name
, &expr
->where
);
16802 if (!s
->fn_result_spec
16803 && s
->attr
.flavor
== FL_PARAMETER
)
16805 /* Function contained in a module.... */
16806 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16809 s
->fn_result_spec
= 1;
16810 /* Make sure that this symbol is translated as a module
16812 st
= gfc_get_unique_symtree (ns
);
16816 /* ... which is use associated and called. */
16817 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16819 /* External function matched with an interface. */
16822 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16823 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16824 && s
->ns
->proc_name
->attr
.function
))
16825 s
->fn_result_spec
= 1;
16832 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16835 resolve_fntype (gfc_namespace
*ns
)
16837 gfc_entry_list
*el
;
16840 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16843 /* If there are any entries, ns->proc_name is the entry master
16844 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16846 sym
= ns
->entries
->sym
;
16848 sym
= ns
->proc_name
;
16849 if (sym
->result
== sym
16850 && sym
->ts
.type
== BT_UNKNOWN
16851 && !gfc_set_default_type (sym
, 0, NULL
)
16852 && !sym
->attr
.untyped
)
16854 gfc_error ("Function %qs at %L has no IMPLICIT type",
16855 sym
->name
, &sym
->declared_at
);
16856 sym
->attr
.untyped
= 1;
16859 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16860 && !sym
->attr
.contained
16861 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16862 && gfc_check_symbol_access (sym
))
16864 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16865 "%L of PRIVATE type %qs", sym
->name
,
16866 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16870 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16872 if (el
->sym
->result
== el
->sym
16873 && el
->sym
->ts
.type
== BT_UNKNOWN
16874 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16875 && !el
->sym
->attr
.untyped
)
16877 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16878 el
->sym
->name
, &el
->sym
->declared_at
);
16879 el
->sym
->attr
.untyped
= 1;
16883 if (sym
->ts
.type
== BT_CHARACTER
)
16884 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16888 /* 12.3.2.1.1 Defined operators. */
16891 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16893 gfc_formal_arglist
*formal
;
16895 if (!sym
->attr
.function
)
16897 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16898 sym
->name
, &where
);
16902 if (sym
->ts
.type
== BT_CHARACTER
16903 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16904 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16905 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16907 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16908 "character length", sym
->name
, &where
);
16912 formal
= gfc_sym_get_dummy_args (sym
);
16913 if (!formal
|| !formal
->sym
)
16915 gfc_error ("User operator procedure %qs at %L must have at least "
16916 "one argument", sym
->name
, &where
);
16920 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16922 gfc_error ("First argument of operator interface at %L must be "
16923 "INTENT(IN)", &where
);
16927 if (formal
->sym
->attr
.optional
)
16929 gfc_error ("First argument of operator interface at %L cannot be "
16930 "optional", &where
);
16934 formal
= formal
->next
;
16935 if (!formal
|| !formal
->sym
)
16938 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16940 gfc_error ("Second argument of operator interface at %L must be "
16941 "INTENT(IN)", &where
);
16945 if (formal
->sym
->attr
.optional
)
16947 gfc_error ("Second argument of operator interface at %L cannot be "
16948 "optional", &where
);
16954 gfc_error ("Operator interface at %L must have, at most, two "
16955 "arguments", &where
);
16963 gfc_resolve_uops (gfc_symtree
*symtree
)
16965 gfc_interface
*itr
;
16967 if (symtree
== NULL
)
16970 gfc_resolve_uops (symtree
->left
);
16971 gfc_resolve_uops (symtree
->right
);
16973 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16974 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16978 /* Examine all of the expressions associated with a program unit,
16979 assign types to all intermediate expressions, make sure that all
16980 assignments are to compatible types and figure out which names
16981 refer to which functions or subroutines. It doesn't check code
16982 block, which is handled by gfc_resolve_code. */
16985 resolve_types (gfc_namespace
*ns
)
16991 gfc_namespace
* old_ns
= gfc_current_ns
;
16993 if (ns
->types_resolved
)
16996 /* Check that all IMPLICIT types are ok. */
16997 if (!ns
->seen_implicit_none
)
17000 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
17001 if (ns
->set_flag
[letter
]
17002 && !resolve_typespec_used (&ns
->default_type
[letter
],
17003 &ns
->implicit_loc
[letter
], NULL
))
17007 gfc_current_ns
= ns
;
17009 resolve_entries (ns
);
17011 resolve_common_vars (&ns
->blank_common
, false);
17012 resolve_common_blocks (ns
->common_root
);
17014 resolve_contained_functions (ns
);
17016 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
17017 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
17018 resolve_formal_arglist (ns
->proc_name
);
17020 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
17022 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
17023 resolve_charlen (cl
);
17025 gfc_traverse_ns (ns
, resolve_symbol
);
17027 resolve_fntype (ns
);
17029 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17031 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
17032 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
17033 "also be PURE", n
->proc_name
->name
,
17034 &n
->proc_name
->declared_at
);
17040 gfc_do_concurrent_flag
= 0;
17041 gfc_check_interfaces (ns
);
17043 gfc_traverse_ns (ns
, resolve_values
);
17045 if (ns
->save_all
|| !flag_automatic
)
17049 for (d
= ns
->data
; d
; d
= d
->next
)
17053 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
17055 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
17057 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
17058 resolve_equivalence (eq
);
17060 /* Warn about unused labels. */
17061 if (warn_unused_label
)
17062 warn_unused_fortran_label (ns
->st_labels
);
17064 gfc_resolve_uops (ns
->uop_root
);
17066 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
17068 gfc_resolve_omp_declare_simd (ns
);
17070 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
17072 ns
->types_resolved
= 1;
17074 gfc_current_ns
= old_ns
;
17078 /* Call gfc_resolve_code recursively. */
17081 resolve_codes (gfc_namespace
*ns
)
17084 bitmap_obstack old_obstack
;
17086 if (ns
->resolved
== 1)
17089 for (n
= ns
->contained
; n
; n
= n
->sibling
)
17092 gfc_current_ns
= ns
;
17094 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
17095 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
17098 /* Set to an out of range value. */
17099 current_entry_id
= -1;
17101 old_obstack
= labels_obstack
;
17102 bitmap_obstack_initialize (&labels_obstack
);
17104 gfc_resolve_oacc_declare (ns
);
17105 gfc_resolve_oacc_routines (ns
);
17106 gfc_resolve_omp_local_vars (ns
);
17107 gfc_resolve_code (ns
->code
, ns
);
17109 bitmap_obstack_release (&labels_obstack
);
17110 labels_obstack
= old_obstack
;
17114 /* This function is called after a complete program unit has been compiled.
17115 Its purpose is to examine all of the expressions associated with a program
17116 unit, assign types to all intermediate expressions, make sure that all
17117 assignments are to compatible types and figure out which names refer to
17118 which functions or subroutines. */
17121 gfc_resolve (gfc_namespace
*ns
)
17123 gfc_namespace
*old_ns
;
17124 code_stack
*old_cs_base
;
17125 struct gfc_omp_saved_state old_omp_state
;
17131 old_ns
= gfc_current_ns
;
17132 old_cs_base
= cs_base
;
17134 /* As gfc_resolve can be called during resolution of an OpenMP construct
17135 body, we should clear any state associated to it, so that say NS's
17136 DO loops are not interpreted as OpenMP loops. */
17137 if (!ns
->construct_entities
)
17138 gfc_omp_save_and_clear_state (&old_omp_state
);
17140 resolve_types (ns
);
17141 component_assignment_level
= 0;
17142 resolve_codes (ns
);
17144 gfc_current_ns
= old_ns
;
17145 cs_base
= old_cs_base
;
17148 gfc_run_passes (ns
);
17150 if (!ns
->construct_entities
)
17151 gfc_omp_restore_state (&old_omp_state
);