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
)
586 /* Try to find out of what the return type is. */
587 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
589 t
= gfc_set_default_type (sym
->result
, 0, ns
);
591 if (!t
&& !sym
->result
->attr
.untyped
)
593 if (sym
->result
== sym
)
594 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
595 sym
->name
, &sym
->declared_at
);
596 else if (!sym
->result
->attr
.proc_pointer
)
597 gfc_error ("Result %qs of contained function %qs at %L has "
598 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
599 &sym
->result
->declared_at
);
600 sym
->result
->attr
.untyped
= 1;
604 /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
605 type, lists the only ways a character length value of * can be used:
606 dummy arguments of procedures, named constants, function results and
607 in allocate statements if the allocate_object is an assumed length dummy
608 in external functions. Internal function results and results of module
609 procedures are not on this list, ergo, not permitted. */
611 if (sym
->result
->ts
.type
== BT_CHARACTER
)
613 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
614 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
616 /* See if this is a module-procedure and adapt error message
619 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
620 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
622 gfc_error (module_proc
623 ? G_("Character-valued module procedure %qs at %L"
624 " must not be assumed length")
625 : G_("Character-valued internal function %qs at %L"
626 " must not be assumed length"),
627 sym
->name
, &sym
->declared_at
);
633 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
634 introduce duplicates. */
637 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
639 gfc_formal_arglist
*f
, *new_arglist
;
642 for (; new_args
!= NULL
; new_args
= new_args
->next
)
644 new_sym
= new_args
->sym
;
645 /* See if this arg is already in the formal argument list. */
646 for (f
= proc
->formal
; f
; f
= f
->next
)
648 if (new_sym
== f
->sym
)
655 /* Add a new argument. Argument order is not important. */
656 new_arglist
= gfc_get_formal_arglist ();
657 new_arglist
->sym
= new_sym
;
658 new_arglist
->next
= proc
->formal
;
659 proc
->formal
= new_arglist
;
664 /* Flag the arguments that are not present in all entries. */
667 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
669 gfc_formal_arglist
*f
, *head
;
672 for (f
= proc
->formal
; f
; f
= f
->next
)
677 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
679 if (new_args
->sym
== f
->sym
)
686 f
->sym
->attr
.not_always_present
= 1;
691 /* Resolve alternate entry points. If a symbol has multiple entry points we
692 create a new master symbol for the main routine, and turn the existing
693 symbol into an entry point. */
696 resolve_entries (gfc_namespace
*ns
)
698 gfc_namespace
*old_ns
;
702 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
703 static int master_count
= 0;
705 if (ns
->proc_name
== NULL
)
708 /* No need to do anything if this procedure doesn't have alternate entry
713 /* We may already have resolved alternate entry points. */
714 if (ns
->proc_name
->attr
.entry_master
)
717 /* If this isn't a procedure something has gone horribly wrong. */
718 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
720 /* Remember the current namespace. */
721 old_ns
= gfc_current_ns
;
725 /* Add the main entry point to the list of entry points. */
726 el
= gfc_get_entry_list ();
727 el
->sym
= ns
->proc_name
;
729 el
->next
= ns
->entries
;
731 ns
->proc_name
->attr
.entry
= 1;
733 /* If it is a module function, it needs to be in the right namespace
734 so that gfc_get_fake_result_decl can gather up the results. The
735 need for this arose in get_proc_name, where these beasts were
736 left in their own namespace, to keep prior references linked to
737 the entry declaration.*/
738 if (ns
->proc_name
->attr
.function
739 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
742 /* Do the same for entries where the master is not a module
743 procedure. These are retained in the module namespace because
744 of the module procedure declaration. */
745 for (el
= el
->next
; el
; el
= el
->next
)
746 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
747 && el
->sym
->attr
.mod_proc
)
751 /* Add an entry statement for it. */
752 c
= gfc_get_code (EXEC_ENTRY
);
757 /* Create a new symbol for the master function. */
758 /* Give the internal function a unique name (within this file).
759 Also include the function name so the user has some hope of figuring
760 out what is going on. */
761 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
762 master_count
++, ns
->proc_name
->name
);
763 gfc_get_ha_symbol (name
, &proc
);
764 gcc_assert (proc
!= NULL
);
766 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
767 if (ns
->proc_name
->attr
.subroutine
)
768 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
772 gfc_typespec
*ts
, *fts
;
773 gfc_array_spec
*as
, *fas
;
774 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
776 fas
= ns
->entries
->sym
->as
;
777 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
778 fts
= &ns
->entries
->sym
->result
->ts
;
779 if (fts
->type
== BT_UNKNOWN
)
780 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
781 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
783 ts
= &el
->sym
->result
->ts
;
785 as
= as
? as
: el
->sym
->result
->as
;
786 if (ts
->type
== BT_UNKNOWN
)
787 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
789 if (! gfc_compare_types (ts
, fts
)
790 || (el
->sym
->result
->attr
.dimension
791 != ns
->entries
->sym
->result
->attr
.dimension
)
792 || (el
->sym
->result
->attr
.pointer
793 != ns
->entries
->sym
->result
->attr
.pointer
))
795 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
796 && gfc_compare_array_spec (as
, fas
) == 0)
797 gfc_error ("Function %s at %L has entries with mismatched "
798 "array specifications", ns
->entries
->sym
->name
,
799 &ns
->entries
->sym
->declared_at
);
800 /* The characteristics need to match and thus both need to have
801 the same string length, i.e. both len=*, or both len=4.
802 Having both len=<variable> is also possible, but difficult to
803 check at compile time. */
804 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
805 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
806 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
808 && ts
->u
.cl
->length
->expr_type
809 != fts
->u
.cl
->length
->expr_type
)
811 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
812 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
813 fts
->u
.cl
->length
->value
.integer
) != 0)))
814 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
815 "entries returning variables of different "
816 "string lengths", ns
->entries
->sym
->name
,
817 &ns
->entries
->sym
->declared_at
);
822 sym
= ns
->entries
->sym
->result
;
823 /* All result types the same. */
825 if (sym
->attr
.dimension
)
826 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
827 if (sym
->attr
.pointer
)
828 gfc_add_pointer (&proc
->attr
, NULL
);
832 /* Otherwise the result will be passed through a union by
834 proc
->attr
.mixed_entry_master
= 1;
835 for (el
= ns
->entries
; el
; el
= el
->next
)
837 sym
= el
->sym
->result
;
838 if (sym
->attr
.dimension
)
840 if (el
== ns
->entries
)
841 gfc_error ("FUNCTION result %s cannot be an array in "
842 "FUNCTION %s at %L", sym
->name
,
843 ns
->entries
->sym
->name
, &sym
->declared_at
);
845 gfc_error ("ENTRY result %s cannot be an array in "
846 "FUNCTION %s at %L", sym
->name
,
847 ns
->entries
->sym
->name
, &sym
->declared_at
);
849 else if (sym
->attr
.pointer
)
851 if (el
== ns
->entries
)
852 gfc_error ("FUNCTION result %s cannot be a POINTER in "
853 "FUNCTION %s at %L", sym
->name
,
854 ns
->entries
->sym
->name
, &sym
->declared_at
);
856 gfc_error ("ENTRY result %s cannot be a POINTER in "
857 "FUNCTION %s at %L", sym
->name
,
858 ns
->entries
->sym
->name
, &sym
->declared_at
);
863 if (ts
->type
== BT_UNKNOWN
)
864 ts
= gfc_get_default_type (sym
->name
, NULL
);
868 if (ts
->kind
== gfc_default_integer_kind
)
872 if (ts
->kind
== gfc_default_real_kind
873 || ts
->kind
== gfc_default_double_kind
)
877 if (ts
->kind
== gfc_default_complex_kind
)
881 if (ts
->kind
== gfc_default_logical_kind
)
885 /* We will issue error elsewhere. */
893 if (el
== ns
->entries
)
894 gfc_error ("FUNCTION result %s cannot be of type %s "
895 "in FUNCTION %s at %L", sym
->name
,
896 gfc_typename (ts
), ns
->entries
->sym
->name
,
899 gfc_error ("ENTRY result %s cannot be of type %s "
900 "in FUNCTION %s at %L", sym
->name
,
901 gfc_typename (ts
), ns
->entries
->sym
->name
,
908 proc
->attr
.access
= ACCESS_PRIVATE
;
909 proc
->attr
.entry_master
= 1;
911 /* Merge all the entry point arguments. */
912 for (el
= ns
->entries
; el
; el
= el
->next
)
913 merge_argument_lists (proc
, el
->sym
->formal
);
915 /* Check the master formal arguments for any that are not
916 present in all entry points. */
917 for (el
= ns
->entries
; el
; el
= el
->next
)
918 check_argument_lists (proc
, el
->sym
->formal
);
920 /* Use the master function for the function body. */
921 ns
->proc_name
= proc
;
923 /* Finalize the new symbols. */
924 gfc_commit_symbols ();
926 /* Restore the original namespace. */
927 gfc_current_ns
= old_ns
;
931 /* Resolve common variables. */
933 resolve_common_vars (gfc_common_head
*common_block
, bool named_common
)
935 gfc_symbol
*csym
= common_block
->head
;
937 for (; csym
; csym
= csym
->common_next
)
939 /* gfc_add_in_common may have been called before, but the reported errors
940 have been ignored to continue parsing.
941 We do the checks again here. */
942 if (!csym
->attr
.use_assoc
)
944 gfc_add_in_common (&csym
->attr
, csym
->name
, &common_block
->where
);
945 gfc_notify_std (GFC_STD_F2018_OBS
, "COMMON block at %L",
946 &common_block
->where
);
949 if (csym
->value
|| csym
->attr
.data
)
951 if (!csym
->ns
->is_block_data
)
952 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
953 "but only in BLOCK DATA initialization is "
954 "allowed", csym
->name
, &csym
->declared_at
);
955 else if (!named_common
)
956 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
957 "in a blank COMMON but initialization is only "
958 "allowed in named common blocks", csym
->name
,
962 if (UNLIMITED_POLY (csym
))
963 gfc_error_now ("%qs in cannot appear in COMMON at %L "
964 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
966 if (csym
->ts
.type
!= BT_DERIVED
)
969 if (!(csym
->ts
.u
.derived
->attr
.sequence
970 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
971 gfc_error_now ("Derived type variable %qs in COMMON at %L "
972 "has neither the SEQUENCE nor the BIND(C) "
973 "attribute", csym
->name
, &csym
->declared_at
);
974 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
975 gfc_error_now ("Derived type variable %qs in COMMON at %L "
976 "has an ultimate component that is "
977 "allocatable", csym
->name
, &csym
->declared_at
);
978 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
979 gfc_error_now ("Derived type variable %qs in COMMON at %L "
980 "may not have default initializer", csym
->name
,
983 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
984 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
988 /* Resolve common blocks. */
990 resolve_common_blocks (gfc_symtree
*common_root
)
995 if (common_root
== NULL
)
998 if (common_root
->left
)
999 resolve_common_blocks (common_root
->left
);
1000 if (common_root
->right
)
1001 resolve_common_blocks (common_root
->right
);
1003 resolve_common_vars (common_root
->n
.common
, true);
1005 /* The common name is a global name - in Fortran 2003 also if it has a
1006 C binding name, since Fortran 2008 only the C binding name is a global
1008 if (!common_root
->n
.common
->binding_label
1009 || gfc_notification_std (GFC_STD_F2008
))
1011 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1012 common_root
->n
.common
->name
);
1014 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
1015 && gsym
->type
== GSYM_COMMON
1016 && ((common_root
->n
.common
->binding_label
1017 && (!gsym
->binding_label
1018 || strcmp (common_root
->n
.common
->binding_label
,
1019 gsym
->binding_label
) != 0))
1020 || (!common_root
->n
.common
->binding_label
1021 && gsym
->binding_label
)))
1023 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1024 "identifier and must thus have the same binding name "
1025 "as the same-named COMMON block at %L: %s vs %s",
1026 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1028 common_root
->n
.common
->binding_label
1029 ? common_root
->n
.common
->binding_label
: "(blank)",
1030 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1034 if (gsym
&& gsym
->type
!= GSYM_COMMON
1035 && !common_root
->n
.common
->binding_label
)
1037 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1039 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1043 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1045 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1046 "%L sharing the identifier with global non-COMMON-block "
1047 "entity at %L", common_root
->n
.common
->name
,
1048 &common_root
->n
.common
->where
, &gsym
->where
);
1053 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
, false);
1054 gsym
->type
= GSYM_COMMON
;
1055 gsym
->where
= common_root
->n
.common
->where
;
1061 if (common_root
->n
.common
->binding_label
)
1063 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1064 common_root
->n
.common
->binding_label
);
1065 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1067 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1068 "global identifier as entity at %L",
1069 &common_root
->n
.common
->where
,
1070 common_root
->n
.common
->binding_label
, &gsym
->where
);
1075 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
, true);
1076 gsym
->type
= GSYM_COMMON
;
1077 gsym
->where
= common_root
->n
.common
->where
;
1083 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1087 if (sym
->attr
.flavor
== FL_PARAMETER
)
1088 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1089 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1091 if (sym
->attr
.external
)
1092 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1093 sym
->name
, &common_root
->n
.common
->where
);
1095 if (sym
->attr
.intrinsic
)
1096 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1097 sym
->name
, &common_root
->n
.common
->where
);
1098 else if (sym
->attr
.result
1099 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1100 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1101 "that is also a function result", sym
->name
,
1102 &common_root
->n
.common
->where
);
1103 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1104 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1105 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1106 "that is also a global procedure", sym
->name
,
1107 &common_root
->n
.common
->where
);
1111 /* Resolve contained function types. Because contained functions can call one
1112 another, they have to be worked out before any of the contained procedures
1115 The good news is that if a function doesn't already have a type, the only
1116 way it can get one is through an IMPLICIT type or a RESULT variable, because
1117 by definition contained functions are contained namespace they're contained
1118 in, not in a sibling or parent namespace. */
1121 resolve_contained_functions (gfc_namespace
*ns
)
1123 gfc_namespace
*child
;
1126 resolve_formal_arglists (ns
);
1128 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1130 /* Resolve alternate entry points first. */
1131 resolve_entries (child
);
1133 /* Then check function return types. */
1134 resolve_contained_fntype (child
->proc_name
, child
);
1135 for (el
= child
->entries
; el
; el
= el
->next
)
1136 resolve_contained_fntype (el
->sym
, child
);
1142 /* A Parameterized Derived Type constructor must contain values for
1143 the PDT KIND parameters or they must have a default initializer.
1144 Go through the constructor picking out the KIND expressions,
1145 storing them in 'param_list' and then call gfc_get_pdt_instance
1146 to obtain the PDT instance. */
1148 static gfc_actual_arglist
*param_list
, *param_tail
, *param
;
1151 get_pdt_spec_expr (gfc_component
*c
, gfc_expr
*expr
)
1153 param
= gfc_get_actual_arglist ();
1155 param_list
= param_tail
= param
;
1158 param_tail
->next
= param
;
1159 param_tail
= param_tail
->next
;
1162 param_tail
->name
= c
->name
;
1164 param_tail
->expr
= gfc_copy_expr (expr
);
1165 else if (c
->initializer
)
1166 param_tail
->expr
= gfc_copy_expr (c
->initializer
);
1169 param_tail
->spec_type
= SPEC_ASSUMED
;
1170 if (c
->attr
.pdt_kind
)
1172 gfc_error ("The KIND parameter %qs in the PDT constructor "
1173 "at %C has no value", param
->name
);
1182 get_pdt_constructor (gfc_expr
*expr
, gfc_constructor
**constr
,
1183 gfc_symbol
*derived
)
1185 gfc_constructor
*cons
= NULL
;
1186 gfc_component
*comp
;
1189 if (expr
&& expr
->expr_type
== EXPR_STRUCTURE
)
1190 cons
= gfc_constructor_first (expr
->value
.constructor
);
1195 comp
= derived
->components
;
1197 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1200 && cons
->expr
->expr_type
== EXPR_STRUCTURE
1201 && comp
->ts
.type
== BT_DERIVED
)
1203 t
= get_pdt_constructor (cons
->expr
, NULL
, comp
->ts
.u
.derived
);
1207 else if (comp
->ts
.type
== BT_DERIVED
)
1209 t
= get_pdt_constructor (NULL
, &cons
, comp
->ts
.u
.derived
);
1213 else if ((comp
->attr
.pdt_kind
|| comp
->attr
.pdt_len
)
1214 && derived
->attr
.pdt_template
)
1216 t
= get_pdt_spec_expr (comp
, cons
->expr
);
1225 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1226 static bool resolve_fl_struct (gfc_symbol
*sym
);
1229 /* Resolve all of the elements of a structure constructor and make sure that
1230 the types are correct. The 'init' flag indicates that the given
1231 constructor is an initializer. */
1234 resolve_structure_cons (gfc_expr
*expr
, int init
)
1236 gfc_constructor
*cons
;
1237 gfc_component
*comp
;
1243 if (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_UNION
)
1245 if (expr
->ts
.u
.derived
->attr
.flavor
== FL_DERIVED
)
1246 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1248 resolve_fl_struct (expr
->ts
.u
.derived
);
1250 /* If this is a Parameterized Derived Type template, find the
1251 instance corresponding to the PDT kind parameters. */
1252 if (expr
->ts
.u
.derived
->attr
.pdt_template
)
1255 t
= get_pdt_constructor (expr
, NULL
, expr
->ts
.u
.derived
);
1258 gfc_get_pdt_instance (param_list
, &expr
->ts
.u
.derived
, NULL
);
1260 expr
->param_list
= gfc_copy_actual_arglist (param_list
);
1263 gfc_free_actual_arglist (param_list
);
1265 if (!expr
->ts
.u
.derived
->attr
.pdt_type
)
1270 cons
= gfc_constructor_first (expr
->value
.constructor
);
1272 /* A constructor may have references if it is the result of substituting a
1273 parameter variable. In this case we just pull out the component we
1276 comp
= expr
->ref
->u
.c
.sym
->components
;
1278 comp
= expr
->ts
.u
.derived
->components
;
1280 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1287 /* Unions use an EXPR_NULL contrived expression to tell the translation
1288 phase to generate an initializer of the appropriate length.
1290 if (cons
->expr
->ts
.type
== BT_UNION
&& cons
->expr
->expr_type
== EXPR_NULL
)
1293 if (!gfc_resolve_expr (cons
->expr
))
1299 rank
= comp
->as
? comp
->as
->rank
: 0;
1300 if (comp
->ts
.type
== BT_CLASS
1301 && !comp
->ts
.u
.derived
->attr
.unlimited_polymorphic
1302 && CLASS_DATA (comp
)->as
)
1303 rank
= CLASS_DATA (comp
)->as
->rank
;
1305 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1306 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1308 gfc_error ("The rank of the element in the structure "
1309 "constructor at %L does not match that of the "
1310 "component (%d/%d)", &cons
->expr
->where
,
1311 cons
->expr
->rank
, rank
);
1315 /* If we don't have the right type, try to convert it. */
1317 if (!comp
->attr
.proc_pointer
&&
1318 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1320 if (strcmp (comp
->name
, "_extends") == 0)
1322 /* Can afford to be brutal with the _extends initializer.
1323 The derived type can get lost because it is PRIVATE
1324 but it is not usage constrained by the standard. */
1325 cons
->expr
->ts
= comp
->ts
;
1327 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1329 gfc_error ("The element in the structure constructor at %L, "
1330 "for pointer component %qs, is %s but should be %s",
1331 &cons
->expr
->where
, comp
->name
,
1332 gfc_basic_typename (cons
->expr
->ts
.type
),
1333 gfc_basic_typename (comp
->ts
.type
));
1338 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1344 /* For strings, the length of the constructor should be the same as
1345 the one of the structure, ensure this if the lengths are known at
1346 compile time and when we are dealing with PARAMETER or structure
1348 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1349 && comp
->ts
.u
.cl
->length
1350 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1351 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1352 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1353 && cons
->expr
->rank
!= 0
1354 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1355 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1357 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1358 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1360 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1361 to make use of the gfc_resolve_character_array_constructor
1362 machinery. The expression is later simplified away to
1363 an array of string literals. */
1364 gfc_expr
*para
= cons
->expr
;
1365 cons
->expr
= gfc_get_expr ();
1366 cons
->expr
->ts
= para
->ts
;
1367 cons
->expr
->where
= para
->where
;
1368 cons
->expr
->expr_type
= EXPR_ARRAY
;
1369 cons
->expr
->rank
= para
->rank
;
1370 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1371 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1372 para
, &cons
->expr
->where
);
1375 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1377 /* Rely on the cleanup of the namespace to deal correctly with
1378 the old charlen. (There was a block here that attempted to
1379 remove the charlen but broke the chain in so doing.) */
1380 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1381 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1382 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1383 gfc_resolve_character_array_constructor (cons
->expr
);
1387 if (cons
->expr
->expr_type
== EXPR_NULL
1388 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1389 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1390 || (comp
->ts
.type
== BT_CLASS
1391 && (CLASS_DATA (comp
)->attr
.class_pointer
1392 || CLASS_DATA (comp
)->attr
.allocatable
))))
1395 gfc_error ("The NULL in the structure constructor at %L is "
1396 "being applied to component %qs, which is neither "
1397 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1401 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1403 /* Check procedure pointer interface. */
1404 gfc_symbol
*s2
= NULL
;
1409 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1412 s2
= c2
->ts
.interface
;
1415 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1417 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1418 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1420 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1422 s2
= cons
->expr
->symtree
->n
.sym
;
1423 name
= cons
->expr
->symtree
->n
.sym
->name
;
1426 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1427 err
, sizeof (err
), NULL
, NULL
))
1429 gfc_error_opt (OPT_Wargument_mismatch
,
1430 "Interface mismatch for procedure-pointer "
1431 "component %qs in structure constructor at %L:"
1432 " %s", comp
->name
, &cons
->expr
->where
, err
);
1437 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1438 || cons
->expr
->expr_type
== EXPR_NULL
)
1441 a
= gfc_expr_attr (cons
->expr
);
1443 if (!a
.pointer
&& !a
.target
)
1446 gfc_error ("The element in the structure constructor at %L, "
1447 "for pointer component %qs should be a POINTER or "
1448 "a TARGET", &cons
->expr
->where
, comp
->name
);
1453 /* F08:C461. Additional checks for pointer initialization. */
1457 gfc_error ("Pointer initialization target at %L "
1458 "must not be ALLOCATABLE", &cons
->expr
->where
);
1463 gfc_error ("Pointer initialization target at %L "
1464 "must have the SAVE attribute", &cons
->expr
->where
);
1468 /* F2003, C1272 (3). */
1469 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1470 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1471 || gfc_is_coindexed (cons
->expr
));
1472 if (impure
&& gfc_pure (NULL
))
1475 gfc_error ("Invalid expression in the structure constructor for "
1476 "pointer component %qs at %L in PURE procedure",
1477 comp
->name
, &cons
->expr
->where
);
1481 gfc_unset_implicit_pure (NULL
);
1488 /****************** Expression name resolution ******************/
1490 /* Returns 0 if a symbol was not declared with a type or
1491 attribute declaration statement, nonzero otherwise. */
1494 was_declared (gfc_symbol
*sym
)
1500 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1503 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1504 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1505 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1506 || a
.asynchronous
|| a
.codimension
)
1513 /* Determine if a symbol is generic or not. */
1516 generic_sym (gfc_symbol
*sym
)
1520 if (sym
->attr
.generic
||
1521 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1524 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1527 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1534 return generic_sym (s
);
1541 /* Determine if a symbol is specific or not. */
1544 specific_sym (gfc_symbol
*sym
)
1548 if (sym
->attr
.if_source
== IFSRC_IFBODY
1549 || sym
->attr
.proc
== PROC_MODULE
1550 || sym
->attr
.proc
== PROC_INTERNAL
1551 || sym
->attr
.proc
== PROC_ST_FUNCTION
1552 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1553 || sym
->attr
.external
)
1556 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1559 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1561 return (s
== NULL
) ? 0 : specific_sym (s
);
1565 /* Figure out if the procedure is specific, generic or unknown. */
1568 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
};
1571 procedure_kind (gfc_symbol
*sym
)
1573 if (generic_sym (sym
))
1574 return PTYPE_GENERIC
;
1576 if (specific_sym (sym
))
1577 return PTYPE_SPECIFIC
;
1579 return PTYPE_UNKNOWN
;
1582 /* Check references to assumed size arrays. The flag need_full_assumed_size
1583 is nonzero when matching actual arguments. */
1585 static int need_full_assumed_size
= 0;
1588 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1590 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1593 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1594 What should it be? */
1595 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1596 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1597 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1599 gfc_error ("The upper bound in the last dimension must "
1600 "appear in the reference to the assumed size "
1601 "array %qs at %L", sym
->name
, &e
->where
);
1608 /* Look for bad assumed size array references in argument expressions
1609 of elemental and array valued intrinsic procedures. Since this is
1610 called from procedure resolution functions, it only recurses at
1614 resolve_assumed_size_actual (gfc_expr
*e
)
1619 switch (e
->expr_type
)
1622 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1627 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1628 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1639 /* Check a generic procedure, passed as an actual argument, to see if
1640 there is a matching specific name. If none, it is an error, and if
1641 more than one, the reference is ambiguous. */
1643 count_specific_procs (gfc_expr
*e
)
1650 sym
= e
->symtree
->n
.sym
;
1652 for (p
= sym
->generic
; p
; p
= p
->next
)
1653 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1655 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1661 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1665 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1666 "argument at %L", sym
->name
, &e
->where
);
1672 /* See if a call to sym could possibly be a not allowed RECURSION because of
1673 a missing RECURSIVE declaration. This means that either sym is the current
1674 context itself, or sym is the parent of a contained procedure calling its
1675 non-RECURSIVE containing procedure.
1676 This also works if sym is an ENTRY. */
1679 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1681 gfc_symbol
* proc_sym
;
1682 gfc_symbol
* context_proc
;
1683 gfc_namespace
* real_context
;
1685 if (sym
->attr
.flavor
== FL_PROGRAM
1686 || gfc_fl_struct (sym
->attr
.flavor
))
1689 /* If we've got an ENTRY, find real procedure. */
1690 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1691 proc_sym
= sym
->ns
->entries
->sym
;
1695 /* If sym is RECURSIVE, all is well of course. */
1696 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1699 /* Find the context procedure's "real" symbol if it has entries.
1700 We look for a procedure symbol, so recurse on the parents if we don't
1701 find one (like in case of a BLOCK construct). */
1702 for (real_context
= context
; ; real_context
= real_context
->parent
)
1704 /* We should find something, eventually! */
1705 gcc_assert (real_context
);
1707 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1708 : real_context
->proc_name
);
1710 /* In some special cases, there may not be a proc_name, like for this
1712 real(bad_kind()) function foo () ...
1713 when checking the call to bad_kind ().
1714 In these cases, we simply return here and assume that the
1719 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1723 /* A call from sym's body to itself is recursion, of course. */
1724 if (context_proc
== proc_sym
)
1727 /* The same is true if context is a contained procedure and sym the
1729 if (context_proc
->attr
.contained
)
1731 gfc_symbol
* parent_proc
;
1733 gcc_assert (context
->parent
);
1734 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1735 : context
->parent
->proc_name
);
1737 if (parent_proc
== proc_sym
)
1745 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1746 its typespec and formal argument list. */
1749 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1751 gfc_intrinsic_sym
* isym
= NULL
;
1757 /* Already resolved. */
1758 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1761 /* We already know this one is an intrinsic, so we don't call
1762 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1763 gfc_find_subroutine directly to check whether it is a function or
1766 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1768 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1769 isym
= gfc_intrinsic_subroutine_by_id (id
);
1771 else if (sym
->intmod_sym_id
)
1773 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1774 isym
= gfc_intrinsic_function_by_id (id
);
1776 else if (!sym
->attr
.subroutine
)
1777 isym
= gfc_find_function (sym
->name
);
1779 if (isym
&& !sym
->attr
.subroutine
)
1781 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1782 && !sym
->attr
.implicit_type
)
1783 gfc_warning (OPT_Wsurprising
,
1784 "Type specified for intrinsic function %qs at %L is"
1785 " ignored", sym
->name
, &sym
->declared_at
);
1787 if (!sym
->attr
.function
&&
1788 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1793 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1795 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1797 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1798 " specifier", sym
->name
, &sym
->declared_at
);
1802 if (!sym
->attr
.subroutine
&&
1803 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1808 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1813 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1815 sym
->attr
.pure
= isym
->pure
;
1816 sym
->attr
.elemental
= isym
->elemental
;
1818 /* Check it is actually available in the standard settings. */
1819 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1821 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1822 "available in the current standard settings but %s. Use "
1823 "an appropriate %<-std=*%> option or enable "
1824 "%<-fall-intrinsics%> in order to use it.",
1825 sym
->name
, &sym
->declared_at
, symstd
);
1833 /* Resolve a procedure expression, like passing it to a called procedure or as
1834 RHS for a procedure pointer assignment. */
1837 resolve_procedure_expression (gfc_expr
* expr
)
1841 if (expr
->expr_type
!= EXPR_VARIABLE
)
1843 gcc_assert (expr
->symtree
);
1845 sym
= expr
->symtree
->n
.sym
;
1847 if (sym
->attr
.intrinsic
)
1848 gfc_resolve_intrinsic (sym
, &expr
->where
);
1850 if (sym
->attr
.flavor
!= FL_PROCEDURE
1851 || (sym
->attr
.function
&& sym
->result
== sym
))
1854 /* A non-RECURSIVE procedure that is used as procedure expression within its
1855 own body is in danger of being called recursively. */
1856 if (is_illegal_recursion (sym
, gfc_current_ns
))
1857 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1858 " itself recursively. Declare it RECURSIVE or use"
1859 " %<-frecursive%>", sym
->name
, &expr
->where
);
1865 /* Resolve an actual argument list. Most of the time, this is just
1866 resolving the expressions in the list.
1867 The exception is that we sometimes have to decide whether arguments
1868 that look like procedure arguments are really simple variable
1872 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1873 bool no_formal_args
)
1876 gfc_symtree
*parent_st
;
1878 gfc_component
*comp
;
1879 int save_need_full_assumed_size
;
1880 bool return_value
= false;
1881 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1884 first_actual_arg
= true;
1886 for (; arg
; arg
= arg
->next
)
1891 /* Check the label is a valid branching target. */
1894 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1896 gfc_error ("Label %d referenced at %L is never defined",
1897 arg
->label
->value
, &arg
->label
->where
);
1901 first_actual_arg
= false;
1905 if (e
->expr_type
== EXPR_VARIABLE
1906 && e
->symtree
->n
.sym
->attr
.generic
1908 && count_specific_procs (e
) != 1)
1911 if (e
->ts
.type
!= BT_PROCEDURE
)
1913 save_need_full_assumed_size
= need_full_assumed_size
;
1914 if (e
->expr_type
!= EXPR_VARIABLE
)
1915 need_full_assumed_size
= 0;
1916 if (!gfc_resolve_expr (e
))
1918 need_full_assumed_size
= save_need_full_assumed_size
;
1922 /* See if the expression node should really be a variable reference. */
1924 sym
= e
->symtree
->n
.sym
;
1926 if (sym
->attr
.flavor
== FL_PROCEDURE
1927 || sym
->attr
.intrinsic
1928 || sym
->attr
.external
)
1932 /* If a procedure is not already determined to be something else
1933 check if it is intrinsic. */
1934 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1935 sym
->attr
.intrinsic
= 1;
1937 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1939 gfc_error ("Statement function %qs at %L is not allowed as an "
1940 "actual argument", sym
->name
, &e
->where
);
1943 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1944 sym
->attr
.subroutine
);
1945 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1947 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1948 "actual argument", sym
->name
, &e
->where
);
1951 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1952 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1954 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1955 " used as actual argument at %L",
1956 sym
->name
, &e
->where
))
1960 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1962 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1963 "allowed as an actual argument at %L", sym
->name
,
1967 /* Check if a generic interface has a specific procedure
1968 with the same name before emitting an error. */
1969 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1972 /* Just in case a specific was found for the expression. */
1973 sym
= e
->symtree
->n
.sym
;
1975 /* If the symbol is the function that names the current (or
1976 parent) scope, then we really have a variable reference. */
1978 if (gfc_is_function_return_value (sym
, sym
->ns
))
1981 /* If all else fails, see if we have a specific intrinsic. */
1982 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1984 gfc_intrinsic_sym
*isym
;
1986 isym
= gfc_find_function (sym
->name
);
1987 if (isym
== NULL
|| !isym
->specific
)
1989 gfc_error ("Unable to find a specific INTRINSIC procedure "
1990 "for the reference %qs at %L", sym
->name
,
1995 sym
->attr
.intrinsic
= 1;
1996 sym
->attr
.function
= 1;
1999 if (!gfc_resolve_expr (e
))
2004 /* See if the name is a module procedure in a parent unit. */
2006 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
2009 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
2011 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
2015 if (parent_st
== NULL
)
2018 sym
= parent_st
->n
.sym
;
2019 e
->symtree
= parent_st
; /* Point to the right thing. */
2021 if (sym
->attr
.flavor
== FL_PROCEDURE
2022 || sym
->attr
.intrinsic
2023 || sym
->attr
.external
)
2025 if (!gfc_resolve_expr (e
))
2031 e
->expr_type
= EXPR_VARIABLE
;
2033 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
2034 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2035 && CLASS_DATA (sym
)->as
))
2037 e
->rank
= sym
->ts
.type
== BT_CLASS
2038 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
2039 e
->ref
= gfc_get_ref ();
2040 e
->ref
->type
= REF_ARRAY
;
2041 e
->ref
->u
.ar
.type
= AR_FULL
;
2042 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
2043 ? CLASS_DATA (sym
)->as
: sym
->as
;
2046 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2047 primary.c (match_actual_arg). If above code determines that it
2048 is a variable instead, it needs to be resolved as it was not
2049 done at the beginning of this function. */
2050 save_need_full_assumed_size
= need_full_assumed_size
;
2051 if (e
->expr_type
!= EXPR_VARIABLE
)
2052 need_full_assumed_size
= 0;
2053 if (!gfc_resolve_expr (e
))
2055 need_full_assumed_size
= save_need_full_assumed_size
;
2058 /* Check argument list functions %VAL, %LOC and %REF. There is
2059 nothing to do for %REF. */
2060 if (arg
->name
&& arg
->name
[0] == '%')
2062 if (strcmp ("%VAL", arg
->name
) == 0)
2064 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
2066 gfc_error ("By-value argument at %L is not of numeric "
2073 gfc_error ("By-value argument at %L cannot be an array or "
2074 "an array section", &e
->where
);
2078 /* Intrinsics are still PROC_UNKNOWN here. However,
2079 since same file external procedures are not resolvable
2080 in gfortran, it is a good deal easier to leave them to
2082 if (ptype
!= PROC_UNKNOWN
2083 && ptype
!= PROC_DUMMY
2084 && ptype
!= PROC_EXTERNAL
2085 && ptype
!= PROC_MODULE
)
2087 gfc_error ("By-value argument at %L is not allowed "
2088 "in this context", &e
->where
);
2093 /* Statement functions have already been excluded above. */
2094 else if (strcmp ("%LOC", arg
->name
) == 0
2095 && e
->ts
.type
== BT_PROCEDURE
)
2097 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
2099 gfc_error ("Passing internal procedure at %L by location "
2100 "not allowed", &e
->where
);
2106 comp
= gfc_get_proc_ptr_comp(e
);
2107 if (e
->expr_type
== EXPR_VARIABLE
2108 && comp
&& comp
->attr
.elemental
)
2110 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2111 "allowed as an actual argument at %L", comp
->name
,
2115 /* Fortran 2008, C1237. */
2116 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
2117 && gfc_has_ultimate_pointer (e
))
2119 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2120 "component", &e
->where
);
2124 first_actual_arg
= false;
2127 return_value
= true;
2130 actual_arg
= actual_arg_sav
;
2131 first_actual_arg
= first_actual_arg_sav
;
2133 return return_value
;
2137 /* Do the checks of the actual argument list that are specific to elemental
2138 procedures. If called with c == NULL, we have a function, otherwise if
2139 expr == NULL, we have a subroutine. */
2142 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2144 gfc_actual_arglist
*arg0
;
2145 gfc_actual_arglist
*arg
;
2146 gfc_symbol
*esym
= NULL
;
2147 gfc_intrinsic_sym
*isym
= NULL
;
2149 gfc_intrinsic_arg
*iformal
= NULL
;
2150 gfc_formal_arglist
*eformal
= NULL
;
2151 bool formal_optional
= false;
2152 bool set_by_optional
= false;
2156 /* Is this an elemental procedure? */
2157 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2159 if (expr
->value
.function
.esym
!= NULL
2160 && expr
->value
.function
.esym
->attr
.elemental
)
2162 arg0
= expr
->value
.function
.actual
;
2163 esym
= expr
->value
.function
.esym
;
2165 else if (expr
->value
.function
.isym
!= NULL
2166 && expr
->value
.function
.isym
->elemental
)
2168 arg0
= expr
->value
.function
.actual
;
2169 isym
= expr
->value
.function
.isym
;
2174 else if (c
&& c
->ext
.actual
!= NULL
)
2176 arg0
= c
->ext
.actual
;
2178 if (c
->resolved_sym
)
2179 esym
= c
->resolved_sym
;
2181 esym
= c
->symtree
->n
.sym
;
2184 if (!esym
->attr
.elemental
)
2190 /* The rank of an elemental is the rank of its array argument(s). */
2191 for (arg
= arg0
; arg
; arg
= arg
->next
)
2193 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2195 rank
= arg
->expr
->rank
;
2196 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2197 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2198 set_by_optional
= true;
2200 /* Function specific; set the result rank and shape. */
2204 if (!expr
->shape
&& arg
->expr
->shape
)
2206 expr
->shape
= gfc_get_shape (rank
);
2207 for (i
= 0; i
< rank
; i
++)
2208 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2215 /* If it is an array, it shall not be supplied as an actual argument
2216 to an elemental procedure unless an array of the same rank is supplied
2217 as an actual argument corresponding to a nonoptional dummy argument of
2218 that elemental procedure(12.4.1.5). */
2219 formal_optional
= false;
2221 iformal
= isym
->formal
;
2223 eformal
= esym
->formal
;
2225 for (arg
= arg0
; arg
; arg
= arg
->next
)
2229 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2230 formal_optional
= true;
2231 eformal
= eformal
->next
;
2233 else if (isym
&& iformal
)
2235 if (iformal
->optional
)
2236 formal_optional
= true;
2237 iformal
= iformal
->next
;
2240 formal_optional
= true;
2242 if (pedantic
&& arg
->expr
!= NULL
2243 && arg
->expr
->expr_type
== EXPR_VARIABLE
2244 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2247 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2248 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2250 gfc_warning (OPT_Wpedantic
,
2251 "%qs at %L is an array and OPTIONAL; IF IT IS "
2252 "MISSING, it cannot be the actual argument of an "
2253 "ELEMENTAL procedure unless there is a non-optional "
2254 "argument with the same rank (12.4.1.5)",
2255 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2259 for (arg
= arg0
; arg
; arg
= arg
->next
)
2261 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2264 /* Being elemental, the last upper bound of an assumed size array
2265 argument must be present. */
2266 if (resolve_assumed_size_actual (arg
->expr
))
2269 /* Elemental procedure's array actual arguments must conform. */
2272 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2279 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2280 is an array, the intent inout/out variable needs to be also an array. */
2281 if (rank
> 0 && esym
&& expr
== NULL
)
2282 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2283 arg
= arg
->next
, eformal
= eformal
->next
)
2284 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2285 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2286 && arg
->expr
&& arg
->expr
->rank
== 0)
2288 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2289 "ELEMENTAL subroutine %qs is a scalar, but another "
2290 "actual argument is an array", &arg
->expr
->where
,
2291 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2292 : "INOUT", eformal
->sym
->name
, esym
->name
);
2299 /* This function does the checking of references to global procedures
2300 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2301 77 and 95 standards. It checks for a gsymbol for the name, making
2302 one if it does not already exist. If it already exists, then the
2303 reference being resolved must correspond to the type of gsymbol.
2304 Otherwise, the new symbol is equipped with the attributes of the
2305 reference. The corresponding code that is called in creating
2306 global entities is parse.c.
2308 In addition, for all but -std=legacy, the gsymbols are used to
2309 check the interfaces of external procedures from the same file.
2310 The namespace of the gsymbol is resolved and then, once this is
2311 done the interface is checked. */
2315 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2317 if (!gsym_ns
->proc_name
->attr
.recursive
)
2320 if (sym
->ns
== gsym_ns
)
2323 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2330 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2332 if (gsym_ns
->entries
)
2334 gfc_entry_list
*entry
= gsym_ns
->entries
;
2336 for (; entry
; entry
= entry
->next
)
2338 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2340 if (strcmp (gsym_ns
->proc_name
->name
,
2341 sym
->ns
->proc_name
->name
) == 0)
2345 && strcmp (gsym_ns
->proc_name
->name
,
2346 sym
->ns
->parent
->proc_name
->name
) == 0)
2355 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2358 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2360 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2362 for ( ; arg
; arg
= arg
->next
)
2367 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2369 strncpy (errmsg
, _("allocatable argument"), err_len
);
2372 else if (arg
->sym
->attr
.asynchronous
)
2374 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2377 else if (arg
->sym
->attr
.optional
)
2379 strncpy (errmsg
, _("optional argument"), err_len
);
2382 else if (arg
->sym
->attr
.pointer
)
2384 strncpy (errmsg
, _("pointer argument"), err_len
);
2387 else if (arg
->sym
->attr
.target
)
2389 strncpy (errmsg
, _("target argument"), err_len
);
2392 else if (arg
->sym
->attr
.value
)
2394 strncpy (errmsg
, _("value argument"), err_len
);
2397 else if (arg
->sym
->attr
.volatile_
)
2399 strncpy (errmsg
, _("volatile argument"), err_len
);
2402 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2404 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2407 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2409 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2412 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2414 strncpy (errmsg
, _("coarray argument"), err_len
);
2417 else if (false) /* (2d) TODO: parametrized derived type */
2419 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2422 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2424 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2427 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2429 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2432 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2434 /* As assumed-type is unlimited polymorphic (cf. above).
2435 See also TS 29113, Note 6.1. */
2436 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2441 if (sym
->attr
.function
)
2443 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2445 if (res
->attr
.dimension
) /* (3a) */
2447 strncpy (errmsg
, _("array result"), err_len
);
2450 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2452 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2455 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2456 && res
->ts
.u
.cl
->length
2457 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2459 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2464 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2466 strncpy (errmsg
, _("elemental procedure"), err_len
);
2469 else if (sym
->attr
.is_bind_c
) /* (5) */
2471 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2480 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2481 gfc_actual_arglist
**actual
, int sub
)
2485 enum gfc_symbol_type type
;
2488 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2490 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
,
2491 sym
->binding_label
!= NULL
);
2493 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2494 gfc_global_used (gsym
, where
);
2496 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2497 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2498 && gsym
->type
!= GSYM_UNKNOWN
2499 && !gsym
->binding_label
2501 && gsym
->ns
->resolved
!= -1
2502 && gsym
->ns
->proc_name
2503 && not_in_recursive (sym
, gsym
->ns
)
2504 && not_entry_self_reference (sym
, gsym
->ns
))
2506 gfc_symbol
*def_sym
;
2508 /* Resolve the gsymbol namespace if needed. */
2509 if (!gsym
->ns
->resolved
)
2511 gfc_symbol
*old_dt_list
;
2513 /* Stash away derived types so that the backend_decls do not
2515 old_dt_list
= gfc_derived_types
;
2516 gfc_derived_types
= NULL
;
2518 gfc_resolve (gsym
->ns
);
2520 /* Store the new derived types with the global namespace. */
2521 if (gfc_derived_types
)
2522 gsym
->ns
->derived_types
= gfc_derived_types
;
2524 /* Restore the derived types of this namespace. */
2525 gfc_derived_types
= old_dt_list
;
2528 /* Make sure that translation for the gsymbol occurs before
2529 the procedure currently being resolved. */
2530 ns
= gfc_global_ns_list
;
2531 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2533 if (ns
->sibling
== gsym
->ns
)
2535 ns
->sibling
= gsym
->ns
->sibling
;
2536 gsym
->ns
->sibling
= gfc_global_ns_list
;
2537 gfc_global_ns_list
= gsym
->ns
;
2542 def_sym
= gsym
->ns
->proc_name
;
2544 /* This can happen if a binding name has been specified. */
2545 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2546 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2548 if (def_sym
->attr
.entry_master
)
2550 gfc_entry_list
*entry
;
2551 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2552 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2554 def_sym
= entry
->sym
;
2559 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2561 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2562 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2563 gfc_typename (&def_sym
->ts
));
2567 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2568 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2570 gfc_error ("Explicit interface required for %qs at %L: %s",
2571 sym
->name
, &sym
->declared_at
, reason
);
2575 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2576 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2577 gfc_errors_to_warnings (true);
2579 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2580 reason
, sizeof(reason
), NULL
, NULL
))
2582 gfc_error_opt (OPT_Wargument_mismatch
,
2583 "Interface mismatch in global procedure %qs at %L:"
2584 " %s", sym
->name
, &sym
->declared_at
, reason
);
2589 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2590 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2591 gfc_errors_to_warnings (true);
2593 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2594 gfc_procedure_use (def_sym
, actual
, where
);
2598 gfc_errors_to_warnings (false);
2600 if (gsym
->type
== GSYM_UNKNOWN
)
2603 gsym
->where
= *where
;
2610 /************* Function resolution *************/
2612 /* Resolve a function call known to be generic.
2613 Section 14.1.2.4.1. */
2616 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2620 if (sym
->attr
.generic
)
2622 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2625 expr
->value
.function
.name
= s
->name
;
2626 expr
->value
.function
.esym
= s
;
2628 if (s
->ts
.type
!= BT_UNKNOWN
)
2630 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2631 expr
->ts
= s
->result
->ts
;
2634 expr
->rank
= s
->as
->rank
;
2635 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2636 expr
->rank
= s
->result
->as
->rank
;
2638 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2643 /* TODO: Need to search for elemental references in generic
2647 if (sym
->attr
.intrinsic
)
2648 return gfc_intrinsic_func_interface (expr
, 0);
2655 resolve_generic_f (gfc_expr
*expr
)
2659 gfc_interface
*intr
= NULL
;
2661 sym
= expr
->symtree
->n
.sym
;
2665 m
= resolve_generic_f0 (expr
, sym
);
2668 else if (m
== MATCH_ERROR
)
2673 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2674 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
2677 if (sym
->ns
->parent
== NULL
)
2679 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2683 if (!generic_sym (sym
))
2687 /* Last ditch attempt. See if the reference is to an intrinsic
2688 that possesses a matching interface. 14.1.2.4 */
2689 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2691 if (gfc_init_expr_flag
)
2692 gfc_error ("Function %qs in initialization expression at %L "
2693 "must be an intrinsic function",
2694 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2696 gfc_error ("There is no specific function for the generic %qs "
2697 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2703 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2706 if (!gfc_use_derived (expr
->ts
.u
.derived
))
2708 return resolve_structure_cons (expr
, 0);
2711 m
= gfc_intrinsic_func_interface (expr
, 0);
2716 gfc_error ("Generic function %qs at %L is not consistent with a "
2717 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2724 /* Resolve a function call known to be specific. */
2727 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2731 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2733 if (sym
->attr
.dummy
)
2735 sym
->attr
.proc
= PROC_DUMMY
;
2739 sym
->attr
.proc
= PROC_EXTERNAL
;
2743 if (sym
->attr
.proc
== PROC_MODULE
2744 || sym
->attr
.proc
== PROC_ST_FUNCTION
2745 || sym
->attr
.proc
== PROC_INTERNAL
)
2748 if (sym
->attr
.intrinsic
)
2750 m
= gfc_intrinsic_func_interface (expr
, 1);
2754 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2755 "with an intrinsic", sym
->name
, &expr
->where
);
2763 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2766 expr
->ts
= sym
->result
->ts
;
2769 expr
->value
.function
.name
= sym
->name
;
2770 expr
->value
.function
.esym
= sym
;
2771 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2773 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2775 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2776 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2777 else if (sym
->as
!= NULL
)
2778 expr
->rank
= sym
->as
->rank
;
2785 resolve_specific_f (gfc_expr
*expr
)
2790 sym
= expr
->symtree
->n
.sym
;
2794 m
= resolve_specific_f0 (sym
, expr
);
2797 if (m
== MATCH_ERROR
)
2800 if (sym
->ns
->parent
== NULL
)
2803 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2809 gfc_error ("Unable to resolve the specific function %qs at %L",
2810 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2815 /* Recursively append candidate SYM to CANDIDATES. Store the number of
2816 candidates in CANDIDATES_LEN. */
2819 lookup_function_fuzzy_find_candidates (gfc_symtree
*sym
,
2821 size_t &candidates_len
)
2827 if ((sym
->n
.sym
->ts
.type
!= BT_UNKNOWN
|| sym
->n
.sym
->attr
.external
)
2828 && sym
->n
.sym
->attr
.flavor
== FL_PROCEDURE
)
2829 vec_push (candidates
, candidates_len
, sym
->name
);
2833 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2837 lookup_function_fuzzy_find_candidates (p
, candidates
, candidates_len
);
2841 /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2844 gfc_lookup_function_fuzzy (const char *fn
, gfc_symtree
*symroot
)
2846 char **candidates
= NULL
;
2847 size_t candidates_len
= 0;
2848 lookup_function_fuzzy_find_candidates (symroot
, candidates
, candidates_len
);
2849 return gfc_closest_fuzzy_match (fn
, candidates
);
2853 /* Resolve a procedure call not known to be generic nor specific. */
2856 resolve_unknown_f (gfc_expr
*expr
)
2861 sym
= expr
->symtree
->n
.sym
;
2863 if (sym
->attr
.dummy
)
2865 sym
->attr
.proc
= PROC_DUMMY
;
2866 expr
->value
.function
.name
= sym
->name
;
2870 /* See if we have an intrinsic function reference. */
2872 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2874 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2879 /* The reference is to an external name. */
2881 sym
->attr
.proc
= PROC_EXTERNAL
;
2882 expr
->value
.function
.name
= sym
->name
;
2883 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2885 if (sym
->as
!= NULL
)
2886 expr
->rank
= sym
->as
->rank
;
2888 /* Type of the expression is either the type of the symbol or the
2889 default type of the symbol. */
2892 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2894 if (sym
->ts
.type
!= BT_UNKNOWN
)
2898 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2900 if (ts
->type
== BT_UNKNOWN
)
2903 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
2905 gfc_error ("Function %qs at %L has no IMPLICIT type"
2906 "; did you mean %qs?",
2907 sym
->name
, &expr
->where
, guessed
);
2909 gfc_error ("Function %qs at %L has no IMPLICIT type",
2910 sym
->name
, &expr
->where
);
2921 /* Return true, if the symbol is an external procedure. */
2923 is_external_proc (gfc_symbol
*sym
)
2925 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2926 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2927 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2928 && !sym
->attr
.proc_pointer
2929 && !sym
->attr
.use_assoc
2937 /* Figure out if a function reference is pure or not. Also set the name
2938 of the function for a potential error message. Return nonzero if the
2939 function is PURE, zero if not. */
2941 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2944 gfc_pure_function (gfc_expr
*e
, const char **name
)
2947 gfc_component
*comp
;
2951 if (e
->symtree
!= NULL
2952 && e
->symtree
->n
.sym
!= NULL
2953 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2954 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2956 comp
= gfc_get_proc_ptr_comp (e
);
2959 pure
= gfc_pure (comp
->ts
.interface
);
2962 else if (e
->value
.function
.esym
)
2964 pure
= gfc_pure (e
->value
.function
.esym
);
2965 *name
= e
->value
.function
.esym
->name
;
2967 else if (e
->value
.function
.isym
)
2969 pure
= e
->value
.function
.isym
->pure
2970 || e
->value
.function
.isym
->elemental
;
2971 *name
= e
->value
.function
.isym
->name
;
2975 /* Implicit functions are not pure. */
2977 *name
= e
->value
.function
.name
;
2984 /* Check if the expression is a reference to an implicitly pure function. */
2987 gfc_implicit_pure_function (gfc_expr
*e
)
2989 gfc_component
*comp
= gfc_get_proc_ptr_comp (e
);
2991 return gfc_implicit_pure (comp
->ts
.interface
);
2992 else if (e
->value
.function
.esym
)
2993 return gfc_implicit_pure (e
->value
.function
.esym
);
3000 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
3001 int *f ATTRIBUTE_UNUSED
)
3005 /* Don't bother recursing into other statement functions
3006 since they will be checked individually for purity. */
3007 if (e
->expr_type
!= EXPR_FUNCTION
3009 || e
->symtree
->n
.sym
== sym
3010 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3013 return gfc_pure_function (e
, &name
) ? false : true;
3018 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
3020 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
3024 /* Check if an impure function is allowed in the current context. */
3026 static bool check_pure_function (gfc_expr
*e
)
3028 const char *name
= NULL
;
3029 if (!gfc_pure_function (e
, &name
) && name
)
3033 gfc_error ("Reference to impure function %qs at %L inside a "
3034 "FORALL %s", name
, &e
->where
,
3035 forall_flag
== 2 ? "mask" : "block");
3038 else if (gfc_do_concurrent_flag
)
3040 gfc_error ("Reference to impure function %qs at %L inside a "
3041 "DO CONCURRENT %s", name
, &e
->where
,
3042 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3045 else if (gfc_pure (NULL
))
3047 gfc_error ("Reference to impure function %qs at %L "
3048 "within a PURE procedure", name
, &e
->where
);
3051 if (!gfc_implicit_pure_function (e
))
3052 gfc_unset_implicit_pure (NULL
);
3058 /* Update current procedure's array_outer_dependency flag, considering
3059 a call to procedure SYM. */
3062 update_current_proc_array_outer_dependency (gfc_symbol
*sym
)
3064 /* Check to see if this is a sibling function that has not yet
3066 gfc_namespace
*sibling
= gfc_current_ns
->sibling
;
3067 for (; sibling
; sibling
= sibling
->sibling
)
3069 if (sibling
->proc_name
== sym
)
3071 gfc_resolve (sibling
);
3076 /* If SYM has references to outer arrays, so has the procedure calling
3077 SYM. If SYM is a procedure pointer, we can assume the worst. */
3078 if ((sym
->attr
.array_outer_dependency
|| sym
->attr
.proc_pointer
)
3079 && gfc_current_ns
->proc_name
)
3080 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3084 /* Resolve a function call, which means resolving the arguments, then figuring
3085 out which entity the name refers to. */
3088 resolve_function (gfc_expr
*expr
)
3090 gfc_actual_arglist
*arg
;
3094 procedure_type p
= PROC_INTRINSIC
;
3095 bool no_formal_args
;
3099 sym
= expr
->symtree
->n
.sym
;
3101 /* If this is a procedure pointer component, it has already been resolved. */
3102 if (gfc_is_proc_ptr_comp (expr
))
3105 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3107 if (sym
&& sym
->attr
.intrinsic
3108 && (sym
->intmod_sym_id
== GFC_ISYM_CAF_GET
3109 || sym
->intmod_sym_id
== GFC_ISYM_CAF_SEND
))
3112 if (sym
&& sym
->attr
.intrinsic
3113 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
3116 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3118 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
3122 /* If this is a deferred TBP with an abstract interface (which may
3123 of course be referenced), expr->value.function.esym will be set. */
3124 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3126 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3127 sym
->name
, &expr
->where
);
3131 /* If this is a deferred TBP with an abstract interface, its result
3132 cannot be an assumed length character (F2003: C418). */
3133 if (sym
&& sym
->attr
.abstract
&& sym
->attr
.function
3134 && sym
->result
->ts
.u
.cl
3135 && sym
->result
->ts
.u
.cl
->length
== NULL
3136 && !sym
->result
->ts
.deferred
)
3138 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3139 "character length result (F2008: C418)", sym
->name
,
3144 /* Switch off assumed size checking and do this again for certain kinds
3145 of procedure, once the procedure itself is resolved. */
3146 need_full_assumed_size
++;
3148 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3149 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3151 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3152 inquiry_argument
= true;
3153 no_formal_args
= sym
&& is_external_proc (sym
)
3154 && gfc_sym_get_dummy_args (sym
) == NULL
;
3156 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
3159 inquiry_argument
= false;
3163 inquiry_argument
= false;
3165 /* Resume assumed_size checking. */
3166 need_full_assumed_size
--;
3168 /* If the procedure is external, check for usage. */
3169 if (sym
&& is_external_proc (sym
))
3170 resolve_global_procedure (sym
, &expr
->where
,
3171 &expr
->value
.function
.actual
, 0);
3173 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3175 && sym
->ts
.u
.cl
->length
== NULL
3177 && !sym
->ts
.deferred
3178 && expr
->value
.function
.esym
== NULL
3179 && !sym
->attr
.contained
)
3181 /* Internal procedures are taken care of in resolve_contained_fntype. */
3182 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3183 "be used at %L since it is not a dummy argument",
3184 sym
->name
, &expr
->where
);
3188 /* See if function is already resolved. */
3190 if (expr
->value
.function
.name
!= NULL
3191 || expr
->value
.function
.isym
!= NULL
)
3193 if (expr
->ts
.type
== BT_UNKNOWN
)
3199 /* Apply the rules of section 14.1.2. */
3201 switch (procedure_kind (sym
))
3204 t
= resolve_generic_f (expr
);
3207 case PTYPE_SPECIFIC
:
3208 t
= resolve_specific_f (expr
);
3212 t
= resolve_unknown_f (expr
);
3216 gfc_internal_error ("resolve_function(): bad function type");
3220 /* If the expression is still a function (it might have simplified),
3221 then we check to see if we are calling an elemental function. */
3223 if (expr
->expr_type
!= EXPR_FUNCTION
)
3226 temp
= need_full_assumed_size
;
3227 need_full_assumed_size
= 0;
3229 if (!resolve_elemental_actual (expr
, NULL
))
3232 if (omp_workshare_flag
3233 && expr
->value
.function
.esym
3234 && ! gfc_elemental (expr
->value
.function
.esym
))
3236 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3237 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3242 #define GENERIC_ID expr->value.function.isym->id
3243 else if (expr
->value
.function
.actual
!= NULL
3244 && expr
->value
.function
.isym
!= NULL
3245 && GENERIC_ID
!= GFC_ISYM_LBOUND
3246 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3247 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3248 && GENERIC_ID
!= GFC_ISYM_LEN
3249 && GENERIC_ID
!= GFC_ISYM_LOC
3250 && GENERIC_ID
!= GFC_ISYM_C_LOC
3251 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3253 /* Array intrinsics must also have the last upper bound of an
3254 assumed size array argument. UBOUND and SIZE have to be
3255 excluded from the check if the second argument is anything
3258 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3260 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3261 && arg
== expr
->value
.function
.actual
3262 && arg
->next
!= NULL
&& arg
->next
->expr
)
3264 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3267 if (arg
->next
->name
&& strcmp (arg
->next
->name
, "kind") == 0)
3270 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3275 if (arg
->expr
!= NULL
3276 && arg
->expr
->rank
> 0
3277 && resolve_assumed_size_actual (arg
->expr
))
3283 need_full_assumed_size
= temp
;
3285 if (!check_pure_function(expr
))
3288 /* Functions without the RECURSIVE attribution are not allowed to
3289 * call themselves. */
3290 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3293 esym
= expr
->value
.function
.esym
;
3295 if (is_illegal_recursion (esym
, gfc_current_ns
))
3297 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3298 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3299 " function %qs is not RECURSIVE",
3300 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3302 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3303 " is not RECURSIVE", esym
->name
, &expr
->where
);
3309 /* Character lengths of use associated functions may contains references to
3310 symbols not referenced from the current program unit otherwise. Make sure
3311 those symbols are marked as referenced. */
3313 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3314 && expr
->value
.function
.esym
->attr
.use_assoc
)
3316 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3319 /* Make sure that the expression has a typespec that works. */
3320 if (expr
->ts
.type
== BT_UNKNOWN
)
3322 if (expr
->symtree
->n
.sym
->result
3323 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3324 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3325 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3328 if (!expr
->ref
&& !expr
->value
.function
.isym
)
3330 if (expr
->value
.function
.esym
)
3331 update_current_proc_array_outer_dependency (expr
->value
.function
.esym
);
3333 update_current_proc_array_outer_dependency (sym
);
3336 /* typebound procedure: Assume the worst. */
3337 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3343 /************* Subroutine resolution *************/
3346 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3353 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3357 else if (gfc_do_concurrent_flag
)
3359 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3363 else if (gfc_pure (NULL
))
3365 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3369 gfc_unset_implicit_pure (NULL
);
3375 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3379 if (sym
->attr
.generic
)
3381 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3384 c
->resolved_sym
= s
;
3385 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3390 /* TODO: Need to search for elemental references in generic interface. */
3393 if (sym
->attr
.intrinsic
)
3394 return gfc_intrinsic_sub_interface (c
, 0);
3401 resolve_generic_s (gfc_code
*c
)
3406 sym
= c
->symtree
->n
.sym
;
3410 m
= resolve_generic_s0 (c
, sym
);
3413 else if (m
== MATCH_ERROR
)
3417 if (sym
->ns
->parent
== NULL
)
3419 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3423 if (!generic_sym (sym
))
3427 /* Last ditch attempt. See if the reference is to an intrinsic
3428 that possesses a matching interface. 14.1.2.4 */
3429 sym
= c
->symtree
->n
.sym
;
3431 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3433 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3434 sym
->name
, &c
->loc
);
3438 m
= gfc_intrinsic_sub_interface (c
, 0);
3442 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3443 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3449 /* Resolve a subroutine call known to be specific. */
3452 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3456 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3458 if (sym
->attr
.dummy
)
3460 sym
->attr
.proc
= PROC_DUMMY
;
3464 sym
->attr
.proc
= PROC_EXTERNAL
;
3468 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3471 if (sym
->attr
.intrinsic
)
3473 m
= gfc_intrinsic_sub_interface (c
, 1);
3477 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3478 "with an intrinsic", sym
->name
, &c
->loc
);
3486 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3488 c
->resolved_sym
= sym
;
3489 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3497 resolve_specific_s (gfc_code
*c
)
3502 sym
= c
->symtree
->n
.sym
;
3506 m
= resolve_specific_s0 (c
, sym
);
3509 if (m
== MATCH_ERROR
)
3512 if (sym
->ns
->parent
== NULL
)
3515 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3521 sym
= c
->symtree
->n
.sym
;
3522 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3523 sym
->name
, &c
->loc
);
3529 /* Resolve a subroutine call not known to be generic nor specific. */
3532 resolve_unknown_s (gfc_code
*c
)
3536 sym
= c
->symtree
->n
.sym
;
3538 if (sym
->attr
.dummy
)
3540 sym
->attr
.proc
= PROC_DUMMY
;
3544 /* See if we have an intrinsic function reference. */
3546 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3548 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3553 /* The reference is to an external name. */
3556 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3558 c
->resolved_sym
= sym
;
3560 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3564 /* Resolve a subroutine call. Although it was tempting to use the same code
3565 for functions, subroutines and functions are stored differently and this
3566 makes things awkward. */
3569 resolve_call (gfc_code
*c
)
3572 procedure_type ptype
= PROC_INTRINSIC
;
3573 gfc_symbol
*csym
, *sym
;
3574 bool no_formal_args
;
3576 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3578 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3580 gfc_error ("%qs at %L has a type, which is not consistent with "
3581 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3585 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3588 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3589 sym
= st
? st
->n
.sym
: NULL
;
3590 if (sym
&& csym
!= sym
3591 && sym
->ns
== gfc_current_ns
3592 && sym
->attr
.flavor
== FL_PROCEDURE
3593 && sym
->attr
.contained
)
3596 if (csym
->attr
.generic
)
3597 c
->symtree
->n
.sym
= sym
;
3600 csym
= c
->symtree
->n
.sym
;
3604 /* If this ia a deferred TBP, c->expr1 will be set. */
3605 if (!c
->expr1
&& csym
)
3607 if (csym
->attr
.abstract
)
3609 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3610 csym
->name
, &c
->loc
);
3614 /* Subroutines without the RECURSIVE attribution are not allowed to
3616 if (is_illegal_recursion (csym
, gfc_current_ns
))
3618 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3619 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3620 "as subroutine %qs is not RECURSIVE",
3621 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3623 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3624 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3630 /* Switch off assumed size checking and do this again for certain kinds
3631 of procedure, once the procedure itself is resolved. */
3632 need_full_assumed_size
++;
3635 ptype
= csym
->attr
.proc
;
3637 no_formal_args
= csym
&& is_external_proc (csym
)
3638 && gfc_sym_get_dummy_args (csym
) == NULL
;
3639 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3642 /* Resume assumed_size checking. */
3643 need_full_assumed_size
--;
3645 /* If external, check for usage. */
3646 if (csym
&& is_external_proc (csym
))
3647 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3650 if (c
->resolved_sym
== NULL
)
3652 c
->resolved_isym
= NULL
;
3653 switch (procedure_kind (csym
))
3656 t
= resolve_generic_s (c
);
3659 case PTYPE_SPECIFIC
:
3660 t
= resolve_specific_s (c
);
3664 t
= resolve_unknown_s (c
);
3668 gfc_internal_error ("resolve_subroutine(): bad function type");
3672 /* Some checks of elemental subroutine actual arguments. */
3673 if (!resolve_elemental_actual (NULL
, c
))
3677 update_current_proc_array_outer_dependency (csym
);
3679 /* Typebound procedure: Assume the worst. */
3680 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
3686 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3687 op1->shape and op2->shape are non-NULL return true if their shapes
3688 match. If both op1->shape and op2->shape are non-NULL return false
3689 if their shapes do not match. If either op1->shape or op2->shape is
3690 NULL, return true. */
3693 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3700 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3702 for (i
= 0; i
< op1
->rank
; i
++)
3704 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3706 gfc_error ("Shapes for operands at %L and %L are not conformable",
3707 &op1
->where
, &op2
->where
);
3717 /* Convert a logical operator to the corresponding bitwise intrinsic call.
3718 For example A .AND. B becomes IAND(A, B). */
3720 logical_to_bitwise (gfc_expr
*e
)
3722 gfc_expr
*tmp
, *op1
, *op2
;
3724 gfc_actual_arglist
*args
= NULL
;
3726 gcc_assert (e
->expr_type
== EXPR_OP
);
3728 isym
= GFC_ISYM_NONE
;
3729 op1
= e
->value
.op
.op1
;
3730 op2
= e
->value
.op
.op2
;
3732 switch (e
->value
.op
.op
)
3735 isym
= GFC_ISYM_NOT
;
3738 isym
= GFC_ISYM_IAND
;
3741 isym
= GFC_ISYM_IOR
;
3743 case INTRINSIC_NEQV
:
3744 isym
= GFC_ISYM_IEOR
;
3747 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3748 Change the old expression to NEQV, which will get replaced by IEOR,
3749 and wrap it in NOT. */
3750 tmp
= gfc_copy_expr (e
);
3751 tmp
->value
.op
.op
= INTRINSIC_NEQV
;
3752 tmp
= logical_to_bitwise (tmp
);
3753 isym
= GFC_ISYM_NOT
;
3758 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3761 /* Inherit the original operation's operands as arguments. */
3762 args
= gfc_get_actual_arglist ();
3766 args
->next
= gfc_get_actual_arglist ();
3767 args
->next
->expr
= op2
;
3770 /* Convert the expression to a function call. */
3771 e
->expr_type
= EXPR_FUNCTION
;
3772 e
->value
.function
.actual
= args
;
3773 e
->value
.function
.isym
= gfc_intrinsic_function_by_id (isym
);
3774 e
->value
.function
.name
= e
->value
.function
.isym
->name
;
3775 e
->value
.function
.esym
= NULL
;
3777 /* Make up a pre-resolved function call symtree if we need to. */
3778 if (!e
->symtree
|| !e
->symtree
->n
.sym
)
3781 gfc_get_ha_sym_tree (e
->value
.function
.isym
->name
, &e
->symtree
);
3782 sym
= e
->symtree
->n
.sym
;
3784 sym
->attr
.flavor
= FL_PROCEDURE
;
3785 sym
->attr
.function
= 1;
3786 sym
->attr
.elemental
= 1;
3788 sym
->attr
.referenced
= 1;
3789 gfc_intrinsic_symbol (sym
);
3790 gfc_commit_symbol (sym
);
3793 args
->name
= e
->value
.function
.isym
->formal
->name
;
3794 if (e
->value
.function
.isym
->formal
->next
)
3795 args
->next
->name
= e
->value
.function
.isym
->formal
->next
->name
;
3800 /* Recursively append candidate UOP to CANDIDATES. Store the number of
3801 candidates in CANDIDATES_LEN. */
3803 lookup_uop_fuzzy_find_candidates (gfc_symtree
*uop
,
3805 size_t &candidates_len
)
3812 /* Not sure how to properly filter here. Use all for a start.
3813 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3814 these as i suppose they don't make terribly sense. */
3816 if (uop
->n
.uop
->op
!= NULL
)
3817 vec_push (candidates
, candidates_len
, uop
->name
);
3821 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3825 lookup_uop_fuzzy_find_candidates (p
, candidates
, candidates_len
);
3828 /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3831 lookup_uop_fuzzy (const char *op
, gfc_symtree
*uop
)
3833 char **candidates
= NULL
;
3834 size_t candidates_len
= 0;
3835 lookup_uop_fuzzy_find_candidates (uop
, candidates
, candidates_len
);
3836 return gfc_closest_fuzzy_match (op
, candidates
);
3840 /* Callback finding an impure function as an operand to an .and. or
3841 .or. expression. Remember the last function warned about to
3842 avoid double warnings when recursing. */
3845 impure_function_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3850 static gfc_expr
*last
= NULL
;
3851 bool *found
= (bool *) data
;
3853 if (f
->expr_type
== EXPR_FUNCTION
)
3856 if (f
!= last
&& !gfc_pure_function (f
, &name
)
3857 && !gfc_implicit_pure_function (f
))
3860 gfc_warning (OPT_Wfunction_elimination
,
3861 "Impure function %qs at %L might not be evaluated",
3864 gfc_warning (OPT_Wfunction_elimination
,
3865 "Impure function at %L might not be evaluated",
3875 /* Resolve an operator expression node. This can involve replacing the
3876 operation with a user defined function call. */
3879 resolve_operator (gfc_expr
*e
)
3881 gfc_expr
*op1
, *op2
;
3883 bool dual_locus_error
;
3886 /* Resolve all subnodes-- give them types. */
3888 switch (e
->value
.op
.op
)
3891 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3897 case INTRINSIC_UPLUS
:
3898 case INTRINSIC_UMINUS
:
3899 case INTRINSIC_PARENTHESES
:
3900 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3905 /* Typecheck the new node. */
3907 op1
= e
->value
.op
.op1
;
3908 op2
= e
->value
.op
.op2
;
3909 dual_locus_error
= false;
3911 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3912 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3914 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3918 switch (e
->value
.op
.op
)
3920 case INTRINSIC_UPLUS
:
3921 case INTRINSIC_UMINUS
:
3922 if (op1
->ts
.type
== BT_INTEGER
3923 || op1
->ts
.type
== BT_REAL
3924 || op1
->ts
.type
== BT_COMPLEX
)
3930 sprintf (msg
, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3931 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3934 case INTRINSIC_PLUS
:
3935 case INTRINSIC_MINUS
:
3936 case INTRINSIC_TIMES
:
3937 case INTRINSIC_DIVIDE
:
3938 case INTRINSIC_POWER
:
3939 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3941 gfc_type_convert_binary (e
, 1);
3945 if (op1
->ts
.type
== BT_DERIVED
|| op2
->ts
.type
== BT_DERIVED
)
3947 _("Unexpected derived-type entities in binary intrinsic "
3948 "numeric operator %%<%s%%> at %%L"),
3949 gfc_op2string (e
->value
.op
.op
));
3952 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3953 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3954 gfc_typename (&op2
->ts
));
3957 case INTRINSIC_CONCAT
:
3958 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3959 && op1
->ts
.kind
== op2
->ts
.kind
)
3961 e
->ts
.type
= BT_CHARACTER
;
3962 e
->ts
.kind
= op1
->ts
.kind
;
3967 _("Operands of string concatenation operator at %%L are %s/%s"),
3968 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3974 case INTRINSIC_NEQV
:
3975 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3977 e
->ts
.type
= BT_LOGICAL
;
3978 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3979 if (op1
->ts
.kind
< e
->ts
.kind
)
3980 gfc_convert_type (op1
, &e
->ts
, 2);
3981 else if (op2
->ts
.kind
< e
->ts
.kind
)
3982 gfc_convert_type (op2
, &e
->ts
, 2);
3984 if (flag_frontend_optimize
&&
3985 (e
->value
.op
.op
== INTRINSIC_AND
|| e
->value
.op
.op
== INTRINSIC_OR
))
3987 /* Warn about short-circuiting
3988 with impure function as second operand. */
3990 gfc_expr_walker (&op2
, impure_function_callback
, &op2_f
);
3995 /* Logical ops on integers become bitwise ops with -fdec. */
3997 && (op1
->ts
.type
== BT_INTEGER
|| op2
->ts
.type
== BT_INTEGER
))
3999 e
->ts
.type
= BT_INTEGER
;
4000 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
4001 if (op1
->ts
.type
!= e
->ts
.type
|| op1
->ts
.kind
!= e
->ts
.kind
)
4002 gfc_convert_type (op1
, &e
->ts
, 1);
4003 if (op2
->ts
.type
!= e
->ts
.type
|| op2
->ts
.kind
!= e
->ts
.kind
)
4004 gfc_convert_type (op2
, &e
->ts
, 1);
4005 e
= logical_to_bitwise (e
);
4009 sprintf (msg
, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4010 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4011 gfc_typename (&op2
->ts
));
4016 /* Logical ops on integers become bitwise ops with -fdec. */
4017 if (flag_dec
&& op1
->ts
.type
== BT_INTEGER
)
4019 e
->ts
.type
= BT_INTEGER
;
4020 e
->ts
.kind
= op1
->ts
.kind
;
4021 e
= logical_to_bitwise (e
);
4025 if (op1
->ts
.type
== BT_LOGICAL
)
4027 e
->ts
.type
= BT_LOGICAL
;
4028 e
->ts
.kind
= op1
->ts
.kind
;
4032 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4033 gfc_typename (&op1
->ts
));
4037 case INTRINSIC_GT_OS
:
4039 case INTRINSIC_GE_OS
:
4041 case INTRINSIC_LT_OS
:
4043 case INTRINSIC_LE_OS
:
4044 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4046 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4053 case INTRINSIC_EQ_OS
:
4055 case INTRINSIC_NE_OS
:
4056 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4057 && op1
->ts
.kind
== op2
->ts
.kind
)
4059 e
->ts
.type
= BT_LOGICAL
;
4060 e
->ts
.kind
= gfc_default_logical_kind
;
4064 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4066 gfc_type_convert_binary (e
, 1);
4068 e
->ts
.type
= BT_LOGICAL
;
4069 e
->ts
.kind
= gfc_default_logical_kind
;
4071 if (warn_compare_reals
)
4073 gfc_intrinsic_op op
= e
->value
.op
.op
;
4075 /* Type conversion has made sure that the types of op1 and op2
4076 agree, so it is only necessary to check the first one. */
4077 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4078 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4079 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4083 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4084 msg
= "Equality comparison for %s at %L";
4086 msg
= "Inequality comparison for %s at %L";
4088 gfc_warning (OPT_Wcompare_reals
, msg
,
4089 gfc_typename (&op1
->ts
), &op1
->where
);
4096 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4098 _("Logicals at %%L must be compared with %s instead of %s"),
4099 (e
->value
.op
.op
== INTRINSIC_EQ
4100 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4101 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4104 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4105 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4106 gfc_typename (&op2
->ts
));
4110 case INTRINSIC_USER
:
4111 if (e
->value
.op
.uop
->op
== NULL
)
4113 const char *name
= e
->value
.op
.uop
->name
;
4114 const char *guessed
;
4115 guessed
= lookup_uop_fuzzy (name
, e
->value
.op
.uop
->ns
->uop_root
);
4117 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4120 sprintf (msg
, _("Unknown operator %%<%s%%> at %%L"), name
);
4122 else if (op2
== NULL
)
4123 sprintf (msg
, _("Operand of user operator %%<%s%%> at %%L is %s"),
4124 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4127 sprintf (msg
, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4128 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4129 gfc_typename (&op2
->ts
));
4130 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4135 case INTRINSIC_PARENTHESES
:
4137 if (e
->ts
.type
== BT_CHARACTER
)
4138 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4142 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4145 /* Deal with arrayness of an operand through an operator. */
4147 switch (e
->value
.op
.op
)
4149 case INTRINSIC_PLUS
:
4150 case INTRINSIC_MINUS
:
4151 case INTRINSIC_TIMES
:
4152 case INTRINSIC_DIVIDE
:
4153 case INTRINSIC_POWER
:
4154 case INTRINSIC_CONCAT
:
4158 case INTRINSIC_NEQV
:
4160 case INTRINSIC_EQ_OS
:
4162 case INTRINSIC_NE_OS
:
4164 case INTRINSIC_GT_OS
:
4166 case INTRINSIC_GE_OS
:
4168 case INTRINSIC_LT_OS
:
4170 case INTRINSIC_LE_OS
:
4172 if (op1
->rank
== 0 && op2
->rank
== 0)
4175 if (op1
->rank
== 0 && op2
->rank
!= 0)
4177 e
->rank
= op2
->rank
;
4179 if (e
->shape
== NULL
)
4180 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4183 if (op1
->rank
!= 0 && op2
->rank
== 0)
4185 e
->rank
= op1
->rank
;
4187 if (e
->shape
== NULL
)
4188 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4191 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4193 if (op1
->rank
== op2
->rank
)
4195 e
->rank
= op1
->rank
;
4196 if (e
->shape
== NULL
)
4198 t
= compare_shapes (op1
, op2
);
4202 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4207 /* Allow higher level expressions to work. */
4210 /* Try user-defined operators, and otherwise throw an error. */
4211 dual_locus_error
= true;
4213 _("Inconsistent ranks for operator at %%L and %%L"));
4220 case INTRINSIC_PARENTHESES
:
4222 case INTRINSIC_UPLUS
:
4223 case INTRINSIC_UMINUS
:
4224 /* Simply copy arrayness attribute */
4225 e
->rank
= op1
->rank
;
4227 if (e
->shape
== NULL
)
4228 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4238 /* Attempt to simplify the expression. */
4241 t
= gfc_simplify_expr (e
, 0);
4242 /* Some calls do not succeed in simplification and return false
4243 even though there is no error; e.g. variable references to
4244 PARAMETER arrays. */
4245 if (!gfc_is_constant_expr (e
))
4253 match m
= gfc_extend_expr (e
);
4256 if (m
== MATCH_ERROR
)
4260 if (dual_locus_error
)
4261 gfc_error (msg
, &op1
->where
, &op2
->where
);
4263 gfc_error (msg
, &e
->where
);
4269 /************** Array resolution subroutines **************/
4272 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
};
4274 /* Compare two integer expressions. */
4276 static compare_result
4277 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4281 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4282 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4285 /* If either of the types isn't INTEGER, we must have
4286 raised an error earlier. */
4288 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4291 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4301 /* Compare an integer expression with an integer. */
4303 static compare_result
4304 compare_bound_int (gfc_expr
*a
, int b
)
4308 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4311 if (a
->ts
.type
!= BT_INTEGER
)
4312 gfc_internal_error ("compare_bound_int(): Bad expression");
4314 i
= mpz_cmp_si (a
->value
.integer
, b
);
4324 /* Compare an integer expression with a mpz_t. */
4326 static compare_result
4327 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4331 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4334 if (a
->ts
.type
!= BT_INTEGER
)
4335 gfc_internal_error ("compare_bound_int(): Bad expression");
4337 i
= mpz_cmp (a
->value
.integer
, b
);
4347 /* Compute the last value of a sequence given by a triplet.
4348 Return 0 if it wasn't able to compute the last value, or if the
4349 sequence if empty, and 1 otherwise. */
4352 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4353 gfc_expr
*stride
, mpz_t last
)
4357 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4358 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4359 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4362 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4363 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4366 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
4368 if (compare_bound (start
, end
) == CMP_GT
)
4370 mpz_set (last
, end
->value
.integer
);
4374 if (compare_bound_int (stride
, 0) == CMP_GT
)
4376 /* Stride is positive */
4377 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4382 /* Stride is negative */
4383 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4388 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4389 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4390 mpz_sub (last
, end
->value
.integer
, rem
);
4397 /* Compare a single dimension of an array reference to the array
4401 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4405 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4407 gcc_assert (ar
->stride
[i
] == NULL
);
4408 /* This implies [*] as [*:] and [*:3] are not possible. */
4409 if (ar
->start
[i
] == NULL
)
4411 gcc_assert (ar
->end
[i
] == NULL
);
4416 /* Given start, end and stride values, calculate the minimum and
4417 maximum referenced indexes. */
4419 switch (ar
->dimen_type
[i
])
4422 case DIMEN_THIS_IMAGE
:
4427 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4430 gfc_warning (0, "Array reference at %L is out of bounds "
4431 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4432 mpz_get_si (ar
->start
[i
]->value
.integer
),
4433 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4435 gfc_warning (0, "Array reference at %L is out of bounds "
4436 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4437 mpz_get_si (ar
->start
[i
]->value
.integer
),
4438 mpz_get_si (as
->lower
[i
]->value
.integer
),
4442 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4445 gfc_warning (0, "Array reference at %L is out of bounds "
4446 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4447 mpz_get_si (ar
->start
[i
]->value
.integer
),
4448 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4450 gfc_warning (0, "Array reference at %L is out of bounds "
4451 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4452 mpz_get_si (ar
->start
[i
]->value
.integer
),
4453 mpz_get_si (as
->upper
[i
]->value
.integer
),
4462 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4463 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4465 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4467 /* Check for zero stride, which is not allowed. */
4468 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4470 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4474 /* if start == len || (stride > 0 && start < len)
4475 || (stride < 0 && start > len),
4476 then the array section contains at least one element. In this
4477 case, there is an out-of-bounds access if
4478 (start < lower || start > upper). */
4479 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4480 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4481 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4482 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4483 && comp_start_end
== CMP_GT
))
4485 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4487 gfc_warning (0, "Lower array reference at %L is out of bounds "
4488 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4489 mpz_get_si (AR_START
->value
.integer
),
4490 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4493 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4495 gfc_warning (0, "Lower array reference at %L is out of bounds "
4496 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4497 mpz_get_si (AR_START
->value
.integer
),
4498 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4503 /* If we can compute the highest index of the array section,
4504 then it also has to be between lower and upper. */
4505 mpz_init (last_value
);
4506 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4509 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4511 gfc_warning (0, "Upper array reference at %L is out of bounds "
4512 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4513 mpz_get_si (last_value
),
4514 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4515 mpz_clear (last_value
);
4518 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4520 gfc_warning (0, "Upper array reference at %L is out of bounds "
4521 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4522 mpz_get_si (last_value
),
4523 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4524 mpz_clear (last_value
);
4528 mpz_clear (last_value
);
4536 gfc_internal_error ("check_dimension(): Bad array reference");
4543 /* Compare an array reference with an array specification. */
4546 compare_spec_to_ref (gfc_array_ref
*ar
)
4553 /* TODO: Full array sections are only allowed as actual parameters. */
4554 if (as
->type
== AS_ASSUMED_SIZE
4555 && (/*ar->type == AR_FULL
4556 ||*/ (ar
->type
== AR_SECTION
4557 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4559 gfc_error ("Rightmost upper bound of assumed size array section "
4560 "not specified at %L", &ar
->where
);
4564 if (ar
->type
== AR_FULL
)
4567 if (as
->rank
!= ar
->dimen
)
4569 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4570 &ar
->where
, ar
->dimen
, as
->rank
);
4574 /* ar->codimen == 0 is a local array. */
4575 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4577 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4578 &ar
->where
, ar
->codimen
, as
->corank
);
4582 for (i
= 0; i
< as
->rank
; i
++)
4583 if (!check_dimension (i
, ar
, as
))
4586 /* Local access has no coarray spec. */
4587 if (ar
->codimen
!= 0)
4588 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4590 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4591 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4593 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4594 i
+ 1 - as
->rank
, &ar
->where
);
4597 if (!check_dimension (i
, ar
, as
))
4605 /* Resolve one part of an array index. */
4608 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4609 int force_index_integer_kind
)
4616 if (!gfc_resolve_expr (index
))
4619 if (check_scalar
&& index
->rank
!= 0)
4621 gfc_error ("Array index at %L must be scalar", &index
->where
);
4625 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4627 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4628 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4632 if (index
->ts
.type
== BT_REAL
)
4633 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4637 if ((index
->ts
.kind
!= gfc_index_integer_kind
4638 && force_index_integer_kind
)
4639 || index
->ts
.type
!= BT_INTEGER
)
4642 ts
.type
= BT_INTEGER
;
4643 ts
.kind
= gfc_index_integer_kind
;
4645 gfc_convert_type_warn (index
, &ts
, 2, 0);
4651 /* Resolve one part of an array index. */
4654 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4656 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4659 /* Resolve a dim argument to an intrinsic function. */
4662 gfc_resolve_dim_arg (gfc_expr
*dim
)
4667 if (!gfc_resolve_expr (dim
))
4672 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4677 if (dim
->ts
.type
!= BT_INTEGER
)
4679 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4683 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4688 ts
.type
= BT_INTEGER
;
4689 ts
.kind
= gfc_index_integer_kind
;
4691 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4697 /* Given an expression that contains array references, update those array
4698 references to point to the right array specifications. While this is
4699 filled in during matching, this information is difficult to save and load
4700 in a module, so we take care of it here.
4702 The idea here is that the original array reference comes from the
4703 base symbol. We traverse the list of reference structures, setting
4704 the stored reference to references. Component references can
4705 provide an additional array specification. */
4708 find_array_spec (gfc_expr
*e
)
4714 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4715 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4717 as
= e
->symtree
->n
.sym
->as
;
4719 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4724 gfc_internal_error ("find_array_spec(): Missing spec");
4731 c
= ref
->u
.c
.component
;
4732 if (c
->attr
.dimension
)
4735 gfc_internal_error ("find_array_spec(): unused as(1)");
4747 gfc_internal_error ("find_array_spec(): unused as(2)");
4751 /* Resolve an array reference. */
4754 resolve_array_ref (gfc_array_ref
*ar
)
4756 int i
, check_scalar
;
4759 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4761 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4763 /* Do not force gfc_index_integer_kind for the start. We can
4764 do fine with any integer kind. This avoids temporary arrays
4765 created for indexing with a vector. */
4766 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4768 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4770 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4775 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4779 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4783 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4784 if (e
->expr_type
== EXPR_VARIABLE
4785 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4786 ar
->start
[i
] = gfc_get_parentheses (e
);
4790 gfc_error ("Array index at %L is an array of rank %d",
4791 &ar
->c_where
[i
], e
->rank
);
4795 /* Fill in the upper bound, which may be lower than the
4796 specified one for something like a(2:10:5), which is
4797 identical to a(2:7:5). Only relevant for strides not equal
4798 to one. Don't try a division by zero. */
4799 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4800 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4801 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4802 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4806 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4808 if (ar
->end
[i
] == NULL
)
4811 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4813 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4815 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4816 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4818 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4829 if (ar
->type
== AR_FULL
)
4831 if (ar
->as
->rank
== 0)
4832 ar
->type
= AR_ELEMENT
;
4834 /* Make sure array is the same as array(:,:), this way
4835 we don't need to special case all the time. */
4836 ar
->dimen
= ar
->as
->rank
;
4837 for (i
= 0; i
< ar
->dimen
; i
++)
4839 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4841 gcc_assert (ar
->start
[i
] == NULL
);
4842 gcc_assert (ar
->end
[i
] == NULL
);
4843 gcc_assert (ar
->stride
[i
] == NULL
);
4847 /* If the reference type is unknown, figure out what kind it is. */
4849 if (ar
->type
== AR_UNKNOWN
)
4851 ar
->type
= AR_ELEMENT
;
4852 for (i
= 0; i
< ar
->dimen
; i
++)
4853 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4854 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4856 ar
->type
= AR_SECTION
;
4861 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4864 if (ar
->as
->corank
&& ar
->codimen
== 0)
4867 ar
->codimen
= ar
->as
->corank
;
4868 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4869 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4877 resolve_substring (gfc_ref
*ref
, bool *equal_length
)
4879 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4881 if (ref
->u
.ss
.start
!= NULL
)
4883 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4886 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4888 gfc_error ("Substring start index at %L must be of type INTEGER",
4889 &ref
->u
.ss
.start
->where
);
4893 if (ref
->u
.ss
.start
->rank
!= 0)
4895 gfc_error ("Substring start index at %L must be scalar",
4896 &ref
->u
.ss
.start
->where
);
4900 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4901 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4902 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4904 gfc_error ("Substring start index at %L is less than one",
4905 &ref
->u
.ss
.start
->where
);
4910 if (ref
->u
.ss
.end
!= NULL
)
4912 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4915 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4917 gfc_error ("Substring end index at %L must be of type INTEGER",
4918 &ref
->u
.ss
.end
->where
);
4922 if (ref
->u
.ss
.end
->rank
!= 0)
4924 gfc_error ("Substring end index at %L must be scalar",
4925 &ref
->u
.ss
.end
->where
);
4929 if (ref
->u
.ss
.length
!= NULL
4930 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4931 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4932 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4934 gfc_error ("Substring end index at %L exceeds the string length",
4935 &ref
->u
.ss
.start
->where
);
4939 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4940 gfc_integer_kinds
[k
].huge
) == CMP_GT
4941 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4942 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4944 gfc_error ("Substring end index at %L is too large",
4945 &ref
->u
.ss
.end
->where
);
4948 /* If the substring has the same length as the original
4949 variable, the reference itself can be deleted. */
4951 if (ref
->u
.ss
.length
!= NULL
4952 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_EQ
4953 && compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_EQ
)
4954 *equal_length
= true;
4961 /* This function supplies missing substring charlens. */
4964 gfc_resolve_substring_charlen (gfc_expr
*e
)
4967 gfc_expr
*start
, *end
;
4968 gfc_typespec
*ts
= NULL
;
4971 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4973 if (char_ref
->type
== REF_SUBSTRING
|| char_ref
->type
== REF_INQUIRY
)
4975 if (char_ref
->type
== REF_COMPONENT
)
4976 ts
= &char_ref
->u
.c
.component
->ts
;
4979 if (!char_ref
|| char_ref
->type
== REF_INQUIRY
)
4982 gcc_assert (char_ref
->next
== NULL
);
4986 if (e
->ts
.u
.cl
->length
)
4987 gfc_free_expr (e
->ts
.u
.cl
->length
);
4988 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.dummy
)
4992 e
->ts
.type
= BT_CHARACTER
;
4993 e
->ts
.kind
= gfc_default_character_kind
;
4996 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4998 if (char_ref
->u
.ss
.start
)
4999 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
5001 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
5003 if (char_ref
->u
.ss
.end
)
5004 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
5005 else if (e
->expr_type
== EXPR_VARIABLE
)
5008 ts
= &e
->symtree
->n
.sym
->ts
;
5009 end
= gfc_copy_expr (ts
->u
.cl
->length
);
5016 gfc_free_expr (start
);
5017 gfc_free_expr (end
);
5021 /* Length = (end - start + 1).
5022 Check first whether it has a constant length. */
5023 if (gfc_dep_difference (end
, start
, &diff
))
5025 gfc_expr
*len
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
5028 mpz_add_ui (len
->value
.integer
, diff
, 1);
5030 e
->ts
.u
.cl
->length
= len
;
5031 /* The check for length < 0 is handled below */
5035 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
5036 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
5037 gfc_get_int_expr (gfc_charlen_int_kind
,
5041 /* F2008, 6.4.1: Both the starting point and the ending point shall
5042 be within the range 1, 2, ..., n unless the starting point exceeds
5043 the ending point, in which case the substring has length zero. */
5045 if (mpz_cmp_si (e
->ts
.u
.cl
->length
->value
.integer
, 0) < 0)
5046 mpz_set_si (e
->ts
.u
.cl
->length
->value
.integer
, 0);
5048 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5049 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5051 /* Make sure that the length is simplified. */
5052 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
5053 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5057 /* Resolve subtype references. */
5060 resolve_ref (gfc_expr
*expr
)
5062 int current_part_dimension
, n_components
, seen_part_dimension
;
5063 gfc_ref
*ref
, **prev
;
5066 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5067 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5069 find_array_spec (expr
);
5073 for (prev
= &expr
->ref
; *prev
!= NULL
;
5074 prev
= *prev
== NULL
? prev
: &(*prev
)->next
)
5075 switch ((*prev
)->type
)
5078 if (!resolve_array_ref (&(*prev
)->u
.ar
))
5087 equal_length
= false;
5088 if (!resolve_substring (*prev
, &equal_length
))
5091 if (expr
->expr_type
!= EXPR_SUBSTRING
&& equal_length
)
5093 /* Remove the reference and move the charlen, if any. */
5097 expr
->ts
.u
.cl
= ref
->u
.ss
.length
;
5098 ref
->u
.ss
.length
= NULL
;
5099 gfc_free_ref_list (ref
);
5104 /* Check constraints on part references. */
5106 current_part_dimension
= 0;
5107 seen_part_dimension
= 0;
5110 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5115 switch (ref
->u
.ar
.type
)
5118 /* Coarray scalar. */
5119 if (ref
->u
.ar
.as
->rank
== 0)
5121 current_part_dimension
= 0;
5126 current_part_dimension
= 1;
5130 current_part_dimension
= 0;
5134 gfc_internal_error ("resolve_ref(): Bad array reference");
5140 if (current_part_dimension
|| seen_part_dimension
)
5143 if (ref
->u
.c
.component
->attr
.pointer
5144 || ref
->u
.c
.component
->attr
.proc_pointer
5145 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5146 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5148 gfc_error ("Component to the right of a part reference "
5149 "with nonzero rank must not have the POINTER "
5150 "attribute at %L", &expr
->where
);
5153 else if (ref
->u
.c
.component
->attr
.allocatable
5154 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5155 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5158 gfc_error ("Component to the right of a part reference "
5159 "with nonzero rank must not have the ALLOCATABLE "
5160 "attribute at %L", &expr
->where
);
5173 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5174 || ref
->next
== NULL
)
5175 && current_part_dimension
5176 && seen_part_dimension
)
5178 gfc_error ("Two or more part references with nonzero rank must "
5179 "not be specified at %L", &expr
->where
);
5183 if (ref
->type
== REF_COMPONENT
)
5185 if (current_part_dimension
)
5186 seen_part_dimension
= 1;
5188 /* reset to make sure */
5189 current_part_dimension
= 0;
5197 /* Given an expression, determine its shape. This is easier than it sounds.
5198 Leaves the shape array NULL if it is not possible to determine the shape. */
5201 expression_shape (gfc_expr
*e
)
5203 mpz_t array
[GFC_MAX_DIMENSIONS
];
5206 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5209 for (i
= 0; i
< e
->rank
; i
++)
5210 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
5213 e
->shape
= gfc_get_shape (e
->rank
);
5215 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5220 for (i
--; i
>= 0; i
--)
5221 mpz_clear (array
[i
]);
5225 /* Given a variable expression node, compute the rank of the expression by
5226 examining the base symbol and any reference structures it may have. */
5229 expression_rank (gfc_expr
*e
)
5234 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5235 could lead to serious confusion... */
5236 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5240 if (e
->expr_type
== EXPR_ARRAY
)
5242 /* Constructors can have a rank different from one via RESHAPE(). */
5244 if (e
->symtree
== NULL
)
5250 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5251 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5257 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5259 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5260 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5261 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5263 if (ref
->type
!= REF_ARRAY
)
5266 if (ref
->u
.ar
.type
== AR_FULL
)
5268 rank
= ref
->u
.ar
.as
->rank
;
5272 if (ref
->u
.ar
.type
== AR_SECTION
)
5274 /* Figure out the rank of the section. */
5276 gfc_internal_error ("expression_rank(): Two array specs");
5278 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5279 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5280 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5290 expression_shape (e
);
5295 add_caf_get_intrinsic (gfc_expr
*e
)
5297 gfc_expr
*wrapper
, *tmp_expr
;
5301 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5302 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5307 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5308 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
5311 tmp_expr
= XCNEW (gfc_expr
);
5313 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
5314 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
5315 wrapper
->ts
= e
->ts
;
5316 wrapper
->rank
= e
->rank
;
5318 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
5325 remove_caf_get_intrinsic (gfc_expr
*e
)
5327 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
5328 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
5329 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
5330 e
->value
.function
.actual
->expr
= NULL
;
5331 gfc_free_actual_arglist (e
->value
.function
.actual
);
5332 gfc_free_shape (&e
->shape
, e
->rank
);
5338 /* Resolve a variable expression. */
5341 resolve_variable (gfc_expr
*e
)
5348 if (e
->symtree
== NULL
)
5350 sym
= e
->symtree
->n
.sym
;
5352 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5353 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5354 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
5356 if (!actual_arg
|| inquiry_argument
)
5358 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5359 "be used as actual argument", sym
->name
, &e
->where
);
5363 /* TS 29113, 407b. */
5364 else if (e
->ts
.type
== BT_ASSUMED
)
5368 gfc_error ("Assumed-type variable %s at %L may only be used "
5369 "as actual argument", sym
->name
, &e
->where
);
5372 else if (inquiry_argument
&& !first_actual_arg
)
5374 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5375 for all inquiry functions in resolve_function; the reason is
5376 that the function-name resolution happens too late in that
5378 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5379 "an inquiry function shall be the first argument",
5380 sym
->name
, &e
->where
);
5384 /* TS 29113, C535b. */
5385 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5386 && CLASS_DATA (sym
)->as
5387 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5388 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5389 && sym
->as
->type
== AS_ASSUMED_RANK
))
5393 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5394 "actual argument", sym
->name
, &e
->where
);
5397 else if (inquiry_argument
&& !first_actual_arg
)
5399 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5400 for all inquiry functions in resolve_function; the reason is
5401 that the function-name resolution happens too late in that
5403 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5404 "to an inquiry function shall be the first argument",
5405 sym
->name
, &e
->where
);
5410 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
5411 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5412 && e
->ref
->next
== NULL
))
5414 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5415 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5418 /* TS 29113, 407b. */
5419 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5420 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5421 && e
->ref
->next
== NULL
))
5423 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5424 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5428 /* TS 29113, C535b. */
5429 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5430 && CLASS_DATA (sym
)->as
5431 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5432 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5433 && sym
->as
->type
== AS_ASSUMED_RANK
))
5435 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5436 && e
->ref
->next
== NULL
))
5438 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5439 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5443 /* For variables that are used in an associate (target => object) where
5444 the object's basetype is array valued while the target is scalar,
5445 the ts' type of the component refs is still array valued, which
5446 can't be translated that way. */
5447 if (sym
->assoc
&& e
->rank
== 0 && e
->ref
&& sym
->ts
.type
== BT_CLASS
5448 && sym
->assoc
->target
&& sym
->assoc
->target
->ts
.type
== BT_CLASS
5449 && CLASS_DATA (sym
->assoc
->target
)->as
)
5451 gfc_ref
*ref
= e
->ref
;
5457 ref
->u
.c
.sym
= sym
->ts
.u
.derived
;
5458 /* Stop the loop. */
5468 /* If this is an associate-name, it may be parsed with an array reference
5469 in error even though the target is scalar. Fail directly in this case.
5470 TODO Understand why class scalar expressions must be excluded. */
5471 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5473 if (sym
->ts
.type
== BT_CLASS
)
5474 gfc_fix_class_refs (e
);
5475 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5477 else if (sym
->attr
.dimension
&& (!e
->ref
|| e
->ref
->type
!= REF_ARRAY
))
5479 /* This can happen because the parser did not detect that the
5480 associate name is an array and the expression had no array
5482 gfc_ref
*ref
= gfc_get_ref ();
5483 ref
->type
= REF_ARRAY
;
5484 ref
->u
.ar
= *gfc_get_array_ref();
5485 ref
->u
.ar
.type
= AR_FULL
;
5488 ref
->u
.ar
.as
= sym
->as
;
5489 ref
->u
.ar
.dimen
= sym
->as
->rank
;
5497 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5498 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5500 /* On the other hand, the parser may not have known this is an array;
5501 in this case, we have to add a FULL reference. */
5502 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5504 e
->ref
= gfc_get_ref ();
5505 e
->ref
->type
= REF_ARRAY
;
5506 e
->ref
->u
.ar
.type
= AR_FULL
;
5507 e
->ref
->u
.ar
.dimen
= 0;
5510 /* Like above, but for class types, where the checking whether an array
5511 ref is present is more complicated. Furthermore make sure not to add
5512 the full array ref to _vptr or _len refs. */
5513 if (sym
->assoc
&& sym
->ts
.type
== BT_CLASS
5514 && CLASS_DATA (sym
)->attr
.dimension
5515 && (e
->ts
.type
!= BT_DERIVED
|| !e
->ts
.u
.derived
->attr
.vtype
))
5517 gfc_ref
*ref
, *newref
;
5519 newref
= gfc_get_ref ();
5520 newref
->type
= REF_ARRAY
;
5521 newref
->u
.ar
.type
= AR_FULL
;
5522 newref
->u
.ar
.dimen
= 0;
5523 /* Because this is an associate var and the first ref either is a ref to
5524 the _data component or not, no traversal of the ref chain is
5525 needed. The array ref needs to be inserted after the _data ref,
5526 or when that is not present, which may happend for polymorphic
5527 types, then at the first position. */
5531 else if (ref
->type
== REF_COMPONENT
5532 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
5534 if (!ref
->next
|| ref
->next
->type
!= REF_ARRAY
)
5536 newref
->next
= ref
->next
;
5540 /* Array ref present already. */
5541 gfc_free_ref_list (newref
);
5543 else if (ref
->type
== REF_ARRAY
)
5544 /* Array ref present already. */
5545 gfc_free_ref_list (newref
);
5553 if (e
->ref
&& !resolve_ref (e
))
5556 if (sym
->attr
.flavor
== FL_PROCEDURE
5557 && (!sym
->attr
.function
5558 || (sym
->attr
.function
&& sym
->result
5559 && sym
->result
->attr
.proc_pointer
5560 && !sym
->result
->attr
.function
)))
5562 e
->ts
.type
= BT_PROCEDURE
;
5563 goto resolve_procedure
;
5566 if (sym
->ts
.type
!= BT_UNKNOWN
)
5567 gfc_variable_attr (e
, &e
->ts
);
5568 else if (sym
->attr
.flavor
== FL_PROCEDURE
5569 && sym
->attr
.function
&& sym
->result
5570 && sym
->result
->ts
.type
!= BT_UNKNOWN
5571 && sym
->result
->attr
.proc_pointer
)
5572 e
->ts
= sym
->result
->ts
;
5575 /* Must be a simple variable reference. */
5576 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
5581 if (check_assumed_size_reference (sym
, e
))
5584 /* Deal with forward references to entries during gfc_resolve_code, to
5585 satisfy, at least partially, 12.5.2.5. */
5586 if (gfc_current_ns
->entries
5587 && current_entry_id
== sym
->entry_id
5590 && cs_base
->current
->op
!= EXEC_ENTRY
)
5592 gfc_entry_list
*entry
;
5593 gfc_formal_arglist
*formal
;
5595 bool seen
, saved_specification_expr
;
5597 /* If the symbol is a dummy... */
5598 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5600 entry
= gfc_current_ns
->entries
;
5603 /* ...test if the symbol is a parameter of previous entries. */
5604 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5605 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5607 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5614 /* If it has not been seen as a dummy, this is an error. */
5617 if (specification_expr
)
5618 gfc_error ("Variable %qs, used in a specification expression"
5619 ", is referenced at %L before the ENTRY statement "
5620 "in which it is a parameter",
5621 sym
->name
, &cs_base
->current
->loc
);
5623 gfc_error ("Variable %qs is used at %L before the ENTRY "
5624 "statement in which it is a parameter",
5625 sym
->name
, &cs_base
->current
->loc
);
5630 /* Now do the same check on the specification expressions. */
5631 saved_specification_expr
= specification_expr
;
5632 specification_expr
= true;
5633 if (sym
->ts
.type
== BT_CHARACTER
5634 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5638 for (n
= 0; n
< sym
->as
->rank
; n
++)
5640 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5642 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5645 specification_expr
= saved_specification_expr
;
5648 /* Update the symbol's entry level. */
5649 sym
->entry_id
= current_entry_id
+ 1;
5652 /* If a symbol has been host_associated mark it. This is used latter,
5653 to identify if aliasing is possible via host association. */
5654 if (sym
->attr
.flavor
== FL_VARIABLE
5655 && gfc_current_ns
->parent
5656 && (gfc_current_ns
->parent
== sym
->ns
5657 || (gfc_current_ns
->parent
->parent
5658 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5659 sym
->attr
.host_assoc
= 1;
5661 if (gfc_current_ns
->proc_name
5662 && sym
->attr
.dimension
5663 && (sym
->ns
!= gfc_current_ns
5664 || sym
->attr
.use_assoc
5665 || sym
->attr
.in_common
))
5666 gfc_current_ns
->proc_name
->attr
.array_outer_dependency
= 1;
5669 if (t
&& !resolve_procedure_expression (e
))
5672 /* F2008, C617 and C1229. */
5673 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5674 && gfc_is_coindexed (e
))
5676 gfc_ref
*ref
, *ref2
= NULL
;
5678 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5680 if (ref
->type
== REF_COMPONENT
)
5682 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5686 for ( ; ref
; ref
= ref
->next
)
5687 if (ref
->type
== REF_COMPONENT
)
5690 /* Expression itself is not coindexed object. */
5691 if (ref
&& e
->ts
.type
== BT_CLASS
)
5693 gfc_error ("Polymorphic subobject of coindexed object at %L",
5698 /* Expression itself is coindexed object. */
5702 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5703 for ( ; c
; c
= c
->next
)
5704 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5706 gfc_error ("Coindexed object with polymorphic allocatable "
5707 "subcomponent at %L", &e
->where
);
5715 expression_rank (e
);
5717 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5718 add_caf_get_intrinsic (e
);
5720 /* Simplify cases where access to a parameter array results in a
5721 single constant. Suppress errors since those will have been
5722 issued before, as warnings. */
5723 if (e
->rank
== 0 && sym
->as
&& sym
->attr
.flavor
== FL_PARAMETER
)
5725 gfc_push_suppress_errors ();
5726 gfc_simplify_expr (e
, 1);
5727 gfc_pop_suppress_errors ();
5734 /* Checks to see that the correct symbol has been host associated.
5735 The only situation where this arises is that in which a twice
5736 contained function is parsed after the host association is made.
5737 Therefore, on detecting this, change the symbol in the expression
5738 and convert the array reference into an actual arglist if the old
5739 symbol is a variable. */
5741 check_host_association (gfc_expr
*e
)
5743 gfc_symbol
*sym
, *old_sym
;
5747 gfc_actual_arglist
*arg
, *tail
= NULL
;
5748 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5750 /* If the expression is the result of substitution in
5751 interface.c(gfc_extend_expr) because there is no way in
5752 which the host association can be wrong. */
5753 if (e
->symtree
== NULL
5754 || e
->symtree
->n
.sym
== NULL
5755 || e
->user_operator
)
5758 old_sym
= e
->symtree
->n
.sym
;
5760 if (gfc_current_ns
->parent
5761 && old_sym
->ns
!= gfc_current_ns
)
5763 /* Use the 'USE' name so that renamed module symbols are
5764 correctly handled. */
5765 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5767 if (sym
&& old_sym
!= sym
5768 && sym
->ts
.type
== old_sym
->ts
.type
5769 && sym
->attr
.flavor
== FL_PROCEDURE
5770 && sym
->attr
.contained
)
5772 /* Clear the shape, since it might not be valid. */
5773 gfc_free_shape (&e
->shape
, e
->rank
);
5775 /* Give the expression the right symtree! */
5776 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5777 gcc_assert (st
!= NULL
);
5779 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5780 || e
->expr_type
== EXPR_FUNCTION
)
5782 /* Original was function so point to the new symbol, since
5783 the actual argument list is already attached to the
5785 e
->value
.function
.esym
= NULL
;
5790 /* Original was variable so convert array references into
5791 an actual arglist. This does not need any checking now
5792 since resolve_function will take care of it. */
5793 e
->value
.function
.actual
= NULL
;
5794 e
->expr_type
= EXPR_FUNCTION
;
5797 /* Ambiguity will not arise if the array reference is not
5798 the last reference. */
5799 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5800 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5803 gcc_assert (ref
->type
== REF_ARRAY
);
5805 /* Grab the start expressions from the array ref and
5806 copy them into actual arguments. */
5807 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5809 arg
= gfc_get_actual_arglist ();
5810 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5811 if (e
->value
.function
.actual
== NULL
)
5812 tail
= e
->value
.function
.actual
= arg
;
5820 /* Dump the reference list and set the rank. */
5821 gfc_free_ref_list (e
->ref
);
5823 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5826 gfc_resolve_expr (e
);
5830 /* This might have changed! */
5831 return e
->expr_type
== EXPR_FUNCTION
;
5836 gfc_resolve_character_operator (gfc_expr
*e
)
5838 gfc_expr
*op1
= e
->value
.op
.op1
;
5839 gfc_expr
*op2
= e
->value
.op
.op2
;
5840 gfc_expr
*e1
= NULL
;
5841 gfc_expr
*e2
= NULL
;
5843 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5845 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5846 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5847 else if (op1
->expr_type
== EXPR_CONSTANT
)
5848 e1
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5849 op1
->value
.character
.length
);
5851 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5852 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5853 else if (op2
->expr_type
== EXPR_CONSTANT
)
5854 e2
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
5855 op2
->value
.character
.length
);
5857 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5867 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5868 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5869 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5870 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5871 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5877 /* Ensure that an character expression has a charlen and, if possible, a
5878 length expression. */
5881 fixup_charlen (gfc_expr
*e
)
5883 /* The cases fall through so that changes in expression type and the need
5884 for multiple fixes are picked up. In all circumstances, a charlen should
5885 be available for the middle end to hang a backend_decl on. */
5886 switch (e
->expr_type
)
5889 gfc_resolve_character_operator (e
);
5893 if (e
->expr_type
== EXPR_ARRAY
)
5894 gfc_resolve_character_array_constructor (e
);
5897 case EXPR_SUBSTRING
:
5898 if (!e
->ts
.u
.cl
&& e
->ref
)
5899 gfc_resolve_substring_charlen (e
);
5904 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5911 /* Update an actual argument to include the passed-object for type-bound
5912 procedures at the right position. */
5914 static gfc_actual_arglist
*
5915 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5918 gcc_assert (argpos
> 0);
5922 gfc_actual_arglist
* result
;
5924 result
= gfc_get_actual_arglist ();
5928 result
->name
= name
;
5934 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5936 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5941 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5944 extract_compcall_passed_object (gfc_expr
* e
)
5948 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5950 if (e
->value
.compcall
.base_object
)
5951 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5954 po
= gfc_get_expr ();
5955 po
->expr_type
= EXPR_VARIABLE
;
5956 po
->symtree
= e
->symtree
;
5957 po
->ref
= gfc_copy_ref (e
->ref
);
5958 po
->where
= e
->where
;
5961 if (!gfc_resolve_expr (po
))
5968 /* Update the arglist of an EXPR_COMPCALL expression to include the
5972 update_compcall_arglist (gfc_expr
* e
)
5975 gfc_typebound_proc
* tbp
;
5977 tbp
= e
->value
.compcall
.tbp
;
5982 po
= extract_compcall_passed_object (e
);
5986 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5992 if (tbp
->pass_arg_num
<= 0)
5995 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6003 /* Extract the passed object from a PPC call (a copy of it). */
6006 extract_ppc_passed_object (gfc_expr
*e
)
6011 po
= gfc_get_expr ();
6012 po
->expr_type
= EXPR_VARIABLE
;
6013 po
->symtree
= e
->symtree
;
6014 po
->ref
= gfc_copy_ref (e
->ref
);
6015 po
->where
= e
->where
;
6017 /* Remove PPC reference. */
6019 while ((*ref
)->next
)
6020 ref
= &(*ref
)->next
;
6021 gfc_free_ref_list (*ref
);
6024 if (!gfc_resolve_expr (po
))
6031 /* Update the actual arglist of a procedure pointer component to include the
6035 update_ppc_arglist (gfc_expr
* e
)
6039 gfc_typebound_proc
* tb
;
6041 ppc
= gfc_get_proc_ptr_comp (e
);
6049 else if (tb
->nopass
)
6052 po
= extract_ppc_passed_object (e
);
6059 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
6064 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
6066 gfc_error ("Base object for procedure-pointer component call at %L is of"
6067 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
6071 gcc_assert (tb
->pass_arg_num
> 0);
6072 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
6080 /* Check that the object a TBP is called on is valid, i.e. it must not be
6081 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6084 check_typebound_baseobject (gfc_expr
* e
)
6087 bool return_value
= false;
6089 base
= extract_compcall_passed_object (e
);
6093 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
6095 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
6099 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
6101 gfc_error ("Base object for type-bound procedure call at %L is of"
6102 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
6106 /* F08:C1230. If the procedure called is NOPASS,
6107 the base object must be scalar. */
6108 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
6110 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6111 " be scalar", &e
->where
);
6115 return_value
= true;
6118 gfc_free_expr (base
);
6119 return return_value
;
6123 /* Resolve a call to a type-bound procedure, either function or subroutine,
6124 statically from the data in an EXPR_COMPCALL expression. The adapted
6125 arglist and the target-procedure symtree are returned. */
6128 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
6129 gfc_actual_arglist
** actual
)
6131 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6132 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6134 /* Update the actual arglist for PASS. */
6135 if (!update_compcall_arglist (e
))
6138 *actual
= e
->value
.compcall
.actual
;
6139 *target
= e
->value
.compcall
.tbp
->u
.specific
;
6141 gfc_free_ref_list (e
->ref
);
6143 e
->value
.compcall
.actual
= NULL
;
6145 /* If we find a deferred typebound procedure, check for derived types
6146 that an overriding typebound procedure has not been missed. */
6147 if (e
->value
.compcall
.name
6148 && !e
->value
.compcall
.tbp
->non_overridable
6149 && e
->value
.compcall
.base_object
6150 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
6153 gfc_symbol
*derived
;
6155 /* Use the derived type of the base_object. */
6156 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
6159 /* If necessary, go through the inheritance chain. */
6160 while (!st
&& derived
)
6162 /* Look for the typebound procedure 'name'. */
6163 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
6164 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
6165 e
->value
.compcall
.name
);
6167 derived
= gfc_get_derived_super_type (derived
);
6170 /* Now find the specific name in the derived type namespace. */
6171 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
6172 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
6173 derived
->ns
, 1, &st
);
6181 /* Get the ultimate declared type from an expression. In addition,
6182 return the last class/derived type reference and the copy of the
6183 reference list. If check_types is set true, derived types are
6184 identified as well as class references. */
6186 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
6187 gfc_expr
*e
, bool check_types
)
6189 gfc_symbol
*declared
;
6196 *new_ref
= gfc_copy_ref (e
->ref
);
6198 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6200 if (ref
->type
!= REF_COMPONENT
)
6203 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
6204 || (check_types
&& gfc_bt_struct (ref
->u
.c
.component
->ts
.type
)))
6205 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
6207 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
6213 if (declared
== NULL
)
6214 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
6220 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6221 which of the specific bindings (if any) matches the arglist and transform
6222 the expression into a call of that binding. */
6225 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
6227 gfc_typebound_proc
* genproc
;
6228 const char* genname
;
6230 gfc_symbol
*derived
;
6232 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
6233 genname
= e
->value
.compcall
.name
;
6234 genproc
= e
->value
.compcall
.tbp
;
6236 if (!genproc
->is_generic
)
6239 /* Try the bindings on this type and in the inheritance hierarchy. */
6240 for (; genproc
; genproc
= genproc
->overridden
)
6244 gcc_assert (genproc
->is_generic
);
6245 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6248 gfc_actual_arglist
* args
;
6251 gcc_assert (g
->specific
);
6253 if (g
->specific
->error
)
6256 target
= g
->specific
->u
.specific
->n
.sym
;
6258 /* Get the right arglist by handling PASS/NOPASS. */
6259 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6260 if (!g
->specific
->nopass
)
6263 po
= extract_compcall_passed_object (e
);
6266 gfc_free_actual_arglist (args
);
6270 gcc_assert (g
->specific
->pass_arg_num
> 0);
6271 gcc_assert (!g
->specific
->error
);
6272 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6273 g
->specific
->pass_arg
);
6275 resolve_actual_arglist (args
, target
->attr
.proc
,
6276 is_external_proc (target
)
6277 && gfc_sym_get_dummy_args (target
) == NULL
);
6279 /* Check if this arglist matches the formal. */
6280 matches
= gfc_arglist_matches_symbol (&args
, target
);
6282 /* Clean up and break out of the loop if we've found it. */
6283 gfc_free_actual_arglist (args
);
6286 e
->value
.compcall
.tbp
= g
->specific
;
6287 genname
= g
->specific_st
->name
;
6288 /* Pass along the name for CLASS methods, where the vtab
6289 procedure pointer component has to be referenced. */
6297 /* Nothing matching found! */
6298 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6299 " %qs at %L", genname
, &e
->where
);
6303 /* Make sure that we have the right specific instance for the name. */
6304 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6306 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6308 e
->value
.compcall
.tbp
= st
->n
.tb
;
6314 /* Resolve a call to a type-bound subroutine. */
6317 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
6319 gfc_actual_arglist
* newactual
;
6320 gfc_symtree
* target
;
6322 /* Check that's really a SUBROUTINE. */
6323 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6325 if (!c
->expr1
->value
.compcall
.tbp
->is_generic
6326 && c
->expr1
->value
.compcall
.tbp
->u
.specific
6327 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
6328 && c
->expr1
->value
.compcall
.tbp
->u
.specific
->n
.sym
->attr
.subroutine
)
6329 c
->expr1
->value
.compcall
.tbp
->subroutine
= 1;
6332 gfc_error ("%qs at %L should be a SUBROUTINE",
6333 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6338 if (!check_typebound_baseobject (c
->expr1
))
6341 /* Pass along the name for CLASS methods, where the vtab
6342 procedure pointer component has to be referenced. */
6344 *name
= c
->expr1
->value
.compcall
.name
;
6346 if (!resolve_typebound_generic_call (c
->expr1
, name
))
6349 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6351 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
6353 /* Transform into an ordinary EXEC_CALL for now. */
6355 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
6358 c
->ext
.actual
= newactual
;
6359 c
->symtree
= target
;
6360 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6362 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6364 gfc_free_expr (c
->expr1
);
6365 c
->expr1
= gfc_get_expr ();
6366 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6367 c
->expr1
->symtree
= target
;
6368 c
->expr1
->where
= c
->loc
;
6370 return resolve_call (c
);
6374 /* Resolve a component-call expression. */
6376 resolve_compcall (gfc_expr
* e
, const char **name
)
6378 gfc_actual_arglist
* newactual
;
6379 gfc_symtree
* target
;
6381 /* Check that's really a FUNCTION. */
6382 if (!e
->value
.compcall
.tbp
->function
)
6384 gfc_error ("%qs at %L should be a FUNCTION",
6385 e
->value
.compcall
.name
, &e
->where
);
6389 /* These must not be assign-calls! */
6390 gcc_assert (!e
->value
.compcall
.assign
);
6392 if (!check_typebound_baseobject (e
))
6395 /* Pass along the name for CLASS methods, where the vtab
6396 procedure pointer component has to be referenced. */
6398 *name
= e
->value
.compcall
.name
;
6400 if (!resolve_typebound_generic_call (e
, name
))
6402 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6404 /* Take the rank from the function's symbol. */
6405 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6406 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6408 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6409 arglist to the TBP's binding target. */
6411 if (!resolve_typebound_static (e
, &target
, &newactual
))
6414 e
->value
.function
.actual
= newactual
;
6415 e
->value
.function
.name
= NULL
;
6416 e
->value
.function
.esym
= target
->n
.sym
;
6417 e
->value
.function
.isym
= NULL
;
6418 e
->symtree
= target
;
6419 e
->ts
= target
->n
.sym
->ts
;
6420 e
->expr_type
= EXPR_FUNCTION
;
6422 /* Resolution is not necessary if this is a class subroutine; this
6423 function only has to identify the specific proc. Resolution of
6424 the call will be done next in resolve_typebound_call. */
6425 return gfc_resolve_expr (e
);
6429 static bool resolve_fl_derived (gfc_symbol
*sym
);
6432 /* Resolve a typebound function, or 'method'. First separate all
6433 the non-CLASS references by calling resolve_compcall directly. */
6436 resolve_typebound_function (gfc_expr
* e
)
6438 gfc_symbol
*declared
;
6450 /* Deal with typebound operators for CLASS objects. */
6451 expr
= e
->value
.compcall
.base_object
;
6452 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6453 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6455 /* If the base_object is not a variable, the corresponding actual
6456 argument expression must be stored in e->base_expression so
6457 that the corresponding tree temporary can be used as the base
6458 object in gfc_conv_procedure_call. */
6459 if (expr
->expr_type
!= EXPR_VARIABLE
)
6461 gfc_actual_arglist
*args
;
6463 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6465 if (expr
== args
->expr
)
6470 /* Since the typebound operators are generic, we have to ensure
6471 that any delays in resolution are corrected and that the vtab
6474 declared
= ts
.u
.derived
;
6475 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6476 if (c
->ts
.u
.derived
== NULL
)
6477 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6479 if (!resolve_compcall (e
, &name
))
6482 /* Use the generic name if it is there. */
6483 name
= name
? name
: e
->value
.function
.esym
->name
;
6484 e
->symtree
= expr
->symtree
;
6485 e
->ref
= gfc_copy_ref (expr
->ref
);
6486 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6488 /* Trim away the extraneous references that emerge from nested
6489 use of interface.c (extend_expr). */
6490 if (class_ref
&& class_ref
->next
)
6492 gfc_free_ref_list (class_ref
->next
);
6493 class_ref
->next
= NULL
;
6495 else if (e
->ref
&& !class_ref
&& expr
->ts
.type
!= BT_CLASS
)
6497 gfc_free_ref_list (e
->ref
);
6501 gfc_add_vptr_component (e
);
6502 gfc_add_component_ref (e
, name
);
6503 e
->value
.function
.esym
= NULL
;
6504 if (expr
->expr_type
!= EXPR_VARIABLE
)
6505 e
->base_expr
= expr
;
6510 return resolve_compcall (e
, NULL
);
6512 if (!resolve_ref (e
))
6515 /* Get the CLASS declared type. */
6516 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6518 if (!resolve_fl_derived (declared
))
6521 /* Weed out cases of the ultimate component being a derived type. */
6522 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6523 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6525 gfc_free_ref_list (new_ref
);
6526 return resolve_compcall (e
, NULL
);
6529 c
= gfc_find_component (declared
, "_data", true, true, NULL
);
6530 declared
= c
->ts
.u
.derived
;
6532 /* Treat the call as if it is a typebound procedure, in order to roll
6533 out the correct name for the specific function. */
6534 if (!resolve_compcall (e
, &name
))
6536 gfc_free_ref_list (new_ref
);
6543 /* Convert the expression to a procedure pointer component call. */
6544 e
->value
.function
.esym
= NULL
;
6550 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6551 gfc_add_vptr_component (e
);
6552 gfc_add_component_ref (e
, name
);
6554 /* Recover the typespec for the expression. This is really only
6555 necessary for generic procedures, where the additional call
6556 to gfc_add_component_ref seems to throw the collection of the
6557 correct typespec. */
6561 gfc_free_ref_list (new_ref
);
6566 /* Resolve a typebound subroutine, or 'method'. First separate all
6567 the non-CLASS references by calling resolve_typebound_call
6571 resolve_typebound_subroutine (gfc_code
*code
)
6573 gfc_symbol
*declared
;
6583 st
= code
->expr1
->symtree
;
6585 /* Deal with typebound operators for CLASS objects. */
6586 expr
= code
->expr1
->value
.compcall
.base_object
;
6587 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6588 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6590 /* If the base_object is not a variable, the corresponding actual
6591 argument expression must be stored in e->base_expression so
6592 that the corresponding tree temporary can be used as the base
6593 object in gfc_conv_procedure_call. */
6594 if (expr
->expr_type
!= EXPR_VARIABLE
)
6596 gfc_actual_arglist
*args
;
6598 args
= code
->expr1
->value
.function
.actual
;
6599 for (; args
; args
= args
->next
)
6600 if (expr
== args
->expr
)
6604 /* Since the typebound operators are generic, we have to ensure
6605 that any delays in resolution are corrected and that the vtab
6607 declared
= expr
->ts
.u
.derived
;
6608 c
= gfc_find_component (declared
, "_vptr", true, true, NULL
);
6609 if (c
->ts
.u
.derived
== NULL
)
6610 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6612 if (!resolve_typebound_call (code
, &name
, NULL
))
6615 /* Use the generic name if it is there. */
6616 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6617 code
->expr1
->symtree
= expr
->symtree
;
6618 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6620 /* Trim away the extraneous references that emerge from nested
6621 use of interface.c (extend_expr). */
6622 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6623 if (class_ref
&& class_ref
->next
)
6625 gfc_free_ref_list (class_ref
->next
);
6626 class_ref
->next
= NULL
;
6628 else if (code
->expr1
->ref
&& !class_ref
)
6630 gfc_free_ref_list (code
->expr1
->ref
);
6631 code
->expr1
->ref
= NULL
;
6634 /* Now use the procedure in the vtable. */
6635 gfc_add_vptr_component (code
->expr1
);
6636 gfc_add_component_ref (code
->expr1
, name
);
6637 code
->expr1
->value
.function
.esym
= NULL
;
6638 if (expr
->expr_type
!= EXPR_VARIABLE
)
6639 code
->expr1
->base_expr
= expr
;
6644 return resolve_typebound_call (code
, NULL
, NULL
);
6646 if (!resolve_ref (code
->expr1
))
6649 /* Get the CLASS declared type. */
6650 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6652 /* Weed out cases of the ultimate component being a derived type. */
6653 if ((class_ref
&& gfc_bt_struct (class_ref
->u
.c
.component
->ts
.type
))
6654 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6656 gfc_free_ref_list (new_ref
);
6657 return resolve_typebound_call (code
, NULL
, NULL
);
6660 if (!resolve_typebound_call (code
, &name
, &overridable
))
6662 gfc_free_ref_list (new_ref
);
6665 ts
= code
->expr1
->ts
;
6669 /* Convert the expression to a procedure pointer component call. */
6670 code
->expr1
->value
.function
.esym
= NULL
;
6671 code
->expr1
->symtree
= st
;
6674 code
->expr1
->ref
= new_ref
;
6676 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6677 gfc_add_vptr_component (code
->expr1
);
6678 gfc_add_component_ref (code
->expr1
, name
);
6680 /* Recover the typespec for the expression. This is really only
6681 necessary for generic procedures, where the additional call
6682 to gfc_add_component_ref seems to throw the collection of the
6683 correct typespec. */
6684 code
->expr1
->ts
= ts
;
6687 gfc_free_ref_list (new_ref
);
6693 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6696 resolve_ppc_call (gfc_code
* c
)
6698 gfc_component
*comp
;
6700 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6701 gcc_assert (comp
!= NULL
);
6703 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6704 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6706 if (!comp
->attr
.subroutine
)
6707 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6709 if (!resolve_ref (c
->expr1
))
6712 if (!update_ppc_arglist (c
->expr1
))
6715 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6717 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6718 !(comp
->ts
.interface
6719 && comp
->ts
.interface
->formal
)))
6722 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6725 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6731 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6734 resolve_expr_ppc (gfc_expr
* e
)
6736 gfc_component
*comp
;
6738 comp
= gfc_get_proc_ptr_comp (e
);
6739 gcc_assert (comp
!= NULL
);
6741 /* Convert to EXPR_FUNCTION. */
6742 e
->expr_type
= EXPR_FUNCTION
;
6743 e
->value
.function
.isym
= NULL
;
6744 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6746 if (comp
->as
!= NULL
)
6747 e
->rank
= comp
->as
->rank
;
6749 if (!comp
->attr
.function
)
6750 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6752 if (!resolve_ref (e
))
6755 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6756 !(comp
->ts
.interface
6757 && comp
->ts
.interface
->formal
)))
6760 if (!update_ppc_arglist (e
))
6763 if (!check_pure_function(e
))
6766 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6773 gfc_is_expandable_expr (gfc_expr
*e
)
6775 gfc_constructor
*con
;
6777 if (e
->expr_type
== EXPR_ARRAY
)
6779 /* Traverse the constructor looking for variables that are flavor
6780 parameter. Parameters must be expanded since they are fully used at
6782 con
= gfc_constructor_first (e
->value
.constructor
);
6783 for (; con
; con
= gfc_constructor_next (con
))
6785 if (con
->expr
->expr_type
== EXPR_VARIABLE
6786 && con
->expr
->symtree
6787 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6788 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6790 if (con
->expr
->expr_type
== EXPR_ARRAY
6791 && gfc_is_expandable_expr (con
->expr
))
6800 /* Sometimes variables in specification expressions of the result
6801 of module procedures in submodules wind up not being the 'real'
6802 dummy. Find this, if possible, in the namespace of the first
6806 fixup_unique_dummy (gfc_expr
*e
)
6808 gfc_symtree
*st
= NULL
;
6809 gfc_symbol
*s
= NULL
;
6811 if (e
->symtree
->n
.sym
->ns
->proc_name
6812 && e
->symtree
->n
.sym
->ns
->proc_name
->formal
)
6813 s
= e
->symtree
->n
.sym
->ns
->proc_name
->formal
->sym
;
6816 st
= gfc_find_symtree (s
->ns
->sym_root
, e
->symtree
->n
.sym
->name
);
6819 && st
->n
.sym
!= NULL
6820 && st
->n
.sym
->attr
.dummy
)
6824 /* Resolve an expression. That is, make sure that types of operands agree
6825 with their operators, intrinsic operators are converted to function calls
6826 for overloaded types and unresolved function references are resolved. */
6829 gfc_resolve_expr (gfc_expr
*e
)
6832 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6837 /* inquiry_argument only applies to variables. */
6838 inquiry_save
= inquiry_argument
;
6839 actual_arg_save
= actual_arg
;
6840 first_actual_arg_save
= first_actual_arg
;
6842 if (e
->expr_type
!= EXPR_VARIABLE
)
6844 inquiry_argument
= false;
6846 first_actual_arg
= false;
6848 else if (e
->symtree
!= NULL
6849 && *e
->symtree
->name
== '@'
6850 && e
->symtree
->n
.sym
->attr
.dummy
)
6852 /* Deal with submodule specification expressions that are not
6853 found to be referenced in module.c(read_cleanup). */
6854 fixup_unique_dummy (e
);
6857 switch (e
->expr_type
)
6860 t
= resolve_operator (e
);
6866 if (check_host_association (e
))
6867 t
= resolve_function (e
);
6869 t
= resolve_variable (e
);
6871 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6872 && e
->ref
->type
!= REF_SUBSTRING
)
6873 gfc_resolve_substring_charlen (e
);
6878 t
= resolve_typebound_function (e
);
6881 case EXPR_SUBSTRING
:
6882 t
= resolve_ref (e
);
6891 t
= resolve_expr_ppc (e
);
6896 if (!resolve_ref (e
))
6899 t
= gfc_resolve_array_constructor (e
);
6900 /* Also try to expand a constructor. */
6903 expression_rank (e
);
6904 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6905 gfc_expand_constructor (e
, false);
6908 /* This provides the opportunity for the length of constructors with
6909 character valued function elements to propagate the string length
6910 to the expression. */
6911 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6913 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6914 here rather then add a duplicate test for it above. */
6915 gfc_expand_constructor (e
, false);
6916 t
= gfc_resolve_character_array_constructor (e
);
6921 case EXPR_STRUCTURE
:
6922 t
= resolve_ref (e
);
6926 t
= resolve_structure_cons (e
, 0);
6930 t
= gfc_simplify_expr (e
, 0);
6934 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6937 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6940 inquiry_argument
= inquiry_save
;
6941 actual_arg
= actual_arg_save
;
6942 first_actual_arg
= first_actual_arg_save
;
6948 /* Resolve an expression from an iterator. They must be scalar and have
6949 INTEGER or (optionally) REAL type. */
6952 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6953 const char *name_msgid
)
6955 if (!gfc_resolve_expr (expr
))
6958 if (expr
->rank
!= 0)
6960 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6964 if (expr
->ts
.type
!= BT_INTEGER
)
6966 if (expr
->ts
.type
== BT_REAL
)
6969 return gfc_notify_std (GFC_STD_F95_DEL
,
6970 "%s at %L must be integer",
6971 _(name_msgid
), &expr
->where
);
6974 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6981 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6989 /* Resolve the expressions in an iterator structure. If REAL_OK is
6990 false allow only INTEGER type iterators, otherwise allow REAL types.
6991 Set own_scope to true for ac-implied-do and data-implied-do as those
6992 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6995 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6997 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
7000 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
7001 _("iterator variable")))
7004 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
7005 "Start expression in DO loop"))
7008 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
7009 "End expression in DO loop"))
7012 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
7013 "Step expression in DO loop"))
7016 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
7018 if ((iter
->step
->ts
.type
== BT_INTEGER
7019 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
7020 || (iter
->step
->ts
.type
== BT_REAL
7021 && mpfr_sgn (iter
->step
->value
.real
) == 0))
7023 gfc_error ("Step expression in DO loop at %L cannot be zero",
7024 &iter
->step
->where
);
7029 /* Convert start, end, and step to the same type as var. */
7030 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
7031 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
7032 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7034 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
7035 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
7036 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7038 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
7039 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
7040 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 1);
7042 if (iter
->start
->expr_type
== EXPR_CONSTANT
7043 && iter
->end
->expr_type
== EXPR_CONSTANT
7044 && iter
->step
->expr_type
== EXPR_CONSTANT
)
7047 if (iter
->start
->ts
.type
== BT_INTEGER
)
7049 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
7050 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
7054 sgn
= mpfr_sgn (iter
->step
->value
.real
);
7055 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
7057 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
7058 gfc_warning (OPT_Wzerotrip
,
7059 "DO loop at %L will be executed zero times",
7060 &iter
->step
->where
);
7063 if (iter
->end
->expr_type
== EXPR_CONSTANT
7064 && iter
->end
->ts
.type
== BT_INTEGER
7065 && iter
->step
->expr_type
== EXPR_CONSTANT
7066 && iter
->step
->ts
.type
== BT_INTEGER
7067 && (mpz_cmp_si (iter
->step
->value
.integer
, -1L) == 0
7068 || mpz_cmp_si (iter
->step
->value
.integer
, 1L) == 0))
7070 bool is_step_positive
= mpz_cmp_ui (iter
->step
->value
.integer
, 1) == 0;
7071 int k
= gfc_validate_kind (BT_INTEGER
, iter
->end
->ts
.kind
, false);
7073 if (is_step_positive
7074 && mpz_cmp (iter
->end
->value
.integer
, gfc_integer_kinds
[k
].huge
) == 0)
7075 gfc_warning (OPT_Wundefined_do_loop
,
7076 "DO loop at %L is undefined as it overflows",
7077 &iter
->step
->where
);
7078 else if (!is_step_positive
7079 && mpz_cmp (iter
->end
->value
.integer
,
7080 gfc_integer_kinds
[k
].min_int
) == 0)
7081 gfc_warning (OPT_Wundefined_do_loop
,
7082 "DO loop at %L is undefined as it underflows",
7083 &iter
->step
->where
);
7090 /* Traversal function for find_forall_index. f == 2 signals that
7091 that variable itself is not to be checked - only the references. */
7094 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
7096 if (expr
->expr_type
!= EXPR_VARIABLE
)
7099 /* A scalar assignment */
7100 if (!expr
->ref
|| *f
== 1)
7102 if (expr
->symtree
->n
.sym
== sym
)
7114 /* Check whether the FORALL index appears in the expression or not.
7115 Returns true if SYM is found in EXPR. */
7118 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
7120 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
7127 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7128 to be a scalar INTEGER variable. The subscripts and stride are scalar
7129 INTEGERs, and if stride is a constant it must be nonzero.
7130 Furthermore "A subscript or stride in a forall-triplet-spec shall
7131 not contain a reference to any index-name in the
7132 forall-triplet-spec-list in which it appears." (7.5.4.1) */
7135 resolve_forall_iterators (gfc_forall_iterator
*it
)
7137 gfc_forall_iterator
*iter
, *iter2
;
7139 for (iter
= it
; iter
; iter
= iter
->next
)
7141 if (gfc_resolve_expr (iter
->var
)
7142 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
7143 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7146 if (gfc_resolve_expr (iter
->start
)
7147 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
7148 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7149 &iter
->start
->where
);
7150 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
7151 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
7153 if (gfc_resolve_expr (iter
->end
)
7154 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
7155 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7157 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
7158 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
7160 if (gfc_resolve_expr (iter
->stride
))
7162 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
7163 gfc_error ("FORALL stride expression at %L must be a scalar %s",
7164 &iter
->stride
->where
, "INTEGER");
7166 if (iter
->stride
->expr_type
== EXPR_CONSTANT
7167 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
7168 gfc_error ("FORALL stride expression at %L cannot be zero",
7169 &iter
->stride
->where
);
7171 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
7172 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
7175 for (iter
= it
; iter
; iter
= iter
->next
)
7176 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
7178 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
7179 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
7180 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
7181 gfc_error ("FORALL index %qs may not appear in triplet "
7182 "specification at %L", iter
->var
->symtree
->name
,
7183 &iter2
->start
->where
);
7188 /* Given a pointer to a symbol that is a derived type, see if it's
7189 inaccessible, i.e. if it's defined in another module and the components are
7190 PRIVATE. The search is recursive if necessary. Returns zero if no
7191 inaccessible components are found, nonzero otherwise. */
7194 derived_inaccessible (gfc_symbol
*sym
)
7198 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
7201 for (c
= sym
->components
; c
; c
= c
->next
)
7203 /* Prevent an infinite loop through this function. */
7204 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
7205 && sym
== c
->ts
.u
.derived
)
7208 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
7216 /* Resolve the argument of a deallocate expression. The expression must be
7217 a pointer or a full array. */
7220 resolve_deallocate_expr (gfc_expr
*e
)
7222 symbol_attribute attr
;
7223 int allocatable
, pointer
;
7229 if (!gfc_resolve_expr (e
))
7232 if (e
->expr_type
!= EXPR_VARIABLE
)
7235 sym
= e
->symtree
->n
.sym
;
7236 unlimited
= UNLIMITED_POLY(sym
);
7238 if (sym
->ts
.type
== BT_CLASS
)
7240 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7241 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7245 allocatable
= sym
->attr
.allocatable
;
7246 pointer
= sym
->attr
.pointer
;
7248 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7253 if (ref
->u
.ar
.type
!= AR_FULL
7254 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
7255 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
7260 c
= ref
->u
.c
.component
;
7261 if (c
->ts
.type
== BT_CLASS
)
7263 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7264 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7268 allocatable
= c
->attr
.allocatable
;
7269 pointer
= c
->attr
.pointer
;
7280 attr
= gfc_expr_attr (e
);
7282 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
7285 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7291 if (gfc_is_coindexed (e
))
7293 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
7298 && !gfc_check_vardef_context (e
, true, true, false,
7299 _("DEALLOCATE object")))
7301 if (!gfc_check_vardef_context (e
, false, true, false,
7302 _("DEALLOCATE object")))
7309 /* Returns true if the expression e contains a reference to the symbol sym. */
7311 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
7313 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
7320 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
7322 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
7326 /* Given the expression node e for an allocatable/pointer of derived type to be
7327 allocated, get the expression node to be initialized afterwards (needed for
7328 derived types with default initializers, and derived types with allocatable
7329 components that need nullification.) */
7332 gfc_expr_to_initialize (gfc_expr
*e
)
7338 result
= gfc_copy_expr (e
);
7340 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7341 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7342 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7344 ref
->u
.ar
.type
= AR_FULL
;
7346 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7347 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7352 gfc_free_shape (&result
->shape
, result
->rank
);
7354 /* Recalculate rank, shape, etc. */
7355 gfc_resolve_expr (result
);
7360 /* If the last ref of an expression is an array ref, return a copy of the
7361 expression with that one removed. Otherwise, a copy of the original
7362 expression. This is used for allocate-expressions and pointer assignment
7363 LHS, where there may be an array specification that needs to be stripped
7364 off when using gfc_check_vardef_context. */
7367 remove_last_array_ref (gfc_expr
* e
)
7372 e2
= gfc_copy_expr (e
);
7373 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7374 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7376 gfc_free_ref_list (*r
);
7385 /* Used in resolve_allocate_expr to check that a allocation-object and
7386 a source-expr are conformable. This does not catch all possible
7387 cases; in particular a runtime checking is needed. */
7390 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7393 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7395 /* First compare rank. */
7396 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7397 || (!tail
&& e1
->rank
!= e2
->rank
))
7399 gfc_error ("Source-expr at %L must be scalar or have the "
7400 "same rank as the allocate-object at %L",
7401 &e1
->where
, &e2
->where
);
7412 for (i
= 0; i
< e1
->rank
; i
++)
7414 if (tail
->u
.ar
.start
[i
] == NULL
)
7417 if (tail
->u
.ar
.end
[i
])
7419 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7420 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7421 mpz_add_ui (s
, s
, 1);
7425 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7428 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7430 gfc_error ("Source-expr at %L and allocate-object at %L must "
7431 "have the same shape", &e1
->where
, &e2
->where
);
7444 /* Resolve the expression in an ALLOCATE statement, doing the additional
7445 checks to see whether the expression is OK or not. The expression must
7446 have a trailing array reference that gives the size of the array. */
7449 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
, bool *array_alloc_wo_spec
)
7451 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7455 symbol_attribute attr
;
7456 gfc_ref
*ref
, *ref2
;
7459 gfc_symbol
*sym
= NULL
;
7464 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7465 checking of coarrays. */
7466 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7467 if (ref
->next
== NULL
)
7470 if (ref
&& ref
->type
== REF_ARRAY
)
7471 ref
->u
.ar
.in_allocate
= true;
7473 if (!gfc_resolve_expr (e
))
7476 /* Make sure the expression is allocatable or a pointer. If it is
7477 pointer, the next-to-last reference must be a pointer. */
7481 sym
= e
->symtree
->n
.sym
;
7483 /* Check whether ultimate component is abstract and CLASS. */
7486 /* Is the allocate-object unlimited polymorphic? */
7487 unlimited
= UNLIMITED_POLY(e
);
7489 if (e
->expr_type
!= EXPR_VARIABLE
)
7492 attr
= gfc_expr_attr (e
);
7493 pointer
= attr
.pointer
;
7494 dimension
= attr
.dimension
;
7495 codimension
= attr
.codimension
;
7499 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7501 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7502 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7503 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7504 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7505 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7509 allocatable
= sym
->attr
.allocatable
;
7510 pointer
= sym
->attr
.pointer
;
7511 dimension
= sym
->attr
.dimension
;
7512 codimension
= sym
->attr
.codimension
;
7517 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7522 if (ref
->u
.ar
.codimen
> 0)
7525 for (n
= ref
->u
.ar
.dimen
;
7526 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7527 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7534 if (ref
->next
!= NULL
)
7542 gfc_error ("Coindexed allocatable object at %L",
7547 c
= ref
->u
.c
.component
;
7548 if (c
->ts
.type
== BT_CLASS
)
7550 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7551 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7552 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7553 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7554 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7558 allocatable
= c
->attr
.allocatable
;
7559 pointer
= c
->attr
.pointer
;
7560 dimension
= c
->attr
.dimension
;
7561 codimension
= c
->attr
.codimension
;
7562 is_abstract
= c
->attr
.abstract
;
7575 /* Check for F08:C628. */
7576 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7578 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7583 /* Some checks for the SOURCE tag. */
7586 /* Check F03:C631. */
7587 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7589 gfc_error ("Type of entity at %L is type incompatible with "
7590 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7594 /* Check F03:C632 and restriction following Note 6.18. */
7595 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
7598 /* Check F03:C633. */
7599 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7601 gfc_error ("The allocate-object at %L and the source-expr at %L "
7602 "shall have the same kind type parameter",
7603 &e
->where
, &code
->expr3
->where
);
7607 /* Check F2008, C642. */
7608 if (code
->expr3
->ts
.type
== BT_DERIVED
7609 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7610 || (code
->expr3
->ts
.u
.derived
->from_intmod
7611 == INTMOD_ISO_FORTRAN_ENV
7612 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7613 == ISOFORTRAN_LOCK_TYPE
)))
7615 gfc_error ("The source-expr at %L shall neither be of type "
7616 "LOCK_TYPE nor have a LOCK_TYPE component if "
7617 "allocate-object at %L is a coarray",
7618 &code
->expr3
->where
, &e
->where
);
7622 /* Check TS18508, C702/C703. */
7623 if (code
->expr3
->ts
.type
== BT_DERIVED
7624 && ((codimension
&& gfc_expr_attr (code
->expr3
).event_comp
)
7625 || (code
->expr3
->ts
.u
.derived
->from_intmod
7626 == INTMOD_ISO_FORTRAN_ENV
7627 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7628 == ISOFORTRAN_EVENT_TYPE
)))
7630 gfc_error ("The source-expr at %L shall neither be of type "
7631 "EVENT_TYPE nor have a EVENT_TYPE component if "
7632 "allocate-object at %L is a coarray",
7633 &code
->expr3
->where
, &e
->where
);
7638 /* Check F08:C629. */
7639 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7642 gcc_assert (e
->ts
.type
== BT_CLASS
);
7643 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7644 "type-spec or source-expr", sym
->name
, &e
->where
);
7648 /* Check F08:C632. */
7649 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
7650 && !UNLIMITED_POLY (e
))
7654 if (!e
->ts
.u
.cl
->length
)
7657 cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7658 code
->ext
.alloc
.ts
.u
.cl
->length
);
7659 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7661 gfc_error ("Allocating %s at %L with type-spec requires the same "
7662 "character-length parameter as in the declaration",
7663 sym
->name
, &e
->where
);
7668 /* In the variable definition context checks, gfc_expr_attr is used
7669 on the expression. This is fooled by the array specification
7670 present in e, thus we have to eliminate that one temporarily. */
7671 e2
= remove_last_array_ref (e
);
7674 t
= gfc_check_vardef_context (e2
, true, true, false,
7675 _("ALLOCATE object"));
7677 t
= gfc_check_vardef_context (e2
, false, true, false,
7678 _("ALLOCATE object"));
7683 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7684 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7686 /* For class arrays, the initialization with SOURCE is done
7687 using _copy and trans_call. It is convenient to exploit that
7688 when the allocated type is different from the declared type but
7689 no SOURCE exists by setting expr3. */
7690 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7692 else if (flag_coarray
!= GFC_FCOARRAY_LIB
&& e
->ts
.type
== BT_DERIVED
7693 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7694 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7696 /* We have to zero initialize the integer variable. */
7697 code
->expr3
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, 0);
7700 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7702 /* Make sure the vtab symbol is present when
7703 the module variables are generated. */
7704 gfc_typespec ts
= e
->ts
;
7706 ts
= code
->expr3
->ts
;
7707 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7708 ts
= code
->ext
.alloc
.ts
;
7710 /* Finding the vtab also publishes the type's symbol. Therefore this
7711 statement is necessary. */
7712 gfc_find_derived_vtab (ts
.u
.derived
);
7714 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7716 /* Again, make sure the vtab symbol is present when
7717 the module variables are generated. */
7718 gfc_typespec
*ts
= NULL
;
7720 ts
= &code
->expr3
->ts
;
7722 ts
= &code
->ext
.alloc
.ts
;
7726 /* Finding the vtab also publishes the type's symbol. Therefore this
7727 statement is necessary. */
7731 if (dimension
== 0 && codimension
== 0)
7734 /* Make sure the last reference node is an array specification. */
7736 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7737 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7742 if (!gfc_notify_std (GFC_STD_F2008
, "Array specification required "
7743 "in ALLOCATE statement at %L", &e
->where
))
7745 if (code
->expr3
->rank
!= 0)
7746 *array_alloc_wo_spec
= true;
7749 gfc_error ("Array specification or array-valued SOURCE= "
7750 "expression required in ALLOCATE statement at %L",
7757 gfc_error ("Array specification required in ALLOCATE statement "
7758 "at %L", &e
->where
);
7763 /* Make sure that the array section reference makes sense in the
7764 context of an ALLOCATE specification. */
7769 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7771 switch (ar
->dimen_type
[i
])
7773 case DIMEN_THIS_IMAGE
:
7774 gfc_error ("Coarray specification required in ALLOCATE statement "
7775 "at %L", &e
->where
);
7779 if (ar
->start
[i
] == 0 || ar
->end
[i
] == 0)
7781 /* If ar->stride[i] is NULL, we issued a previous error. */
7782 if (ar
->stride
[i
] == NULL
)
7783 gfc_error ("Bad array specification in ALLOCATE statement "
7784 "at %L", &e
->where
);
7787 else if (gfc_dep_compare_expr (ar
->start
[i
], ar
->end
[i
]) == 1)
7789 gfc_error ("Upper cobound is less than lower cobound at %L",
7790 &ar
->start
[i
]->where
);
7796 if (ar
->start
[i
]->expr_type
== EXPR_CONSTANT
)
7798 gcc_assert (ar
->start
[i
]->ts
.type
== BT_INTEGER
);
7799 if (mpz_cmp_si (ar
->start
[i
]->value
.integer
, 1) < 0)
7801 gfc_error ("Upper cobound is less than lower cobound "
7802 "of 1 at %L", &ar
->start
[i
]->where
);
7812 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7818 for (i
= 0; i
< ar
->dimen
; i
++)
7820 if (ar
->type
== AR_ELEMENT
|| ar
->type
== AR_FULL
)
7823 switch (ar
->dimen_type
[i
])
7829 if (ar
->start
[i
] != NULL
7830 && ar
->end
[i
] != NULL
7831 && ar
->stride
[i
] == NULL
)
7839 case DIMEN_THIS_IMAGE
:
7840 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7846 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7848 sym
= a
->expr
->symtree
->n
.sym
;
7850 /* TODO - check derived type components. */
7851 if (gfc_bt_struct (sym
->ts
.type
) || sym
->ts
.type
== BT_CLASS
)
7854 if ((ar
->start
[i
] != NULL
7855 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7856 || (ar
->end
[i
] != NULL
7857 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7859 gfc_error ("%qs must not appear in the array specification at "
7860 "%L in the same ALLOCATE statement where it is "
7861 "itself allocated", sym
->name
, &ar
->where
);
7867 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7869 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7870 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7872 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7874 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7875 "statement at %L", &e
->where
);
7881 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7882 && ar
->stride
[i
] == NULL
)
7885 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7899 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7901 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7902 gfc_alloc
*a
, *p
, *q
;
7905 errmsg
= code
->expr2
;
7907 /* Check the stat variable. */
7910 gfc_check_vardef_context (stat
, false, false, false,
7911 _("STAT variable"));
7913 if ((stat
->ts
.type
!= BT_INTEGER
7914 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7915 || stat
->ref
->type
== REF_COMPONENT
)))
7917 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7918 "variable", &stat
->where
);
7920 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7921 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7923 gfc_ref
*ref1
, *ref2
;
7926 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7927 ref1
= ref1
->next
, ref2
= ref2
->next
)
7929 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7931 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7940 gfc_error ("Stat-variable at %L shall not be %sd within "
7941 "the same %s statement", &stat
->where
, fcn
, fcn
);
7947 /* Check the errmsg variable. */
7951 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7954 gfc_check_vardef_context (errmsg
, false, false, false,
7955 _("ERRMSG variable"));
7957 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
7958 F18:R930 errmsg-variable is scalar-default-char-variable
7959 F18:R906 default-char-variable is variable
7960 F18:C906 default-char-variable shall be default character. */
7961 if ((errmsg
->ts
.type
!= BT_CHARACTER
7963 && (errmsg
->ref
->type
== REF_ARRAY
7964 || errmsg
->ref
->type
== REF_COMPONENT
)))
7966 || errmsg
->ts
.kind
!= gfc_default_character_kind
)
7967 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
7968 "variable", &errmsg
->where
);
7970 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7971 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7973 gfc_ref
*ref1
, *ref2
;
7976 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7977 ref1
= ref1
->next
, ref2
= ref2
->next
)
7979 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7981 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7990 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7991 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7997 /* Check that an allocate-object appears only once in the statement. */
7999 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
8002 for (q
= p
->next
; q
; q
= q
->next
)
8005 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
8007 /* This is a potential collision. */
8008 gfc_ref
*pr
= pe
->ref
;
8009 gfc_ref
*qr
= qe
->ref
;
8011 /* Follow the references until
8012 a) They start to differ, in which case there is no error;
8013 you can deallocate a%b and a%c in a single statement
8014 b) Both of them stop, which is an error
8015 c) One of them stops, which is also an error. */
8018 if (pr
== NULL
&& qr
== NULL
)
8020 gfc_error ("Allocate-object at %L also appears at %L",
8021 &pe
->where
, &qe
->where
);
8024 else if (pr
!= NULL
&& qr
== NULL
)
8026 gfc_error ("Allocate-object at %L is subobject of"
8027 " object at %L", &pe
->where
, &qe
->where
);
8030 else if (pr
== NULL
&& qr
!= NULL
)
8032 gfc_error ("Allocate-object at %L is subobject of"
8033 " object at %L", &qe
->where
, &pe
->where
);
8036 /* Here, pr != NULL && qr != NULL */
8037 gcc_assert(pr
->type
== qr
->type
);
8038 if (pr
->type
== REF_ARRAY
)
8040 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8042 gcc_assert (qr
->type
== REF_ARRAY
);
8044 if (pr
->next
&& qr
->next
)
8047 gfc_array_ref
*par
= &(pr
->u
.ar
);
8048 gfc_array_ref
*qar
= &(qr
->u
.ar
);
8050 for (i
=0; i
<par
->dimen
; i
++)
8052 if ((par
->start
[i
] != NULL
8053 || qar
->start
[i
] != NULL
)
8054 && gfc_dep_compare_expr (par
->start
[i
],
8055 qar
->start
[i
]) != 0)
8062 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
8075 if (strcmp (fcn
, "ALLOCATE") == 0)
8077 bool arr_alloc_wo_spec
= false;
8079 /* Resolving the expr3 in the loop over all objects to allocate would
8080 execute loop invariant code for each loop item. Therefore do it just
8082 if (code
->expr3
&& code
->expr3
->mold
8083 && code
->expr3
->ts
.type
== BT_DERIVED
)
8085 /* Default initialization via MOLD (non-polymorphic). */
8086 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
8089 gfc_resolve_expr (rhs
);
8090 gfc_free_expr (code
->expr3
);
8094 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8095 resolve_allocate_expr (a
->expr
, code
, &arr_alloc_wo_spec
);
8097 if (arr_alloc_wo_spec
&& code
->expr3
)
8099 /* Mark the allocate to have to take the array specification
8101 code
->ext
.alloc
.arr_spec_from_expr3
= 1;
8106 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
8107 resolve_deallocate_expr (a
->expr
);
8112 /************ SELECT CASE resolution subroutines ************/
8114 /* Callback function for our mergesort variant. Determines interval
8115 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8116 op1 > op2. Assumes we're not dealing with the default case.
8117 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8118 There are nine situations to check. */
8121 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
8125 if (op1
->low
== NULL
) /* op1 = (:L) */
8127 /* op2 = (:N), so overlap. */
8129 /* op2 = (M:) or (M:N), L < M */
8130 if (op2
->low
!= NULL
8131 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8134 else if (op1
->high
== NULL
) /* op1 = (K:) */
8136 /* op2 = (M:), so overlap. */
8138 /* op2 = (:N) or (M:N), K > N */
8139 if (op2
->high
!= NULL
8140 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8143 else /* op1 = (K:L) */
8145 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
8146 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8148 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
8149 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8151 else /* op2 = (M:N) */
8155 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
8158 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
8167 /* Merge-sort a double linked case list, detecting overlap in the
8168 process. LIST is the head of the double linked case list before it
8169 is sorted. Returns the head of the sorted list if we don't see any
8170 overlap, or NULL otherwise. */
8173 check_case_overlap (gfc_case
*list
)
8175 gfc_case
*p
, *q
, *e
, *tail
;
8176 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
8178 /* If the passed list was empty, return immediately. */
8185 /* Loop unconditionally. The only exit from this loop is a return
8186 statement, when we've finished sorting the case list. */
8193 /* Count the number of merges we do in this pass. */
8196 /* Loop while there exists a merge to be done. */
8201 /* Count this merge. */
8204 /* Cut the list in two pieces by stepping INSIZE places
8205 forward in the list, starting from P. */
8208 for (i
= 0; i
< insize
; i
++)
8217 /* Now we have two lists. Merge them! */
8218 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
8220 /* See from which the next case to merge comes from. */
8223 /* P is empty so the next case must come from Q. */
8228 else if (qsize
== 0 || q
== NULL
)
8237 cmp
= compare_cases (p
, q
);
8240 /* The whole case range for P is less than the
8248 /* The whole case range for Q is greater than
8249 the case range for P. */
8256 /* The cases overlap, or they are the same
8257 element in the list. Either way, we must
8258 issue an error and get the next case from P. */
8259 /* FIXME: Sort P and Q by line number. */
8260 gfc_error ("CASE label at %L overlaps with CASE "
8261 "label at %L", &p
->where
, &q
->where
);
8269 /* Add the next element to the merged list. */
8278 /* P has now stepped INSIZE places along, and so has Q. So
8279 they're the same. */
8284 /* If we have done only one merge or none at all, we've
8285 finished sorting the cases. */
8294 /* Otherwise repeat, merging lists twice the size. */
8300 /* Check to see if an expression is suitable for use in a CASE statement.
8301 Makes sure that all case expressions are scalar constants of the same
8302 type. Return false if anything is wrong. */
8305 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
8307 if (e
== NULL
) return true;
8309 if (e
->ts
.type
!= case_expr
->ts
.type
)
8311 gfc_error ("Expression in CASE statement at %L must be of type %s",
8312 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
8316 /* C805 (R808) For a given case-construct, each case-value shall be of
8317 the same type as case-expr. For character type, length differences
8318 are allowed, but the kind type parameters shall be the same. */
8320 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
8322 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8323 &e
->where
, case_expr
->ts
.kind
);
8327 /* Convert the case value kind to that of case expression kind,
8330 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
8331 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
8335 gfc_error ("Expression in CASE statement at %L must be scalar",
8344 /* Given a completely parsed select statement, we:
8346 - Validate all expressions and code within the SELECT.
8347 - Make sure that the selection expression is not of the wrong type.
8348 - Make sure that no case ranges overlap.
8349 - Eliminate unreachable cases and unreachable code resulting from
8350 removing case labels.
8352 The standard does allow unreachable cases, e.g. CASE (5:3). But
8353 they are a hassle for code generation, and to prevent that, we just
8354 cut them out here. This is not necessary for overlapping cases
8355 because they are illegal and we never even try to generate code.
8357 We have the additional caveat that a SELECT construct could have
8358 been a computed GOTO in the source code. Fortunately we can fairly
8359 easily work around that here: The case_expr for a "real" SELECT CASE
8360 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8361 we have to do is make sure that the case_expr is a scalar integer
8365 resolve_select (gfc_code
*code
, bool select_type
)
8368 gfc_expr
*case_expr
;
8369 gfc_case
*cp
, *default_case
, *tail
, *head
;
8370 int seen_unreachable
;
8376 if (code
->expr1
== NULL
)
8378 /* This was actually a computed GOTO statement. */
8379 case_expr
= code
->expr2
;
8380 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
8381 gfc_error ("Selection expression in computed GOTO statement "
8382 "at %L must be a scalar integer expression",
8385 /* Further checking is not necessary because this SELECT was built
8386 by the compiler, so it should always be OK. Just move the
8387 case_expr from expr2 to expr so that we can handle computed
8388 GOTOs as normal SELECTs from here on. */
8389 code
->expr1
= code
->expr2
;
8394 case_expr
= code
->expr1
;
8395 type
= case_expr
->ts
.type
;
8398 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
8400 gfc_error ("Argument of SELECT statement at %L cannot be %s",
8401 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
8403 /* Punt. Going on here just produce more garbage error messages. */
8408 if (!select_type
&& case_expr
->rank
!= 0)
8410 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8411 "expression", &case_expr
->where
);
8417 /* Raise a warning if an INTEGER case value exceeds the range of
8418 the case-expr. Later, all expressions will be promoted to the
8419 largest kind of all case-labels. */
8421 if (type
== BT_INTEGER
)
8422 for (body
= code
->block
; body
; body
= body
->block
)
8423 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8426 && gfc_check_integer_range (cp
->low
->value
.integer
,
8427 case_expr
->ts
.kind
) != ARITH_OK
)
8428 gfc_warning (0, "Expression in CASE statement at %L is "
8429 "not in the range of %s", &cp
->low
->where
,
8430 gfc_typename (&case_expr
->ts
));
8433 && cp
->low
!= cp
->high
8434 && gfc_check_integer_range (cp
->high
->value
.integer
,
8435 case_expr
->ts
.kind
) != ARITH_OK
)
8436 gfc_warning (0, "Expression in CASE statement at %L is "
8437 "not in the range of %s", &cp
->high
->where
,
8438 gfc_typename (&case_expr
->ts
));
8441 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8442 of the SELECT CASE expression and its CASE values. Walk the lists
8443 of case values, and if we find a mismatch, promote case_expr to
8444 the appropriate kind. */
8446 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8448 for (body
= code
->block
; body
; body
= body
->block
)
8450 /* Walk the case label list. */
8451 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8453 /* Intercept the DEFAULT case. It does not have a kind. */
8454 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8457 /* Unreachable case ranges are discarded, so ignore. */
8458 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8459 && cp
->low
!= cp
->high
8460 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8464 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8465 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8467 if (cp
->high
!= NULL
8468 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8469 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8474 /* Assume there is no DEFAULT case. */
8475 default_case
= NULL
;
8480 for (body
= code
->block
; body
; body
= body
->block
)
8482 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8484 seen_unreachable
= 0;
8486 /* Walk the case label list, making sure that all case labels
8488 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8490 /* Count the number of cases in the whole construct. */
8493 /* Intercept the DEFAULT case. */
8494 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8496 if (default_case
!= NULL
)
8498 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8499 "by a second DEFAULT CASE at %L",
8500 &default_case
->where
, &cp
->where
);
8511 /* Deal with single value cases and case ranges. Errors are
8512 issued from the validation function. */
8513 if (!validate_case_label_expr (cp
->low
, case_expr
)
8514 || !validate_case_label_expr (cp
->high
, case_expr
))
8520 if (type
== BT_LOGICAL
8521 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8522 || cp
->low
!= cp
->high
))
8524 gfc_error ("Logical range in CASE statement at %L is not "
8525 "allowed", &cp
->low
->where
);
8530 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8533 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8534 if (value
& seen_logical
)
8536 gfc_error ("Constant logical value in CASE statement "
8537 "is repeated at %L",
8542 seen_logical
|= value
;
8545 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8546 && cp
->low
!= cp
->high
8547 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8549 if (warn_surprising
)
8550 gfc_warning (OPT_Wsurprising
,
8551 "Range specification at %L can never be matched",
8554 cp
->unreachable
= 1;
8555 seen_unreachable
= 1;
8559 /* If the case range can be matched, it can also overlap with
8560 other cases. To make sure it does not, we put it in a
8561 double linked list here. We sort that with a merge sort
8562 later on to detect any overlapping cases. */
8566 head
->right
= head
->left
= NULL
;
8571 tail
->right
->left
= tail
;
8578 /* It there was a failure in the previous case label, give up
8579 for this case label list. Continue with the next block. */
8583 /* See if any case labels that are unreachable have been seen.
8584 If so, we eliminate them. This is a bit of a kludge because
8585 the case lists for a single case statement (label) is a
8586 single forward linked lists. */
8587 if (seen_unreachable
)
8589 /* Advance until the first case in the list is reachable. */
8590 while (body
->ext
.block
.case_list
!= NULL
8591 && body
->ext
.block
.case_list
->unreachable
)
8593 gfc_case
*n
= body
->ext
.block
.case_list
;
8594 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8596 gfc_free_case_list (n
);
8599 /* Strip all other unreachable cases. */
8600 if (body
->ext
.block
.case_list
)
8602 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
8604 if (cp
->next
->unreachable
)
8606 gfc_case
*n
= cp
->next
;
8607 cp
->next
= cp
->next
->next
;
8609 gfc_free_case_list (n
);
8616 /* See if there were overlapping cases. If the check returns NULL,
8617 there was overlap. In that case we don't do anything. If head
8618 is non-NULL, we prepend the DEFAULT case. The sorted list can
8619 then used during code generation for SELECT CASE constructs with
8620 a case expression of a CHARACTER type. */
8623 head
= check_case_overlap (head
);
8625 /* Prepend the default_case if it is there. */
8626 if (head
!= NULL
&& default_case
)
8628 default_case
->left
= NULL
;
8629 default_case
->right
= head
;
8630 head
->left
= default_case
;
8634 /* Eliminate dead blocks that may be the result if we've seen
8635 unreachable case labels for a block. */
8636 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8638 if (body
->block
->ext
.block
.case_list
== NULL
)
8640 /* Cut the unreachable block from the code chain. */
8641 gfc_code
*c
= body
->block
;
8642 body
->block
= c
->block
;
8644 /* Kill the dead block, but not the blocks below it. */
8646 gfc_free_statements (c
);
8650 /* More than two cases is legal but insane for logical selects.
8651 Issue a warning for it. */
8652 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
8653 gfc_warning (OPT_Wsurprising
,
8654 "Logical SELECT CASE block at %L has more that two cases",
8659 /* Check if a derived type is extensible. */
8662 gfc_type_is_extensible (gfc_symbol
*sym
)
8664 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8665 || (sym
->attr
.is_class
8666 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8671 resolve_types (gfc_namespace
*ns
);
8673 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8674 correct as well as possibly the array-spec. */
8677 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8681 gcc_assert (sym
->assoc
);
8682 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8684 /* If this is for SELECT TYPE, the target may not yet be set. In that
8685 case, return. Resolution will be called later manually again when
8687 target
= sym
->assoc
->target
;
8690 gcc_assert (!sym
->assoc
->dangling
);
8692 if (resolve_target
&& !gfc_resolve_expr (target
))
8695 /* For variable targets, we get some attributes from the target. */
8696 if (target
->expr_type
== EXPR_VARIABLE
)
8700 gcc_assert (target
->symtree
);
8701 tsym
= target
->symtree
->n
.sym
;
8703 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8704 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8706 sym
->attr
.target
= tsym
->attr
.target
8707 || gfc_expr_attr (target
).pointer
;
8708 if (is_subref_array (target
))
8709 sym
->attr
.subref_array_pointer
= 1;
8712 if (target
->expr_type
== EXPR_NULL
)
8714 gfc_error ("Selector at %L cannot be NULL()", &target
->where
);
8717 else if (target
->ts
.type
== BT_UNKNOWN
)
8719 gfc_error ("Selector at %L has no type", &target
->where
);
8723 /* Get type if this was not already set. Note that it can be
8724 some other type than the target in case this is a SELECT TYPE
8725 selector! So we must not update when the type is already there. */
8726 if (sym
->ts
.type
== BT_UNKNOWN
)
8727 sym
->ts
= target
->ts
;
8729 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8731 /* See if this is a valid association-to-variable. */
8732 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8733 && !gfc_has_vector_subscript (target
));
8735 /* Finally resolve if this is an array or not. */
8736 if (sym
->attr
.dimension
&& target
->rank
== 0)
8738 /* primary.c makes the assumption that a reference to an associate
8739 name followed by a left parenthesis is an array reference. */
8740 if (sym
->ts
.type
!= BT_CHARACTER
)
8741 gfc_error ("Associate-name %qs at %L is used as array",
8742 sym
->name
, &sym
->declared_at
);
8743 sym
->attr
.dimension
= 0;
8748 /* We cannot deal with class selectors that need temporaries. */
8749 if (target
->ts
.type
== BT_CLASS
8750 && gfc_ref_needs_temporary_p (target
->ref
))
8752 gfc_error ("CLASS selector at %L needs a temporary which is not "
8753 "yet implemented", &target
->where
);
8757 if (target
->ts
.type
== BT_CLASS
)
8758 gfc_fix_class_refs (target
);
8760 if (target
->rank
!= 0)
8763 /* The rank may be incorrectly guessed at parsing, therefore make sure
8764 it is corrected now. */
8765 if (sym
->ts
.type
!= BT_CLASS
&& (!sym
->as
|| sym
->assoc
->rankguessed
))
8768 sym
->as
= gfc_get_array_spec ();
8770 as
->rank
= target
->rank
;
8771 as
->type
= AS_DEFERRED
;
8772 as
->corank
= gfc_get_corank (target
);
8773 sym
->attr
.dimension
= 1;
8774 if (as
->corank
!= 0)
8775 sym
->attr
.codimension
= 1;
8777 else if (sym
->ts
.type
== BT_CLASS
&& (!CLASS_DATA (sym
)->as
|| sym
->assoc
->rankguessed
))
8779 if (!CLASS_DATA (sym
)->as
)
8780 CLASS_DATA (sym
)->as
= gfc_get_array_spec ();
8781 as
= CLASS_DATA (sym
)->as
;
8782 as
->rank
= target
->rank
;
8783 as
->type
= AS_DEFERRED
;
8784 as
->corank
= gfc_get_corank (target
);
8785 CLASS_DATA (sym
)->attr
.dimension
= 1;
8786 if (as
->corank
!= 0)
8787 CLASS_DATA (sym
)->attr
.codimension
= 1;
8792 /* target's rank is 0, but the type of the sym is still array valued,
8793 which has to be corrected. */
8794 if (sym
->ts
.type
== BT_CLASS
8795 && CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
8798 symbol_attribute attr
;
8799 /* The associated variable's type is still the array type
8800 correct this now. */
8801 gfc_typespec
*ts
= &target
->ts
;
8804 for (ref
= target
->ref
; ref
!= NULL
; ref
= ref
->next
)
8809 ts
= &ref
->u
.c
.component
->ts
;
8812 if (ts
->type
== BT_CLASS
)
8813 ts
= &ts
->u
.derived
->components
->ts
;
8819 /* Create a scalar instance of the current class type. Because the
8820 rank of a class array goes into its name, the type has to be
8821 rebuild. The alternative of (re-)setting just the attributes
8822 and as in the current type, destroys the type also in other
8826 sym
->ts
.type
= BT_CLASS
;
8827 attr
= CLASS_DATA (sym
)->attr
;
8829 attr
.associate_var
= 1;
8830 attr
.dimension
= attr
.codimension
= 0;
8831 attr
.class_pointer
= 1;
8832 if (!gfc_build_class_symbol (&sym
->ts
, &attr
, &as
))
8834 /* Make sure the _vptr is set. */
8835 c
= gfc_find_component (sym
->ts
.u
.derived
, "_vptr", true, true, NULL
);
8836 if (c
->ts
.u
.derived
== NULL
)
8837 c
->ts
.u
.derived
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
8838 CLASS_DATA (sym
)->attr
.pointer
= 1;
8839 CLASS_DATA (sym
)->attr
.class_pointer
= 1;
8840 gfc_set_sym_referenced (sym
->ts
.u
.derived
);
8841 gfc_commit_symbol (sym
->ts
.u
.derived
);
8842 /* _vptr now has the _vtab in it, change it to the _vtype. */
8843 if (c
->ts
.u
.derived
->attr
.vtab
)
8844 c
->ts
.u
.derived
= c
->ts
.u
.derived
->ts
.u
.derived
;
8845 c
->ts
.u
.derived
->ns
->types_resolved
= 0;
8846 resolve_types (c
->ts
.u
.derived
->ns
);
8850 /* Mark this as an associate variable. */
8851 sym
->attr
.associate_var
= 1;
8853 /* Fix up the type-spec for CHARACTER types. */
8854 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.select_type_temporary
)
8857 sym
->ts
.u
.cl
= target
->ts
.u
.cl
;
8859 if (sym
->ts
.deferred
&& target
->expr_type
== EXPR_VARIABLE
8860 && target
->symtree
->n
.sym
->attr
.dummy
8861 && sym
->ts
.u
.cl
== target
->ts
.u
.cl
)
8863 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8864 sym
->ts
.deferred
= 1;
8867 if (!sym
->ts
.u
.cl
->length
8868 && !sym
->ts
.deferred
8869 && target
->expr_type
== EXPR_CONSTANT
)
8871 sym
->ts
.u
.cl
->length
=
8872 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8873 target
->value
.character
.length
);
8875 else if ((!sym
->ts
.u
.cl
->length
8876 || sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8877 && target
->expr_type
!= EXPR_VARIABLE
)
8879 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
8880 sym
->ts
.deferred
= 1;
8882 /* This is reset in trans-stmt.c after the assignment
8883 of the target expression to the associate name. */
8884 sym
->attr
.allocatable
= 1;
8888 /* If the target is a good class object, so is the associate variable. */
8889 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8890 sym
->attr
.class_ok
= 1;
8894 /* Ensure that SELECT TYPE expressions have the correct rank and a full
8895 array reference, where necessary. The symbols are artificial and so
8896 the dimension attribute and arrayspec can also be set. In addition,
8897 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
8898 This is corrected here as well.*/
8901 fixup_array_ref (gfc_expr
**expr1
, gfc_expr
*expr2
,
8902 int rank
, gfc_ref
*ref
)
8904 gfc_ref
*nref
= (*expr1
)->ref
;
8905 gfc_symbol
*sym1
= (*expr1
)->symtree
->n
.sym
;
8906 gfc_symbol
*sym2
= expr2
? expr2
->symtree
->n
.sym
: NULL
;
8907 (*expr1
)->rank
= rank
;
8908 if (sym1
->ts
.type
== BT_CLASS
)
8910 if ((*expr1
)->ts
.type
!= BT_CLASS
)
8911 (*expr1
)->ts
= sym1
->ts
;
8913 CLASS_DATA (sym1
)->attr
.dimension
= 1;
8914 if (CLASS_DATA (sym1
)->as
== NULL
&& sym2
)
8915 CLASS_DATA (sym1
)->as
8916 = gfc_copy_array_spec (CLASS_DATA (sym2
)->as
);
8920 sym1
->attr
.dimension
= 1;
8921 if (sym1
->as
== NULL
&& sym2
)
8922 sym1
->as
= gfc_copy_array_spec (sym2
->as
);
8925 for (; nref
; nref
= nref
->next
)
8926 if (nref
->next
== NULL
)
8929 if (ref
&& nref
&& nref
->type
!= REF_ARRAY
)
8930 nref
->next
= gfc_copy_ref (ref
);
8931 else if (ref
&& !nref
)
8932 (*expr1
)->ref
= gfc_copy_ref (ref
);
8937 build_loc_call (gfc_expr
*sym_expr
)
8940 loc_call
= gfc_get_expr ();
8941 loc_call
->expr_type
= EXPR_FUNCTION
;
8942 gfc_get_sym_tree ("_loc", gfc_current_ns
, &loc_call
->symtree
, false);
8943 loc_call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
8944 loc_call
->symtree
->n
.sym
->attr
.intrinsic
= 1;
8945 loc_call
->symtree
->n
.sym
->result
= loc_call
->symtree
->n
.sym
;
8946 gfc_commit_symbol (loc_call
->symtree
->n
.sym
);
8947 loc_call
->ts
.type
= BT_INTEGER
;
8948 loc_call
->ts
.kind
= gfc_index_integer_kind
;
8949 loc_call
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LOC
);
8950 loc_call
->value
.function
.actual
= gfc_get_actual_arglist ();
8951 loc_call
->value
.function
.actual
->expr
= sym_expr
;
8952 loc_call
->where
= sym_expr
->where
;
8956 /* Resolve a SELECT TYPE statement. */
8959 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8961 gfc_symbol
*selector_type
;
8962 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8963 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8966 char name
[GFC_MAX_SYMBOL_LEN
];
8970 gfc_ref
* ref
= NULL
;
8971 gfc_expr
*selector_expr
= NULL
;
8973 ns
= code
->ext
.block
.ns
;
8976 /* Check for F03:C813. */
8977 if (code
->expr1
->ts
.type
!= BT_CLASS
8978 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8980 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8981 "at %L", &code
->loc
);
8985 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8990 gfc_ref
*ref2
= NULL
;
8991 for (ref
= code
->expr2
->ref
; ref
!= NULL
; ref
= ref
->next
)
8992 if (ref
->type
== REF_COMPONENT
8993 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
8998 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8999 code
->expr1
->symtree
->n
.sym
->ts
= ref2
->u
.c
.component
->ts
;
9000 selector_type
= CLASS_DATA (ref2
->u
.c
.component
)->ts
.u
.derived
;
9004 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
9005 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
9006 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
9009 if (code
->expr2
->rank
&& CLASS_DATA (code
->expr1
)->as
)
9010 CLASS_DATA (code
->expr1
)->as
->rank
= code
->expr2
->rank
;
9012 /* F2008: C803 The selector expression must not be coindexed. */
9013 if (gfc_is_coindexed (code
->expr2
))
9015 gfc_error ("Selector at %L must not be coindexed",
9016 &code
->expr2
->where
);
9023 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
9025 if (gfc_is_coindexed (code
->expr1
))
9027 gfc_error ("Selector at %L must not be coindexed",
9028 &code
->expr1
->where
);
9033 /* Loop over TYPE IS / CLASS IS cases. */
9034 for (body
= code
->block
; body
; body
= body
->block
)
9036 c
= body
->ext
.block
.case_list
;
9040 /* Check for repeated cases. */
9041 for (tail
= code
->block
; tail
; tail
= tail
->block
)
9043 gfc_case
*d
= tail
->ext
.block
.case_list
;
9047 if (c
->ts
.type
== d
->ts
.type
9048 && ((c
->ts
.type
== BT_DERIVED
9049 && c
->ts
.u
.derived
&& d
->ts
.u
.derived
9050 && !strcmp (c
->ts
.u
.derived
->name
,
9051 d
->ts
.u
.derived
->name
))
9052 || c
->ts
.type
== BT_UNKNOWN
9053 || (!(c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9054 && c
->ts
.kind
== d
->ts
.kind
)))
9056 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9057 &c
->where
, &d
->where
);
9063 /* Check F03:C815. */
9064 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9065 && !selector_type
->attr
.unlimited_polymorphic
9066 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
9068 gfc_error ("Derived type %qs at %L must be extensible",
9069 c
->ts
.u
.derived
->name
, &c
->where
);
9074 /* Check F03:C816. */
9075 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
9076 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
9077 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
9079 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9080 gfc_error ("Derived type %qs at %L must be an extension of %qs",
9081 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
9083 gfc_error ("Unexpected intrinsic type %qs at %L",
9084 gfc_basic_typename (c
->ts
.type
), &c
->where
);
9089 /* Check F03:C814. */
9090 if (c
->ts
.type
== BT_CHARACTER
9091 && (c
->ts
.u
.cl
->length
!= NULL
|| c
->ts
.deferred
))
9093 gfc_error ("The type-spec at %L shall specify that each length "
9094 "type parameter is assumed", &c
->where
);
9099 /* Intercept the DEFAULT case. */
9100 if (c
->ts
.type
== BT_UNKNOWN
)
9102 /* Check F03:C818. */
9105 gfc_error ("The DEFAULT CASE at %L cannot be followed "
9106 "by a second DEFAULT CASE at %L",
9107 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
9112 default_case
= body
;
9119 /* Transform SELECT TYPE statement to BLOCK and associate selector to
9120 target if present. If there are any EXIT statements referring to the
9121 SELECT TYPE construct, this is no problem because the gfc_code
9122 reference stays the same and EXIT is equally possible from the BLOCK
9123 it is changed to. */
9124 code
->op
= EXEC_BLOCK
;
9127 gfc_association_list
* assoc
;
9129 assoc
= gfc_get_association_list ();
9130 assoc
->st
= code
->expr1
->symtree
;
9131 assoc
->target
= gfc_copy_expr (code
->expr2
);
9132 assoc
->target
->where
= code
->expr2
->where
;
9133 /* assoc->variable will be set by resolve_assoc_var. */
9135 code
->ext
.block
.assoc
= assoc
;
9136 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
9138 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
9141 code
->ext
.block
.assoc
= NULL
;
9143 /* Ensure that the selector rank and arrayspec are available to
9144 correct expressions in which they might be missing. */
9145 if (code
->expr2
&& code
->expr2
->rank
)
9147 rank
= code
->expr2
->rank
;
9148 for (ref
= code
->expr2
->ref
; ref
; ref
= ref
->next
)
9149 if (ref
->next
== NULL
)
9151 if (ref
&& ref
->type
== REF_ARRAY
)
9152 ref
= gfc_copy_ref (ref
);
9154 /* Fixup expr1 if necessary. */
9156 fixup_array_ref (&code
->expr1
, code
->expr2
, rank
, ref
);
9158 else if (code
->expr1
->rank
)
9160 rank
= code
->expr1
->rank
;
9161 for (ref
= code
->expr1
->ref
; ref
; ref
= ref
->next
)
9162 if (ref
->next
== NULL
)
9164 if (ref
&& ref
->type
== REF_ARRAY
)
9165 ref
= gfc_copy_ref (ref
);
9168 /* Add EXEC_SELECT to switch on type. */
9169 new_st
= gfc_get_code (code
->op
);
9170 new_st
->expr1
= code
->expr1
;
9171 new_st
->expr2
= code
->expr2
;
9172 new_st
->block
= code
->block
;
9173 code
->expr1
= code
->expr2
= NULL
;
9178 ns
->code
->next
= new_st
;
9180 code
->op
= EXEC_SELECT_TYPE
;
9182 /* Use the intrinsic LOC function to generate an integer expression
9183 for the vtable of the selector. Note that the rank of the selector
9184 expression has to be set to zero. */
9185 gfc_add_vptr_component (code
->expr1
);
9186 code
->expr1
->rank
= 0;
9187 code
->expr1
= build_loc_call (code
->expr1
);
9188 selector_expr
= code
->expr1
->value
.function
.actual
->expr
;
9190 /* Loop over TYPE IS / CLASS IS cases. */
9191 for (body
= code
->block
; body
; body
= body
->block
)
9195 c
= body
->ext
.block
.case_list
;
9197 /* Generate an index integer expression for address of the
9198 TYPE/CLASS vtable and store it in c->low. The hash expression
9199 is stored in c->high and is used to resolve intrinsic cases. */
9200 if (c
->ts
.type
!= BT_UNKNOWN
)
9202 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9204 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9206 c
->high
= gfc_get_int_expr (gfc_integer_4_kind
, NULL
,
9207 c
->ts
.u
.derived
->hash_value
);
9211 vtab
= gfc_find_vtab (&c
->ts
);
9212 gcc_assert (vtab
&& CLASS_DATA (vtab
)->initializer
);
9213 e
= CLASS_DATA (vtab
)->initializer
;
9214 c
->high
= gfc_copy_expr (e
);
9215 if (c
->high
->ts
.kind
!= gfc_integer_4_kind
)
9218 ts
.kind
= gfc_integer_4_kind
;
9219 ts
.type
= BT_INTEGER
;
9220 gfc_convert_type_warn (c
->high
, &ts
, 2, 0);
9224 e
= gfc_lval_expr_from_sym (vtab
);
9225 c
->low
= build_loc_call (e
);
9230 /* Associate temporary to selector. This should only be done
9231 when this case is actually true, so build a new ASSOCIATE
9232 that does precisely this here (instead of using the
9235 if (c
->ts
.type
== BT_CLASS
)
9236 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
9237 else if (c
->ts
.type
== BT_DERIVED
)
9238 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
9239 else if (c
->ts
.type
== BT_CHARACTER
)
9241 HOST_WIDE_INT charlen
= 0;
9242 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
9243 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9244 charlen
= gfc_mpz_get_hwi (c
->ts
.u
.cl
->length
->value
.integer
);
9245 snprintf (name
, sizeof (name
),
9246 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
9247 gfc_basic_typename (c
->ts
.type
), charlen
, c
->ts
.kind
);
9250 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
9253 st
= gfc_find_symtree (ns
->sym_root
, name
);
9254 gcc_assert (st
->n
.sym
->assoc
);
9255 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (selector_expr
->symtree
);
9256 st
->n
.sym
->assoc
->target
->where
= selector_expr
->where
;
9257 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
9259 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
9260 /* Fixup the target expression if necessary. */
9262 fixup_array_ref (&st
->n
.sym
->assoc
->target
, NULL
, rank
, ref
);
9265 new_st
= gfc_get_code (EXEC_BLOCK
);
9266 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
9267 new_st
->ext
.block
.ns
->code
= body
->next
;
9268 body
->next
= new_st
;
9270 /* Chain in the new list only if it is marked as dangling. Otherwise
9271 there is a CASE label overlap and this is already used. Just ignore,
9272 the error is diagnosed elsewhere. */
9273 if (st
->n
.sym
->assoc
->dangling
)
9275 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
9276 st
->n
.sym
->assoc
->dangling
= 0;
9279 resolve_assoc_var (st
->n
.sym
, false);
9282 /* Take out CLASS IS cases for separate treatment. */
9284 while (body
&& body
->block
)
9286 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
9288 /* Add to class_is list. */
9289 if (class_is
== NULL
)
9291 class_is
= body
->block
;
9296 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
9297 tail
->block
= body
->block
;
9300 /* Remove from EXEC_SELECT list. */
9301 body
->block
= body
->block
->block
;
9314 /* Add a default case to hold the CLASS IS cases. */
9315 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
9316 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
9318 tail
->ext
.block
.case_list
= gfc_get_case ();
9319 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
9321 default_case
= tail
;
9324 /* More than one CLASS IS block? */
9325 if (class_is
->block
)
9329 /* Sort CLASS IS blocks by extension level. */
9333 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
9336 /* F03:C817 (check for doubles). */
9337 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
9338 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
9340 gfc_error ("Double CLASS IS block in SELECT TYPE "
9342 &c2
->ext
.block
.case_list
->where
);
9345 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
9346 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
9349 (*c1
)->block
= c2
->block
;
9359 /* Generate IF chain. */
9360 if_st
= gfc_get_code (EXEC_IF
);
9362 for (body
= class_is
; body
; body
= body
->block
)
9364 new_st
->block
= gfc_get_code (EXEC_IF
);
9365 new_st
= new_st
->block
;
9366 /* Set up IF condition: Call _gfortran_is_extension_of. */
9367 new_st
->expr1
= gfc_get_expr ();
9368 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
9369 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
9370 new_st
->expr1
->ts
.kind
= 4;
9371 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
9372 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
9373 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
9374 /* Set up arguments. */
9375 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
9376 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (selector_expr
->symtree
);
9377 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
9378 new_st
->expr1
->where
= code
->loc
;
9379 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
9380 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
9381 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
9382 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
9383 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
9384 new_st
->expr1
->value
.function
.actual
->next
->expr
->where
= code
->loc
;
9385 new_st
->next
= body
->next
;
9387 if (default_case
->next
)
9389 new_st
->block
= gfc_get_code (EXEC_IF
);
9390 new_st
= new_st
->block
;
9391 new_st
->next
= default_case
->next
;
9394 /* Replace CLASS DEFAULT code by the IF chain. */
9395 default_case
->next
= if_st
;
9398 /* Resolve the internal code. This cannot be done earlier because
9399 it requires that the sym->assoc of selectors is set already. */
9400 gfc_current_ns
= ns
;
9401 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
9402 gfc_current_ns
= old_ns
;
9409 /* Resolve a transfer statement. This is making sure that:
9410 -- a derived type being transferred has only non-pointer components
9411 -- a derived type being transferred doesn't have private components, unless
9412 it's being transferred from the module where the type was defined
9413 -- we're not trying to transfer a whole assumed size array. */
9416 resolve_transfer (gfc_code
*code
)
9418 gfc_symbol
*sym
, *derived
;
9422 bool formatted
= false;
9423 gfc_dt
*dt
= code
->ext
.dt
;
9424 gfc_symbol
*dtio_sub
= NULL
;
9428 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
9429 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
9430 exp
= exp
->value
.op
.op1
;
9432 if (exp
&& exp
->expr_type
== EXPR_NULL
9435 gfc_error ("Invalid context for NULL () intrinsic at %L",
9440 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
9441 && exp
->expr_type
!= EXPR_FUNCTION
9442 && exp
->expr_type
!= EXPR_STRUCTURE
))
9445 /* If we are reading, the variable will be changed. Note that
9446 code->ext.dt may be NULL if the TRANSFER is related to
9447 an INQUIRE statement -- but in this case, we are not reading, either. */
9448 if (dt
&& dt
->dt_io_kind
->value
.iokind
== M_READ
9449 && !gfc_check_vardef_context (exp
, false, false, false,
9453 const gfc_typespec
*ts
= exp
->expr_type
== EXPR_STRUCTURE
9454 || exp
->expr_type
== EXPR_FUNCTION
9455 ? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
9457 /* Go to actual component transferred. */
9458 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
9459 if (ref
->type
== REF_COMPONENT
)
9460 ts
= &ref
->u
.c
.component
->ts
;
9462 if (dt
&& dt
->dt_io_kind
->value
.iokind
!= M_INQUIRE
9463 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
))
9465 derived
= ts
->u
.derived
;
9467 /* Determine when to use the formatted DTIO procedure. */
9468 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
9471 write
= dt
->dt_io_kind
->value
.iokind
== M_WRITE
9472 || dt
->dt_io_kind
->value
.iokind
== M_PRINT
;
9473 dtio_sub
= gfc_find_specific_dtio_proc (derived
, write
, formatted
);
9475 if (dtio_sub
!= NULL
&& exp
->expr_type
== EXPR_VARIABLE
)
9478 sym
= exp
->symtree
->n
.sym
->ns
->proc_name
;
9479 /* Check to see if this is a nested DTIO call, with the
9480 dummy as the io-list object. */
9481 if (sym
&& sym
== dtio_sub
&& sym
->formal
9482 && sym
->formal
->sym
== exp
->symtree
->n
.sym
9483 && exp
->ref
== NULL
)
9485 if (!sym
->attr
.recursive
)
9487 gfc_error ("DTIO %s procedure at %L must be recursive",
9488 sym
->name
, &sym
->declared_at
);
9495 if (ts
->type
== BT_CLASS
&& dtio_sub
== NULL
)
9497 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
9498 "it is processed by a defined input/output procedure",
9503 if (ts
->type
== BT_DERIVED
)
9505 /* Check that transferred derived type doesn't contain POINTER
9506 components unless it is processed by a defined input/output
9508 if (ts
->u
.derived
->attr
.pointer_comp
&& dtio_sub
== NULL
)
9510 gfc_error ("Data transfer element at %L cannot have POINTER "
9511 "components unless it is processed by a defined "
9512 "input/output procedure", &code
->loc
);
9517 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
9519 gfc_error ("Data transfer element at %L cannot have "
9520 "procedure pointer components", &code
->loc
);
9524 if (ts
->u
.derived
->attr
.alloc_comp
&& dtio_sub
== NULL
)
9526 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
9527 "components unless it is processed by a defined "
9528 "input/output procedure", &code
->loc
);
9532 /* C_PTR and C_FUNPTR have private components which means they cannot
9533 be printed. However, if -std=gnu and not -pedantic, allow
9534 the component to be printed to help debugging. */
9535 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
9537 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
9538 "cannot have PRIVATE components", &code
->loc
))
9541 else if (derived_inaccessible (ts
->u
.derived
) && dtio_sub
== NULL
)
9543 gfc_error ("Data transfer element at %L cannot have "
9544 "PRIVATE components unless it is processed by "
9545 "a defined input/output procedure", &code
->loc
);
9550 if (exp
->expr_type
== EXPR_STRUCTURE
)
9553 sym
= exp
->symtree
->n
.sym
;
9555 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
9556 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
9558 gfc_error ("Data transfer element at %L cannot be a full reference to "
9559 "an assumed-size array", &code
->loc
);
9563 if (async_io_dt
&& exp
->expr_type
== EXPR_VARIABLE
)
9564 exp
->symtree
->n
.sym
->attr
.asynchronous
= 1;
9568 /*********** Toplevel code resolution subroutines ***********/
9570 /* Find the set of labels that are reachable from this block. We also
9571 record the last statement in each block. */
9574 find_reachable_labels (gfc_code
*block
)
9581 cs_base
->reachable_labels
= bitmap_alloc (&labels_obstack
);
9583 /* Collect labels in this block. We don't keep those corresponding
9584 to END {IF|SELECT}, these are checked in resolve_branch by going
9585 up through the code_stack. */
9586 for (c
= block
; c
; c
= c
->next
)
9588 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
9589 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
9592 /* Merge with labels from parent block. */
9595 gcc_assert (cs_base
->prev
->reachable_labels
);
9596 bitmap_ior_into (cs_base
->reachable_labels
,
9597 cs_base
->prev
->reachable_labels
);
9603 resolve_lock_unlock_event (gfc_code
*code
)
9605 if (code
->expr1
->expr_type
== EXPR_FUNCTION
9606 && code
->expr1
->value
.function
.isym
9607 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9608 remove_caf_get_intrinsic (code
->expr1
);
9610 if ((code
->op
== EXEC_LOCK
|| code
->op
== EXEC_UNLOCK
)
9611 && (code
->expr1
->ts
.type
!= BT_DERIVED
9612 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9613 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
9614 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
9615 || code
->expr1
->rank
!= 0
9616 || (!gfc_is_coarray (code
->expr1
) &&
9617 !gfc_is_coindexed (code
->expr1
))))
9618 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
9619 &code
->expr1
->where
);
9620 else if ((code
->op
== EXEC_EVENT_POST
|| code
->op
== EXEC_EVENT_WAIT
)
9621 && (code
->expr1
->ts
.type
!= BT_DERIVED
9622 || code
->expr1
->expr_type
!= EXPR_VARIABLE
9623 || code
->expr1
->ts
.u
.derived
->from_intmod
9624 != INTMOD_ISO_FORTRAN_ENV
9625 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
9626 != ISOFORTRAN_EVENT_TYPE
9627 || code
->expr1
->rank
!= 0))
9628 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
9629 &code
->expr1
->where
);
9630 else if (code
->op
== EXEC_EVENT_POST
&& !gfc_is_coarray (code
->expr1
)
9631 && !gfc_is_coindexed (code
->expr1
))
9632 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
9633 &code
->expr1
->where
);
9634 else if (code
->op
== EXEC_EVENT_WAIT
&& !gfc_is_coarray (code
->expr1
))
9635 gfc_error ("Event variable argument at %L must be a coarray but not "
9636 "coindexed", &code
->expr1
->where
);
9640 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9641 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9642 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9643 &code
->expr2
->where
);
9646 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
9647 _("STAT variable")))
9652 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9653 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9654 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9655 &code
->expr3
->where
);
9658 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
9659 _("ERRMSG variable")))
9662 /* Check for LOCK the ACQUIRED_LOCK. */
9663 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9664 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
9665 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
9666 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
9667 "variable", &code
->expr4
->where
);
9669 if (code
->op
!= EXEC_EVENT_WAIT
&& code
->expr4
9670 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
9671 _("ACQUIRED_LOCK variable")))
9674 /* Check for EVENT WAIT the UNTIL_COUNT. */
9675 if (code
->op
== EXEC_EVENT_WAIT
&& code
->expr4
)
9677 if (!gfc_resolve_expr (code
->expr4
) || code
->expr4
->ts
.type
!= BT_INTEGER
9678 || code
->expr4
->rank
!= 0)
9679 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
9680 "expression", &code
->expr4
->where
);
9686 resolve_critical (gfc_code
*code
)
9688 gfc_symtree
*symtree
;
9689 gfc_symbol
*lock_type
;
9690 char name
[GFC_MAX_SYMBOL_LEN
];
9691 static int serial
= 0;
9693 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
9696 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
9697 GFC_PREFIX ("lock_type"));
9699 lock_type
= symtree
->n
.sym
;
9702 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
9705 lock_type
= symtree
->n
.sym
;
9706 lock_type
->attr
.flavor
= FL_DERIVED
;
9707 lock_type
->attr
.zero_comp
= 1;
9708 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
9709 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
9712 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
9713 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
9716 code
->resolved_sym
= symtree
->n
.sym
;
9717 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9718 symtree
->n
.sym
->attr
.referenced
= 1;
9719 symtree
->n
.sym
->attr
.artificial
= 1;
9720 symtree
->n
.sym
->attr
.codimension
= 1;
9721 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
9722 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
9723 symtree
->n
.sym
->as
= gfc_get_array_spec ();
9724 symtree
->n
.sym
->as
->corank
= 1;
9725 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
9726 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
9727 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
9729 gfc_commit_symbols();
9734 resolve_sync (gfc_code
*code
)
9736 /* Check imageset. The * case matches expr1 == NULL. */
9739 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
9740 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
9741 "INTEGER expression", &code
->expr1
->where
);
9742 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
9743 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
9744 gfc_error ("Imageset argument at %L must between 1 and num_images()",
9745 &code
->expr1
->where
);
9746 else if (code
->expr1
->expr_type
== EXPR_ARRAY
9747 && gfc_simplify_expr (code
->expr1
, 0))
9749 gfc_constructor
*cons
;
9750 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
9751 for (; cons
; cons
= gfc_constructor_next (cons
))
9752 if (cons
->expr
->expr_type
== EXPR_CONSTANT
9753 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
9754 gfc_error ("Imageset argument at %L must between 1 and "
9755 "num_images()", &cons
->expr
->where
);
9760 gfc_resolve_expr (code
->expr2
);
9762 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
9763 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
9764 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
9765 &code
->expr2
->where
);
9768 gfc_resolve_expr (code
->expr3
);
9770 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
9771 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
9772 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
9773 &code
->expr3
->where
);
9777 /* Given a branch to a label, see if the branch is conforming.
9778 The code node describes where the branch is located. */
9781 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
9788 /* Step one: is this a valid branching target? */
9790 if (label
->defined
== ST_LABEL_UNKNOWN
)
9792 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
9797 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
9799 gfc_error ("Statement at %L is not a valid branch target statement "
9800 "for the branch statement at %L", &label
->where
, &code
->loc
);
9804 /* Step two: make sure this branch is not a branch to itself ;-) */
9806 if (code
->here
== label
)
9809 "Branch at %L may result in an infinite loop", &code
->loc
);
9813 /* Step three: See if the label is in the same block as the
9814 branching statement. The hard work has been done by setting up
9815 the bitmap reachable_labels. */
9817 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
9819 /* Check now whether there is a CRITICAL construct; if so, check
9820 whether the label is still visible outside of the CRITICAL block,
9821 which is invalid. */
9822 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9824 if (stack
->current
->op
== EXEC_CRITICAL
9825 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9826 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9827 "label at %L", &code
->loc
, &label
->where
);
9828 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
9829 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
9830 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9831 "for label at %L", &code
->loc
, &label
->where
);
9837 /* Step four: If we haven't found the label in the bitmap, it may
9838 still be the label of the END of the enclosing block, in which
9839 case we find it by going up the code_stack. */
9841 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
9843 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
9845 if (stack
->current
->op
== EXEC_CRITICAL
)
9847 /* Note: A label at END CRITICAL does not leave the CRITICAL
9848 construct as END CRITICAL is still part of it. */
9849 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9850 " at %L", &code
->loc
, &label
->where
);
9853 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
9855 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9856 "label at %L", &code
->loc
, &label
->where
);
9863 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9867 /* The label is not in an enclosing block, so illegal. This was
9868 allowed in Fortran 66, so we allow it as extension. No
9869 further checks are necessary in this case. */
9870 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9871 "as the GOTO statement at %L", &label
->where
,
9877 /* Check whether EXPR1 has the same shape as EXPR2. */
9880 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9882 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9883 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9884 bool result
= false;
9887 /* Compare the rank. */
9888 if (expr1
->rank
!= expr2
->rank
)
9891 /* Compare the size of each dimension. */
9892 for (i
=0; i
<expr1
->rank
; i
++)
9894 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
9897 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
9900 if (mpz_cmp (shape
[i
], shape2
[i
]))
9904 /* When either of the two expression is an assumed size array, we
9905 ignore the comparison of dimension sizes. */
9910 gfc_clear_shape (shape
, i
);
9911 gfc_clear_shape (shape2
, i
);
9916 /* Check whether a WHERE assignment target or a WHERE mask expression
9917 has the same shape as the outmost WHERE mask expression. */
9920 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9926 cblock
= code
->block
;
9928 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9929 In case of nested WHERE, only the outmost one is stored. */
9930 if (mask
== NULL
) /* outmost WHERE */
9932 else /* inner WHERE */
9939 /* Check if the mask-expr has a consistent shape with the
9940 outmost WHERE mask-expr. */
9941 if (!resolve_where_shape (cblock
->expr1
, e
))
9942 gfc_error ("WHERE mask at %L has inconsistent shape",
9943 &cblock
->expr1
->where
);
9946 /* the assignment statement of a WHERE statement, or the first
9947 statement in where-body-construct of a WHERE construct */
9948 cnext
= cblock
->next
;
9953 /* WHERE assignment statement */
9956 /* Check shape consistent for WHERE assignment target. */
9957 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
9958 gfc_error ("WHERE assignment target at %L has "
9959 "inconsistent shape", &cnext
->expr1
->where
);
9963 case EXEC_ASSIGN_CALL
:
9964 resolve_call (cnext
);
9965 if (!cnext
->resolved_sym
->attr
.elemental
)
9966 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9967 &cnext
->ext
.actual
->expr
->where
);
9970 /* WHERE or WHERE construct is part of a where-body-construct */
9972 resolve_where (cnext
, e
);
9976 gfc_error ("Unsupported statement inside WHERE at %L",
9979 /* the next statement within the same where-body-construct */
9980 cnext
= cnext
->next
;
9982 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9983 cblock
= cblock
->block
;
9988 /* Resolve assignment in FORALL construct.
9989 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9990 FORALL index variables. */
9993 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9997 for (n
= 0; n
< nvar
; n
++)
9999 gfc_symbol
*forall_index
;
10001 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
10003 /* Check whether the assignment target is one of the FORALL index
10005 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
10006 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
10007 gfc_error ("Assignment to a FORALL index variable at %L",
10008 &code
->expr1
->where
);
10011 /* If one of the FORALL index variables doesn't appear in the
10012 assignment variable, then there could be a many-to-one
10013 assignment. Emit a warning rather than an error because the
10014 mask could be resolving this problem. */
10015 if (!find_forall_index (code
->expr1
, forall_index
, 0))
10016 gfc_warning (0, "The FORALL with index %qs is not used on the "
10017 "left side of the assignment at %L and so might "
10018 "cause multiple assignment to this object",
10019 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
10025 /* Resolve WHERE statement in FORALL construct. */
10028 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
10029 gfc_expr
**var_expr
)
10034 cblock
= code
->block
;
10037 /* the assignment statement of a WHERE statement, or the first
10038 statement in where-body-construct of a WHERE construct */
10039 cnext
= cblock
->next
;
10044 /* WHERE assignment statement */
10046 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
10049 /* WHERE operator assignment statement */
10050 case EXEC_ASSIGN_CALL
:
10051 resolve_call (cnext
);
10052 if (!cnext
->resolved_sym
->attr
.elemental
)
10053 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10054 &cnext
->ext
.actual
->expr
->where
);
10057 /* WHERE or WHERE construct is part of a where-body-construct */
10059 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
10063 gfc_error ("Unsupported statement inside WHERE at %L",
10066 /* the next statement within the same where-body-construct */
10067 cnext
= cnext
->next
;
10069 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10070 cblock
= cblock
->block
;
10075 /* Traverse the FORALL body to check whether the following errors exist:
10076 1. For assignment, check if a many-to-one assignment happens.
10077 2. For WHERE statement, check the WHERE body to see if there is any
10078 many-to-one assignment. */
10081 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
10085 c
= code
->block
->next
;
10091 case EXEC_POINTER_ASSIGN
:
10092 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
10095 case EXEC_ASSIGN_CALL
:
10099 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10100 there is no need to handle it here. */
10104 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
10109 /* The next statement in the FORALL body. */
10115 /* Counts the number of iterators needed inside a forall construct, including
10116 nested forall constructs. This is used to allocate the needed memory
10117 in gfc_resolve_forall. */
10120 gfc_count_forall_iterators (gfc_code
*code
)
10122 int max_iters
, sub_iters
, current_iters
;
10123 gfc_forall_iterator
*fa
;
10125 gcc_assert(code
->op
== EXEC_FORALL
);
10129 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10132 code
= code
->block
->next
;
10136 if (code
->op
== EXEC_FORALL
)
10138 sub_iters
= gfc_count_forall_iterators (code
);
10139 if (sub_iters
> max_iters
)
10140 max_iters
= sub_iters
;
10145 return current_iters
+ max_iters
;
10149 /* Given a FORALL construct, first resolve the FORALL iterator, then call
10150 gfc_resolve_forall_body to resolve the FORALL body. */
10153 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
10155 static gfc_expr
**var_expr
;
10156 static int total_var
= 0;
10157 static int nvar
= 0;
10158 int i
, old_nvar
, tmp
;
10159 gfc_forall_iterator
*fa
;
10163 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "FORALL construct at %L", &code
->loc
))
10166 /* Start to resolve a FORALL construct */
10167 if (forall_save
== 0)
10169 /* Count the total number of FORALL indices in the nested FORALL
10170 construct in order to allocate the VAR_EXPR with proper size. */
10171 total_var
= gfc_count_forall_iterators (code
);
10173 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10174 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
10177 /* The information about FORALL iterator, including FORALL indices start, end
10178 and stride. An outer FORALL indice cannot appear in start, end or stride. */
10179 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
10181 /* Fortran 20008: C738 (R753). */
10182 if (fa
->var
->ref
&& fa
->var
->ref
->type
== REF_ARRAY
)
10184 gfc_error ("FORALL index-name at %L must be a scalar variable "
10185 "of type integer", &fa
->var
->where
);
10189 /* Check if any outer FORALL index name is the same as the current
10191 for (i
= 0; i
< nvar
; i
++)
10193 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
10194 gfc_error ("An outer FORALL construct already has an index "
10195 "with this name %L", &fa
->var
->where
);
10198 /* Record the current FORALL index. */
10199 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
10203 /* No memory leak. */
10204 gcc_assert (nvar
<= total_var
);
10207 /* Resolve the FORALL body. */
10208 gfc_resolve_forall_body (code
, nvar
, var_expr
);
10210 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10211 gfc_resolve_blocks (code
->block
, ns
);
10215 /* Free only the VAR_EXPRs allocated in this frame. */
10216 for (i
= nvar
; i
< tmp
; i
++)
10217 gfc_free_expr (var_expr
[i
]);
10221 /* We are in the outermost FORALL construct. */
10222 gcc_assert (forall_save
== 0);
10224 /* VAR_EXPR is not needed any more. */
10231 /* Resolve a BLOCK construct statement. */
10234 resolve_block_construct (gfc_code
* code
)
10236 /* Resolve the BLOCK's namespace. */
10237 gfc_resolve (code
->ext
.block
.ns
);
10239 /* For an ASSOCIATE block, the associations (and their targets) are already
10240 resolved during resolve_symbol. */
10244 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
10248 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
10252 for (; b
; b
= b
->block
)
10254 t
= gfc_resolve_expr (b
->expr1
);
10255 if (!gfc_resolve_expr (b
->expr2
))
10261 if (t
&& b
->expr1
!= NULL
10262 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
10263 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10269 && b
->expr1
!= NULL
10270 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
10271 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
10276 resolve_branch (b
->label1
, b
);
10280 resolve_block_construct (b
);
10284 case EXEC_SELECT_TYPE
:
10287 case EXEC_DO_WHILE
:
10288 case EXEC_DO_CONCURRENT
:
10289 case EXEC_CRITICAL
:
10292 case EXEC_IOLENGTH
:
10296 case EXEC_OMP_ATOMIC
:
10297 case EXEC_OACC_ATOMIC
:
10299 gfc_omp_atomic_op aop
10300 = (gfc_omp_atomic_op
) (b
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
10302 /* Verify this before calling gfc_resolve_code, which might
10304 gcc_assert (b
->next
&& b
->next
->op
== EXEC_ASSIGN
);
10305 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
)
10306 && b
->next
->next
== NULL
)
10307 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
10308 && b
->next
->next
!= NULL
10309 && b
->next
->next
->op
== EXEC_ASSIGN
10310 && b
->next
->next
->next
== NULL
));
10314 case EXEC_OACC_PARALLEL_LOOP
:
10315 case EXEC_OACC_PARALLEL
:
10316 case EXEC_OACC_KERNELS_LOOP
:
10317 case EXEC_OACC_KERNELS
:
10318 case EXEC_OACC_DATA
:
10319 case EXEC_OACC_HOST_DATA
:
10320 case EXEC_OACC_LOOP
:
10321 case EXEC_OACC_UPDATE
:
10322 case EXEC_OACC_WAIT
:
10323 case EXEC_OACC_CACHE
:
10324 case EXEC_OACC_ENTER_DATA
:
10325 case EXEC_OACC_EXIT_DATA
:
10326 case EXEC_OACC_ROUTINE
:
10327 case EXEC_OMP_CRITICAL
:
10328 case EXEC_OMP_DISTRIBUTE
:
10329 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10330 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10331 case EXEC_OMP_DISTRIBUTE_SIMD
:
10333 case EXEC_OMP_DO_SIMD
:
10334 case EXEC_OMP_MASTER
:
10335 case EXEC_OMP_ORDERED
:
10336 case EXEC_OMP_PARALLEL
:
10337 case EXEC_OMP_PARALLEL_DO
:
10338 case EXEC_OMP_PARALLEL_DO_SIMD
:
10339 case EXEC_OMP_PARALLEL_SECTIONS
:
10340 case EXEC_OMP_PARALLEL_WORKSHARE
:
10341 case EXEC_OMP_SECTIONS
:
10342 case EXEC_OMP_SIMD
:
10343 case EXEC_OMP_SINGLE
:
10344 case EXEC_OMP_TARGET
:
10345 case EXEC_OMP_TARGET_DATA
:
10346 case EXEC_OMP_TARGET_ENTER_DATA
:
10347 case EXEC_OMP_TARGET_EXIT_DATA
:
10348 case EXEC_OMP_TARGET_PARALLEL
:
10349 case EXEC_OMP_TARGET_PARALLEL_DO
:
10350 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10351 case EXEC_OMP_TARGET_SIMD
:
10352 case EXEC_OMP_TARGET_TEAMS
:
10353 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10354 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10355 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10356 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10357 case EXEC_OMP_TARGET_UPDATE
:
10358 case EXEC_OMP_TASK
:
10359 case EXEC_OMP_TASKGROUP
:
10360 case EXEC_OMP_TASKLOOP
:
10361 case EXEC_OMP_TASKLOOP_SIMD
:
10362 case EXEC_OMP_TASKWAIT
:
10363 case EXEC_OMP_TASKYIELD
:
10364 case EXEC_OMP_TEAMS
:
10365 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10366 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10367 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10368 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10369 case EXEC_OMP_WORKSHARE
:
10373 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
10376 gfc_resolve_code (b
->next
, ns
);
10381 /* Does everything to resolve an ordinary assignment. Returns true
10382 if this is an interface assignment. */
10384 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
10391 symbol_attribute attr
;
10393 if (gfc_extend_assign (code
, ns
))
10397 if (code
->op
== EXEC_ASSIGN_CALL
)
10399 lhs
= code
->ext
.actual
->expr
;
10400 rhsptr
= &code
->ext
.actual
->next
->expr
;
10404 gfc_actual_arglist
* args
;
10405 gfc_typebound_proc
* tbp
;
10407 gcc_assert (code
->op
== EXEC_COMPCALL
);
10409 args
= code
->expr1
->value
.compcall
.actual
;
10411 rhsptr
= &args
->next
->expr
;
10413 tbp
= code
->expr1
->value
.compcall
.tbp
;
10414 gcc_assert (!tbp
->is_generic
);
10417 /* Make a temporary rhs when there is a default initializer
10418 and rhs is the same symbol as the lhs. */
10419 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
10420 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
10421 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
10422 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
10423 *rhsptr
= gfc_get_parentheses (*rhsptr
);
10432 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
10433 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
10437 /* Handle the case of a BOZ literal on the RHS. */
10438 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
10441 if (warn_surprising
)
10442 gfc_warning (OPT_Wsurprising
,
10443 "BOZ literal at %L is bitwise transferred "
10444 "non-integer symbol %qs", &code
->loc
,
10445 lhs
->symtree
->n
.sym
->name
);
10447 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
10449 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
10451 if (rc
== ARITH_UNDERFLOW
)
10452 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
10453 ". This check can be disabled with the option "
10454 "%<-fno-range-check%>", &rhs
->where
);
10455 else if (rc
== ARITH_OVERFLOW
)
10456 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
10457 ". This check can be disabled with the option "
10458 "%<-fno-range-check%>", &rhs
->where
);
10459 else if (rc
== ARITH_NAN
)
10460 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
10461 ". This check can be disabled with the option "
10462 "%<-fno-range-check%>", &rhs
->where
);
10467 if (lhs
->ts
.type
== BT_CHARACTER
10468 && warn_character_truncation
)
10470 HOST_WIDE_INT llen
= 0, rlen
= 0;
10471 if (lhs
->ts
.u
.cl
!= NULL
10472 && lhs
->ts
.u
.cl
->length
!= NULL
10473 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10474 llen
= gfc_mpz_get_hwi (lhs
->ts
.u
.cl
->length
->value
.integer
);
10476 if (rhs
->expr_type
== EXPR_CONSTANT
)
10477 rlen
= rhs
->value
.character
.length
;
10479 else if (rhs
->ts
.u
.cl
!= NULL
10480 && rhs
->ts
.u
.cl
->length
!= NULL
10481 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10482 rlen
= gfc_mpz_get_hwi (rhs
->ts
.u
.cl
->length
->value
.integer
);
10484 if (rlen
&& llen
&& rlen
> llen
)
10485 gfc_warning_now (OPT_Wcharacter_truncation
,
10486 "CHARACTER expression will be truncated "
10487 "in assignment (%ld/%ld) at %L",
10488 (long) llen
, (long) rlen
, &code
->loc
);
10491 /* Ensure that a vector index expression for the lvalue is evaluated
10492 to a temporary if the lvalue symbol is referenced in it. */
10495 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
10496 if (ref
->type
== REF_ARRAY
)
10498 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
10499 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
10500 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
10501 ref
->u
.ar
.start
[n
]))
10503 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
10507 if (gfc_pure (NULL
))
10509 if (lhs
->ts
.type
== BT_DERIVED
10510 && lhs
->expr_type
== EXPR_VARIABLE
10511 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10512 && rhs
->expr_type
== EXPR_VARIABLE
10513 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10514 || gfc_is_coindexed (rhs
)))
10516 /* F2008, C1283. */
10517 if (gfc_is_coindexed (rhs
))
10518 gfc_error ("Coindexed expression at %L is assigned to "
10519 "a derived type variable with a POINTER "
10520 "component in a PURE procedure",
10523 gfc_error ("The impure variable at %L is assigned to "
10524 "a derived type variable with a POINTER "
10525 "component in a PURE procedure (12.6)",
10530 /* Fortran 2008, C1283. */
10531 if (gfc_is_coindexed (lhs
))
10533 gfc_error ("Assignment to coindexed variable at %L in a PURE "
10534 "procedure", &rhs
->where
);
10539 if (gfc_implicit_pure (NULL
))
10541 if (lhs
->expr_type
== EXPR_VARIABLE
10542 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
10543 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
10544 gfc_unset_implicit_pure (NULL
);
10546 if (lhs
->ts
.type
== BT_DERIVED
10547 && lhs
->expr_type
== EXPR_VARIABLE
10548 && lhs
->ts
.u
.derived
->attr
.pointer_comp
10549 && rhs
->expr_type
== EXPR_VARIABLE
10550 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
10551 || gfc_is_coindexed (rhs
)))
10552 gfc_unset_implicit_pure (NULL
);
10554 /* Fortran 2008, C1283. */
10555 if (gfc_is_coindexed (lhs
))
10556 gfc_unset_implicit_pure (NULL
);
10559 /* F2008, 7.2.1.2. */
10560 attr
= gfc_expr_attr (lhs
);
10561 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
10563 if (attr
.codimension
)
10565 gfc_error ("Assignment to polymorphic coarray at %L is not "
10566 "permitted", &lhs
->where
);
10569 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
10570 "polymorphic variable at %L", &lhs
->where
))
10572 if (!flag_realloc_lhs
)
10574 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
10575 "requires %<-frealloc-lhs%>", &lhs
->where
);
10579 else if (lhs
->ts
.type
== BT_CLASS
)
10581 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
10582 "assignment at %L - check that there is a matching specific "
10583 "subroutine for '=' operator", &lhs
->where
);
10587 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
10589 /* F2008, Section 7.2.1.2. */
10590 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
10592 gfc_error ("Coindexed variable must not have an allocatable ultimate "
10593 "component in assignment at %L", &lhs
->where
);
10597 /* Assign the 'data' of a class object to a derived type. */
10598 if (lhs
->ts
.type
== BT_DERIVED
10599 && rhs
->ts
.type
== BT_CLASS
10600 && rhs
->expr_type
!= EXPR_ARRAY
)
10601 gfc_add_data_component (rhs
);
10603 /* Make sure there is a vtable and, in particular, a _copy for the
10605 if (UNLIMITED_POLY (lhs
) && lhs
->rank
&& rhs
->ts
.type
!= BT_CLASS
)
10606 gfc_find_vtab (&rhs
->ts
);
10608 bool caf_convert_to_send
= flag_coarray
== GFC_FCOARRAY_LIB
10610 || (code
->expr2
->expr_type
== EXPR_FUNCTION
10611 && code
->expr2
->value
.function
.isym
10612 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
10613 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
10614 && !gfc_expr_attr (rhs
).allocatable
10615 && !gfc_has_vector_subscript (rhs
)));
10617 gfc_check_assign (lhs
, rhs
, 1, !caf_convert_to_send
);
10619 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
10620 Additionally, insert this code when the RHS is a CAF as we then use the
10621 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
10622 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
10623 noncoindexed array and the RHS is a coindexed scalar, use the normal code
10625 if (caf_convert_to_send
)
10627 if (code
->expr2
->expr_type
== EXPR_FUNCTION
10628 && code
->expr2
->value
.function
.isym
10629 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10630 remove_caf_get_intrinsic (code
->expr2
);
10631 code
->op
= EXEC_CALL
;
10632 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
10633 code
->resolved_sym
= code
->symtree
->n
.sym
;
10634 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
10635 code
->resolved_sym
->attr
.intrinsic
= 1;
10636 code
->resolved_sym
->attr
.subroutine
= 1;
10637 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10638 gfc_commit_symbol (code
->resolved_sym
);
10639 code
->ext
.actual
= gfc_get_actual_arglist ();
10640 code
->ext
.actual
->expr
= lhs
;
10641 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
10642 code
->ext
.actual
->next
->expr
= rhs
;
10643 code
->expr1
= NULL
;
10644 code
->expr2
= NULL
;
10651 /* Add a component reference onto an expression. */
10654 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
10659 ref
= &((*ref
)->next
);
10660 *ref
= gfc_get_ref ();
10661 (*ref
)->type
= REF_COMPONENT
;
10662 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
10663 (*ref
)->u
.c
.component
= c
;
10666 /* Add a full array ref, as necessary. */
10669 gfc_add_full_array_ref (e
, c
->as
);
10670 e
->rank
= c
->as
->rank
;
10675 /* Build an assignment. Keep the argument 'op' for future use, so that
10676 pointer assignments can be made. */
10679 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
10680 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
10682 gfc_code
*this_code
;
10684 this_code
= gfc_get_code (op
);
10685 this_code
->next
= NULL
;
10686 this_code
->expr1
= gfc_copy_expr (expr1
);
10687 this_code
->expr2
= gfc_copy_expr (expr2
);
10688 this_code
->loc
= loc
;
10689 if (comp1
&& comp2
)
10691 add_comp_ref (this_code
->expr1
, comp1
);
10692 add_comp_ref (this_code
->expr2
, comp2
);
10699 /* Makes a temporary variable expression based on the characteristics of
10700 a given variable expression. */
10703 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
10705 static int serial
= 0;
10706 char name
[GFC_MAX_SYMBOL_LEN
];
10708 gfc_array_spec
*as
;
10709 gfc_array_ref
*aref
;
10712 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
10713 gfc_get_sym_tree (name
, ns
, &tmp
, false);
10714 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
10716 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_CHARACTER
)
10717 tmp
->n
.sym
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
10719 e
->value
.character
.length
);
10725 /* Obtain the arrayspec for the temporary. */
10726 if (e
->rank
&& e
->expr_type
!= EXPR_ARRAY
10727 && e
->expr_type
!= EXPR_FUNCTION
10728 && e
->expr_type
!= EXPR_OP
)
10730 aref
= gfc_find_array_ref (e
);
10731 if (e
->expr_type
== EXPR_VARIABLE
10732 && e
->symtree
->n
.sym
->as
== aref
->as
)
10736 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
10737 if (ref
->type
== REF_COMPONENT
10738 && ref
->u
.c
.component
->as
== aref
->as
)
10746 /* Add the attributes and the arrayspec to the temporary. */
10747 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
10748 tmp
->n
.sym
->attr
.function
= 0;
10749 tmp
->n
.sym
->attr
.result
= 0;
10750 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
10751 tmp
->n
.sym
->attr
.dummy
= 0;
10752 tmp
->n
.sym
->attr
.intent
= INTENT_UNKNOWN
;
10756 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
10759 if (as
->type
== AS_DEFERRED
)
10760 tmp
->n
.sym
->attr
.allocatable
= 1;
10762 else if (e
->rank
&& (e
->expr_type
== EXPR_ARRAY
10763 || e
->expr_type
== EXPR_FUNCTION
10764 || e
->expr_type
== EXPR_OP
))
10766 tmp
->n
.sym
->as
= gfc_get_array_spec ();
10767 tmp
->n
.sym
->as
->type
= AS_DEFERRED
;
10768 tmp
->n
.sym
->as
->rank
= e
->rank
;
10769 tmp
->n
.sym
->attr
.allocatable
= 1;
10770 tmp
->n
.sym
->attr
.dimension
= 1;
10773 tmp
->n
.sym
->attr
.dimension
= 0;
10775 gfc_set_sym_referenced (tmp
->n
.sym
);
10776 gfc_commit_symbol (tmp
->n
.sym
);
10777 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
10779 /* Should the lhs be a section, use its array ref for the
10780 temporary expression. */
10781 if (aref
&& aref
->type
!= AR_FULL
)
10783 gfc_free_ref_list (e
->ref
);
10784 e
->ref
= gfc_copy_ref (ref
);
10790 /* Add one line of code to the code chain, making sure that 'head' and
10791 'tail' are appropriately updated. */
10794 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
10796 gcc_assert (this_code
);
10798 *head
= *tail
= *this_code
;
10800 *tail
= gfc_append_code (*tail
, *this_code
);
10805 /* Counts the potential number of part array references that would
10806 result from resolution of typebound defined assignments. */
10809 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
10812 int c_depth
= 0, t_depth
;
10814 for (c
= derived
->components
; c
; c
= c
->next
)
10816 if ((!gfc_bt_struct (c
->ts
.type
)
10818 || c
->attr
.allocatable
10819 || c
->attr
.proc_pointer_comp
10820 || c
->attr
.class_pointer
10821 || c
->attr
.proc_pointer
)
10822 && !c
->attr
.defined_assign_comp
)
10825 if (c
->as
&& c_depth
== 0)
10828 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
10829 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
10834 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
10836 return depth
+ c_depth
;
10840 /* Implement 7.2.1.3 of the F08 standard:
10841 "An intrinsic assignment where the variable is of derived type is
10842 performed as if each component of the variable were assigned from the
10843 corresponding component of expr using pointer assignment (7.2.2) for
10844 each pointer component, defined assignment for each nonpointer
10845 nonallocatable component of a type that has a type-bound defined
10846 assignment consistent with the component, intrinsic assignment for
10847 each other nonpointer nonallocatable component, ..."
10849 The pointer assignments are taken care of by the intrinsic
10850 assignment of the structure itself. This function recursively adds
10851 defined assignments where required. The recursion is accomplished
10852 by calling gfc_resolve_code.
10854 When the lhs in a defined assignment has intent INOUT, we need a
10855 temporary for the lhs. In pseudo-code:
10857 ! Only call function lhs once.
10858 if (lhs is not a constant or an variable)
10861 ! Do the intrinsic assignment
10863 ! Now do the defined assignments
10864 do over components with typebound defined assignment [%cmp]
10865 #if one component's assignment procedure is INOUT
10867 #if expr2 non-variable
10873 t1%cmp {defined=} expr2%cmp
10879 expr1%cmp {defined=} expr2%cmp
10883 /* The temporary assignments have to be put on top of the additional
10884 code to avoid the result being changed by the intrinsic assignment.
10886 static int component_assignment_level
= 0;
10887 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
10890 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
10892 gfc_component
*comp1
, *comp2
;
10893 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
10895 int error_count
, depth
;
10897 gfc_get_errors (NULL
, &error_count
);
10899 /* Filter out continuing processing after an error. */
10901 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
10902 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
10905 /* TODO: Handle more than one part array reference in assignments. */
10906 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
10907 (*code
)->expr1
->rank
? 1 : 0);
10910 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10911 "done because multiple part array references would "
10912 "occur in intermediate expressions.", &(*code
)->loc
);
10916 component_assignment_level
++;
10918 /* Create a temporary so that functions get called only once. */
10919 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
10920 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
10922 gfc_expr
*tmp_expr
;
10924 /* Assign the rhs to the temporary. */
10925 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
10926 this_code
= build_assignment (EXEC_ASSIGN
,
10927 tmp_expr
, (*code
)->expr2
,
10928 NULL
, NULL
, (*code
)->loc
);
10929 /* Add the code and substitute the rhs expression. */
10930 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
10931 gfc_free_expr ((*code
)->expr2
);
10932 (*code
)->expr2
= tmp_expr
;
10935 /* Do the intrinsic assignment. This is not needed if the lhs is one
10936 of the temporaries generated here, since the intrinsic assignment
10937 to the final result already does this. */
10938 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
10940 this_code
= build_assignment (EXEC_ASSIGN
,
10941 (*code
)->expr1
, (*code
)->expr2
,
10942 NULL
, NULL
, (*code
)->loc
);
10943 add_code_to_chain (&this_code
, &head
, &tail
);
10946 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
10947 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
10950 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
10952 bool inout
= false;
10954 /* The intrinsic assignment does the right thing for pointers
10955 of all kinds and allocatable components. */
10956 if (!gfc_bt_struct (comp1
->ts
.type
)
10957 || comp1
->attr
.pointer
10958 || comp1
->attr
.allocatable
10959 || comp1
->attr
.proc_pointer_comp
10960 || comp1
->attr
.class_pointer
10961 || comp1
->attr
.proc_pointer
)
10964 /* Make an assigment for this component. */
10965 this_code
= build_assignment (EXEC_ASSIGN
,
10966 (*code
)->expr1
, (*code
)->expr2
,
10967 comp1
, comp2
, (*code
)->loc
);
10969 /* Convert the assignment if there is a defined assignment for
10970 this type. Otherwise, using the call from gfc_resolve_code,
10971 recurse into its components. */
10972 gfc_resolve_code (this_code
, ns
);
10974 if (this_code
->op
== EXEC_ASSIGN_CALL
)
10976 gfc_formal_arglist
*dummy_args
;
10978 /* Check that there is a typebound defined assignment. If not,
10979 then this must be a module defined assignment. We cannot
10980 use the defined_assign_comp attribute here because it must
10981 be this derived type that has the defined assignment and not
10983 if (!(comp1
->ts
.u
.derived
->f2k_derived
10984 && comp1
->ts
.u
.derived
->f2k_derived
10985 ->tb_op
[INTRINSIC_ASSIGN
]))
10987 gfc_free_statements (this_code
);
10992 /* If the first argument of the subroutine has intent INOUT
10993 a temporary must be generated and used instead. */
10994 rsym
= this_code
->resolved_sym
;
10995 dummy_args
= gfc_sym_get_dummy_args (rsym
);
10997 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
10999 gfc_code
*temp_code
;
11002 /* Build the temporary required for the assignment and put
11003 it at the head of the generated code. */
11006 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
11007 temp_code
= build_assignment (EXEC_ASSIGN
,
11008 t1
, (*code
)->expr1
,
11009 NULL
, NULL
, (*code
)->loc
);
11011 /* For allocatable LHS, check whether it is allocated. Note
11012 that allocatable components with defined assignment are
11013 not yet support. See PR 57696. */
11014 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
11018 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11019 block
= gfc_get_code (EXEC_IF
);
11020 block
->block
= gfc_get_code (EXEC_IF
);
11021 block
->block
->expr1
11022 = gfc_build_intrinsic_call (ns
,
11023 GFC_ISYM_ALLOCATED
, "allocated",
11024 (*code
)->loc
, 1, e
);
11025 block
->block
->next
= temp_code
;
11028 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
11031 /* Replace the first actual arg with the component of the
11033 gfc_free_expr (this_code
->ext
.actual
->expr
);
11034 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
11035 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
11037 /* If the LHS variable is allocatable and wasn't allocated and
11038 the temporary is allocatable, pointer assign the address of
11039 the freshly allocated LHS to the temporary. */
11040 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11041 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11046 cond
= gfc_get_expr ();
11047 cond
->ts
.type
= BT_LOGICAL
;
11048 cond
->ts
.kind
= gfc_default_logical_kind
;
11049 cond
->expr_type
= EXPR_OP
;
11050 cond
->where
= (*code
)->loc
;
11051 cond
->value
.op
.op
= INTRINSIC_NOT
;
11052 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
11053 GFC_ISYM_ALLOCATED
, "allocated",
11054 (*code
)->loc
, 1, gfc_copy_expr (t1
));
11055 block
= gfc_get_code (EXEC_IF
);
11056 block
->block
= gfc_get_code (EXEC_IF
);
11057 block
->block
->expr1
= cond
;
11058 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11059 t1
, (*code
)->expr1
,
11060 NULL
, NULL
, (*code
)->loc
);
11061 add_code_to_chain (&block
, &head
, &tail
);
11065 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
11067 /* Don't add intrinsic assignments since they are already
11068 effected by the intrinsic assignment of the structure. */
11069 gfc_free_statements (this_code
);
11074 add_code_to_chain (&this_code
, &head
, &tail
);
11078 /* Transfer the value to the final result. */
11079 this_code
= build_assignment (EXEC_ASSIGN
,
11080 (*code
)->expr1
, t1
,
11081 comp1
, comp2
, (*code
)->loc
);
11082 add_code_to_chain (&this_code
, &head
, &tail
);
11086 /* Put the temporary assignments at the top of the generated code. */
11087 if (tmp_head
&& component_assignment_level
== 1)
11089 gfc_append_code (tmp_head
, head
);
11091 tmp_head
= tmp_tail
= NULL
;
11094 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11095 // not accidentally deallocated. Hence, nullify t1.
11096 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
11097 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
11103 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
11104 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
11105 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
11106 block
= gfc_get_code (EXEC_IF
);
11107 block
->block
= gfc_get_code (EXEC_IF
);
11108 block
->block
->expr1
= cond
;
11109 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
11110 t1
, gfc_get_null_expr (&(*code
)->loc
),
11111 NULL
, NULL
, (*code
)->loc
);
11112 gfc_append_code (tail
, block
);
11116 /* Now attach the remaining code chain to the input code. Step on
11117 to the end of the new code since resolution is complete. */
11118 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
11119 tail
->next
= (*code
)->next
;
11120 /* Overwrite 'code' because this would place the intrinsic assignment
11121 before the temporary for the lhs is created. */
11122 gfc_free_expr ((*code
)->expr1
);
11123 gfc_free_expr ((*code
)->expr2
);
11129 component_assignment_level
--;
11133 /* F2008: Pointer function assignments are of the form:
11134 ptr_fcn (args) = expr
11135 This function breaks these assignments into two statements:
11136 temporary_pointer => ptr_fcn(args)
11137 temporary_pointer = expr */
11140 resolve_ptr_fcn_assign (gfc_code
**code
, gfc_namespace
*ns
)
11142 gfc_expr
*tmp_ptr_expr
;
11143 gfc_code
*this_code
;
11144 gfc_component
*comp
;
11147 if ((*code
)->expr1
->expr_type
!= EXPR_FUNCTION
)
11150 /* Even if standard does not support this feature, continue to build
11151 the two statements to avoid upsetting frontend_passes.c. */
11152 gfc_notify_std (GFC_STD_F2008
, "Pointer procedure assignment at "
11153 "%L", &(*code
)->loc
);
11155 comp
= gfc_get_proc_ptr_comp ((*code
)->expr1
);
11158 s
= comp
->ts
.interface
;
11160 s
= (*code
)->expr1
->symtree
->n
.sym
;
11162 if (s
== NULL
|| !s
->result
->attr
.pointer
)
11164 gfc_error ("The function result on the lhs of the assignment at "
11165 "%L must have the pointer attribute.",
11166 &(*code
)->expr1
->where
);
11167 (*code
)->op
= EXEC_NOP
;
11171 tmp_ptr_expr
= get_temp_from_expr ((*code
)->expr2
, ns
);
11173 /* get_temp_from_expression is set up for ordinary assignments. To that
11174 end, where array bounds are not known, arrays are made allocatable.
11175 Change the temporary to a pointer here. */
11176 tmp_ptr_expr
->symtree
->n
.sym
->attr
.pointer
= 1;
11177 tmp_ptr_expr
->symtree
->n
.sym
->attr
.allocatable
= 0;
11178 tmp_ptr_expr
->where
= (*code
)->loc
;
11180 this_code
= build_assignment (EXEC_ASSIGN
,
11181 tmp_ptr_expr
, (*code
)->expr2
,
11182 NULL
, NULL
, (*code
)->loc
);
11183 this_code
->next
= (*code
)->next
;
11184 (*code
)->next
= this_code
;
11185 (*code
)->op
= EXEC_POINTER_ASSIGN
;
11186 (*code
)->expr2
= (*code
)->expr1
;
11187 (*code
)->expr1
= tmp_ptr_expr
;
11193 /* Deferred character length assignments from an operator expression
11194 require a temporary because the character length of the lhs can
11195 change in the course of the assignment. */
11198 deferred_op_assign (gfc_code
**code
, gfc_namespace
*ns
)
11200 gfc_expr
*tmp_expr
;
11201 gfc_code
*this_code
;
11203 if (!((*code
)->expr1
->ts
.type
== BT_CHARACTER
11204 && (*code
)->expr1
->ts
.deferred
&& (*code
)->expr1
->rank
11205 && (*code
)->expr2
->expr_type
== EXPR_OP
))
11208 if (!gfc_check_dependency ((*code
)->expr1
, (*code
)->expr2
, 1))
11211 if (gfc_expr_attr ((*code
)->expr1
).pointer
)
11214 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
11215 tmp_expr
->where
= (*code
)->loc
;
11217 /* A new charlen is required to ensure that the variable string
11218 length is different to that of the original lhs. */
11219 tmp_expr
->ts
.u
.cl
= gfc_get_charlen();
11220 tmp_expr
->symtree
->n
.sym
->ts
.u
.cl
= tmp_expr
->ts
.u
.cl
;
11221 tmp_expr
->ts
.u
.cl
->next
= (*code
)->expr2
->ts
.u
.cl
->next
;
11222 (*code
)->expr2
->ts
.u
.cl
->next
= tmp_expr
->ts
.u
.cl
;
11224 tmp_expr
->symtree
->n
.sym
->ts
.deferred
= 1;
11226 this_code
= build_assignment (EXEC_ASSIGN
,
11228 gfc_copy_expr (tmp_expr
),
11229 NULL
, NULL
, (*code
)->loc
);
11231 (*code
)->expr1
= tmp_expr
;
11233 this_code
->next
= (*code
)->next
;
11234 (*code
)->next
= this_code
;
11240 /* Given a block of code, recursively resolve everything pointed to by this
11244 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
11246 int omp_workshare_save
;
11247 int forall_save
, do_concurrent_save
;
11251 frame
.prev
= cs_base
;
11255 find_reachable_labels (code
);
11257 for (; code
; code
= code
->next
)
11259 frame
.current
= code
;
11260 forall_save
= forall_flag
;
11261 do_concurrent_save
= gfc_do_concurrent_flag
;
11263 if (code
->op
== EXEC_FORALL
)
11266 gfc_resolve_forall (code
, ns
, forall_save
);
11269 else if (code
->block
)
11271 omp_workshare_save
= -1;
11274 case EXEC_OACC_PARALLEL_LOOP
:
11275 case EXEC_OACC_PARALLEL
:
11276 case EXEC_OACC_KERNELS_LOOP
:
11277 case EXEC_OACC_KERNELS
:
11278 case EXEC_OACC_DATA
:
11279 case EXEC_OACC_HOST_DATA
:
11280 case EXEC_OACC_LOOP
:
11281 gfc_resolve_oacc_blocks (code
, ns
);
11283 case EXEC_OMP_PARALLEL_WORKSHARE
:
11284 omp_workshare_save
= omp_workshare_flag
;
11285 omp_workshare_flag
= 1;
11286 gfc_resolve_omp_parallel_blocks (code
, ns
);
11288 case EXEC_OMP_PARALLEL
:
11289 case EXEC_OMP_PARALLEL_DO
:
11290 case EXEC_OMP_PARALLEL_DO_SIMD
:
11291 case EXEC_OMP_PARALLEL_SECTIONS
:
11292 case EXEC_OMP_TARGET_PARALLEL
:
11293 case EXEC_OMP_TARGET_PARALLEL_DO
:
11294 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11295 case EXEC_OMP_TARGET_TEAMS
:
11296 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11297 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11298 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11299 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11300 case EXEC_OMP_TASK
:
11301 case EXEC_OMP_TASKLOOP
:
11302 case EXEC_OMP_TASKLOOP_SIMD
:
11303 case EXEC_OMP_TEAMS
:
11304 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11305 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11306 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11307 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11308 omp_workshare_save
= omp_workshare_flag
;
11309 omp_workshare_flag
= 0;
11310 gfc_resolve_omp_parallel_blocks (code
, ns
);
11312 case EXEC_OMP_DISTRIBUTE
:
11313 case EXEC_OMP_DISTRIBUTE_SIMD
:
11315 case EXEC_OMP_DO_SIMD
:
11316 case EXEC_OMP_SIMD
:
11317 case EXEC_OMP_TARGET_SIMD
:
11318 gfc_resolve_omp_do_blocks (code
, ns
);
11320 case EXEC_SELECT_TYPE
:
11321 /* Blocks are handled in resolve_select_type because we have
11322 to transform the SELECT TYPE into ASSOCIATE first. */
11324 case EXEC_DO_CONCURRENT
:
11325 gfc_do_concurrent_flag
= 1;
11326 gfc_resolve_blocks (code
->block
, ns
);
11327 gfc_do_concurrent_flag
= 2;
11329 case EXEC_OMP_WORKSHARE
:
11330 omp_workshare_save
= omp_workshare_flag
;
11331 omp_workshare_flag
= 1;
11334 gfc_resolve_blocks (code
->block
, ns
);
11338 if (omp_workshare_save
!= -1)
11339 omp_workshare_flag
= omp_workshare_save
;
11343 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
11344 t
= gfc_resolve_expr (code
->expr1
);
11345 forall_flag
= forall_save
;
11346 gfc_do_concurrent_flag
= do_concurrent_save
;
11348 if (!gfc_resolve_expr (code
->expr2
))
11351 if (code
->op
== EXEC_ALLOCATE
11352 && !gfc_resolve_expr (code
->expr3
))
11358 case EXEC_END_BLOCK
:
11359 case EXEC_END_NESTED_BLOCK
:
11363 case EXEC_ERROR_STOP
:
11365 case EXEC_CONTINUE
:
11367 case EXEC_ASSIGN_CALL
:
11370 case EXEC_CRITICAL
:
11371 resolve_critical (code
);
11374 case EXEC_SYNC_ALL
:
11375 case EXEC_SYNC_IMAGES
:
11376 case EXEC_SYNC_MEMORY
:
11377 resolve_sync (code
);
11382 case EXEC_EVENT_POST
:
11383 case EXEC_EVENT_WAIT
:
11384 resolve_lock_unlock_event (code
);
11387 case EXEC_FAIL_IMAGE
:
11388 case EXEC_FORM_TEAM
:
11389 case EXEC_CHANGE_TEAM
:
11390 case EXEC_END_TEAM
:
11391 case EXEC_SYNC_TEAM
:
11395 /* Keep track of which entry we are up to. */
11396 current_entry_id
= code
->ext
.entry
->id
;
11400 resolve_where (code
, NULL
);
11404 if (code
->expr1
!= NULL
)
11406 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
11407 gfc_error ("ASSIGNED GOTO statement at %L requires an "
11408 "INTEGER variable", &code
->expr1
->where
);
11409 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
11410 gfc_error ("Variable %qs has not been assigned a target "
11411 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
11412 &code
->expr1
->where
);
11415 resolve_branch (code
->label1
, code
);
11419 if (code
->expr1
!= NULL
11420 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
11421 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
11422 "INTEGER return specifier", &code
->expr1
->where
);
11425 case EXEC_INIT_ASSIGN
:
11426 case EXEC_END_PROCEDURE
:
11433 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
11435 if (code
->expr1
->expr_type
== EXPR_FUNCTION
11436 && code
->expr1
->value
.function
.isym
11437 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11438 remove_caf_get_intrinsic (code
->expr1
);
11440 /* If this is a pointer function in an lvalue variable context,
11441 the new code will have to be resolved afresh. This is also the
11442 case with an error, where the code is transformed into NOP to
11443 prevent ICEs downstream. */
11444 if (resolve_ptr_fcn_assign (&code
, ns
)
11445 || code
->op
== EXEC_NOP
)
11448 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
11452 if (resolve_ordinary_assign (code
, ns
))
11454 if (code
->op
== EXEC_COMPCALL
)
11460 /* Check for dependencies in deferred character length array
11461 assignments and generate a temporary, if necessary. */
11462 if (code
->op
== EXEC_ASSIGN
&& deferred_op_assign (&code
, ns
))
11465 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
11466 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
11467 && code
->expr1
->ts
.u
.derived
11468 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
11469 generate_component_assignments (&code
, ns
);
11473 case EXEC_LABEL_ASSIGN
:
11474 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
11475 gfc_error ("Label %d referenced at %L is never defined",
11476 code
->label1
->value
, &code
->label1
->where
);
11478 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
11479 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
11480 || code
->expr1
->symtree
->n
.sym
->ts
.kind
11481 != gfc_default_integer_kind
11482 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
11483 gfc_error ("ASSIGN statement at %L requires a scalar "
11484 "default INTEGER variable", &code
->expr1
->where
);
11487 case EXEC_POINTER_ASSIGN
:
11494 /* This is both a variable definition and pointer assignment
11495 context, so check both of them. For rank remapping, a final
11496 array ref may be present on the LHS and fool gfc_expr_attr
11497 used in gfc_check_vardef_context. Remove it. */
11498 e
= remove_last_array_ref (code
->expr1
);
11499 t
= gfc_check_vardef_context (e
, true, false, false,
11500 _("pointer assignment"));
11502 t
= gfc_check_vardef_context (e
, false, false, false,
11503 _("pointer assignment"));
11506 t
= gfc_check_pointer_assign (code
->expr1
, code
->expr2
, !t
) && t
;
11511 /* Assigning a class object always is a regular assign. */
11512 if (code
->expr2
->ts
.type
== BT_CLASS
11513 && code
->expr1
->ts
.type
== BT_CLASS
11514 && !CLASS_DATA (code
->expr2
)->attr
.dimension
11515 && !(gfc_expr_attr (code
->expr1
).proc_pointer
11516 && code
->expr2
->expr_type
== EXPR_VARIABLE
11517 && code
->expr2
->symtree
->n
.sym
->attr
.flavor
11519 code
->op
= EXEC_ASSIGN
;
11523 case EXEC_ARITHMETIC_IF
:
11525 gfc_expr
*e
= code
->expr1
;
11527 gfc_resolve_expr (e
);
11528 if (e
->expr_type
== EXPR_NULL
)
11529 gfc_error ("Invalid NULL at %L", &e
->where
);
11531 if (t
&& (e
->rank
> 0
11532 || !(e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_INTEGER
)))
11533 gfc_error ("Arithmetic IF statement at %L requires a scalar "
11534 "REAL or INTEGER expression", &e
->where
);
11536 resolve_branch (code
->label1
, code
);
11537 resolve_branch (code
->label2
, code
);
11538 resolve_branch (code
->label3
, code
);
11543 if (t
&& code
->expr1
!= NULL
11544 && (code
->expr1
->ts
.type
!= BT_LOGICAL
11545 || code
->expr1
->rank
!= 0))
11546 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11547 &code
->expr1
->where
);
11552 resolve_call (code
);
11555 case EXEC_COMPCALL
:
11557 resolve_typebound_subroutine (code
);
11560 case EXEC_CALL_PPC
:
11561 resolve_ppc_call (code
);
11565 /* Select is complicated. Also, a SELECT construct could be
11566 a transformed computed GOTO. */
11567 resolve_select (code
, false);
11570 case EXEC_SELECT_TYPE
:
11571 resolve_select_type (code
, ns
);
11575 resolve_block_construct (code
);
11579 if (code
->ext
.iterator
!= NULL
)
11581 gfc_iterator
*iter
= code
->ext
.iterator
;
11582 if (gfc_resolve_iterator (iter
, true, false))
11583 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
,
11588 case EXEC_DO_WHILE
:
11589 if (code
->expr1
== NULL
)
11590 gfc_internal_error ("gfc_resolve_code(): No expression on "
11593 && (code
->expr1
->rank
!= 0
11594 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
11595 gfc_error ("Exit condition of DO WHILE loop at %L must be "
11596 "a scalar LOGICAL expression", &code
->expr1
->where
);
11599 case EXEC_ALLOCATE
:
11601 resolve_allocate_deallocate (code
, "ALLOCATE");
11605 case EXEC_DEALLOCATE
:
11607 resolve_allocate_deallocate (code
, "DEALLOCATE");
11612 if (!gfc_resolve_open (code
->ext
.open
))
11615 resolve_branch (code
->ext
.open
->err
, code
);
11619 if (!gfc_resolve_close (code
->ext
.close
))
11622 resolve_branch (code
->ext
.close
->err
, code
);
11625 case EXEC_BACKSPACE
:
11629 if (!gfc_resolve_filepos (code
->ext
.filepos
, &code
->loc
))
11632 resolve_branch (code
->ext
.filepos
->err
, code
);
11636 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11639 resolve_branch (code
->ext
.inquire
->err
, code
);
11642 case EXEC_IOLENGTH
:
11643 gcc_assert (code
->ext
.inquire
!= NULL
);
11644 if (!gfc_resolve_inquire (code
->ext
.inquire
))
11647 resolve_branch (code
->ext
.inquire
->err
, code
);
11651 if (!gfc_resolve_wait (code
->ext
.wait
))
11654 resolve_branch (code
->ext
.wait
->err
, code
);
11655 resolve_branch (code
->ext
.wait
->end
, code
);
11656 resolve_branch (code
->ext
.wait
->eor
, code
);
11661 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
11664 resolve_branch (code
->ext
.dt
->err
, code
);
11665 resolve_branch (code
->ext
.dt
->end
, code
);
11666 resolve_branch (code
->ext
.dt
->eor
, code
);
11669 case EXEC_TRANSFER
:
11670 resolve_transfer (code
);
11673 case EXEC_DO_CONCURRENT
:
11675 resolve_forall_iterators (code
->ext
.forall_iterator
);
11677 if (code
->expr1
!= NULL
11678 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
11679 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
11680 "expression", &code
->expr1
->where
);
11683 case EXEC_OACC_PARALLEL_LOOP
:
11684 case EXEC_OACC_PARALLEL
:
11685 case EXEC_OACC_KERNELS_LOOP
:
11686 case EXEC_OACC_KERNELS
:
11687 case EXEC_OACC_DATA
:
11688 case EXEC_OACC_HOST_DATA
:
11689 case EXEC_OACC_LOOP
:
11690 case EXEC_OACC_UPDATE
:
11691 case EXEC_OACC_WAIT
:
11692 case EXEC_OACC_CACHE
:
11693 case EXEC_OACC_ENTER_DATA
:
11694 case EXEC_OACC_EXIT_DATA
:
11695 case EXEC_OACC_ATOMIC
:
11696 case EXEC_OACC_DECLARE
:
11697 gfc_resolve_oacc_directive (code
, ns
);
11700 case EXEC_OMP_ATOMIC
:
11701 case EXEC_OMP_BARRIER
:
11702 case EXEC_OMP_CANCEL
:
11703 case EXEC_OMP_CANCELLATION_POINT
:
11704 case EXEC_OMP_CRITICAL
:
11705 case EXEC_OMP_FLUSH
:
11706 case EXEC_OMP_DISTRIBUTE
:
11707 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11708 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11709 case EXEC_OMP_DISTRIBUTE_SIMD
:
11711 case EXEC_OMP_DO_SIMD
:
11712 case EXEC_OMP_MASTER
:
11713 case EXEC_OMP_ORDERED
:
11714 case EXEC_OMP_SECTIONS
:
11715 case EXEC_OMP_SIMD
:
11716 case EXEC_OMP_SINGLE
:
11717 case EXEC_OMP_TARGET
:
11718 case EXEC_OMP_TARGET_DATA
:
11719 case EXEC_OMP_TARGET_ENTER_DATA
:
11720 case EXEC_OMP_TARGET_EXIT_DATA
:
11721 case EXEC_OMP_TARGET_PARALLEL
:
11722 case EXEC_OMP_TARGET_PARALLEL_DO
:
11723 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11724 case EXEC_OMP_TARGET_SIMD
:
11725 case EXEC_OMP_TARGET_TEAMS
:
11726 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11727 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11728 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11729 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11730 case EXEC_OMP_TARGET_UPDATE
:
11731 case EXEC_OMP_TASK
:
11732 case EXEC_OMP_TASKGROUP
:
11733 case EXEC_OMP_TASKLOOP
:
11734 case EXEC_OMP_TASKLOOP_SIMD
:
11735 case EXEC_OMP_TASKWAIT
:
11736 case EXEC_OMP_TASKYIELD
:
11737 case EXEC_OMP_TEAMS
:
11738 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11739 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11740 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11741 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11742 case EXEC_OMP_WORKSHARE
:
11743 gfc_resolve_omp_directive (code
, ns
);
11746 case EXEC_OMP_PARALLEL
:
11747 case EXEC_OMP_PARALLEL_DO
:
11748 case EXEC_OMP_PARALLEL_DO_SIMD
:
11749 case EXEC_OMP_PARALLEL_SECTIONS
:
11750 case EXEC_OMP_PARALLEL_WORKSHARE
:
11751 omp_workshare_save
= omp_workshare_flag
;
11752 omp_workshare_flag
= 0;
11753 gfc_resolve_omp_directive (code
, ns
);
11754 omp_workshare_flag
= omp_workshare_save
;
11758 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
11762 cs_base
= frame
.prev
;
11766 /* Resolve initial values and make sure they are compatible with
11770 resolve_values (gfc_symbol
*sym
)
11774 if (sym
->value
== NULL
)
11777 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
11778 t
= resolve_structure_cons (sym
->value
, 1);
11780 t
= gfc_resolve_expr (sym
->value
);
11785 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
11789 /* Verify any BIND(C) derived types in the namespace so we can report errors
11790 for them once, rather than for each variable declared of that type. */
11793 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
11795 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
11796 && derived_sym
->attr
.is_bind_c
== 1)
11797 verify_bind_c_derived_type (derived_sym
);
11803 /* Check the interfaces of DTIO procedures associated with derived
11804 type 'sym'. These procedures can either have typebound bindings or
11805 can appear in DTIO generic interfaces. */
11808 gfc_verify_DTIO_procedures (gfc_symbol
*sym
)
11810 if (!sym
|| sym
->attr
.flavor
!= FL_DERIVED
)
11813 gfc_check_dtio_interfaces (sym
);
11818 /* Verify that any binding labels used in a given namespace do not collide
11819 with the names or binding labels of any global symbols. Multiple INTERFACE
11820 for the same procedure are permitted. */
11823 gfc_verify_binding_labels (gfc_symbol
*sym
)
11826 const char *module
;
11828 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
11829 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
11832 gsym
= gfc_find_case_gsymbol (gfc_gsym_root
, sym
->binding_label
);
11835 module
= sym
->module
;
11836 else if (sym
->ns
&& sym
->ns
->proc_name
11837 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
11838 module
= sym
->ns
->proc_name
->name
;
11839 else if (sym
->ns
&& sym
->ns
->parent
11840 && sym
->ns
&& sym
->ns
->parent
->proc_name
11841 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11842 module
= sym
->ns
->parent
->proc_name
->name
;
11848 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
11851 gsym
= gfc_get_gsymbol (sym
->binding_label
, true);
11852 gsym
->where
= sym
->declared_at
;
11853 gsym
->sym_name
= sym
->name
;
11854 gsym
->binding_label
= sym
->binding_label
;
11855 gsym
->ns
= sym
->ns
;
11856 gsym
->mod_name
= module
;
11857 if (sym
->attr
.function
)
11858 gsym
->type
= GSYM_FUNCTION
;
11859 else if (sym
->attr
.subroutine
)
11860 gsym
->type
= GSYM_SUBROUTINE
;
11861 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11862 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
11866 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
11868 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
11869 "identifier as entity at %L", sym
->name
,
11870 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11871 /* Clear the binding label to prevent checking multiple times. */
11872 sym
->binding_label
= NULL
;
11876 if (sym
->attr
.flavor
== FL_VARIABLE
&& module
11877 && (strcmp (module
, gsym
->mod_name
) != 0
11878 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
11880 /* This can only happen if the variable is defined in a module - if it
11881 isn't the same module, reject it. */
11882 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
11883 "uses the same global identifier as entity at %L from module %qs",
11884 sym
->name
, module
, sym
->binding_label
,
11885 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
11886 sym
->binding_label
= NULL
;
11890 if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
11891 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
11892 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
11893 && (sym
!= gsym
->ns
->proc_name
&& sym
->attr
.entry
== 0)
11894 && (module
!= gsym
->mod_name
11895 || strcmp (gsym
->sym_name
, sym
->name
) != 0
11896 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
11898 /* Print an error if the procedure is defined multiple times; we have to
11899 exclude references to the same procedure via module association or
11900 multiple checks for the same procedure. */
11901 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
11902 "global identifier as entity at %L", sym
->name
,
11903 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
11904 sym
->binding_label
= NULL
;
11909 /* Resolve an index expression. */
11912 resolve_index_expr (gfc_expr
*e
)
11914 if (!gfc_resolve_expr (e
))
11917 if (!gfc_simplify_expr (e
, 0))
11920 if (!gfc_specification_expr (e
))
11927 /* Resolve a charlen structure. */
11930 resolve_charlen (gfc_charlen
*cl
)
11933 bool saved_specification_expr
;
11939 saved_specification_expr
= specification_expr
;
11940 specification_expr
= true;
11942 if (cl
->length_from_typespec
)
11944 if (!gfc_resolve_expr (cl
->length
))
11946 specification_expr
= saved_specification_expr
;
11950 if (!gfc_simplify_expr (cl
->length
, 0))
11952 specification_expr
= saved_specification_expr
;
11956 /* cl->length has been resolved. It should have an integer type. */
11957 if (cl
->length
->ts
.type
!= BT_INTEGER
)
11959 gfc_error ("Scalar INTEGER expression expected at %L",
11960 &cl
->length
->where
);
11966 if (!resolve_index_expr (cl
->length
))
11968 specification_expr
= saved_specification_expr
;
11973 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11974 a negative value, the length of character entities declared is zero. */
11975 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11976 && mpz_sgn (cl
->length
->value
.integer
) < 0)
11977 gfc_replace_expr (cl
->length
,
11978 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 0));
11980 /* Check that the character length is not too large. */
11981 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
11982 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
11983 && cl
->length
->ts
.type
== BT_INTEGER
11984 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
11986 gfc_error ("String length at %L is too large", &cl
->length
->where
);
11987 specification_expr
= saved_specification_expr
;
11991 specification_expr
= saved_specification_expr
;
11996 /* Test for non-constant shape arrays. */
11999 is_non_constant_shape_array (gfc_symbol
*sym
)
12005 not_constant
= false;
12006 if (sym
->as
!= NULL
)
12008 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12009 has not been simplified; parameter array references. Do the
12010 simplification now. */
12011 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
12013 e
= sym
->as
->lower
[i
];
12014 if (e
&& (!resolve_index_expr(e
)
12015 || !gfc_is_constant_expr (e
)))
12016 not_constant
= true;
12017 e
= sym
->as
->upper
[i
];
12018 if (e
&& (!resolve_index_expr(e
)
12019 || !gfc_is_constant_expr (e
)))
12020 not_constant
= true;
12023 return not_constant
;
12026 /* Given a symbol and an initialization expression, add code to initialize
12027 the symbol to the function entry. */
12029 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
12033 gfc_namespace
*ns
= sym
->ns
;
12035 /* Search for the function namespace if this is a contained
12036 function without an explicit result. */
12037 if (sym
->attr
.function
&& sym
== sym
->result
12038 && sym
->name
!= sym
->ns
->proc_name
->name
)
12040 ns
= ns
->contained
;
12041 for (;ns
; ns
= ns
->sibling
)
12042 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
12048 gfc_free_expr (init
);
12052 /* Build an l-value expression for the result. */
12053 lval
= gfc_lval_expr_from_sym (sym
);
12055 /* Add the code at scope entry. */
12056 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
12057 init_st
->next
= ns
->code
;
12058 ns
->code
= init_st
;
12060 /* Assign the default initializer to the l-value. */
12061 init_st
->loc
= sym
->declared_at
;
12062 init_st
->expr1
= lval
;
12063 init_st
->expr2
= init
;
12067 /* Whether or not we can generate a default initializer for a symbol. */
12070 can_generate_init (gfc_symbol
*sym
)
12072 symbol_attribute
*a
;
12077 /* These symbols should never have a default initialization. */
12082 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
12083 && (CLASS_DATA (sym
)->attr
.class_pointer
12084 || CLASS_DATA (sym
)->attr
.proc_pointer
))
12085 || a
->in_equivalence
12092 || (!a
->referenced
&& !a
->result
)
12093 || (a
->dummy
&& a
->intent
!= INTENT_OUT
)
12094 || (a
->function
&& sym
!= sym
->result
)
12099 /* Assign the default initializer to a derived type variable or result. */
12102 apply_default_init (gfc_symbol
*sym
)
12104 gfc_expr
*init
= NULL
;
12106 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12109 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
12110 init
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12112 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
12115 build_init_assign (sym
, init
);
12116 sym
->attr
.referenced
= 1;
12120 /* Build an initializer for a local. Returns null if the symbol should not have
12121 a default initialization. */
12124 build_default_init_expr (gfc_symbol
*sym
)
12126 /* These symbols should never have a default initialization. */
12127 if (sym
->attr
.allocatable
12128 || sym
->attr
.external
12130 || sym
->attr
.pointer
12131 || sym
->attr
.in_equivalence
12132 || sym
->attr
.in_common
12135 || sym
->attr
.cray_pointee
12136 || sym
->attr
.cray_pointer
12140 /* Get the appropriate init expression. */
12141 return gfc_build_default_init_expr (&sym
->ts
, &sym
->declared_at
);
12144 /* Add an initialization expression to a local variable. */
12146 apply_default_init_local (gfc_symbol
*sym
)
12148 gfc_expr
*init
= NULL
;
12150 /* The symbol should be a variable or a function return value. */
12151 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
12152 || (sym
->attr
.function
&& sym
->result
!= sym
))
12155 /* Try to build the initializer expression. If we can't initialize
12156 this symbol, then init will be NULL. */
12157 init
= build_default_init_expr (sym
);
12161 /* For saved variables, we don't want to add an initializer at function
12162 entry, so we just add a static initializer. Note that automatic variables
12163 are stack allocated even with -fno-automatic; we have also to exclude
12164 result variable, which are also nonstatic. */
12165 if (!sym
->attr
.automatic
12166 && (sym
->attr
.save
|| sym
->ns
->save_all
12167 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
12168 && (sym
->ns
->proc_name
&& !sym
->ns
->proc_name
->attr
.recursive
)
12169 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
)))))
12171 /* Don't clobber an existing initializer! */
12172 gcc_assert (sym
->value
== NULL
);
12177 build_init_assign (sym
, init
);
12181 /* Resolution of common features of flavors variable and procedure. */
12184 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
12186 gfc_array_spec
*as
;
12188 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12189 as
= CLASS_DATA (sym
)->as
;
12193 /* Constraints on deferred shape variable. */
12194 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
12196 bool pointer
, allocatable
, dimension
;
12198 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12200 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
12201 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
12202 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
12206 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
12207 allocatable
= sym
->attr
.allocatable
;
12208 dimension
= sym
->attr
.dimension
;
12213 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12215 gfc_error ("Allocatable array %qs at %L must have a deferred "
12216 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
12219 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
12220 "%qs at %L may not be ALLOCATABLE",
12221 sym
->name
, &sym
->declared_at
))
12225 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
12227 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
12228 "assumed rank", sym
->name
, &sym
->declared_at
);
12234 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
12235 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
12237 gfc_error ("Array %qs at %L cannot have a deferred shape",
12238 sym
->name
, &sym
->declared_at
);
12243 /* Constraints on polymorphic variables. */
12244 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
12247 if (sym
->attr
.class_ok
12248 && !sym
->attr
.select_type_temporary
12249 && !UNLIMITED_POLY (sym
)
12250 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
12252 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
12253 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
12254 &sym
->declared_at
);
12259 /* Assume that use associated symbols were checked in the module ns.
12260 Class-variables that are associate-names are also something special
12261 and excepted from the test. */
12262 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
12264 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
12265 "or pointer", sym
->name
, &sym
->declared_at
);
12274 /* Additional checks for symbols with flavor variable and derived
12275 type. To be called from resolve_fl_variable. */
12278 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
12280 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
12282 /* Check to see if a derived type is blocked from being host
12283 associated by the presence of another class I symbol in the same
12284 namespace. 14.6.1.3 of the standard and the discussion on
12285 comp.lang.fortran. */
12286 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
12287 && !sym
->ts
.u
.derived
->attr
.use_assoc
12288 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
12291 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
12292 if (s
&& s
->attr
.generic
)
12293 s
= gfc_find_dt_in_generic (s
);
12294 if (s
&& !gfc_fl_struct (s
->attr
.flavor
))
12296 gfc_error ("The type %qs cannot be host associated at %L "
12297 "because it is blocked by an incompatible object "
12298 "of the same name declared at %L",
12299 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
12305 /* 4th constraint in section 11.3: "If an object of a type for which
12306 component-initialization is specified (R429) appears in the
12307 specification-part of a module and does not have the ALLOCATABLE
12308 or POINTER attribute, the object shall have the SAVE attribute."
12310 The check for initializers is performed with
12311 gfc_has_default_initializer because gfc_default_initializer generates
12312 a hidden default for allocatable components. */
12313 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
12314 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12315 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
) && !sym
->attr
.save
12316 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
12317 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
12318 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
12319 "%qs at %L, needed due to the default "
12320 "initialization", sym
->name
, &sym
->declared_at
))
12323 /* Assign default initializer. */
12324 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
12325 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
12326 sym
->value
= gfc_generate_initializer (&sym
->ts
, can_generate_init (sym
));
12332 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
12333 except in the declaration of an entity or component that has the POINTER
12334 or ALLOCATABLE attribute. */
12337 deferred_requirements (gfc_symbol
*sym
)
12339 if (sym
->ts
.deferred
12340 && !(sym
->attr
.pointer
12341 || sym
->attr
.allocatable
12342 || sym
->attr
.associate_var
12343 || sym
->attr
.omp_udr_artificial_var
))
12345 gfc_error ("Entity %qs at %L has a deferred type parameter and "
12346 "requires either the POINTER or ALLOCATABLE attribute",
12347 sym
->name
, &sym
->declared_at
);
12354 /* Resolve symbols with flavor variable. */
12357 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
12359 const char *auto_save_msg
= "Automatic object %qs at %L cannot have the "
12362 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
12365 /* Set this flag to check that variables are parameters of all entries.
12366 This check is effected by the call to gfc_resolve_expr through
12367 is_non_constant_shape_array. */
12368 bool saved_specification_expr
= specification_expr
;
12369 specification_expr
= true;
12371 if (sym
->ns
->proc_name
12372 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12373 || sym
->ns
->proc_name
->attr
.is_main_program
)
12374 && !sym
->attr
.use_assoc
12375 && !sym
->attr
.allocatable
12376 && !sym
->attr
.pointer
12377 && is_non_constant_shape_array (sym
))
12379 /* F08:C541. The shape of an array defined in a main program or module
12380 * needs to be constant. */
12381 gfc_error ("The module or main program array %qs at %L must "
12382 "have constant shape", sym
->name
, &sym
->declared_at
);
12383 specification_expr
= saved_specification_expr
;
12387 /* Constraints on deferred type parameter. */
12388 if (!deferred_requirements (sym
))
12391 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.associate_var
)
12393 /* Make sure that character string variables with assumed length are
12394 dummy arguments. */
12395 gfc_expr
*e
= NULL
;
12398 e
= sym
->ts
.u
.cl
->length
;
12402 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
12403 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
12404 && !sym
->attr
.omp_udr_artificial_var
)
12406 gfc_error ("Entity with assumed character length at %L must be a "
12407 "dummy argument or a PARAMETER", &sym
->declared_at
);
12408 specification_expr
= saved_specification_expr
;
12412 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
12414 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12415 specification_expr
= saved_specification_expr
;
12419 if (!gfc_is_constant_expr (e
)
12420 && !(e
->expr_type
== EXPR_VARIABLE
12421 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
12423 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
12424 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12425 || sym
->ns
->proc_name
->attr
.is_main_program
))
12427 gfc_error ("%qs at %L must have constant character length "
12428 "in this context", sym
->name
, &sym
->declared_at
);
12429 specification_expr
= saved_specification_expr
;
12432 if (sym
->attr
.in_common
)
12434 gfc_error ("COMMON variable %qs at %L must have constant "
12435 "character length", sym
->name
, &sym
->declared_at
);
12436 specification_expr
= saved_specification_expr
;
12442 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
12443 apply_default_init_local (sym
); /* Try to apply a default initialization. */
12445 /* Determine if the symbol may not have an initializer. */
12446 int no_init_flag
= 0, automatic_flag
= 0;
12447 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
12448 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
12450 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
12451 && is_non_constant_shape_array (sym
))
12453 no_init_flag
= automatic_flag
= 1;
12455 /* Also, they must not have the SAVE attribute.
12456 SAVE_IMPLICIT is checked below. */
12457 if (sym
->as
&& sym
->attr
.codimension
)
12459 int corank
= sym
->as
->corank
;
12460 sym
->as
->corank
= 0;
12461 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
12462 sym
->as
->corank
= corank
;
12464 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
12466 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
12467 specification_expr
= saved_specification_expr
;
12472 /* Ensure that any initializer is simplified. */
12474 gfc_simplify_expr (sym
->value
, 1);
12476 /* Reject illegal initializers. */
12477 if (!sym
->mark
&& sym
->value
)
12479 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
12480 && CLASS_DATA (sym
)->attr
.allocatable
))
12481 gfc_error ("Allocatable %qs at %L cannot have an initializer",
12482 sym
->name
, &sym
->declared_at
);
12483 else if (sym
->attr
.external
)
12484 gfc_error ("External %qs at %L cannot have an initializer",
12485 sym
->name
, &sym
->declared_at
);
12486 else if (sym
->attr
.dummy
12487 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
12488 gfc_error ("Dummy %qs at %L cannot have an initializer",
12489 sym
->name
, &sym
->declared_at
);
12490 else if (sym
->attr
.intrinsic
)
12491 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
12492 sym
->name
, &sym
->declared_at
);
12493 else if (sym
->attr
.result
)
12494 gfc_error ("Function result %qs at %L cannot have an initializer",
12495 sym
->name
, &sym
->declared_at
);
12496 else if (automatic_flag
)
12497 gfc_error ("Automatic array %qs at %L cannot have an initializer",
12498 sym
->name
, &sym
->declared_at
);
12500 goto no_init_error
;
12501 specification_expr
= saved_specification_expr
;
12506 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
12508 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
12509 specification_expr
= saved_specification_expr
;
12513 specification_expr
= saved_specification_expr
;
12518 /* Compare the dummy characteristics of a module procedure interface
12519 declaration with the corresponding declaration in a submodule. */
12520 static gfc_formal_arglist
*new_formal
;
12521 static char errmsg
[200];
12524 compare_fsyms (gfc_symbol
*sym
)
12528 if (sym
== NULL
|| new_formal
== NULL
)
12531 fsym
= new_formal
->sym
;
12536 if (strcmp (sym
->name
, fsym
->name
) == 0)
12538 if (!gfc_check_dummy_characteristics (fsym
, sym
, true, errmsg
, 200))
12539 gfc_error ("%s at %L", errmsg
, &fsym
->declared_at
);
12544 /* Resolve a procedure. */
12547 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
12549 gfc_formal_arglist
*arg
;
12551 if (sym
->attr
.function
12552 && !resolve_fl_var_and_proc (sym
, mp_flag
))
12555 if (sym
->ts
.type
== BT_CHARACTER
)
12557 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12559 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
12560 && !resolve_charlen (cl
))
12563 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12564 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
12566 gfc_error ("Character-valued statement function %qs at %L must "
12567 "have constant length", sym
->name
, &sym
->declared_at
);
12572 /* Ensure that derived type for are not of a private type. Internal
12573 module procedures are excluded by 2.2.3.3 - i.e., they are not
12574 externally accessible and can access all the objects accessible in
12576 if (!(sym
->ns
->parent
&& sym
->ns
->parent
->proc_name
12577 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
12578 && gfc_check_symbol_access (sym
))
12580 gfc_interface
*iface
;
12582 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
12585 && arg
->sym
->ts
.type
== BT_DERIVED
12586 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12587 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12588 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
12589 "and cannot be a dummy argument"
12590 " of %qs, which is PUBLIC at %L",
12591 arg
->sym
->name
, sym
->name
,
12592 &sym
->declared_at
))
12594 /* Stop this message from recurring. */
12595 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12600 /* PUBLIC interfaces may expose PRIVATE procedures that take types
12601 PRIVATE to the containing module. */
12602 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
12604 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
12607 && arg
->sym
->ts
.type
== BT_DERIVED
12608 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
12609 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
12610 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
12611 "PUBLIC interface %qs at %L "
12612 "takes dummy arguments of %qs which "
12613 "is PRIVATE", iface
->sym
->name
,
12614 sym
->name
, &iface
->sym
->declared_at
,
12615 gfc_typename(&arg
->sym
->ts
)))
12617 /* Stop this message from recurring. */
12618 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
12625 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
12626 && !sym
->attr
.proc_pointer
)
12628 gfc_error ("Function %qs at %L cannot have an initializer",
12629 sym
->name
, &sym
->declared_at
);
12631 /* Make sure no second error is issued for this. */
12632 sym
->value
->error
= 1;
12636 /* An external symbol may not have an initializer because it is taken to be
12637 a procedure. Exception: Procedure Pointers. */
12638 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
12640 gfc_error ("External object %qs at %L may not have an initializer",
12641 sym
->name
, &sym
->declared_at
);
12645 /* An elemental function is required to return a scalar 12.7.1 */
12646 if (sym
->attr
.elemental
&& sym
->attr
.function
12647 && (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)))
12649 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
12650 "result", sym
->name
, &sym
->declared_at
);
12651 /* Reset so that the error only occurs once. */
12652 sym
->attr
.elemental
= 0;
12656 if (sym
->attr
.proc
== PROC_ST_FUNCTION
12657 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
12659 gfc_error ("Statement function %qs at %L may not have pointer or "
12660 "allocatable attribute", sym
->name
, &sym
->declared_at
);
12664 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
12665 char-len-param shall not be array-valued, pointer-valued, recursive
12666 or pure. ....snip... A character value of * may only be used in the
12667 following ways: (i) Dummy arg of procedure - dummy associates with
12668 actual length; (ii) To declare a named constant; or (iii) External
12669 function - but length must be declared in calling scoping unit. */
12670 if (sym
->attr
.function
12671 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
12672 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
12674 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
12675 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
12677 if (sym
->as
&& sym
->as
->rank
)
12678 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12679 "array-valued", sym
->name
, &sym
->declared_at
);
12681 if (sym
->attr
.pointer
)
12682 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12683 "pointer-valued", sym
->name
, &sym
->declared_at
);
12685 if (sym
->attr
.pure
)
12686 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12687 "pure", sym
->name
, &sym
->declared_at
);
12689 if (sym
->attr
.recursive
)
12690 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
12691 "recursive", sym
->name
, &sym
->declared_at
);
12696 /* Appendix B.2 of the standard. Contained functions give an
12697 error anyway. Deferred character length is an F2003 feature.
12698 Don't warn on intrinsic conversion functions, which start
12699 with two underscores. */
12700 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
12701 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
12702 gfc_notify_std (GFC_STD_F95_OBS
,
12703 "CHARACTER(*) function %qs at %L",
12704 sym
->name
, &sym
->declared_at
);
12707 /* F2008, C1218. */
12708 if (sym
->attr
.elemental
)
12710 if (sym
->attr
.proc_pointer
)
12712 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
12713 sym
->name
, &sym
->declared_at
);
12716 if (sym
->attr
.dummy
)
12718 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
12719 sym
->name
, &sym
->declared_at
);
12724 /* F2018, C15100: "The result of an elemental function shall be scalar,
12725 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
12726 pointer is tested and caught elsewhere. */
12727 if (sym
->attr
.elemental
&& sym
->result
12728 && (sym
->result
->attr
.allocatable
|| sym
->result
->attr
.pointer
))
12730 gfc_error ("Function result variable %qs at %L of elemental "
12731 "function %qs shall not have an ALLOCATABLE or POINTER "
12732 "attribute", sym
->result
->name
,
12733 &sym
->result
->declared_at
, sym
->name
);
12737 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
12739 gfc_formal_arglist
*curr_arg
;
12740 int has_non_interop_arg
= 0;
12742 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12743 sym
->common_block
))
12745 /* Clear these to prevent looking at them again if there was an
12747 sym
->attr
.is_bind_c
= 0;
12748 sym
->attr
.is_c_interop
= 0;
12749 sym
->ts
.is_c_interop
= 0;
12753 /* So far, no errors have been found. */
12754 sym
->attr
.is_c_interop
= 1;
12755 sym
->ts
.is_c_interop
= 1;
12758 curr_arg
= gfc_sym_get_dummy_args (sym
);
12759 while (curr_arg
!= NULL
)
12761 /* Skip implicitly typed dummy args here. */
12762 if (curr_arg
->sym
&& curr_arg
->sym
->attr
.implicit_type
== 0)
12763 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
12764 /* If something is found to fail, record the fact so we
12765 can mark the symbol for the procedure as not being
12766 BIND(C) to try and prevent multiple errors being
12768 has_non_interop_arg
= 1;
12770 curr_arg
= curr_arg
->next
;
12773 /* See if any of the arguments were not interoperable and if so, clear
12774 the procedure symbol to prevent duplicate error messages. */
12775 if (has_non_interop_arg
!= 0)
12777 sym
->attr
.is_c_interop
= 0;
12778 sym
->ts
.is_c_interop
= 0;
12779 sym
->attr
.is_bind_c
= 0;
12783 if (!sym
->attr
.proc_pointer
)
12785 if (sym
->attr
.save
== SAVE_EXPLICIT
)
12787 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12788 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12791 if (sym
->attr
.intent
)
12793 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12794 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12797 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
12799 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12800 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12803 if (sym
->attr
.external
&& sym
->attr
.function
&& !sym
->attr
.module_procedure
12804 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
12805 || sym
->attr
.contained
))
12807 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12808 "in %qs at %L", sym
->name
, &sym
->declared_at
);
12811 if (strcmp ("ppr@", sym
->name
) == 0)
12813 gfc_error ("Procedure pointer result %qs at %L "
12814 "is missing the pointer attribute",
12815 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
12820 /* Assume that a procedure whose body is not known has references
12821 to external arrays. */
12822 if (sym
->attr
.if_source
!= IFSRC_DECL
)
12823 sym
->attr
.array_outer_dependency
= 1;
12825 /* Compare the characteristics of a module procedure with the
12826 interface declaration. Ideally this would be done with
12827 gfc_compare_interfaces but, at present, the formal interface
12828 cannot be copied to the ts.interface. */
12829 if (sym
->attr
.module_procedure
12830 && sym
->attr
.if_source
== IFSRC_DECL
)
12833 char name
[2*GFC_MAX_SYMBOL_LEN
+ 1];
12835 char *submodule_name
;
12836 strcpy (name
, sym
->ns
->proc_name
->name
);
12837 module_name
= strtok (name
, ".");
12838 submodule_name
= strtok (NULL
, ".");
12840 iface
= sym
->tlink
;
12843 /* Make sure that the result uses the correct charlen for deferred
12845 if (iface
&& sym
->result
12846 && iface
->ts
.type
== BT_CHARACTER
12847 && iface
->ts
.deferred
)
12848 sym
->result
->ts
.u
.cl
= iface
->ts
.u
.cl
;
12853 /* Check the procedure characteristics. */
12854 if (sym
->attr
.elemental
!= iface
->attr
.elemental
)
12856 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12857 "PROCEDURE at %L and its interface in %s",
12858 &sym
->declared_at
, module_name
);
12862 if (sym
->attr
.pure
!= iface
->attr
.pure
)
12864 gfc_error ("Mismatch in PURE attribute between MODULE "
12865 "PROCEDURE at %L and its interface in %s",
12866 &sym
->declared_at
, module_name
);
12870 if (sym
->attr
.recursive
!= iface
->attr
.recursive
)
12872 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12873 "PROCEDURE at %L and its interface in %s",
12874 &sym
->declared_at
, module_name
);
12878 /* Check the result characteristics. */
12879 if (!gfc_check_result_characteristics (sym
, iface
, errmsg
, 200))
12881 gfc_error ("%s between the MODULE PROCEDURE declaration "
12882 "in MODULE %qs and the declaration at %L in "
12884 errmsg
, module_name
, &sym
->declared_at
,
12885 submodule_name
? submodule_name
: module_name
);
12890 /* Check the characteristics of the formal arguments. */
12891 if (sym
->formal
&& sym
->formal_ns
)
12893 for (arg
= sym
->formal
; arg
&& arg
->sym
; arg
= arg
->next
)
12896 gfc_traverse_ns (sym
->formal_ns
, compare_fsyms
);
12904 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12905 been defined and we now know their defined arguments, check that they fulfill
12906 the requirements of the standard for procedures used as finalizers. */
12909 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
12911 gfc_finalizer
* list
;
12912 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
12913 bool result
= true;
12914 bool seen_scalar
= false;
12917 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
12920 gfc_resolve_finalizers (parent
, finalizable
);
12922 /* Ensure that derived-type components have a their finalizers resolved. */
12923 bool has_final
= derived
->f2k_derived
&& derived
->f2k_derived
->finalizers
;
12924 for (c
= derived
->components
; c
; c
= c
->next
)
12925 if (c
->ts
.type
== BT_DERIVED
12926 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
12928 bool has_final2
= false;
12929 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final2
))
12930 return false; /* Error. */
12931 has_final
= has_final
|| has_final2
;
12933 /* Return early if not finalizable. */
12937 *finalizable
= false;
12941 /* Walk over the list of finalizer-procedures, check them, and if any one
12942 does not fit in with the standard's definition, print an error and remove
12943 it from the list. */
12944 prev_link
= &derived
->f2k_derived
->finalizers
;
12945 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
12947 gfc_formal_arglist
*dummy_args
;
12952 /* Skip this finalizer if we already resolved it. */
12953 if (list
->proc_tree
)
12955 if (list
->proc_tree
->n
.sym
->formal
->sym
->as
== NULL
12956 || list
->proc_tree
->n
.sym
->formal
->sym
->as
->rank
== 0)
12957 seen_scalar
= true;
12958 prev_link
= &(list
->next
);
12962 /* Check this exists and is a SUBROUTINE. */
12963 if (!list
->proc_sym
->attr
.subroutine
)
12965 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12966 list
->proc_sym
->name
, &list
->where
);
12970 /* We should have exactly one argument. */
12971 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
12972 if (!dummy_args
|| dummy_args
->next
)
12974 gfc_error ("FINAL procedure at %L must have exactly one argument",
12978 arg
= dummy_args
->sym
;
12980 /* This argument must be of our type. */
12981 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
12983 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12984 &arg
->declared_at
, derived
->name
);
12988 /* It must neither be a pointer nor allocatable nor optional. */
12989 if (arg
->attr
.pointer
)
12991 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12992 &arg
->declared_at
);
12995 if (arg
->attr
.allocatable
)
12997 gfc_error ("Argument of FINAL procedure at %L must not be"
12998 " ALLOCATABLE", &arg
->declared_at
);
13001 if (arg
->attr
.optional
)
13003 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13004 &arg
->declared_at
);
13008 /* It must not be INTENT(OUT). */
13009 if (arg
->attr
.intent
== INTENT_OUT
)
13011 gfc_error ("Argument of FINAL procedure at %L must not be"
13012 " INTENT(OUT)", &arg
->declared_at
);
13016 /* Warn if the procedure is non-scalar and not assumed shape. */
13017 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
13018 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
13019 gfc_warning (OPT_Wsurprising
,
13020 "Non-scalar FINAL procedure at %L should have assumed"
13021 " shape argument", &arg
->declared_at
);
13023 /* Check that it does not match in kind and rank with a FINAL procedure
13024 defined earlier. To really loop over the *earlier* declarations,
13025 we need to walk the tail of the list as new ones were pushed at the
13027 /* TODO: Handle kind parameters once they are implemented. */
13028 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
13029 for (i
= list
->next
; i
; i
= i
->next
)
13031 gfc_formal_arglist
*dummy_args
;
13033 /* Argument list might be empty; that is an error signalled earlier,
13034 but we nevertheless continued resolving. */
13035 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
13038 gfc_symbol
* i_arg
= dummy_args
->sym
;
13039 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
13040 if (i_rank
== my_rank
)
13042 gfc_error ("FINAL procedure %qs declared at %L has the same"
13043 " rank (%d) as %qs",
13044 list
->proc_sym
->name
, &list
->where
, my_rank
,
13045 i
->proc_sym
->name
);
13051 /* Is this the/a scalar finalizer procedure? */
13053 seen_scalar
= true;
13055 /* Find the symtree for this procedure. */
13056 gcc_assert (!list
->proc_tree
);
13057 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
13059 prev_link
= &list
->next
;
13062 /* Remove wrong nodes immediately from the list so we don't risk any
13063 troubles in the future when they might fail later expectations. */
13066 *prev_link
= list
->next
;
13067 gfc_free_finalizer (i
);
13071 if (result
== false)
13074 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13075 were nodes in the list, must have been for arrays. It is surely a good
13076 idea to have a scalar version there if there's something to finalize. */
13077 if (warn_surprising
&& derived
->f2k_derived
->finalizers
&& !seen_scalar
)
13078 gfc_warning (OPT_Wsurprising
,
13079 "Only array FINAL procedures declared for derived type %qs"
13080 " defined at %L, suggest also scalar one",
13081 derived
->name
, &derived
->declared_at
);
13083 vtab
= gfc_find_derived_vtab (derived
);
13084 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
13085 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
13088 *finalizable
= true;
13094 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13097 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
13098 const char* generic_name
, locus where
)
13100 gfc_symbol
*sym1
, *sym2
;
13101 const char *pass1
, *pass2
;
13102 gfc_formal_arglist
*dummy_args
;
13104 gcc_assert (t1
->specific
&& t2
->specific
);
13105 gcc_assert (!t1
->specific
->is_generic
);
13106 gcc_assert (!t2
->specific
->is_generic
);
13107 gcc_assert (t1
->is_operator
== t2
->is_operator
);
13109 sym1
= t1
->specific
->u
.specific
->n
.sym
;
13110 sym2
= t2
->specific
->u
.specific
->n
.sym
;
13115 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13116 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
13117 || sym1
->attr
.function
!= sym2
->attr
.function
)
13119 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
13120 " GENERIC %qs at %L",
13121 sym1
->name
, sym2
->name
, generic_name
, &where
);
13125 /* Determine PASS arguments. */
13126 if (t1
->specific
->nopass
)
13128 else if (t1
->specific
->pass_arg
)
13129 pass1
= t1
->specific
->pass_arg
;
13132 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
13134 pass1
= dummy_args
->sym
->name
;
13138 if (t2
->specific
->nopass
)
13140 else if (t2
->specific
->pass_arg
)
13141 pass2
= t2
->specific
->pass_arg
;
13144 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
13146 pass2
= dummy_args
->sym
->name
;
13151 /* Compare the interfaces. */
13152 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
13153 NULL
, 0, pass1
, pass2
))
13155 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
13156 sym1
->name
, sym2
->name
, generic_name
, &where
);
13164 /* Worker function for resolving a generic procedure binding; this is used to
13165 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13167 The difference between those cases is finding possible inherited bindings
13168 that are overridden, as one has to look for them in tb_sym_root,
13169 tb_uop_root or tb_op, respectively. Thus the caller must already find
13170 the super-type and set p->overridden correctly. */
13173 resolve_tb_generic_targets (gfc_symbol
* super_type
,
13174 gfc_typebound_proc
* p
, const char* name
)
13176 gfc_tbp_generic
* target
;
13177 gfc_symtree
* first_target
;
13178 gfc_symtree
* inherited
;
13180 gcc_assert (p
&& p
->is_generic
);
13182 /* Try to find the specific bindings for the symtrees in our target-list. */
13183 gcc_assert (p
->u
.generic
);
13184 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13185 if (!target
->specific
)
13187 gfc_typebound_proc
* overridden_tbp
;
13188 gfc_tbp_generic
* g
;
13189 const char* target_name
;
13191 target_name
= target
->specific_st
->name
;
13193 /* Defined for this type directly. */
13194 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
13196 target
->specific
= target
->specific_st
->n
.tb
;
13197 goto specific_found
;
13200 /* Look for an inherited specific binding. */
13203 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
13208 gcc_assert (inherited
->n
.tb
);
13209 target
->specific
= inherited
->n
.tb
;
13210 goto specific_found
;
13214 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
13215 " at %L", target_name
, name
, &p
->where
);
13218 /* Once we've found the specific binding, check it is not ambiguous with
13219 other specifics already found or inherited for the same GENERIC. */
13221 gcc_assert (target
->specific
);
13223 /* This must really be a specific binding! */
13224 if (target
->specific
->is_generic
)
13226 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13227 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
13231 /* Check those already resolved on this type directly. */
13232 for (g
= p
->u
.generic
; g
; g
= g
->next
)
13233 if (g
!= target
&& g
->specific
13234 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13237 /* Check for ambiguity with inherited specific targets. */
13238 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
13239 overridden_tbp
= overridden_tbp
->overridden
)
13240 if (overridden_tbp
->is_generic
)
13242 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
13244 gcc_assert (g
->specific
);
13245 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
13251 /* If we attempt to "overwrite" a specific binding, this is an error. */
13252 if (p
->overridden
&& !p
->overridden
->is_generic
)
13254 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
13255 " the same name", name
, &p
->where
);
13259 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
13260 all must have the same attributes here. */
13261 first_target
= p
->u
.generic
->specific
->u
.specific
;
13262 gcc_assert (first_target
);
13263 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
13264 p
->function
= first_target
->n
.sym
->attr
.function
;
13270 /* Resolve a GENERIC procedure binding for a derived type. */
13273 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
13275 gfc_symbol
* super_type
;
13277 /* Find the overridden binding if any. */
13278 st
->n
.tb
->overridden
= NULL
;
13279 super_type
= gfc_get_derived_super_type (derived
);
13282 gfc_symtree
* overridden
;
13283 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
13286 if (overridden
&& overridden
->n
.tb
)
13287 st
->n
.tb
->overridden
= overridden
->n
.tb
;
13290 /* Resolve using worker function. */
13291 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
13295 /* Retrieve the target-procedure of an operator binding and do some checks in
13296 common for intrinsic and user-defined type-bound operators. */
13299 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
13301 gfc_symbol
* target_proc
;
13303 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
13304 target_proc
= target
->specific
->u
.specific
->n
.sym
;
13305 gcc_assert (target_proc
);
13307 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
13308 if (target
->specific
->nopass
)
13310 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where
);
13314 return target_proc
;
13318 /* Resolve a type-bound intrinsic operator. */
13321 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
13322 gfc_typebound_proc
* p
)
13324 gfc_symbol
* super_type
;
13325 gfc_tbp_generic
* target
;
13327 /* If there's already an error here, do nothing (but don't fail again). */
13331 /* Operators should always be GENERIC bindings. */
13332 gcc_assert (p
->is_generic
);
13334 /* Look for an overridden binding. */
13335 super_type
= gfc_get_derived_super_type (derived
);
13336 if (super_type
&& super_type
->f2k_derived
)
13337 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
13340 p
->overridden
= NULL
;
13342 /* Resolve general GENERIC properties using worker function. */
13343 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
13346 /* Check the targets to be procedures of correct interface. */
13347 for (target
= p
->u
.generic
; target
; target
= target
->next
)
13349 gfc_symbol
* target_proc
;
13351 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
13355 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
13358 /* Add target to non-typebound operator list. */
13359 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
13360 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
13362 gfc_interface
*head
, *intr
;
13364 /* Preempt 'gfc_check_new_interface' for submodules, where the
13365 mechanism for handling module procedures winds up resolving
13366 operator interfaces twice and would otherwise cause an error. */
13367 for (intr
= derived
->ns
->op
[op
]; intr
; intr
= intr
->next
)
13368 if (intr
->sym
== target_proc
13369 && target_proc
->attr
.used_in_submodule
)
13372 if (!gfc_check_new_interface (derived
->ns
->op
[op
],
13373 target_proc
, p
->where
))
13375 head
= derived
->ns
->op
[op
];
13376 intr
= gfc_get_interface ();
13377 intr
->sym
= target_proc
;
13378 intr
->where
= p
->where
;
13380 derived
->ns
->op
[op
] = intr
;
13392 /* Resolve a type-bound user operator (tree-walker callback). */
13394 static gfc_symbol
* resolve_bindings_derived
;
13395 static bool resolve_bindings_result
;
13397 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
13400 resolve_typebound_user_op (gfc_symtree
* stree
)
13402 gfc_symbol
* super_type
;
13403 gfc_tbp_generic
* target
;
13405 gcc_assert (stree
&& stree
->n
.tb
);
13407 if (stree
->n
.tb
->error
)
13410 /* Operators should always be GENERIC bindings. */
13411 gcc_assert (stree
->n
.tb
->is_generic
);
13413 /* Find overridden procedure, if any. */
13414 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13415 if (super_type
&& super_type
->f2k_derived
)
13417 gfc_symtree
* overridden
;
13418 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
13419 stree
->name
, true, NULL
);
13421 if (overridden
&& overridden
->n
.tb
)
13422 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13425 stree
->n
.tb
->overridden
= NULL
;
13427 /* Resolve basically using worker function. */
13428 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
13431 /* Check the targets to be functions of correct interface. */
13432 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
13434 gfc_symbol
* target_proc
;
13436 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
13440 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
13447 resolve_bindings_result
= false;
13448 stree
->n
.tb
->error
= 1;
13452 /* Resolve the type-bound procedures for a derived type. */
13455 resolve_typebound_procedure (gfc_symtree
* stree
)
13459 gfc_symbol
* me_arg
;
13460 gfc_symbol
* super_type
;
13461 gfc_component
* comp
;
13463 gcc_assert (stree
);
13465 /* Undefined specific symbol from GENERIC target definition. */
13469 if (stree
->n
.tb
->error
)
13472 /* If this is a GENERIC binding, use that routine. */
13473 if (stree
->n
.tb
->is_generic
)
13475 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
13480 /* Get the target-procedure to check it. */
13481 gcc_assert (!stree
->n
.tb
->is_generic
);
13482 gcc_assert (stree
->n
.tb
->u
.specific
);
13483 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
13484 where
= stree
->n
.tb
->where
;
13486 /* Default access should already be resolved from the parser. */
13487 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
13489 if (stree
->n
.tb
->deferred
)
13491 if (!check_proc_interface (proc
, &where
))
13496 /* Check for F08:C465. */
13497 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
13498 || (proc
->attr
.proc
!= PROC_MODULE
13499 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
13500 || proc
->attr
.abstract
)
13502 gfc_error ("%qs must be a module procedure or an external procedure with"
13503 " an explicit interface at %L", proc
->name
, &where
);
13508 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
13509 stree
->n
.tb
->function
= proc
->attr
.function
;
13511 /* Find the super-type of the current derived type. We could do this once and
13512 store in a global if speed is needed, but as long as not I believe this is
13513 more readable and clearer. */
13514 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
13516 /* If PASS, resolve and check arguments if not already resolved / loaded
13517 from a .mod file. */
13518 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
13520 gfc_formal_arglist
*dummy_args
;
13522 dummy_args
= gfc_sym_get_dummy_args (proc
);
13523 if (stree
->n
.tb
->pass_arg
)
13525 gfc_formal_arglist
*i
;
13527 /* If an explicit passing argument name is given, walk the arg-list
13528 and look for it. */
13531 stree
->n
.tb
->pass_arg_num
= 1;
13532 for (i
= dummy_args
; i
; i
= i
->next
)
13534 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
13539 ++stree
->n
.tb
->pass_arg_num
;
13544 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
13546 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
13547 stree
->n
.tb
->pass_arg
);
13553 /* Otherwise, take the first one; there should in fact be at least
13555 stree
->n
.tb
->pass_arg_num
= 1;
13558 gfc_error ("Procedure %qs with PASS at %L must have at"
13559 " least one argument", proc
->name
, &where
);
13562 me_arg
= dummy_args
->sym
;
13565 /* Now check that the argument-type matches and the passed-object
13566 dummy argument is generally fine. */
13568 gcc_assert (me_arg
);
13570 if (me_arg
->ts
.type
!= BT_CLASS
)
13572 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13573 " at %L", proc
->name
, &where
);
13577 if (CLASS_DATA (me_arg
)->ts
.u
.derived
13578 != resolve_bindings_derived
)
13580 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13581 " the derived-type %qs", me_arg
->name
, proc
->name
,
13582 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
13586 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
13587 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
13589 gfc_error ("Passed-object dummy argument of %qs at %L must be"
13590 " scalar", proc
->name
, &where
);
13593 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
13595 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13596 " be ALLOCATABLE", proc
->name
, &where
);
13599 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
13601 gfc_error ("Passed-object dummy argument of %qs at %L must not"
13602 " be POINTER", proc
->name
, &where
);
13607 /* If we are extending some type, check that we don't override a procedure
13608 flagged NON_OVERRIDABLE. */
13609 stree
->n
.tb
->overridden
= NULL
;
13612 gfc_symtree
* overridden
;
13613 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
13614 stree
->name
, true, NULL
);
13618 if (overridden
->n
.tb
)
13619 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
13621 if (!gfc_check_typebound_override (stree
, overridden
))
13626 /* See if there's a name collision with a component directly in this type. */
13627 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
13628 if (!strcmp (comp
->name
, stree
->name
))
13630 gfc_error ("Procedure %qs at %L has the same name as a component of"
13632 stree
->name
, &where
, resolve_bindings_derived
->name
);
13636 /* Try to find a name collision with an inherited component. */
13637 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true,
13640 gfc_error ("Procedure %qs at %L has the same name as an inherited"
13641 " component of %qs",
13642 stree
->name
, &where
, resolve_bindings_derived
->name
);
13646 stree
->n
.tb
->error
= 0;
13650 resolve_bindings_result
= false;
13651 stree
->n
.tb
->error
= 1;
13656 resolve_typebound_procedures (gfc_symbol
* derived
)
13659 gfc_symbol
* super_type
;
13661 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
13664 super_type
= gfc_get_derived_super_type (derived
);
13666 resolve_symbol (super_type
);
13668 resolve_bindings_derived
= derived
;
13669 resolve_bindings_result
= true;
13671 if (derived
->f2k_derived
->tb_sym_root
)
13672 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
13673 &resolve_typebound_procedure
);
13675 if (derived
->f2k_derived
->tb_uop_root
)
13676 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
13677 &resolve_typebound_user_op
);
13679 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
13681 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
13682 if (p
&& !resolve_typebound_intrinsic_op (derived
,
13683 (gfc_intrinsic_op
)op
, p
))
13684 resolve_bindings_result
= false;
13687 return resolve_bindings_result
;
13691 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
13692 to give all identical derived types the same backend_decl. */
13694 add_dt_to_dt_list (gfc_symbol
*derived
)
13696 if (!derived
->dt_next
)
13698 if (gfc_derived_types
)
13700 derived
->dt_next
= gfc_derived_types
->dt_next
;
13701 gfc_derived_types
->dt_next
= derived
;
13705 derived
->dt_next
= derived
;
13707 gfc_derived_types
= derived
;
13712 /* Ensure that a derived-type is really not abstract, meaning that every
13713 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
13716 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
13721 if (!ensure_not_abstract_walker (sub
, st
->left
))
13723 if (!ensure_not_abstract_walker (sub
, st
->right
))
13726 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
13728 gfc_symtree
* overriding
;
13729 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
13732 gcc_assert (overriding
->n
.tb
);
13733 if (overriding
->n
.tb
->deferred
)
13735 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
13736 " %qs is DEFERRED and not overridden",
13737 sub
->name
, &sub
->declared_at
, st
->name
);
13746 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
13748 /* The algorithm used here is to recursively travel up the ancestry of sub
13749 and for each ancestor-type, check all bindings. If any of them is
13750 DEFERRED, look it up starting from sub and see if the found (overriding)
13751 binding is not DEFERRED.
13752 This is not the most efficient way to do this, but it should be ok and is
13753 clearer than something sophisticated. */
13755 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
13757 if (!ancestor
->attr
.abstract
)
13760 /* Walk bindings of this ancestor. */
13761 if (ancestor
->f2k_derived
)
13764 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
13769 /* Find next ancestor type and recurse on it. */
13770 ancestor
= gfc_get_derived_super_type (ancestor
);
13772 return ensure_not_abstract (sub
, ancestor
);
13778 /* This check for typebound defined assignments is done recursively
13779 since the order in which derived types are resolved is not always in
13780 order of the declarations. */
13783 check_defined_assignments (gfc_symbol
*derived
)
13787 for (c
= derived
->components
; c
; c
= c
->next
)
13789 if (!gfc_bt_struct (c
->ts
.type
)
13791 || c
->attr
.allocatable
13792 || c
->attr
.proc_pointer_comp
13793 || c
->attr
.class_pointer
13794 || c
->attr
.proc_pointer
)
13797 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
13798 || (c
->ts
.u
.derived
->f2k_derived
13799 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
13801 derived
->attr
.defined_assign_comp
= 1;
13805 check_defined_assignments (c
->ts
.u
.derived
);
13806 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
13808 derived
->attr
.defined_assign_comp
= 1;
13815 /* Resolve a single component of a derived type or structure. */
13818 resolve_component (gfc_component
*c
, gfc_symbol
*sym
)
13820 gfc_symbol
*super_type
;
13821 symbol_attribute
*attr
;
13823 if (c
->attr
.artificial
)
13826 /* Do not allow vtype components to be resolved in nameless namespaces
13827 such as block data because the procedure pointers will cause ICEs
13828 and vtables are not needed in these contexts. */
13829 if (sym
->attr
.vtype
&& sym
->attr
.use_assoc
13830 && sym
->ns
->proc_name
== NULL
)
13834 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
13835 && c
->attr
.codimension
13836 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
13838 gfc_error ("Coarray component %qs at %L must be allocatable with "
13839 "deferred shape", c
->name
, &c
->loc
);
13844 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
13845 && c
->ts
.u
.derived
->ts
.is_iso_c
)
13847 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13848 "shall not be a coarray", c
->name
, &c
->loc
);
13853 if (gfc_bt_struct (c
->ts
.type
) && c
->ts
.u
.derived
->attr
.coarray_comp
13854 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
13855 || c
->attr
.allocatable
))
13857 gfc_error ("Component %qs at %L with coarray component "
13858 "shall be a nonpointer, nonallocatable scalar",
13864 if (c
->ts
.type
== BT_CLASS
)
13866 if (CLASS_DATA (c
))
13868 attr
= &(CLASS_DATA (c
)->attr
);
13870 /* Fix up contiguous attribute. */
13871 if (c
->attr
.contiguous
)
13872 attr
->contiguous
= 1;
13880 if (attr
&& attr
->contiguous
&& (!attr
->dimension
|| !attr
->pointer
))
13882 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13883 "is not an array pointer", c
->name
, &c
->loc
);
13887 /* F2003, 15.2.1 - length has to be one. */
13888 if (sym
->attr
.is_bind_c
&& c
->ts
.type
== BT_CHARACTER
13889 && (c
->ts
.u
.cl
== NULL
|| c
->ts
.u
.cl
->length
== NULL
13890 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
)
13891 || mpz_cmp_si (c
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
13893 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
13898 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
13900 gfc_symbol
*ifc
= c
->ts
.interface
;
13902 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
13908 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
13910 /* Resolve interface and copy attributes. */
13911 if (ifc
->formal
&& !ifc
->formal_ns
)
13912 resolve_symbol (ifc
);
13913 if (ifc
->attr
.intrinsic
)
13914 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
13918 c
->ts
= ifc
->result
->ts
;
13919 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
13920 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
13921 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
13922 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
13923 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
13928 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
13929 c
->attr
.pointer
= ifc
->attr
.pointer
;
13930 c
->attr
.dimension
= ifc
->attr
.dimension
;
13931 c
->as
= gfc_copy_array_spec (ifc
->as
);
13932 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
13934 c
->ts
.interface
= ifc
;
13935 c
->attr
.function
= ifc
->attr
.function
;
13936 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
13938 c
->attr
.pure
= ifc
->attr
.pure
;
13939 c
->attr
.elemental
= ifc
->attr
.elemental
;
13940 c
->attr
.recursive
= ifc
->attr
.recursive
;
13941 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
13942 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
13943 /* Copy char length. */
13944 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
13946 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
13947 if (cl
->length
&& !cl
->resolved
13948 && !gfc_resolve_expr (cl
->length
))
13957 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
13959 /* Since PPCs are not implicitly typed, a PPC without an explicit
13960 interface must be a subroutine. */
13961 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
13964 /* Procedure pointer components: Check PASS arg. */
13965 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
13966 && !sym
->attr
.vtype
)
13968 gfc_symbol
* me_arg
;
13970 if (c
->tb
->pass_arg
)
13972 gfc_formal_arglist
* i
;
13974 /* If an explicit passing argument name is given, walk the arg-list
13975 and look for it. */
13978 c
->tb
->pass_arg_num
= 1;
13979 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
13981 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
13986 c
->tb
->pass_arg_num
++;
13991 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13992 "at %L has no argument %qs", c
->name
,
13993 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
14000 /* Otherwise, take the first one; there should in fact be at least
14002 c
->tb
->pass_arg_num
= 1;
14003 if (!c
->ts
.interface
->formal
)
14005 gfc_error ("Procedure pointer component %qs with PASS at %L "
14006 "must have at least one argument",
14011 me_arg
= c
->ts
.interface
->formal
->sym
;
14014 /* Now check that the argument-type matches. */
14015 gcc_assert (me_arg
);
14016 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
14017 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
14018 || (me_arg
->ts
.type
== BT_CLASS
14019 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
14021 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14022 " the derived type %qs", me_arg
->name
, c
->name
,
14023 me_arg
->name
, &c
->loc
, sym
->name
);
14028 /* Check for F03:C453. */
14029 if (CLASS_DATA (me_arg
)->attr
.dimension
)
14031 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14032 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
14038 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
14040 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14041 "may not have the POINTER attribute", me_arg
->name
,
14042 c
->name
, me_arg
->name
, &c
->loc
);
14047 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
14049 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14050 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
14051 me_arg
->name
, &c
->loc
);
14056 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
14058 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14059 " at %L", c
->name
, &c
->loc
);
14065 /* Check type-spec if this is not the parent-type component. */
14066 if (((sym
->attr
.is_class
14067 && (!sym
->components
->ts
.u
.derived
->attr
.extension
14068 || c
!= sym
->components
->ts
.u
.derived
->components
))
14069 || (!sym
->attr
.is_class
14070 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
14071 && !sym
->attr
.vtype
14072 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
14075 super_type
= gfc_get_derived_super_type (sym
);
14077 /* If this type is an extension, set the accessibility of the parent
14080 && ((sym
->attr
.is_class
14081 && c
== sym
->components
->ts
.u
.derived
->components
)
14082 || (!sym
->attr
.is_class
&& c
== sym
->components
))
14083 && strcmp (super_type
->name
, c
->name
) == 0)
14084 c
->attr
.access
= super_type
->attr
.access
;
14086 /* If this type is an extension, see if this component has the same name
14087 as an inherited type-bound procedure. */
14088 if (super_type
&& !sym
->attr
.is_class
14089 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
14091 gfc_error ("Component %qs of %qs at %L has the same name as an"
14092 " inherited type-bound procedure",
14093 c
->name
, sym
->name
, &c
->loc
);
14097 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
14098 && !c
->ts
.deferred
)
14100 if (c
->ts
.u
.cl
->length
== NULL
14101 || (!resolve_charlen(c
->ts
.u
.cl
))
14102 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
14104 gfc_error ("Character length of component %qs needs to "
14105 "be a constant specification expression at %L",
14107 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
14112 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
14113 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
14115 gfc_error ("Character component %qs of %qs at %L with deferred "
14116 "length must be a POINTER or ALLOCATABLE",
14117 c
->name
, sym
->name
, &c
->loc
);
14121 /* Add the hidden deferred length field. */
14122 if (c
->ts
.type
== BT_CHARACTER
14123 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)
14124 && !c
->attr
.function
14125 && !sym
->attr
.is_class
)
14127 char name
[GFC_MAX_SYMBOL_LEN
+9];
14128 gfc_component
*strlen
;
14129 sprintf (name
, "_%s_length", c
->name
);
14130 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
14131 if (strlen
== NULL
)
14133 if (!gfc_add_component (sym
, name
, &strlen
))
14135 strlen
->ts
.type
= BT_INTEGER
;
14136 strlen
->ts
.kind
= gfc_charlen_int_kind
;
14137 strlen
->attr
.access
= ACCESS_PRIVATE
;
14138 strlen
->attr
.artificial
= 1;
14142 if (c
->ts
.type
== BT_DERIVED
14143 && sym
->component_access
!= ACCESS_PRIVATE
14144 && gfc_check_symbol_access (sym
)
14145 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
14146 && !c
->ts
.u
.derived
->attr
.use_assoc
14147 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
14148 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
14149 "PRIVATE type and cannot be a component of "
14150 "%qs, which is PUBLIC at %L", c
->name
,
14151 sym
->name
, &sym
->declared_at
))
14154 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
14156 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14157 "type %s", c
->name
, &c
->loc
, sym
->name
);
14161 if (sym
->attr
.sequence
)
14163 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
14165 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14166 "not have the SEQUENCE attribute",
14167 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
14172 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
14173 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
14174 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
14175 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
14176 CLASS_DATA (c
)->ts
.u
.derived
14177 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
14179 /* If an allocatable component derived type is of the same type as
14180 the enclosing derived type, we need a vtable generating so that
14181 the __deallocate procedure is created. */
14182 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
14183 && c
->ts
.u
.derived
== sym
&& c
->attr
.allocatable
== 1)
14184 gfc_find_vtab (&c
->ts
);
14186 /* Ensure that all the derived type components are put on the
14187 derived type list; even in formal namespaces, where derived type
14188 pointer components might not have been declared. */
14189 if (c
->ts
.type
== BT_DERIVED
14191 && c
->ts
.u
.derived
->components
14193 && sym
!= c
->ts
.u
.derived
)
14194 add_dt_to_dt_list (c
->ts
.u
.derived
);
14196 if (!gfc_resolve_array_spec (c
->as
,
14197 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
14198 || c
->attr
.allocatable
)))
14201 if (c
->initializer
&& !sym
->attr
.vtype
14202 && !c
->attr
.pdt_kind
&& !c
->attr
.pdt_len
14203 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
14210 /* Be nice about the locus for a structure expression - show the locus of the
14211 first non-null sub-expression if we can. */
14214 cons_where (gfc_expr
*struct_expr
)
14216 gfc_constructor
*cons
;
14218 gcc_assert (struct_expr
&& struct_expr
->expr_type
== EXPR_STRUCTURE
);
14220 cons
= gfc_constructor_first (struct_expr
->value
.constructor
);
14221 for (; cons
; cons
= gfc_constructor_next (cons
))
14223 if (cons
->expr
&& cons
->expr
->expr_type
!= EXPR_NULL
)
14224 return &cons
->expr
->where
;
14227 return &struct_expr
->where
;
14230 /* Resolve the components of a structure type. Much less work than derived
14234 resolve_fl_struct (gfc_symbol
*sym
)
14237 gfc_expr
*init
= NULL
;
14240 /* Make sure UNIONs do not have overlapping initializers. */
14241 if (sym
->attr
.flavor
== FL_UNION
)
14243 for (c
= sym
->components
; c
; c
= c
->next
)
14245 if (init
&& c
->initializer
)
14247 gfc_error ("Conflicting initializers in union at %L and %L",
14248 cons_where (init
), cons_where (c
->initializer
));
14249 gfc_free_expr (c
->initializer
);
14250 c
->initializer
= NULL
;
14253 init
= c
->initializer
;
14258 for (c
= sym
->components
; c
; c
= c
->next
)
14259 if (!resolve_component (c
, sym
))
14265 if (sym
->components
)
14266 add_dt_to_dt_list (sym
);
14272 /* Resolve the components of a derived type. This does not have to wait until
14273 resolution stage, but can be done as soon as the dt declaration has been
14277 resolve_fl_derived0 (gfc_symbol
*sym
)
14279 gfc_symbol
* super_type
;
14281 gfc_formal_arglist
*f
;
14284 if (sym
->attr
.unlimited_polymorphic
)
14287 super_type
= gfc_get_derived_super_type (sym
);
14290 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
14292 gfc_error ("As extending type %qs at %L has a coarray component, "
14293 "parent type %qs shall also have one", sym
->name
,
14294 &sym
->declared_at
, super_type
->name
);
14298 /* Ensure the extended type gets resolved before we do. */
14299 if (super_type
&& !resolve_fl_derived0 (super_type
))
14302 /* An ABSTRACT type must be extensible. */
14303 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
14305 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
14306 sym
->name
, &sym
->declared_at
);
14310 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
14314 for ( ; c
!= NULL
; c
= c
->next
)
14315 if (!resolve_component (c
, sym
))
14321 /* Now add the caf token field, where needed. */
14322 if (flag_coarray
!= GFC_FCOARRAY_NONE
14323 && !sym
->attr
.is_class
&& !sym
->attr
.vtype
)
14325 for (c
= sym
->components
; c
; c
= c
->next
)
14326 if (!c
->attr
.dimension
&& !c
->attr
.codimension
14327 && (c
->attr
.allocatable
|| c
->attr
.pointer
))
14329 char name
[GFC_MAX_SYMBOL_LEN
+9];
14330 gfc_component
*token
;
14331 sprintf (name
, "_caf_%s", c
->name
);
14332 token
= gfc_find_component (sym
, name
, true, true, NULL
);
14335 if (!gfc_add_component (sym
, name
, &token
))
14337 token
->ts
.type
= BT_VOID
;
14338 token
->ts
.kind
= gfc_default_integer_kind
;
14339 token
->attr
.access
= ACCESS_PRIVATE
;
14340 token
->attr
.artificial
= 1;
14341 token
->attr
.caf_token
= 1;
14346 check_defined_assignments (sym
);
14348 if (!sym
->attr
.defined_assign_comp
&& super_type
)
14349 sym
->attr
.defined_assign_comp
14350 = super_type
->attr
.defined_assign_comp
;
14352 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
14353 all DEFERRED bindings are overridden. */
14354 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
14355 && !sym
->attr
.is_class
14356 && !ensure_not_abstract (sym
, super_type
))
14359 /* Check that there is a component for every PDT parameter. */
14360 if (sym
->attr
.pdt_template
)
14362 for (f
= sym
->formal
; f
; f
= f
->next
)
14366 c
= gfc_find_component (sym
, f
->sym
->name
, true, true, NULL
);
14369 gfc_error ("Parameterized type %qs does not have a component "
14370 "corresponding to parameter %qs at %L", sym
->name
,
14371 f
->sym
->name
, &sym
->declared_at
);
14377 /* Add derived type to the derived type list. */
14378 add_dt_to_dt_list (sym
);
14384 /* The following procedure does the full resolution of a derived type,
14385 including resolution of all type-bound procedures (if present). In contrast
14386 to 'resolve_fl_derived0' this can only be done after the module has been
14387 parsed completely. */
14390 resolve_fl_derived (gfc_symbol
*sym
)
14392 gfc_symbol
*gen_dt
= NULL
;
14394 if (sym
->attr
.unlimited_polymorphic
)
14397 if (!sym
->attr
.is_class
)
14398 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
14399 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
14400 && (!gen_dt
->generic
->sym
->attr
.use_assoc
14401 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
14402 && !gfc_notify_std (GFC_STD_F2003
, "Generic name %qs of function "
14403 "%qs at %L being the same name as derived "
14404 "type at %L", sym
->name
,
14405 gen_dt
->generic
->sym
== sym
14406 ? gen_dt
->generic
->next
->sym
->name
14407 : gen_dt
->generic
->sym
->name
,
14408 gen_dt
->generic
->sym
== sym
14409 ? &gen_dt
->generic
->next
->sym
->declared_at
14410 : &gen_dt
->generic
->sym
->declared_at
,
14411 &sym
->declared_at
))
14414 if (sym
->components
== NULL
&& !sym
->attr
.zero_comp
&& !sym
->attr
.use_assoc
)
14416 gfc_error ("Derived type %qs at %L has not been declared",
14417 sym
->name
, &sym
->declared_at
);
14421 /* Resolve the finalizer procedures. */
14422 if (!gfc_resolve_finalizers (sym
, NULL
))
14425 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
14427 /* Fix up incomplete CLASS symbols. */
14428 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true, NULL
);
14429 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true, NULL
);
14431 /* Nothing more to do for unlimited polymorphic entities. */
14432 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
14434 else if (vptr
->ts
.u
.derived
== NULL
)
14436 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
14438 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
14439 if (!resolve_fl_derived0 (vptr
->ts
.u
.derived
))
14444 if (!resolve_fl_derived0 (sym
))
14447 /* Resolve the type-bound procedures. */
14448 if (!resolve_typebound_procedures (sym
))
14451 /* Generate module vtables subject to their accessibility and their not
14452 being vtables or pdt templates. If this is not done class declarations
14453 in external procedures wind up with their own version and so SELECT TYPE
14454 fails because the vptrs do not have the same address. */
14455 if (gfc_option
.allow_std
& GFC_STD_F2003
14456 && sym
->ns
->proc_name
14457 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14458 && sym
->attr
.access
!= ACCESS_PRIVATE
14459 && !(sym
->attr
.use_assoc
|| sym
->attr
.vtype
|| sym
->attr
.pdt_template
))
14461 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
);
14462 gfc_set_sym_referenced (vtab
);
14470 resolve_fl_namelist (gfc_symbol
*sym
)
14475 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14477 /* Check again, the check in match only works if NAMELIST comes
14479 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
14481 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
14482 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14486 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
14487 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14488 "with assumed shape in namelist %qs at %L",
14489 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14492 if (is_non_constant_shape_array (nl
->sym
)
14493 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
14494 "with nonconstant shape in namelist %qs at %L",
14495 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
14498 if (nl
->sym
->ts
.type
== BT_CHARACTER
14499 && (nl
->sym
->ts
.u
.cl
->length
== NULL
14500 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
14501 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
14502 "nonconstant character length in "
14503 "namelist %qs at %L", nl
->sym
->name
,
14504 sym
->name
, &sym
->declared_at
))
14509 /* Reject PRIVATE objects in a PUBLIC namelist. */
14510 if (gfc_check_symbol_access (sym
))
14512 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14514 if (!nl
->sym
->attr
.use_assoc
14515 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
14516 && !gfc_check_symbol_access (nl
->sym
))
14518 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
14519 "cannot be member of PUBLIC namelist %qs at %L",
14520 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14524 if (nl
->sym
->ts
.type
== BT_DERIVED
14525 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
14526 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
14528 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
14529 "namelist %qs at %L with ALLOCATABLE "
14530 "or POINTER components", nl
->sym
->name
,
14531 sym
->name
, &sym
->declared_at
))
14536 /* Types with private components that came here by USE-association. */
14537 if (nl
->sym
->ts
.type
== BT_DERIVED
14538 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
14540 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
14541 "components and cannot be member of namelist %qs at %L",
14542 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14546 /* Types with private components that are defined in the same module. */
14547 if (nl
->sym
->ts
.type
== BT_DERIVED
14548 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
14549 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
14551 gfc_error ("NAMELIST object %qs has PRIVATE components and "
14552 "cannot be a member of PUBLIC namelist %qs at %L",
14553 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
14560 /* 14.1.2 A module or internal procedure represent local entities
14561 of the same type as a namelist member and so are not allowed. */
14562 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14564 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
14567 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
14568 if ((nl
->sym
== sym
->ns
->proc_name
)
14570 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
14575 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
14576 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
14578 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
14579 "attribute in %qs at %L", nlsym
->name
,
14580 &sym
->declared_at
);
14587 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
14588 nl
->sym
->attr
.asynchronous
= 1;
14595 resolve_fl_parameter (gfc_symbol
*sym
)
14597 /* A parameter array's shape needs to be constant. */
14598 if (sym
->as
!= NULL
14599 && (sym
->as
->type
== AS_DEFERRED
14600 || is_non_constant_shape_array (sym
)))
14602 gfc_error ("Parameter array %qs at %L cannot be automatic "
14603 "or of deferred shape", sym
->name
, &sym
->declared_at
);
14607 /* Constraints on deferred type parameter. */
14608 if (!deferred_requirements (sym
))
14611 /* Make sure a parameter that has been implicitly typed still
14612 matches the implicit type, since PARAMETER statements can precede
14613 IMPLICIT statements. */
14614 if (sym
->attr
.implicit_type
14615 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
14618 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
14619 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
14623 /* Make sure the types of derived parameters are consistent. This
14624 type checking is deferred until resolution because the type may
14625 refer to a derived type from the host. */
14626 if (sym
->ts
.type
== BT_DERIVED
14627 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
14629 gfc_error ("Incompatible derived type in PARAMETER at %L",
14630 &sym
->value
->where
);
14634 /* F03:C509,C514. */
14635 if (sym
->ts
.type
== BT_CLASS
)
14637 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
14638 sym
->name
, &sym
->declared_at
);
14646 /* Called by resolve_symbol to check PDTs. */
14649 resolve_pdt (gfc_symbol
* sym
)
14651 gfc_symbol
*derived
= NULL
;
14652 gfc_actual_arglist
*param
;
14654 bool const_len_exprs
= true;
14655 bool assumed_len_exprs
= false;
14656 symbol_attribute
*attr
;
14658 if (sym
->ts
.type
== BT_DERIVED
)
14660 derived
= sym
->ts
.u
.derived
;
14661 attr
= &(sym
->attr
);
14663 else if (sym
->ts
.type
== BT_CLASS
)
14665 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
14666 attr
= &(CLASS_DATA (sym
)->attr
);
14669 gcc_unreachable ();
14671 gcc_assert (derived
->attr
.pdt_type
);
14673 for (param
= sym
->param_list
; param
; param
= param
->next
)
14675 c
= gfc_find_component (derived
, param
->name
, false, true, NULL
);
14677 if (c
->attr
.pdt_kind
)
14680 if (param
->expr
&& !gfc_is_constant_expr (param
->expr
)
14681 && c
->attr
.pdt_len
)
14682 const_len_exprs
= false;
14683 else if (param
->spec_type
== SPEC_ASSUMED
)
14684 assumed_len_exprs
= true;
14686 if (param
->spec_type
== SPEC_DEFERRED
14687 && !attr
->allocatable
&& !attr
->pointer
)
14688 gfc_error ("The object %qs at %L has a deferred LEN "
14689 "parameter %qs and is neither allocatable "
14690 "nor a pointer", sym
->name
, &sym
->declared_at
,
14695 if (!const_len_exprs
14696 && (sym
->ns
->proc_name
->attr
.is_main_program
14697 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
14698 || sym
->attr
.save
!= SAVE_NONE
))
14699 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
14700 "SAVE attribute or be a variable declared in the "
14701 "main program, a module or a submodule(F08/C513)",
14702 sym
->name
, &sym
->declared_at
);
14704 if (assumed_len_exprs
&& !(sym
->attr
.dummy
14705 || sym
->attr
.select_type_temporary
|| sym
->attr
.associate_var
))
14706 gfc_error ("The object %qs at %L with ASSUMED type parameters "
14707 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
14708 sym
->name
, &sym
->declared_at
);
14712 /* Do anything necessary to resolve a symbol. Right now, we just
14713 assume that an otherwise unknown symbol is a variable. This sort
14714 of thing commonly happens for symbols in module. */
14717 resolve_symbol (gfc_symbol
*sym
)
14719 int check_constant
, mp_flag
;
14720 gfc_symtree
*symtree
;
14721 gfc_symtree
*this_symtree
;
14724 symbol_attribute class_attr
;
14725 gfc_array_spec
*as
;
14726 bool saved_specification_expr
;
14732 /* No symbol will ever have union type; only components can be unions.
14733 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
14734 (just like derived type declaration symbols have flavor FL_DERIVED). */
14735 gcc_assert (sym
->ts
.type
!= BT_UNION
);
14737 /* Coarrayed polymorphic objects with allocatable or pointer components are
14738 yet unsupported for -fcoarray=lib. */
14739 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->ts
.type
== BT_CLASS
14740 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
14741 && CLASS_DATA (sym
)->attr
.codimension
14742 && (CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
14743 || CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
))
14745 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
14746 "type coarrays at %L are unsupported", &sym
->declared_at
);
14750 if (sym
->attr
.artificial
)
14753 if (sym
->attr
.unlimited_polymorphic
)
14756 if (sym
->attr
.flavor
== FL_UNKNOWN
14757 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
14758 && !sym
->attr
.generic
&& !sym
->attr
.external
14759 && sym
->attr
.if_source
== IFSRC_UNKNOWN
14760 && sym
->ts
.type
== BT_UNKNOWN
))
14763 /* If we find that a flavorless symbol is an interface in one of the
14764 parent namespaces, find its symtree in this namespace, free the
14765 symbol and set the symtree to point to the interface symbol. */
14766 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
14768 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
14769 if (symtree
&& (symtree
->n
.sym
->generic
||
14770 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
14771 && sym
->ns
->construct_entities
)))
14773 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
14775 if (this_symtree
->n
.sym
== sym
)
14777 symtree
->n
.sym
->refs
++;
14778 gfc_release_symbol (sym
);
14779 this_symtree
->n
.sym
= symtree
->n
.sym
;
14785 /* Otherwise give it a flavor according to such attributes as
14787 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
14788 && sym
->attr
.intrinsic
== 0)
14789 sym
->attr
.flavor
= FL_VARIABLE
;
14790 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
14792 sym
->attr
.flavor
= FL_PROCEDURE
;
14793 if (sym
->attr
.dimension
)
14794 sym
->attr
.function
= 1;
14798 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
14799 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14801 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
14802 && !resolve_procedure_interface (sym
))
14805 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
14806 && (sym
->attr
.procedure
|| sym
->attr
.external
))
14808 if (sym
->attr
.external
)
14809 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
14810 "at %L", &sym
->declared_at
);
14812 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
14813 "at %L", &sym
->declared_at
);
14818 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
14821 else if ((sym
->attr
.flavor
== FL_STRUCT
|| sym
->attr
.flavor
== FL_UNION
)
14822 && !resolve_fl_struct (sym
))
14825 /* Symbols that are module procedures with results (functions) have
14826 the types and array specification copied for type checking in
14827 procedures that call them, as well as for saving to a module
14828 file. These symbols can't stand the scrutiny that their results
14830 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
14832 /* Make sure that the intrinsic is consistent with its internal
14833 representation. This needs to be done before assigning a default
14834 type to avoid spurious warnings. */
14835 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
14836 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
14839 /* Resolve associate names. */
14841 resolve_assoc_var (sym
, true);
14843 /* Assign default type to symbols that need one and don't have one. */
14844 if (sym
->ts
.type
== BT_UNKNOWN
)
14846 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
14848 gfc_set_default_type (sym
, 1, NULL
);
14851 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
14852 && !sym
->attr
.function
&& !sym
->attr
.subroutine
14853 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
14854 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
14856 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14858 /* The specific case of an external procedure should emit an error
14859 in the case that there is no implicit type. */
14862 if (!sym
->attr
.mixed_entry_master
)
14863 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
14867 /* Result may be in another namespace. */
14868 resolve_symbol (sym
->result
);
14870 if (!sym
->result
->attr
.proc_pointer
)
14872 sym
->ts
= sym
->result
->ts
;
14873 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
14874 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
14875 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
14876 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
14877 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
14882 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
14884 bool saved_specification_expr
= specification_expr
;
14885 specification_expr
= true;
14886 gfc_resolve_array_spec (sym
->result
->as
, false);
14887 specification_expr
= saved_specification_expr
;
14890 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
14892 as
= CLASS_DATA (sym
)->as
;
14893 class_attr
= CLASS_DATA (sym
)->attr
;
14894 class_attr
.pointer
= class_attr
.class_pointer
;
14898 class_attr
= sym
->attr
;
14903 if (sym
->attr
.contiguous
14904 && (!class_attr
.dimension
14905 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
14906 && !class_attr
.pointer
)))
14908 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
14909 "array pointer or an assumed-shape or assumed-rank array",
14910 sym
->name
, &sym
->declared_at
);
14914 /* Assumed size arrays and assumed shape arrays must be dummy
14915 arguments. Array-spec's of implied-shape should have been resolved to
14916 AS_EXPLICIT already. */
14920 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
14921 specification expression. */
14922 if (as
->type
== AS_IMPLIED_SHAPE
)
14925 for (i
=0; i
<as
->rank
; i
++)
14927 if (as
->lower
[i
] != NULL
&& as
->upper
[i
] == NULL
)
14929 gfc_error ("Bad specification for assumed size array at %L",
14930 &as
->lower
[i
]->where
);
14937 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
14938 || as
->type
== AS_ASSUMED_SHAPE
)
14939 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
14941 if (as
->type
== AS_ASSUMED_SIZE
)
14942 gfc_error ("Assumed size array at %L must be a dummy argument",
14943 &sym
->declared_at
);
14945 gfc_error ("Assumed shape array at %L must be a dummy argument",
14946 &sym
->declared_at
);
14949 /* TS 29113, C535a. */
14950 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
14951 && !sym
->attr
.select_type_temporary
)
14953 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14954 &sym
->declared_at
);
14957 if (as
->type
== AS_ASSUMED_RANK
14958 && (sym
->attr
.codimension
|| sym
->attr
.value
))
14960 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14961 "CODIMENSION attribute", &sym
->declared_at
);
14966 /* Make sure symbols with known intent or optional are really dummy
14967 variable. Because of ENTRY statement, this has to be deferred
14968 until resolution time. */
14970 if (!sym
->attr
.dummy
14971 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
14973 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
14977 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
14979 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14980 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
14984 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
14986 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
14987 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
14989 gfc_error ("Character dummy variable %qs at %L with VALUE "
14990 "attribute must have constant length",
14991 sym
->name
, &sym
->declared_at
);
14995 if (sym
->ts
.is_c_interop
14996 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
14998 gfc_error ("C interoperable character dummy variable %qs at %L "
14999 "with VALUE attribute must have length one",
15000 sym
->name
, &sym
->declared_at
);
15005 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15006 && sym
->ts
.u
.derived
->attr
.generic
)
15008 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
15009 if (!sym
->ts
.u
.derived
)
15011 gfc_error ("The derived type %qs at %L is of type %qs, "
15012 "which has not been defined", sym
->name
,
15013 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15014 sym
->ts
.type
= BT_UNKNOWN
;
15019 /* Use the same constraints as TYPE(*), except for the type check
15020 and that only scalars and assumed-size arrays are permitted. */
15021 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
15023 if (!sym
->attr
.dummy
)
15025 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15026 "a dummy argument", sym
->name
, &sym
->declared_at
);
15030 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
15031 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
15032 && sym
->ts
.type
!= BT_COMPLEX
)
15034 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15035 "of type TYPE(*) or of an numeric intrinsic type",
15036 sym
->name
, &sym
->declared_at
);
15040 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15041 || sym
->attr
.pointer
|| sym
->attr
.value
)
15043 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15044 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15045 "attribute", sym
->name
, &sym
->declared_at
);
15049 if (sym
->attr
.intent
== INTENT_OUT
)
15051 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15052 "have the INTENT(OUT) attribute",
15053 sym
->name
, &sym
->declared_at
);
15056 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
15058 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15059 "either be a scalar or an assumed-size array",
15060 sym
->name
, &sym
->declared_at
);
15064 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15065 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15067 sym
->ts
.type
= BT_ASSUMED
;
15068 sym
->as
= gfc_get_array_spec ();
15069 sym
->as
->type
= AS_ASSUMED_SIZE
;
15071 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
15073 else if (sym
->ts
.type
== BT_ASSUMED
)
15075 /* TS 29113, C407a. */
15076 if (!sym
->attr
.dummy
)
15078 gfc_error ("Assumed type of variable %s at %L is only permitted "
15079 "for dummy variables", sym
->name
, &sym
->declared_at
);
15082 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
15083 || sym
->attr
.pointer
|| sym
->attr
.value
)
15085 gfc_error ("Assumed-type variable %s at %L may not have the "
15086 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15087 sym
->name
, &sym
->declared_at
);
15090 if (sym
->attr
.intent
== INTENT_OUT
)
15092 gfc_error ("Assumed-type variable %s at %L may not have the "
15093 "INTENT(OUT) attribute",
15094 sym
->name
, &sym
->declared_at
);
15097 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
15099 gfc_error ("Assumed-type variable %s at %L shall not be an "
15100 "explicit-shape array", sym
->name
, &sym
->declared_at
);
15105 /* If the symbol is marked as bind(c), that it is declared at module level
15106 scope and verify its type and kind. Do not do the latter for symbols
15107 that are implicitly typed because that is handled in
15108 gfc_set_default_type. Handle dummy arguments and procedure definitions
15109 separately. Also, anything that is use associated is not handled here
15110 but instead is handled in the module it is declared in. Finally, derived
15111 type definitions are allowed to be BIND(C) since that only implies that
15112 they're interoperable, and they are checked fully for interoperability
15113 when a variable is declared of that type. */
15114 if (sym
->attr
.is_bind_c
&& sym
->attr
.use_assoc
== 0
15115 && sym
->attr
.dummy
== 0 && sym
->attr
.flavor
!= FL_PROCEDURE
15116 && sym
->attr
.flavor
!= FL_DERIVED
)
15120 /* First, make sure the variable is declared at the
15121 module-level scope (J3/04-007, Section 15.3). */
15122 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
15123 sym
->attr
.in_common
== 0)
15125 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
15126 "is neither a COMMON block nor declared at the "
15127 "module level scope", sym
->name
, &(sym
->declared_at
));
15130 else if (sym
->ts
.type
== BT_CHARACTER
15131 && (sym
->ts
.u
.cl
== NULL
|| sym
->ts
.u
.cl
->length
== NULL
15132 || !gfc_is_constant_expr (sym
->ts
.u
.cl
->length
)
15133 || mpz_cmp_si (sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
15135 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15136 sym
->name
, &sym
->declared_at
);
15139 else if (sym
->common_head
!= NULL
&& sym
->attr
.implicit_type
== 0)
15141 t
= verify_com_block_vars_c_interop (sym
->common_head
);
15143 else if (sym
->attr
.implicit_type
== 0)
15145 /* If type() declaration, we need to verify that the components
15146 of the given type are all C interoperable, etc. */
15147 if (sym
->ts
.type
== BT_DERIVED
&&
15148 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
15150 /* Make sure the user marked the derived type as BIND(C). If
15151 not, call the verify routine. This could print an error
15152 for the derived type more than once if multiple variables
15153 of that type are declared. */
15154 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
15155 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
15159 /* Verify the variable itself as C interoperable if it
15160 is BIND(C). It is not possible for this to succeed if
15161 the verify_bind_c_derived_type failed, so don't have to handle
15162 any error returned by verify_bind_c_derived_type. */
15163 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
15164 sym
->common_block
);
15169 /* clear the is_bind_c flag to prevent reporting errors more than
15170 once if something failed. */
15171 sym
->attr
.is_bind_c
= 0;
15176 /* If a derived type symbol has reached this point, without its
15177 type being declared, we have an error. Notice that most
15178 conditions that produce undefined derived types have already
15179 been dealt with. However, the likes of:
15180 implicit type(t) (t) ..... call foo (t) will get us here if
15181 the type is not declared in the scope of the implicit
15182 statement. Change the type to BT_UNKNOWN, both because it is so
15183 and to prevent an ICE. */
15184 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
15185 && sym
->ts
.u
.derived
->components
== NULL
15186 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
15188 gfc_error ("The derived type %qs at %L is of type %qs, "
15189 "which has not been defined", sym
->name
,
15190 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
15191 sym
->ts
.type
= BT_UNKNOWN
;
15195 /* Make sure that the derived type has been resolved and that the
15196 derived type is visible in the symbol's namespace, if it is a
15197 module function and is not PRIVATE. */
15198 if (sym
->ts
.type
== BT_DERIVED
15199 && sym
->ts
.u
.derived
->attr
.use_assoc
15200 && sym
->ns
->proc_name
15201 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15202 && !resolve_fl_derived (sym
->ts
.u
.derived
))
15205 /* Unless the derived-type declaration is use associated, Fortran 95
15206 does not allow public entries of private derived types.
15207 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15208 161 in 95-006r3. */
15209 if (sym
->ts
.type
== BT_DERIVED
15210 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15211 && !sym
->ts
.u
.derived
->attr
.use_assoc
15212 && gfc_check_symbol_access (sym
)
15213 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
15214 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
15215 "derived type %qs",
15216 (sym
->attr
.flavor
== FL_PARAMETER
)
15217 ? "parameter" : "variable",
15218 sym
->name
, &sym
->declared_at
,
15219 sym
->ts
.u
.derived
->name
))
15222 /* F2008, C1302. */
15223 if (sym
->ts
.type
== BT_DERIVED
15224 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15225 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
15226 || sym
->ts
.u
.derived
->attr
.lock_comp
)
15227 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15229 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
15230 "type LOCK_TYPE must be a coarray", sym
->name
,
15231 &sym
->declared_at
);
15235 /* TS18508, C702/C703. */
15236 if (sym
->ts
.type
== BT_DERIVED
15237 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
15238 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
15239 || sym
->ts
.u
.derived
->attr
.event_comp
)
15240 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
15242 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
15243 "type EVENT_TYPE must be a coarray", sym
->name
,
15244 &sym
->declared_at
);
15248 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
15249 default initialization is defined (5.1.2.4.4). */
15250 if (sym
->ts
.type
== BT_DERIVED
15252 && sym
->attr
.intent
== INTENT_OUT
15254 && sym
->as
->type
== AS_ASSUMED_SIZE
)
15256 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
15258 if (c
->initializer
)
15260 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
15261 "ASSUMED SIZE and so cannot have a default initializer",
15262 sym
->name
, &sym
->declared_at
);
15269 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15270 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
15272 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
15273 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15278 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
15279 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.event_comp
)
15281 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
15282 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
15287 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15288 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15289 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15290 || class_attr
.codimension
)
15291 && (sym
->attr
.result
|| sym
->result
== sym
))
15293 gfc_error ("Function result %qs at %L shall not be a coarray or have "
15294 "a coarray component", sym
->name
, &sym
->declared_at
);
15299 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
15300 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
15302 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15303 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
15308 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15309 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15310 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15311 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
15312 || class_attr
.allocatable
))
15314 gfc_error ("Variable %qs at %L with coarray component shall be a "
15315 "nonpointer, nonallocatable scalar, which is not a coarray",
15316 sym
->name
, &sym
->declared_at
);
15320 /* F2008, C526. The function-result case was handled above. */
15321 if (class_attr
.codimension
15322 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
15323 || sym
->attr
.select_type_temporary
15324 || sym
->attr
.associate_var
15325 || (sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15326 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
15327 || sym
->ns
->proc_name
->attr
.is_main_program
15328 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
15330 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
15331 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
15335 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
15336 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
15338 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
15339 "deferred shape", sym
->name
, &sym
->declared_at
);
15342 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
15343 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
15345 gfc_error ("Allocatable coarray variable %qs at %L must have "
15346 "deferred shape", sym
->name
, &sym
->declared_at
);
15351 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
15352 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
15353 && CLASS_DATA (sym
)->attr
.coarray_comp
))
15354 || (class_attr
.codimension
&& class_attr
.allocatable
))
15355 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
15357 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
15358 "allocatable coarray or have coarray components",
15359 sym
->name
, &sym
->declared_at
);
15363 if (class_attr
.codimension
&& sym
->attr
.dummy
15364 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
15366 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
15367 "procedure %qs", sym
->name
, &sym
->declared_at
,
15368 sym
->ns
->proc_name
->name
);
15372 if (sym
->ts
.type
== BT_LOGICAL
15373 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
15374 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
15375 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
15378 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
15379 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
15381 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
15382 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
15383 "%L with non-C_Bool kind in BIND(C) procedure "
15384 "%qs", sym
->name
, &sym
->declared_at
,
15385 sym
->ns
->proc_name
->name
))
15387 else if (!gfc_logical_kinds
[i
].c_bool
15388 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
15389 "%qs at %L with non-C_Bool kind in "
15390 "BIND(C) procedure %qs", sym
->name
,
15392 sym
->attr
.function
? sym
->name
15393 : sym
->ns
->proc_name
->name
))
15397 switch (sym
->attr
.flavor
)
15400 if (!resolve_fl_variable (sym
, mp_flag
))
15405 if (sym
->formal
&& !sym
->formal_ns
)
15407 /* Check that none of the arguments are a namelist. */
15408 gfc_formal_arglist
*formal
= sym
->formal
;
15410 for (; formal
; formal
= formal
->next
)
15411 if (formal
->sym
&& formal
->sym
->attr
.flavor
== FL_NAMELIST
)
15413 gfc_error ("Namelist %qs cannot be an argument to "
15414 "subroutine or function at %L",
15415 formal
->sym
->name
, &sym
->declared_at
);
15420 if (!resolve_fl_procedure (sym
, mp_flag
))
15425 if (!resolve_fl_namelist (sym
))
15430 if (!resolve_fl_parameter (sym
))
15438 /* Resolve array specifier. Check as well some constraints
15439 on COMMON blocks. */
15441 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
15443 /* Set the formal_arg_flag so that check_conflict will not throw
15444 an error for host associated variables in the specification
15445 expression for an array_valued function. */
15446 if ((sym
->attr
.function
|| sym
->attr
.result
) && sym
->as
)
15447 formal_arg_flag
= true;
15449 saved_specification_expr
= specification_expr
;
15450 specification_expr
= true;
15451 gfc_resolve_array_spec (sym
->as
, check_constant
);
15452 specification_expr
= saved_specification_expr
;
15454 formal_arg_flag
= false;
15456 /* Resolve formal namespaces. */
15457 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
15458 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
15459 gfc_resolve (sym
->formal_ns
);
15461 /* Make sure the formal namespace is present. */
15462 if (sym
->formal
&& !sym
->formal_ns
)
15464 gfc_formal_arglist
*formal
= sym
->formal
;
15465 while (formal
&& !formal
->sym
)
15466 formal
= formal
->next
;
15470 sym
->formal_ns
= formal
->sym
->ns
;
15471 if (sym
->ns
!= formal
->sym
->ns
)
15472 sym
->formal_ns
->refs
++;
15476 /* Check threadprivate restrictions. */
15477 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
15478 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15479 && (!sym
->attr
.in_common
15480 && sym
->module
== NULL
15481 && (sym
->ns
->proc_name
== NULL
15482 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15483 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
15485 /* Check omp declare target restrictions. */
15486 if (sym
->attr
.omp_declare_target
15487 && sym
->attr
.flavor
== FL_VARIABLE
15489 && !(sym
->ns
->save_all
&& !sym
->attr
.automatic
)
15490 && (!sym
->attr
.in_common
15491 && sym
->module
== NULL
15492 && (sym
->ns
->proc_name
== NULL
15493 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
15494 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
15495 sym
->name
, &sym
->declared_at
);
15497 /* If we have come this far we can apply default-initializers, as
15498 described in 14.7.5, to those variables that have not already
15499 been assigned one. */
15500 if (sym
->ts
.type
== BT_DERIVED
15502 && !sym
->attr
.allocatable
15503 && !sym
->attr
.alloc_comp
)
15505 symbol_attribute
*a
= &sym
->attr
;
15507 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
15508 && !a
->in_common
&& !a
->use_assoc
15510 && !((a
->function
|| a
->result
)
15512 || sym
->ts
.u
.derived
->attr
.alloc_comp
15513 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15514 && !(a
->function
&& sym
!= sym
->result
))
15515 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
15516 apply_default_init (sym
);
15517 else if (a
->function
&& sym
->result
&& a
->access
!= ACCESS_PRIVATE
15518 && (sym
->ts
.u
.derived
->attr
.alloc_comp
15519 || sym
->ts
.u
.derived
->attr
.pointer_comp
))
15520 /* Mark the result symbol to be referenced, when it has allocatable
15522 sym
->result
->attr
.referenced
= 1;
15525 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
15526 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
15527 && !CLASS_DATA (sym
)->attr
.class_pointer
15528 && !CLASS_DATA (sym
)->attr
.allocatable
)
15529 apply_default_init (sym
);
15531 /* If this symbol has a type-spec, check it. */
15532 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
15533 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
15534 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
15537 if (sym
->param_list
)
15542 /************* Resolve DATA statements *************/
15546 gfc_data_value
*vnode
;
15552 /* Advance the values structure to point to the next value in the data list. */
15555 next_data_value (void)
15557 while (mpz_cmp_ui (values
.left
, 0) == 0)
15560 if (values
.vnode
->next
== NULL
)
15563 values
.vnode
= values
.vnode
->next
;
15564 mpz_set (values
.left
, values
.vnode
->repeat
);
15572 check_data_variable (gfc_data_variable
*var
, locus
*where
)
15578 ar_type mark
= AR_UNKNOWN
;
15580 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
15586 if (!gfc_resolve_expr (var
->expr
))
15590 mpz_init_set_si (offset
, 0);
15593 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
15594 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
15595 e
= e
->value
.function
.actual
->expr
;
15597 if (e
->expr_type
!= EXPR_VARIABLE
)
15599 gfc_error ("Expecting definable entity near %L", where
);
15603 sym
= e
->symtree
->n
.sym
;
15605 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
15607 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
15608 sym
->name
, &sym
->declared_at
);
15612 if (e
->ref
== NULL
&& sym
->as
)
15614 gfc_error ("DATA array %qs at %L must be specified in a previous"
15615 " declaration", sym
->name
, where
);
15619 has_pointer
= sym
->attr
.pointer
;
15621 if (gfc_is_coindexed (e
))
15623 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
15628 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15630 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
15634 && ref
->type
== REF_ARRAY
15635 && ref
->u
.ar
.type
!= AR_FULL
)
15637 gfc_error ("DATA element %qs at %L is a pointer and so must "
15638 "be a full array", sym
->name
, where
);
15643 if (e
->rank
== 0 || has_pointer
)
15645 mpz_init_set_ui (size
, 1);
15652 /* Find the array section reference. */
15653 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
15655 if (ref
->type
!= REF_ARRAY
)
15657 if (ref
->u
.ar
.type
== AR_ELEMENT
)
15663 /* Set marks according to the reference pattern. */
15664 switch (ref
->u
.ar
.type
)
15672 /* Get the start position of array section. */
15673 gfc_get_section_index (ar
, section_index
, &offset
);
15678 gcc_unreachable ();
15681 if (!gfc_array_size (e
, &size
))
15683 gfc_error ("Nonconstant array section at %L in DATA statement",
15685 mpz_clear (offset
);
15692 while (mpz_cmp_ui (size
, 0) > 0)
15694 if (!next_data_value ())
15696 gfc_error ("DATA statement at %L has more variables than values",
15702 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
15706 /* If we have more than one element left in the repeat count,
15707 and we have more than one element left in the target variable,
15708 then create a range assignment. */
15709 /* FIXME: Only done for full arrays for now, since array sections
15711 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
15712 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
15716 if (mpz_cmp (size
, values
.left
) >= 0)
15718 mpz_init_set (range
, values
.left
);
15719 mpz_sub (size
, size
, values
.left
);
15720 mpz_set_ui (values
.left
, 0);
15724 mpz_init_set (range
, size
);
15725 mpz_sub (values
.left
, values
.left
, size
);
15726 mpz_set_ui (size
, 0);
15729 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15732 mpz_add (offset
, offset
, range
);
15739 /* Assign initial value to symbol. */
15742 mpz_sub_ui (values
.left
, values
.left
, 1);
15743 mpz_sub_ui (size
, size
, 1);
15745 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
15750 if (mark
== AR_FULL
)
15751 mpz_add_ui (offset
, offset
, 1);
15753 /* Modify the array section indexes and recalculate the offset
15754 for next element. */
15755 else if (mark
== AR_SECTION
)
15756 gfc_advance_section (section_index
, ar
, &offset
);
15760 if (mark
== AR_SECTION
)
15762 for (i
= 0; i
< ar
->dimen
; i
++)
15763 mpz_clear (section_index
[i
]);
15767 mpz_clear (offset
);
15773 static bool traverse_data_var (gfc_data_variable
*, locus
*);
15775 /* Iterate over a list of elements in a DATA statement. */
15778 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
15781 iterator_stack frame
;
15782 gfc_expr
*e
, *start
, *end
, *step
;
15783 bool retval
= true;
15785 mpz_init (frame
.value
);
15788 start
= gfc_copy_expr (var
->iter
.start
);
15789 end
= gfc_copy_expr (var
->iter
.end
);
15790 step
= gfc_copy_expr (var
->iter
.step
);
15792 if (!gfc_simplify_expr (start
, 1)
15793 || start
->expr_type
!= EXPR_CONSTANT
)
15795 gfc_error ("start of implied-do loop at %L could not be "
15796 "simplified to a constant value", &start
->where
);
15800 if (!gfc_simplify_expr (end
, 1)
15801 || end
->expr_type
!= EXPR_CONSTANT
)
15803 gfc_error ("end of implied-do loop at %L could not be "
15804 "simplified to a constant value", &start
->where
);
15808 if (!gfc_simplify_expr (step
, 1)
15809 || step
->expr_type
!= EXPR_CONSTANT
)
15811 gfc_error ("step of implied-do loop at %L could not be "
15812 "simplified to a constant value", &start
->where
);
15817 mpz_set (trip
, end
->value
.integer
);
15818 mpz_sub (trip
, trip
, start
->value
.integer
);
15819 mpz_add (trip
, trip
, step
->value
.integer
);
15821 mpz_div (trip
, trip
, step
->value
.integer
);
15823 mpz_set (frame
.value
, start
->value
.integer
);
15825 frame
.prev
= iter_stack
;
15826 frame
.variable
= var
->iter
.var
->symtree
;
15827 iter_stack
= &frame
;
15829 while (mpz_cmp_ui (trip
, 0) > 0)
15831 if (!traverse_data_var (var
->list
, where
))
15837 e
= gfc_copy_expr (var
->expr
);
15838 if (!gfc_simplify_expr (e
, 1))
15845 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
15847 mpz_sub_ui (trip
, trip
, 1);
15851 mpz_clear (frame
.value
);
15854 gfc_free_expr (start
);
15855 gfc_free_expr (end
);
15856 gfc_free_expr (step
);
15858 iter_stack
= frame
.prev
;
15863 /* Type resolve variables in the variable list of a DATA statement. */
15866 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
15870 for (; var
; var
= var
->next
)
15872 if (var
->expr
== NULL
)
15873 t
= traverse_data_list (var
, where
);
15875 t
= check_data_variable (var
, where
);
15885 /* Resolve the expressions and iterators associated with a data statement.
15886 This is separate from the assignment checking because data lists should
15887 only be resolved once. */
15890 resolve_data_variables (gfc_data_variable
*d
)
15892 for (; d
; d
= d
->next
)
15894 if (d
->list
== NULL
)
15896 if (!gfc_resolve_expr (d
->expr
))
15901 if (!gfc_resolve_iterator (&d
->iter
, false, true))
15904 if (!resolve_data_variables (d
->list
))
15913 /* Resolve a single DATA statement. We implement this by storing a pointer to
15914 the value list into static variables, and then recursively traversing the
15915 variables list, expanding iterators and such. */
15918 resolve_data (gfc_data
*d
)
15921 if (!resolve_data_variables (d
->var
))
15924 values
.vnode
= d
->value
;
15925 if (d
->value
== NULL
)
15926 mpz_set_ui (values
.left
, 0);
15928 mpz_set (values
.left
, d
->value
->repeat
);
15930 if (!traverse_data_var (d
->var
, &d
->where
))
15933 /* At this point, we better not have any values left. */
15935 if (next_data_value ())
15936 gfc_error ("DATA statement at %L has more values than variables",
15941 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15942 accessed by host or use association, is a dummy argument to a pure function,
15943 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15944 is storage associated with any such variable, shall not be used in the
15945 following contexts: (clients of this function). */
15947 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15948 procedure. Returns zero if assignment is OK, nonzero if there is a
15951 gfc_impure_variable (gfc_symbol
*sym
)
15956 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
15959 /* Check if the symbol's ns is inside the pure procedure. */
15960 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15964 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
15968 proc
= sym
->ns
->proc_name
;
15969 if (sym
->attr
.dummy
15970 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
15971 || proc
->attr
.function
))
15974 /* TODO: Sort out what can be storage associated, if anything, and include
15975 it here. In principle equivalences should be scanned but it does not
15976 seem to be possible to storage associate an impure variable this way. */
15981 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15982 current namespace is inside a pure procedure. */
15985 gfc_pure (gfc_symbol
*sym
)
15987 symbol_attribute attr
;
15992 /* Check if the current namespace or one of its parents
15993 belongs to a pure procedure. */
15994 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
15996 sym
= ns
->proc_name
;
16000 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
16008 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
16012 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16013 checks if the current namespace is implicitly pure. Note that this
16014 function returns false for a PURE procedure. */
16017 gfc_implicit_pure (gfc_symbol
*sym
)
16023 /* Check if the current procedure is implicit_pure. Walk up
16024 the procedure list until we find a procedure. */
16025 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16027 sym
= ns
->proc_name
;
16031 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16036 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
16037 && !sym
->attr
.pure
;
16042 gfc_unset_implicit_pure (gfc_symbol
*sym
)
16048 /* Check if the current procedure is implicit_pure. Walk up
16049 the procedure list until we find a procedure. */
16050 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
16052 sym
= ns
->proc_name
;
16056 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16061 if (sym
->attr
.flavor
== FL_PROCEDURE
)
16062 sym
->attr
.implicit_pure
= 0;
16064 sym
->attr
.pure
= 0;
16068 /* Test whether the current procedure is elemental or not. */
16071 gfc_elemental (gfc_symbol
*sym
)
16073 symbol_attribute attr
;
16076 sym
= gfc_current_ns
->proc_name
;
16081 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
16085 /* Warn about unused labels. */
16088 warn_unused_fortran_label (gfc_st_label
*label
)
16093 warn_unused_fortran_label (label
->left
);
16095 if (label
->defined
== ST_LABEL_UNKNOWN
)
16098 switch (label
->referenced
)
16100 case ST_LABEL_UNKNOWN
:
16101 gfc_warning (OPT_Wunused_label
, "Label %d at %L defined but not used",
16102 label
->value
, &label
->where
);
16105 case ST_LABEL_BAD_TARGET
:
16106 gfc_warning (OPT_Wunused_label
,
16107 "Label %d at %L defined but cannot be used",
16108 label
->value
, &label
->where
);
16115 warn_unused_fortran_label (label
->right
);
16119 /* Returns the sequence type of a symbol or sequence. */
16122 sequence_type (gfc_typespec ts
)
16131 if (ts
.u
.derived
->components
== NULL
)
16132 return SEQ_NONDEFAULT
;
16134 result
= sequence_type (ts
.u
.derived
->components
->ts
);
16135 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
16136 if (sequence_type (c
->ts
) != result
)
16142 if (ts
.kind
!= gfc_default_character_kind
)
16143 return SEQ_NONDEFAULT
;
16145 return SEQ_CHARACTER
;
16148 if (ts
.kind
!= gfc_default_integer_kind
)
16149 return SEQ_NONDEFAULT
;
16151 return SEQ_NUMERIC
;
16154 if (!(ts
.kind
== gfc_default_real_kind
16155 || ts
.kind
== gfc_default_double_kind
))
16156 return SEQ_NONDEFAULT
;
16158 return SEQ_NUMERIC
;
16161 if (ts
.kind
!= gfc_default_complex_kind
)
16162 return SEQ_NONDEFAULT
;
16164 return SEQ_NUMERIC
;
16167 if (ts
.kind
!= gfc_default_logical_kind
)
16168 return SEQ_NONDEFAULT
;
16170 return SEQ_NUMERIC
;
16173 return SEQ_NONDEFAULT
;
16178 /* Resolve derived type EQUIVALENCE object. */
16181 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
16183 gfc_component
*c
= derived
->components
;
16188 /* Shall not be an object of nonsequence derived type. */
16189 if (!derived
->attr
.sequence
)
16191 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
16192 "attribute to be an EQUIVALENCE object", sym
->name
,
16197 /* Shall not have allocatable components. */
16198 if (derived
->attr
.alloc_comp
)
16200 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
16201 "components to be an EQUIVALENCE object",sym
->name
,
16206 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
16208 gfc_error ("Derived type variable %qs at %L with default "
16209 "initialization cannot be in EQUIVALENCE with a variable "
16210 "in COMMON", sym
->name
, &e
->where
);
16214 for (; c
; c
= c
->next
)
16216 if (gfc_bt_struct (c
->ts
.type
)
16217 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
16220 /* Shall not be an object of sequence derived type containing a pointer
16221 in the structure. */
16222 if (c
->attr
.pointer
)
16224 gfc_error ("Derived type variable %qs at %L with pointer "
16225 "component(s) cannot be an EQUIVALENCE object",
16226 sym
->name
, &e
->where
);
16234 /* Resolve equivalence object.
16235 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
16236 an allocatable array, an object of nonsequence derived type, an object of
16237 sequence derived type containing a pointer at any level of component
16238 selection, an automatic object, a function name, an entry name, a result
16239 name, a named constant, a structure component, or a subobject of any of
16240 the preceding objects. A substring shall not have length zero. A
16241 derived type shall not have components with default initialization nor
16242 shall two objects of an equivalence group be initialized.
16243 Either all or none of the objects shall have an protected attribute.
16244 The simple constraints are done in symbol.c(check_conflict) and the rest
16245 are implemented here. */
16248 resolve_equivalence (gfc_equiv
*eq
)
16251 gfc_symbol
*first_sym
;
16254 locus
*last_where
= NULL
;
16255 seq_type eq_type
, last_eq_type
;
16256 gfc_typespec
*last_ts
;
16257 int object
, cnt_protected
;
16260 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
16262 first_sym
= eq
->expr
->symtree
->n
.sym
;
16266 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
16270 e
->ts
= e
->symtree
->n
.sym
->ts
;
16271 /* match_varspec might not know yet if it is seeing
16272 array reference or substring reference, as it doesn't
16274 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
16276 gfc_ref
*ref
= e
->ref
;
16277 sym
= e
->symtree
->n
.sym
;
16279 if (sym
->attr
.dimension
)
16281 ref
->u
.ar
.as
= sym
->as
;
16285 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
16286 if (e
->ts
.type
== BT_CHARACTER
16288 && ref
->type
== REF_ARRAY
16289 && ref
->u
.ar
.dimen
== 1
16290 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
16291 && ref
->u
.ar
.stride
[0] == NULL
)
16293 gfc_expr
*start
= ref
->u
.ar
.start
[0];
16294 gfc_expr
*end
= ref
->u
.ar
.end
[0];
16297 /* Optimize away the (:) reference. */
16298 if (start
== NULL
&& end
== NULL
)
16301 e
->ref
= ref
->next
;
16303 e
->ref
->next
= ref
->next
;
16308 ref
->type
= REF_SUBSTRING
;
16310 start
= gfc_get_int_expr (gfc_charlen_int_kind
,
16312 ref
->u
.ss
.start
= start
;
16313 if (end
== NULL
&& e
->ts
.u
.cl
)
16314 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
16315 ref
->u
.ss
.end
= end
;
16316 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
16323 /* Any further ref is an error. */
16326 gcc_assert (ref
->type
== REF_ARRAY
);
16327 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
16333 if (!gfc_resolve_expr (e
))
16336 sym
= e
->symtree
->n
.sym
;
16338 if (sym
->attr
.is_protected
)
16340 if (cnt_protected
> 0 && cnt_protected
!= object
)
16342 gfc_error ("Either all or none of the objects in the "
16343 "EQUIVALENCE set at %L shall have the "
16344 "PROTECTED attribute",
16349 /* Shall not equivalence common block variables in a PURE procedure. */
16350 if (sym
->ns
->proc_name
16351 && sym
->ns
->proc_name
->attr
.pure
16352 && sym
->attr
.in_common
)
16354 /* Need to check for symbols that may have entered the pure
16355 procedure via a USE statement. */
16356 bool saw_sym
= false;
16357 if (sym
->ns
->use_stmts
)
16360 for (r
= sym
->ns
->use_stmts
->rename
; r
; r
= r
->next
)
16361 if (strcmp(r
->use_name
, sym
->name
) == 0) saw_sym
= true;
16367 gfc_error ("COMMON block member %qs at %L cannot be an "
16368 "EQUIVALENCE object in the pure procedure %qs",
16369 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
16373 /* Shall not be a named constant. */
16374 if (e
->expr_type
== EXPR_CONSTANT
)
16376 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
16377 "object", sym
->name
, &e
->where
);
16381 if (e
->ts
.type
== BT_DERIVED
16382 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
16385 /* Check that the types correspond correctly:
16387 A numeric sequence structure may be equivalenced to another sequence
16388 structure, an object of default integer type, default real type, double
16389 precision real type, default logical type such that components of the
16390 structure ultimately only become associated to objects of the same
16391 kind. A character sequence structure may be equivalenced to an object
16392 of default character kind or another character sequence structure.
16393 Other objects may be equivalenced only to objects of the same type and
16394 kind parameters. */
16396 /* Identical types are unconditionally OK. */
16397 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
16398 goto identical_types
;
16400 last_eq_type
= sequence_type (*last_ts
);
16401 eq_type
= sequence_type (sym
->ts
);
16403 /* Since the pair of objects is not of the same type, mixed or
16404 non-default sequences can be rejected. */
16406 msg
= "Sequence %s with mixed components in EQUIVALENCE "
16407 "statement at %L with different type objects";
16409 && last_eq_type
== SEQ_MIXED
16410 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16411 || (eq_type
== SEQ_MIXED
16412 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16415 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
16416 "statement at %L with objects of different type";
16418 && last_eq_type
== SEQ_NONDEFAULT
16419 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
16420 || (eq_type
== SEQ_NONDEFAULT
16421 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
16424 msg
="Non-CHARACTER object %qs in default CHARACTER "
16425 "EQUIVALENCE statement at %L";
16426 if (last_eq_type
== SEQ_CHARACTER
16427 && eq_type
!= SEQ_CHARACTER
16428 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16431 msg
="Non-NUMERIC object %qs in default NUMERIC "
16432 "EQUIVALENCE statement at %L";
16433 if (last_eq_type
== SEQ_NUMERIC
16434 && eq_type
!= SEQ_NUMERIC
16435 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
16440 last_where
= &e
->where
;
16445 /* Shall not be an automatic array. */
16446 if (e
->ref
->type
== REF_ARRAY
16447 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
16449 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
16450 "an EQUIVALENCE object", sym
->name
, &e
->where
);
16457 /* Shall not be a structure component. */
16458 if (r
->type
== REF_COMPONENT
)
16460 gfc_error ("Structure component %qs at %L cannot be an "
16461 "EQUIVALENCE object",
16462 r
->u
.c
.component
->name
, &e
->where
);
16466 /* A substring shall not have length zero. */
16467 if (r
->type
== REF_SUBSTRING
)
16469 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
16471 gfc_error ("Substring at %L has length zero",
16472 &r
->u
.ss
.start
->where
);
16482 /* Function called by resolve_fntype to flag other symbol used in the
16483 length type parameter specification of function resuls. */
16486 flag_fn_result_spec (gfc_expr
*expr
,
16488 int *f ATTRIBUTE_UNUSED
)
16493 if (expr
->expr_type
== EXPR_VARIABLE
)
16495 s
= expr
->symtree
->n
.sym
;
16496 for (ns
= s
->ns
; ns
; ns
= ns
->parent
)
16502 gfc_error ("Self reference in character length expression "
16503 "for %qs at %L", sym
->name
, &expr
->where
);
16507 if (!s
->fn_result_spec
16508 && s
->attr
.flavor
== FL_PARAMETER
)
16510 /* Function contained in a module.... */
16511 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_MODULE
)
16514 s
->fn_result_spec
= 1;
16515 /* Make sure that this symbol is translated as a module
16517 st
= gfc_get_unique_symtree (ns
);
16521 /* ... which is use associated and called. */
16522 else if (s
->attr
.use_assoc
|| s
->attr
.used_in_submodule
16524 /* External function matched with an interface. */
16527 && s
->ns
->proc_name
->attr
.if_source
== IFSRC_DECL
)
16528 || s
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16529 && s
->ns
->proc_name
->attr
.function
))
16530 s
->fn_result_spec
= 1;
16537 /* Resolve function and ENTRY types, issue diagnostics if needed. */
16540 resolve_fntype (gfc_namespace
*ns
)
16542 gfc_entry_list
*el
;
16545 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
16548 /* If there are any entries, ns->proc_name is the entry master
16549 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
16551 sym
= ns
->entries
->sym
;
16553 sym
= ns
->proc_name
;
16554 if (sym
->result
== sym
16555 && sym
->ts
.type
== BT_UNKNOWN
16556 && !gfc_set_default_type (sym
, 0, NULL
)
16557 && !sym
->attr
.untyped
)
16559 gfc_error ("Function %qs at %L has no IMPLICIT type",
16560 sym
->name
, &sym
->declared_at
);
16561 sym
->attr
.untyped
= 1;
16564 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
16565 && !sym
->attr
.contained
16566 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
16567 && gfc_check_symbol_access (sym
))
16569 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
16570 "%L of PRIVATE type %qs", sym
->name
,
16571 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
16575 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
16577 if (el
->sym
->result
== el
->sym
16578 && el
->sym
->ts
.type
== BT_UNKNOWN
16579 && !gfc_set_default_type (el
->sym
, 0, NULL
)
16580 && !el
->sym
->attr
.untyped
)
16582 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
16583 el
->sym
->name
, &el
->sym
->declared_at
);
16584 el
->sym
->attr
.untyped
= 1;
16588 if (sym
->ts
.type
== BT_CHARACTER
)
16589 gfc_traverse_expr (sym
->ts
.u
.cl
->length
, sym
, flag_fn_result_spec
, 0);
16593 /* 12.3.2.1.1 Defined operators. */
16596 check_uop_procedure (gfc_symbol
*sym
, locus where
)
16598 gfc_formal_arglist
*formal
;
16600 if (!sym
->attr
.function
)
16602 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
16603 sym
->name
, &where
);
16607 if (sym
->ts
.type
== BT_CHARACTER
16608 && !((sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
) || sym
->ts
.deferred
)
16609 && !(sym
->result
&& ((sym
->result
->ts
.u
.cl
16610 && sym
->result
->ts
.u
.cl
->length
) || sym
->result
->ts
.deferred
)))
16612 gfc_error ("User operator procedure %qs at %L cannot be assumed "
16613 "character length", sym
->name
, &where
);
16617 formal
= gfc_sym_get_dummy_args (sym
);
16618 if (!formal
|| !formal
->sym
)
16620 gfc_error ("User operator procedure %qs at %L must have at least "
16621 "one argument", sym
->name
, &where
);
16625 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16627 gfc_error ("First argument of operator interface at %L must be "
16628 "INTENT(IN)", &where
);
16632 if (formal
->sym
->attr
.optional
)
16634 gfc_error ("First argument of operator interface at %L cannot be "
16635 "optional", &where
);
16639 formal
= formal
->next
;
16640 if (!formal
|| !formal
->sym
)
16643 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
16645 gfc_error ("Second argument of operator interface at %L must be "
16646 "INTENT(IN)", &where
);
16650 if (formal
->sym
->attr
.optional
)
16652 gfc_error ("Second argument of operator interface at %L cannot be "
16653 "optional", &where
);
16659 gfc_error ("Operator interface at %L must have, at most, two "
16660 "arguments", &where
);
16668 gfc_resolve_uops (gfc_symtree
*symtree
)
16670 gfc_interface
*itr
;
16672 if (symtree
== NULL
)
16675 gfc_resolve_uops (symtree
->left
);
16676 gfc_resolve_uops (symtree
->right
);
16678 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
16679 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
16683 /* Examine all of the expressions associated with a program unit,
16684 assign types to all intermediate expressions, make sure that all
16685 assignments are to compatible types and figure out which names
16686 refer to which functions or subroutines. It doesn't check code
16687 block, which is handled by gfc_resolve_code. */
16690 resolve_types (gfc_namespace
*ns
)
16696 gfc_namespace
* old_ns
= gfc_current_ns
;
16698 if (ns
->types_resolved
)
16701 /* Check that all IMPLICIT types are ok. */
16702 if (!ns
->seen_implicit_none
)
16705 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
16706 if (ns
->set_flag
[letter
]
16707 && !resolve_typespec_used (&ns
->default_type
[letter
],
16708 &ns
->implicit_loc
[letter
], NULL
))
16712 gfc_current_ns
= ns
;
16714 resolve_entries (ns
);
16716 resolve_common_vars (&ns
->blank_common
, false);
16717 resolve_common_blocks (ns
->common_root
);
16719 resolve_contained_functions (ns
);
16721 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
16722 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
16723 resolve_formal_arglist (ns
->proc_name
);
16725 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
16727 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
16728 resolve_charlen (cl
);
16730 gfc_traverse_ns (ns
, resolve_symbol
);
16732 resolve_fntype (ns
);
16734 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16736 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
16737 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
16738 "also be PURE", n
->proc_name
->name
,
16739 &n
->proc_name
->declared_at
);
16745 gfc_do_concurrent_flag
= 0;
16746 gfc_check_interfaces (ns
);
16748 gfc_traverse_ns (ns
, resolve_values
);
16750 if (ns
->save_all
|| !flag_automatic
)
16754 for (d
= ns
->data
; d
; d
= d
->next
)
16758 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
16760 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
16762 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
16763 resolve_equivalence (eq
);
16765 /* Warn about unused labels. */
16766 if (warn_unused_label
)
16767 warn_unused_fortran_label (ns
->st_labels
);
16769 gfc_resolve_uops (ns
->uop_root
);
16771 gfc_traverse_ns (ns
, gfc_verify_DTIO_procedures
);
16773 gfc_resolve_omp_declare_simd (ns
);
16775 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
16777 ns
->types_resolved
= 1;
16779 gfc_current_ns
= old_ns
;
16783 /* Call gfc_resolve_code recursively. */
16786 resolve_codes (gfc_namespace
*ns
)
16789 bitmap_obstack old_obstack
;
16791 if (ns
->resolved
== 1)
16794 for (n
= ns
->contained
; n
; n
= n
->sibling
)
16797 gfc_current_ns
= ns
;
16799 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
16800 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
16803 /* Set to an out of range value. */
16804 current_entry_id
= -1;
16806 old_obstack
= labels_obstack
;
16807 bitmap_obstack_initialize (&labels_obstack
);
16809 gfc_resolve_oacc_declare (ns
);
16810 gfc_resolve_omp_local_vars (ns
);
16811 gfc_resolve_code (ns
->code
, ns
);
16813 bitmap_obstack_release (&labels_obstack
);
16814 labels_obstack
= old_obstack
;
16818 /* This function is called after a complete program unit has been compiled.
16819 Its purpose is to examine all of the expressions associated with a program
16820 unit, assign types to all intermediate expressions, make sure that all
16821 assignments are to compatible types and figure out which names refer to
16822 which functions or subroutines. */
16825 gfc_resolve (gfc_namespace
*ns
)
16827 gfc_namespace
*old_ns
;
16828 code_stack
*old_cs_base
;
16829 struct gfc_omp_saved_state old_omp_state
;
16835 old_ns
= gfc_current_ns
;
16836 old_cs_base
= cs_base
;
16838 /* As gfc_resolve can be called during resolution of an OpenMP construct
16839 body, we should clear any state associated to it, so that say NS's
16840 DO loops are not interpreted as OpenMP loops. */
16841 if (!ns
->construct_entities
)
16842 gfc_omp_save_and_clear_state (&old_omp_state
);
16844 resolve_types (ns
);
16845 component_assignment_level
= 0;
16846 resolve_codes (ns
);
16848 gfc_current_ns
= old_ns
;
16849 cs_base
= old_cs_base
;
16852 gfc_run_passes (ns
);
16854 if (!ns
->construct_entities
)
16855 gfc_omp_restore_state (&old_omp_state
);